Successfully identified regression in *gcc* in CI configuration tcwg_gcc_check/master-arm. So far, this commit has regressed CI configurations: - tcwg_gcc_check/master-arm

Culprit: <cut> commit 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c Author: Tobias Burnus tobias@codesourcery.com Date: Mon Jul 26 14:20:46 2021 +0200

PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling

Fortran: Fix attributes and bounds in ISO_Fortran_binding.

2021-07-26 José Rui Faustino de Sousa jrfsousa@gmail.com Tobias Burnus tobias@codesourcery.com

PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046

gcc/fortran/ChangeLog:

* trans-decl.c (convert_CFI_desc): Only copy out the descriptor if necessary. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute handling which reflect a previous intermediate version of the standard. Only copy out the descriptor if necessary.

libgfortran/ChangeLog:

* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code to verify the descriptor. Correct bounds calculation. (gfc_desc_to_cfi_desc): Add code to verify the descriptor.

gcc/testsuite/ChangeLog:

* gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute, this test is still erroneous but now it compiles. * gfortran.dg/bind_c_array_params_2.f90: Update regex to match code changes. * gfortran.dg/PR93308.f90: New test. * gfortran.dg/PR93963.f90: New test. * gfortran.dg/PR94327.c: New test. * gfortran.dg/PR94327.f90: New test. * gfortran.dg/PR94331.c: New test. * gfortran.dg/PR94331.f90: New test. * gfortran.dg/PR97046.f90: New test. </cut>

Results regressed to (for first_bad == 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c) # reset_artifacts: -10 # build_abe binutils: -2 # build_abe gcc: -1 # build_abe dejagnu: 0 # build_abe check_gcc -- --set runtestflags=gcc.dg/dg.exp --set runtestflags=gcc.dg/guality/guality.exp --set runtestflags=gcc.dg/ipa/ipa.exp --set runtestflags=gcc.dg/tree-prof/tree-prof.exp --set runtestflags=gcc.target/arm/arm.exp --set runtestflags=gfortran.dg/dg.exp --set runtestflags=libstdc++-dg/conformance.exp: 1 # Getting actual results from build directory /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/libstdc++.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/gfortran.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/libitm.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/libgomp.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/libatomic.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/g++.sum # /home/tcwg-buildslave/workspace/tcwg_gnu_3/artifacts/build-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c/sumfiles/gcc.sum # Manifest: gcc-compare-results/contrib/testsuite-management/flaky.xfail # Getting actual results from build directory base-artifacts/sumfiles # base-artifacts/sumfiles/libstdc++.sum # base-artifacts/sumfiles/gfortran.sum # base-artifacts/sumfiles/libitm.sum # base-artifacts/sumfiles/libgomp.sum # base-artifacts/sumfiles/libatomic.sum # base-artifacts/sumfiles/g++.sum # base-artifacts/sumfiles/gcc.sum # # # Unexpected results in this build (new failures) # === gcc tests === # # Running gfortran.dg/dg.exp ... # FAIL: gfortran.dg/PR93308.f90 -O0 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -O0 compilation failed to produce executable # FAIL: gfortran.dg/PR93308.f90 -O1 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -O1 compilation failed to produce executable # FAIL: gfortran.dg/PR93308.f90 -O2 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -O2 compilation failed to produce executable # FAIL: gfortran.dg/PR93308.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions compilation failed to produce executable # FAIL: gfortran.dg/PR93308.f90 -O3 -g (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -O3 -g compilation failed to produce executable # FAIL: gfortran.dg/PR93308.f90 -Os (test for excess errors) # UNRESOLVED: gfortran.dg/PR93308.f90 -Os compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -O0 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -O0 compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -O1 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -O1 compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -O2 (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -O2 compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -O3 -g (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -O3 -g compilation failed to produce executable # FAIL: gfortran.dg/PR93963.f90 -Os (test for excess errors) # UNRESOLVED: gfortran.dg/PR93963.f90 -Os compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -O0 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -O0 compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -O1 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -O1 compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -O2 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -O2 compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -O3 -g (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -O3 -g compilation failed to produce executable # FAIL: gfortran.dg/PR94327.f90 -Os (test for excess errors) # UNRESOLVED: gfortran.dg/PR94327.f90 -Os compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -O0 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -O0 compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -O1 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -O1 compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -O2 (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -O2 compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -O3 -g (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -O3 -g compilation failed to produce executable # FAIL: gfortran.dg/PR94331.f90 -Os (test for excess errors) # UNRESOLVED: gfortran.dg/PR94331.f90 -Os compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -O0 (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -O0 compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -O1 (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -O1 compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -O2 (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -O2 compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -O3 -g (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -O3 -g compilation failed to produce executable # FAIL: gfortran.dg/PR97046.f90 -Os (test for excess errors) # UNRESOLVED: gfortran.dg/PR97046.f90 -Os compilation failed to produce executable # # === Results Summary === # # # Expected results not present in this build (fixed tests) # # NOTE: This is not a failure. It just means that these tests were expected # to fail, but either they worked in this configuration or they were not # present at all. # # === gfortran tests === # # Running gfortran.dg/dg.exp ... # FAIL: gfortran.dg/nearest_2.f90 -O0 execution test # # === Results Summary ===

from (for last_good == 32f7506bdc3956762bcc7dc84133fd7c3a00bb7b) # reset_artifacts: -10 # build_abe binutils: -2 # build_abe gcc: -1 # build_abe dejagnu: 0 # build_abe check_gcc -- --set runtestflags=gcc.dg/dg.exp --set runtestflags=gcc.dg/guality/guality.exp --set runtestflags=gcc.dg/ipa/ipa.exp --set runtestflags=gcc.dg/tree-prof/tree-prof.exp --set runtestflags=gcc.target/arm/arm.exp --set runtestflags=gfortran.dg/dg.exp --set runtestflags=libstdc++-dg/conformance.exp: 1

Artifacts of last_good build: https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... Artifacts of first_bad build: https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... Build top page/logs: https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/

Configuration details:

Reproduce builds: <cut> mkdir investigate-gcc-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c cd investigate-gcc-0cbf03689e3e7d9d6002b8e5d159ef3716d0404c

git clone https://git.linaro.org/toolchain/jenkins-scripts

mkdir -p artifacts/manifests curl -o artifacts/manifests/build-baseline.sh https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... --fail curl -o artifacts/manifests/build-parameters.sh https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... --fail curl -o artifacts/test.sh https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... --fail chmod +x artifacts/test.sh

# Reproduce the baseline build (build all pre-requisites) ./jenkins-scripts/tcwg_gnu-build.sh @@ artifacts/manifests/build-baseline.sh

# Save baseline build state (which is then restored in artifacts/test.sh) mkdir -p ./bisect rsync -a --del --delete-excluded --exclude /bisect/ --exclude /artifacts/ --exclude /gcc/ ./ ./bisect/baseline/

cd gcc

# Reproduce first_bad build git checkout --detach 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c ../artifacts/test.sh

# Reproduce last_good build git checkout --detach 32f7506bdc3956762bcc7dc84133fd7c3a00bb7b ../artifacts/test.sh

cd .. </cut>

History of pending regressions and results: https://git.linaro.org/toolchain/ci/base-artifacts.git/log/?h=linaro-local/c...

Artifacts: https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/artifact/artifa... Build log: https://ci.linaro.org/job/tcwg_gcc_check-bisect-master-arm/2/consoleText

Full commit (up to 1000 lines): <cut> commit 0cbf03689e3e7d9d6002b8e5d159ef3716d0404c Author: Tobias Burnus tobias@codesourcery.com Date: Mon Jul 26 14:20:46 2021 +0200

PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling

Fortran: Fix attributes and bounds in ISO_Fortran_binding.

2021-07-26 José Rui Faustino de Sousa jrfsousa@gmail.com Tobias Burnus tobias@codesourcery.com

PR fortran/93308 PR fortran/93963 PR fortran/94327 PR fortran/94331 PR fortran/97046

gcc/fortran/ChangeLog:

* trans-decl.c (convert_CFI_desc): Only copy out the descriptor if necessary. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute handling which reflect a previous intermediate version of the standard. Only copy out the descriptor if necessary.

libgfortran/ChangeLog:

* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code to verify the descriptor. Correct bounds calculation. (gfc_desc_to_cfi_desc): Add code to verify the descriptor.

gcc/testsuite/ChangeLog:

* gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute, this test is still erroneous but now it compiles. * gfortran.dg/bind_c_array_params_2.f90: Update regex to match code changes. * gfortran.dg/PR93308.f90: New test. * gfortran.dg/PR93963.f90: New test. * gfortran.dg/PR94327.c: New test. * gfortran.dg/PR94327.f90: New test. * gfortran.dg/PR94331.c: New test. * gfortran.dg/PR94331.f90: New test. * gfortran.dg/PR97046.f90: New test. --- gcc/fortran/trans-decl.c | 32 +-- gcc/fortran/trans-expr.c | 24 +- .../gfortran.dg/ISO_Fortran_binding_1.f90 | 2 +- gcc/testsuite/gfortran.dg/PR93308.f90 | 52 +++++ gcc/testsuite/gfortran.dg/PR93963.f90 | 150 ++++++++++++ gcc/testsuite/gfortran.dg/PR94327.c | 70 ++++++ gcc/testsuite/gfortran.dg/PR94327.f90 | 195 ++++++++++++++++ gcc/testsuite/gfortran.dg/PR94331.c | 73 ++++++ gcc/testsuite/gfortran.dg/PR94331.f90 | 252 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/PR97046.f90 | 58 +++++ .../gfortran.dg/bind_c_array_params_2.f90 | 2 +- libgfortran/runtime/ISO_Fortran_binding.c | 56 ++++- 12 files changed, 933 insertions(+), 33 deletions(-)

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index bf8783a35f8..784f7b61ce1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4539,22 +4539,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym) gfc_add_expr_to_block (&outer_block, incoming); incoming = gfc_finish_block (&outer_block);

- /* Convert the gfc descriptor back to the CFI type before going out of scope, if the CFI type was present at entry. */ - gfc_init_block (&outer_block); - gfc_init_block (&tmpblock); - - tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); - outgoing = build_call_expr_loc (input_location, - gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); - gfc_add_expr_to_block (&tmpblock, outgoing); + outgoing = NULL_TREE; + if ((sym->attr.pointer || sym->attr.allocatable) + && !sym->attr.value + && sym->attr.intent != INTENT_IN) + { + gfc_init_block (&outer_block); + gfc_init_block (&tmpblock);

- outgoing = build3_v (COND_EXPR, present, - gfc_finish_block (&tmpblock), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&outer_block, outgoing); - outgoing = gfc_finish_block (&outer_block); + tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr); + outgoing = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, + tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&tmpblock, outgoing); + + outgoing = build3_v (COND_EXPR, present, + gfc_finish_block (&tmpblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&outer_block, outgoing); + outgoing = gfc_finish_block (&outer_block); + }

/* Add the lot to the procedure init and finally blocks. */ gfc_add_init_cleanup (block, incoming, outgoing); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b18a9ec9799..c4291cce079 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5502,13 +5502,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) attribute = 1; }

- /* If the formal argument is assumed shape and neither a pointer nor - allocatable, it is unconditionally CFI_attribute_other. */ - if (fsym->as->type == AS_ASSUMED_SHAPE - && !fsym->attr.pointer && !fsym->attr.allocatable) - cfi_attribute = 2; + if (fsym->attr.pointer) + cfi_attribute = 0; + else if (fsym->attr.allocatable) + cfi_attribute = 1; else - cfi_attribute = attribute; + cfi_attribute = 2;

if (e->rank != 0) { @@ -5616,10 +5615,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_prepend_expr_to_block (&parmse->post, tmp);

/* Transfer values back to gfc descriptor. */ - tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); - gfc_prepend_expr_to_block (&parmse->post, tmp); + if (cfi_attribute != 2 /* CFI_attribute_other. */ + && !fsym->attr.value + && fsym->attr.intent != INTENT_IN) + { + tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_prepend_expr_to_block (&parmse->post, tmp); + }

/* Deal with an optional dummy being passed to an optional formal arg by finishing the pre and post blocks and making their execution diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 102bc60310c..0cf3b2cb88c 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -39,7 +39,7 @@ USE, INTRINSIC :: ISO_C_BINDING import INTEGER(C_INT) :: err - type (T), DIMENSION(..), intent(out) :: a + type (T), pointer, DIMENSION(..), intent(out) :: a END FUNCTION c_establish

FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err) diff --git a/gcc/testsuite/gfortran.dg/PR93308.f90 b/gcc/testsuite/gfortran.dg/PR93308.f90 new file mode 100644 index 00000000000..ee116f961de --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93308.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Robin Hogan r.j.hogan@reading.ac.uk +! + +program test + + use, intrinsic :: iso_c_binding, only: & + c_int, c_float + + implicit none + + integer :: i + integer, parameter :: n = 11 + real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)] + + real(kind=c_float), allocatable :: A(:) + real(kind=c_float) :: E(n) + integer(kind=c_int) :: l1, l2, l3 + + allocate(A, source=u) + l1 = lbound(A, 1) + call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A... + l3 = lbound(A, 1) + if (l1 /= 1) stop 1 + if (l1 /= l2) stop 2 + if (l1 /= l3) stop 3 + if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4 + deallocate(A) + ! + E = u + l1 = lbound(E, 1) + call routine_bindc(E, l2) ! ...but does not change lbound of E + l3 = lbound(E, 1) + if (l1 /= 1) stop 5 + if (l1 /= l2) stop 6 + if (l1 /= l3) stop 7 + if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8 + +contains + + subroutine routine_bindc(v, l) bind(c) + real(kind=c_float), intent(inout) :: v(:) + integer(kind=c_int), intent(out) :: l + + l = lbound(v, 1) + if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9 + end subroutine routine_bindc + +end program test diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90 new file mode 100644 index 00000000000..4e1b06fd525 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR93963.f90 @@ -0,0 +1,150 @@ +! { dg-do run } +! +! Test the fix for PR93963 +! + +function rank_p(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), pointer, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_p + +function rank_a(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), allocatable, intent(in) :: this(..) + integer(kind=c_int) :: rnk + + select rank(this) + rank(0) + rnk = 0 + rank(1) + rnk = 1 + rank(2) + rnk = 2 + rank(3) + rnk = 3 + rank(4) + rnk = 4 + rank(5) + rnk = 5 + rank(6) + rnk = 6 + rank(7) + rnk = 7 + rank(8) + rnk = 8 + rank(9) + rnk = 9 + rank(10) + rnk = 10 + rank(11) + rnk = 11 + rank(12) + rnk = 12 + rank(13) + rnk = 13 + rank(14) + rnk = 14 + rank(15) + rnk = 15 + rank default + rnk = -1000 + end select + return +end function rank_a + +program selr_p + + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + interface + function rank_p(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(kind=c_int), pointer, intent(in) :: this(..) + integer(kind=c_int) :: rnk + end function rank_p + end interface + + interface + function rank_a(this) result(rnk) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(kind=c_int), allocatable, intent(in) :: this(..) + integer(kind=c_int) :: rnk + end function rank_a + end interface + + integer(kind=c_int), parameter :: siz = 7 + integer(kind=c_int), parameter :: rnk = 1 + + integer(kind=c_int), pointer :: intp(:) + integer(kind=c_int), allocatable :: inta(:) + integer(kind=c_int) :: irnk + + nullify(intp) + irnk = rank_p(intp) + if (irnk /= rnk) stop 1 + if (irnk /= rank(intp)) stop 2 + ! + irnk = rank_a(inta) + if (irnk /= rnk) stop 3 + if (irnk /= rank(inta)) stop 4 + ! + allocate(intp(siz)) + irnk = rank_p(intp) + if (irnk /= rnk) stop 5 + if (irnk /= rank(intp)) stop 6 + deallocate(intp) + nullify(intp) + ! + allocate(inta(siz)) + if (irnk /= rnk) stop 7 + if (irnk /= rank(inta)) stop 8 + deallocate(inta) + +end program selr_p diff --git a/gcc/testsuite/gfortran.dg/PR94327.c b/gcc/testsuite/gfortran.dg/PR94327.c new file mode 100644 index 00000000000..6791c373546 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.c @@ -0,0 +1,70 @@ +/* Test the fix for PR94327. */ + +#include <assert.h> +#include <stdbool.h> +#include <stdlib.h> + +#include "../../../libgfortran/ISO_Fortran_binding.h" + +bool c_vrfy (const CFI_cdesc_t *restrict); + +char get_attr (const CFI_cdesc_t*restrict, bool); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; i<ex; i++) + if (*ip++ != i+1) + return false; + for (i=lb; i<ub+1; i++) + { + ip = (int*)CFI_address(auxp, &i); + if (*ip != i-lb+1) + return false; + } + return true; +} + +char +get_attr (const CFI_cdesc_t *restrict auxp, bool alloc) +{ + char attr; + + assert (auxp); + assert (auxp->elem_len == 4); + assert (auxp->rank == 1); + assert (auxp->type == CFI_type_int); + attr = '\0'; + switch (auxp->attribute) + { + case CFI_attribute_pointer: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'p'; + break; + case CFI_attribute_allocatable: + if (alloc && !c_vrfy (auxp)) + break; + attr = 'a'; + break; + case CFI_attribute_other: + assert (alloc); + if (!c_vrfy (auxp)) + break; + attr = 'o'; + break; + default: + break; + } + return attr; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90 new file mode 100644 index 00000000000..3cb3ac3dda1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94327.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! { dg-additional-sources PR94327.c } +! +! Test the fix for PR94327 +! + +program attr_p + + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + + implicit none + + integer :: i + integer, parameter :: n = 11 + integer, parameter :: u(*) = [(i, i=1,n)] + + interface + function attr_p_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_as + function attr_a_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_as + function attr_o_as(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(:) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_as + function attr_p_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_p_ar + function attr_a_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_a_ar + function attr_o_ar(a, s) result(c) & + bind(c, name="get_attr") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool, c_char + implicit none + integer(kind=c_int), intent(in) :: a(..) + logical(kind=c_bool), value, intent(in) :: s + character(kind=c_char) :: c + end function attr_o_ar + end interface + + integer(kind=c_int), target :: a(n) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + character(kind=c_char) :: c + + a = u + c = attr_p_as(a, .true._c_bool) + if(c/='p') stop 1 + if(any(a/=u)) stop 2 + ! + a = u + c = attr_p_ar(a, .true._c_bool) + if(c/='p') stop 3 + if(any(a/=u)) stop 4 + ! + a = u + c = attr_o_as(a, .true._c_bool) + if(c/='o') stop 5 + if(any(a/=u)) stop 6 + ! + a = u + c = attr_o_ar(a, .true._c_bool) + if(c/='o') stop 7 + if(any(a/=u)) stop 8 + ! + allocate(b, source=u) + c = attr_p_as(b, .true._c_bool) + if(c/='p') stop 9 + if(.not.allocated(b)) stop 10 + if(any(b/=u)) stop 11 + ! + deallocate(b) + allocate(b, source=u) + c = attr_p_ar(b, .true._c_bool) + if(c/='p') stop 12 + if(.not.allocated(b)) stop 13 + if(any(b/=u)) stop 14 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_as(b, .true._c_bool) + if(c/='a') stop 15 + if(.not.allocated(b)) stop 16 + if(any(b/=u)) stop 17 + ! + deallocate(b) + allocate(b, source=u) + c = attr_a_ar(b, .true._c_bool) + if(c/='a') stop 18 + if(.not.allocated(b)) stop 19 + if(any(b/=u)) stop 20 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_as(b, .true._c_bool) + if(c/='o') stop 21 + if(.not.allocated(b)) stop 22 + if(any(b/=u)) stop 23 + ! + deallocate(b) + allocate(b, source=u) + c = attr_o_ar(b, .true._c_bool) + if(c/='o') stop 24 + if(.not.allocated(b)) stop 25 + if(any(b/=u)) stop 26 + ! + deallocate(b) + c = attr_a_as(b, .false._c_bool) + if(c/='a') stop 27 + if(allocated(b)) stop 28 + ! + c = attr_a_ar(b, .false._c_bool) + if(c/='a') stop 29 + if(allocated(b)) stop 30 + ! + nullify(p) + p => a + c = attr_p_as(p, .true._c_bool) + if(c/='p') stop 31 + if(.not.associated(p)) stop 32 + if(.not.associated(p, a)) stop 33 + if(any(p/=u)) stop 34 + ! + nullify(p) + p => a + c = attr_p_ar(p, .true._c_bool) + if(c/='p') stop 35 + if(.not.associated(p)) stop 36 + if(.not.associated(p, a)) stop 37 + if(any(p/=u)) stop 38 + ! + nullify(p) + p => a + c = attr_o_as(p, .true._c_bool) + if(c/='o') stop 39 + if(.not.associated(p)) stop 40 + if(.not.associated(p, a)) stop 41 + if(any(p/=u)) stop 42 + ! + nullify(p) + p => a + c = attr_o_ar(p, .true._c_bool) + if(c/='o') stop 43 + if(.not.associated(p)) stop 44 + if(.not.associated(p, a)) stop 45 + if(any(p/=u)) stop 46 + ! + nullify(p) + c = attr_p_as(p, .false._c_bool) + if(c/='p') stop 47 + if(associated(p)) stop 48 + if(associated(p, a)) stop 49 + ! + nullify(p) + c = attr_p_ar(p, .false._c_bool) + if(c/='p') stop 50 + if(associated(p)) stop 51 + if(associated(p, a)) stop 52 + stop + +end program attr_p diff --git a/gcc/testsuite/gfortran.dg/PR94331.c b/gcc/testsuite/gfortran.dg/PR94331.c new file mode 100644 index 00000000000..4e130515455 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.c @@ -0,0 +1,73 @@ +/* Test the fix for PR94331. */ + +#include <assert.h> +#include <stdbool.h> +#include <stdlib.h> + +#include "../../../libgfortran/ISO_Fortran_binding.h" + +bool c_vrfy (const CFI_cdesc_t *restrict); + +bool check_bounds(const CFI_cdesc_t*restrict, const int, const int); + +bool +c_vrfy (const CFI_cdesc_t *restrict auxp) +{ + CFI_index_t i, lb, ub, ex; + int *ip = NULL; + + assert (auxp); + assert (auxp->base_addr); + lb = auxp->dim[0].lower_bound; + ex = auxp->dim[0].extent; + ub = ex + lb - 1; + ip = (int*)auxp->base_addr; + for (i=0; i<ex; i++) + if (*ip++ != i+1) + return false; + for (i=lb; i<ub+1; i++) + { + ip = (int*)CFI_address(auxp, &i); + if (*ip != i-lb+1) + return false; + } + return true; +} + +bool +check_bounds (const CFI_cdesc_t *restrict auxp, const int lb, const int ub) +{ + CFI_index_t ex = ub-lb+1; + size_t el; + bool is_ok = false; + + assert (auxp); + el = auxp->elem_len; + assert (auxp->rank==1); + assert (auxp->type==CFI_type_int); + assert (auxp->dim[0].sm>0); + assert ((size_t)auxp->dim[0].sm==el); + if (auxp->dim[0].extent==ex + && auxp->dim[0].lower_bound==lb) + { + switch(auxp->attribute) + { + case CFI_attribute_pointer: + case CFI_attribute_allocatable: + if (!c_vrfy (auxp)) + break; + is_ok = true; + break; + case CFI_attribute_other: + if (!c_vrfy (auxp)) + break; + is_ok = (lb==0); + break; + default: + assert (false); + break; + } + } + return is_ok; +} + diff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90 new file mode 100644 index 00000000000..6185031afc5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94331.f90 @@ -0,0 +1,252 @@ +! { dg-do run } +! { dg-additional-sources PR94331.c } +! +! Test the fix for PR94331 +! + +program main_p + + use, intrinsic :: iso_c_binding, only: & + c_int + + implicit none + + integer :: i + integer, parameter :: ex = 11 + integer, parameter :: lb = 11 + integer, parameter :: ub = ex+lb-1 + integer, parameter :: u(*) = [(i, i=1,ex)] + + interface + function checkb_p_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_as + function checkb_a_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_as + function checkb_o_as(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(:) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_as + function checkb_p_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), pointer, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_p_ar + function checkb_a_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), allocatable, intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_a_ar + function checkb_o_ar(a, l, u) result(c) & + bind(c, name="check_bounds") + use, intrinsic :: iso_c_binding, only: & + c_int, c_bool + implicit none + integer(kind=c_int), intent(in) :: a(..) + integer(kind=c_int), value, intent(in) :: l + integer(kind=c_int), value, intent(in) :: u + logical(kind=c_bool) :: c + end function checkb_o_ar + end interface + + integer(kind=c_int), target :: a(lb:ub) + integer(kind=c_int), allocatable, target :: b(:) + integer(kind=c_int), pointer :: p(:) + + a = u + if(lbound(a,1)/=lb) stop 1 + if(ubound(a,1)/=ub) stop 2 + if(any(shape(a)/=[ex])) stop 3 + if(.not.checkb_p_as(a, lb, ub)) stop 4 + if(lbound(a,1)/=lb) stop 5 + if(ubound(a,1)/=ub) stop 6 + if(any(shape(a)/=[ex])) stop 7 + if(any(a/=u)) stop 8 + ! + a = u + if(lbound(a,1)/=lb) stop 9 + if(ubound(a,1)/=ub) stop 10 + if(any(shape(a)/=[ex])) stop 11 + if(.not.checkb_p_ar(a, lb, ub)) stop 12 + if(lbound(a,1)/=lb) stop 13 + if(ubound(a,1)/=ub) stop 14 + if(any(shape(a)/=[ex])) stop 15 + if(any(a/=u)) stop 16 + ! + a = u + if(lbound(a,1)/=lb) stop 17 + if(ubound(a,1)/=ub) stop 18 + if(any(shape(a)/=[ex])) stop 19 + if(.not.checkb_o_as(a, 0, ex-1))stop 20 + if(lbound(a,1)/=lb) stop 21 + if(ubound(a,1)/=ub) stop 22 + if(any(shape(a)/=[ex])) stop 23 + if(any(a/=u)) stop 24 + ! + a = u + if(lbound(a,1)/=lb) stop 25 + if(ubound(a,1)/=ub) stop 26 + if(any(shape(a)/=[ex])) stop 27 + if(.not.checkb_o_ar(a, 0, ex-1))stop 28 + if(lbound(a,1)/=lb) stop 29 + if(ubound(a,1)/=ub) stop 30 + if(any(shape(a)/=[ex])) stop 31 + if(any(a/=u)) stop 32 + ! + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 33 + if(ubound(b,1)/=ub) stop 34 + if(any(shape(b)/=[ex])) stop 35 + if(.not.checkb_p_as(b, lb, ub)) stop 36 + if(.not.allocated(b)) stop 37 + if(lbound(b,1)/=lb) stop 38 + if(ubound(b,1)/=ub) stop 39 + if(any(shape(b)/=[ex])) stop 40 + if(any(b/=u)) stop 41 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 42 + if(ubound(b,1)/=ub) stop 43 + if(any(shape(b)/=[ex])) stop 44 + if(.not.checkb_p_ar(b, lb, ub)) stop 45 + if(.not.allocated(b)) stop 46 + if(lbound(b,1)/=lb) stop 47 + if(ubound(b,1)/=ub) stop 48 + if(any(shape(b)/=[ex])) stop 49 + if(any(b/=u)) stop 50 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 51 + if(ubound(b,1)/=ub) stop 52 + if(any(shape(b)/=[ex])) stop 53 + if(.not.checkb_a_as(b, lb, ub)) stop 54 + if(.not.allocated(b)) stop 55 + if(lbound(b,1)/=lb) stop 56 + if(ubound(b,1)/=ub) stop 57 + if(any(shape(b)/=[ex])) stop 58 + if(any(b/=u)) stop 59 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 60 + if(ubound(b,1)/=ub) stop 61 + if(any(shape(b)/=[ex])) stop 62 + if(.not.checkb_a_ar(b, lb, ub)) stop 63 + if(.not.allocated(b)) stop 64 + if(lbound(b,1)/=lb) stop 65 + if(ubound(b,1)/=ub) stop 66 + if(any(shape(b)/=[ex])) stop 67 + if(any(b/=u)) stop 68 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 69 + if(ubound(b,1)/=ub) stop 70 + if(any(shape(b)/=[ex])) stop 71 + if(.not.checkb_o_as(b, 0, ex-1))stop 72 + if(.not.allocated(b)) stop 73 + if(lbound(b,1)/=lb) stop 74 + if(ubound(b,1)/=ub) stop 75 + if(any(shape(b)/=[ex])) stop 76 + if(any(b/=u)) stop 77 + ! + deallocate(b) + allocate(b(lb:ub), source=u) + if(lbound(b,1)/=lb) stop 78 + if(ubound(b,1)/=ub) stop 79 + if(any(shape(b)/=[ex])) stop 80 + if(.not.checkb_o_ar(b, 0, ex-1))stop 81 + if(.not.allocated(b)) stop 82 + if(lbound(b,1)/=lb) stop 83 + if(ubound(b,1)/=ub) stop 84 + if(any(shape(b)/=[ex])) stop 85 + if(any(b/=u)) stop 86 + deallocate(b) + ! + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 87 + if(ubound(p,1)/=ub) stop 88 + if(any(shape(p)/=[ex])) stop 89 + if(.not.checkb_p_as(p, lb, ub)) stop 90 + if(.not.associated(p)) stop 91 + if(.not.associated(p, a)) stop 92 + if(lbound(p,1)/=lb) stop 93 + if(ubound(p,1)/=ub) stop 94 + if(any(shape(p)/=[ex])) stop 95 + if(any(p/=u)) stop 96 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 97 + if(ubound(p,1)/=ub) stop 98 + if(any(shape(p)/=[ex])) stop 99 + if(.not.checkb_p_ar(p, lb, ub)) stop 100 + if(.not.associated(p)) stop 101 + if(.not.associated(p, a)) stop 102 + if(lbound(p,1)/=lb) stop 103 + if(ubound(p,1)/=ub) stop 104 + if(any(shape(p)/=[ex])) stop 105 + if(any(p/=u)) stop 106 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 107 + if(ubound(p,1)/=ub) stop 108 + if(any(shape(p)/=[ex])) stop 109 + if(.not.checkb_o_as(p, 0, ex-1))stop 110 + if(.not.associated(p)) stop 111 + if(.not.associated(p, a)) stop 112 + if(lbound(p,1)/=lb) stop 113 + if(ubound(p,1)/=ub) stop 114 + if(any(shape(p)/=[ex])) stop 115 + if(any(p/=u)) stop 116 + ! + nullify(p) + p(lb:ub) => a + if(lbound(p,1)/=lb) stop 117 + if(ubound(p,1)/=ub) stop 118 + if(any(shape(p)/=[ex])) stop 119 + if(.not.checkb_o_ar(p, 0, ex-1))stop 120 + if(.not.associated(p)) stop 121 + if(.not.associated(p, a)) stop 122 + if(lbound(p,1)/=lb) stop 123 + if(ubound(p,1)/=ub) stop 124 + if(any(shape(p)/=[ex])) stop 125 + if(any(p/=u)) stop 126 + nullify(p) + stop + +end program main_p diff --git a/gcc/testsuite/gfortran.dg/PR97046.f90 b/gcc/testsuite/gfortran.dg/PR97046.f90 new file mode 100644 index 00000000000..7d133a5ad70 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR97046.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Test the fix for PR94331 +! +! Contributed by Igor Gayday igor.gayday@mu.edu </cut>