From e93f828c400e352fc4ad585b27b33d9e73258c12 Mon Sep 17 00:00:00 2001 From: Leandro Lupori Date: Thu, 22 Aug 2024 06:02:12 -0300 Subject: [PATCH 1/4] [Fortran/gfortran] Disable flaky test random_init_2.f90 (#153) The random_init_2.f90 test is flaky and may fail sometimes, even when no Fortran/Flang changes are made: - https://lab.llvm.org/buildbot/#/builders/143/builds/1236 - https://lab.llvm.org/buildbot/#/builders/17/builds/2058 Looking at the test source, it seems there is no guarantee that 2 distinct random numbers will never collide. This is made worse by multiplying them by 1e6 and converting them to integer, which could make distinct but close enough single-precision floating-point numbers give the same result and fail the test. --- Fortran/gfortran/regression/DisabledFiles.cmake | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Fortran/gfortran/regression/DisabledFiles.cmake b/Fortran/gfortran/regression/DisabledFiles.cmake index f498b4c7c..266f57669 100644 --- a/Fortran/gfortran/regression/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/DisabledFiles.cmake @@ -1748,4 +1748,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # __trampoline_setup. This is probably an unrelated issue, but as a quick fix # for the buildbot, this is disabled. internal_dummy_2.f08 + + # These are flaky tests, which may fail sometimes. + random_init_2.f90 ) From 1459f2ac2ed50e045500ef92b892fe21a77acfe5 Mon Sep 17 00:00:00 2001 From: Tarun Prabhu Date: Thu, 22 Aug 2024 07:41:26 -0600 Subject: [PATCH 2/4] [Fortran/gfortran] Sync gfortran tests with upstream These are synced with a9e9f772c7488 [https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=a9e9f772c7488ac0c09dd92f28890bdab939771a] The static test configuration files, and denylists have been updated. A quick fix is also included that prevents ninja builds from being serialized. --------- Co-authored-by: Tarun Prabhu --- Fortran/gfortran/CMakeLists.txt | 6 +- Fortran/gfortran/regression/20231103-1.f90 | 22 + Fortran/gfortran/regression/20231103-2.f90 | 22 + .../gfortran/regression/DisabledFiles.cmake | 92 ++- Fortran/gfortran/regression/PR105658.f90 | 50 ++ Fortran/gfortran/regression/PR113061.f90 | 12 + .../regression/allocatable_function_1.f90 | 2 +- .../regression/allocatable_function_11.f90 | 36 ++ .../regression/allocatable_length.f90 | 9 + .../regression/allocatable_length_2.f90 | 107 ++++ .../regression/allocate_with_source_25.f90 | 2 +- .../regression/allocate_with_source_27.f90 | 20 + .../regression/allocate_with_source_28.f90 | 90 +++ .../regression/allocate_with_source_29.f90 | 48 ++ .../regression/allocate_with_source_30.f90 | 51 ++ .../regression/allocate_with_source_31.f90 | 38 ++ .../regression/allocate_with_source_32.f90 | 33 + .../regression/allocate_with_source_33.f90 | 69 ++ Fortran/gfortran/regression/allocated_4.f90 | 195 ++++++ .../gfortran/regression/analyzer/analyzer.exp | 2 +- .../regression/arithmetic_overflow_2.f90 | 12 + .../regression/arithmetic_overflow_3.f90 | 48 ++ .../gfortran/regression/array_memset_3.f90 | 52 ++ Fortran/gfortran/regression/asan/asan.exp | 5 +- .../gfortran/regression/asan/pr110415-2.f90 | 45 ++ .../gfortran/regression/asan/pr110415-3.f90 | 49 ++ Fortran/gfortran/regression/asan/tests.cmake | 5 +- .../asan/unlimited_polymorphic_34.f90 | 135 ++++ Fortran/gfortran/regression/associate_5.f03 | 2 +- Fortran/gfortran/regression/associate_54.f90 | 2 +- Fortran/gfortran/regression/associate_55.f90 | 2 +- Fortran/gfortran/regression/associate_61.f90 | 54 ++ Fortran/gfortran/regression/associate_62.f90 | 25 + Fortran/gfortran/regression/associate_63.f90 | 57 ++ Fortran/gfortran/regression/associate_64.f90 | 345 ++++++++++ Fortran/gfortran/regression/associate_65.f90 | 30 + Fortran/gfortran/regression/associate_66.f90 | 45 ++ Fortran/gfortran/regression/associate_67.f90 | 41 ++ Fortran/gfortran/regression/associate_68.f90 | 79 +++ Fortran/gfortran/regression/associate_69.f90 | 33 + .../gfortran/regression/assumed_rank_10.f90 | 6 +- .../gfortran/regression/assumed_rank_8.f90 | 4 +- .../gfortran/regression/assumed_rank_9.f90 | 13 +- .../gfortran/regression/assumed_type_18.f90 | 52 ++ .../regression/bind_c_array_params_2.f90 | 6 +- .../gfortran/regression/bind_c_char_11.f90 | 45 ++ Fortran/gfortran/regression/bind_c_coms.f90 | 1 + .../gfortran/regression/bind_c_optional-2.f90 | 104 ++++ .../gfortran/regression/bind_c_usage_13.f03 | 8 +- Fortran/gfortran/regression/bind_c_vars.f90 | 1 + Fortran/gfortran/regression/block_17.f90 | 9 + Fortran/gfortran/regression/bound_10.f90 | 207 ++++++ Fortran/gfortran/regression/bound_11.f90 | 588 ++++++++++++++++++ .../gfortran/regression/bounds_check_17.f90 | 2 +- .../gfortran/regression/bounds_check_24.f90 | 28 + .../gfortran/regression/bounds_check_25.f90 | 32 + .../regression/bounds_check_fail_5.f90 | 26 + .../regression/bounds_check_fail_6.f90 | 29 + .../regression/bounds_check_fail_7.f90 | 20 + .../regression/bounds_check_fail_8.f90 | 56 ++ .../regression/c-interop/c-interop.exp | 2 +- .../gfortran/regression/c-interop/c1255-2.f90 | 4 +- .../regression/c_f_pointer_tests_9.f90 | 37 ++ Fortran/gfortran/regression/c_sizeof_6.f90 | 2 +- Fortran/gfortran/regression/c_sizeof_7.f90 | 42 ++ Fortran/gfortran/regression/c_sizeof_8.f90 | 23 + Fortran/gfortran/regression/class_76.f90 | 66 ++ Fortran/gfortran/regression/class_77.f90 | 83 +++ Fortran/gfortran/regression/class_78.f90 | 29 + .../gfortran/regression/class_dummy_11.f90 | 194 ++++++ .../regression/coarray/DisabledFiles.cmake | 3 + .../regression/coarray/alloc_comp_6.f90 | 29 + .../regression/coarray/alloc_comp_7.f90 | 49 ++ .../regression/coarray/alloc_comp_8.f90 | 51 ++ Fortran/gfortran/regression/coarray/caf.exp | 14 +- .../gfortran/regression/coarray/dummy_1.f90 | 2 + .../regression/coarray/poly_run_1.f90 | 33 +- .../regression/coarray/poly_run_2.f90 | 28 +- .../gfortran/regression/coarray/tests.cmake | 3 + .../regression/coarray_alloc_comp_4.f08 | 2 +- .../gfortran/regression/coarray_poly_6.f90 | 2 +- .../gfortran/regression/coarray_poly_7.f90 | 2 +- .../gfortran/regression/coarray_poly_8.f90 | 2 +- Fortran/gfortran/regression/common_28.f90 | 7 + Fortran/gfortran/regression/contiguous_13.f90 | 22 + Fortran/gfortran/regression/contiguous_14.f90 | 39 ++ Fortran/gfortran/regression/contiguous_15.f90 | 234 +++++++ .../gfortran/regression/continuation_17.f90 | 267 ++++++++ .../gfortran/regression/continuation_18.f90 | 267 ++++++++ Fortran/gfortran/regression/continuation_19.f | 267 ++++++++ Fortran/gfortran/regression/data_array_7.f90 | 26 + Fortran/gfortran/regression/data_bounds_1.f90 | 2 +- Fortran/gfortran/regression/data_bounds_2.f90 | 9 + Fortran/gfortran/regression/data_char_4.f90 | 2 +- Fortran/gfortran/regression/data_char_5.f90 | 8 +- Fortran/gfortran/regression/data_char_6.f90 | 26 + .../regression/data_initialized_4.f90 | 16 + .../gfortran/regression/data_pointer_3.f90 | 77 +++ .../regression/data_vector_section.f90 | 26 + .../gfortran/regression/date_and_time_2.f90 | 21 + .../gfortran/regression/date_and_time_3.f90 | 29 + .../gfortran/regression/date_and_time_4.f90 | 30 + Fortran/gfortran/regression/debug/debug.exp | 2 +- Fortran/gfortran/regression/dec_math.f90 | 1 + .../regression/deferred_character_37.f90 | 88 +++ .../regression/deferred_character_38.f90 | 20 + .../gfortran/regression/dependent_decls_2.f90 | 89 +++ .../gfortran/regression/dependent_decls_3.f90 | 26 + .../regression/derived_comp_array_ref_8.f90 | 1 + .../derived_function_interface_1.f90 | 2 +- Fortran/gfortran/regression/dg.exp | 10 +- .../regression/diagnostic-format-json-1.F90 | 45 +- .../regression/diagnostic-format-json-2.F90 | 49 +- .../regression/diagnostic-format-json-3.F90 | 49 +- .../gfortran/regression/do_concurrent_7.f90 | 26 + Fortran/gfortran/regression/dtio_25.f90 | 2 +- Fortran/gfortran/regression/endfile_5.f90 | 30 + Fortran/gfortran/regression/finalize_38.f90 | 16 + Fortran/gfortran/regression/finalize_53.f90 | 34 + Fortran/gfortran/regression/finalize_54.f90 | 47 ++ Fortran/gfortran/regression/finalize_55.f90 | 89 +++ Fortran/gfortran/regression/finalize_56.f90 | 168 +++++ Fortran/gfortran/regression/finalize_57.f90 | 63 ++ Fortran/gfortran/regression/finalize_8.f03 | 68 +- Fortran/gfortran/regression/findloc_10.f90 | 13 + Fortran/gfortran/regression/findloc_9.f90 | 19 + Fortran/gfortran/regression/fmt_en.f90 | 2 +- Fortran/gfortran/regression/fmt_en_rd.f90 | 2 +- Fortran/gfortran/regression/fmt_en_rn.f90 | 2 +- Fortran/gfortran/regression/fmt_en_ru.f90 | 2 +- Fortran/gfortran/regression/fmt_en_rz.f90 | 2 +- Fortran/gfortran/regression/fmt_error_10.f | 2 +- .../fmt_f_default_field_width_3.f90 | 2 +- .../fmt_g_default_field_width_3.f90 | 2 +- Fortran/gfortran/regression/g77/README | 2 +- .../regression/goacc-gomp/goacc-gomp.exp | 2 +- .../regression/goacc/DisabledFiles.cmake | 4 + .../regression/goacc/attach-descriptor.f90 | 12 +- .../gfortran/regression/goacc/default-3.f95 | 77 ++- Fortran/gfortran/regression/goacc/default-4.f | 36 ++ Fortran/gfortran/regression/goacc/default-5.f | 19 +- .../regression/goacc/enter-exit-data-2.f90 | 38 ++ .../gfortran/regression/goacc/finalize-1.f | 8 +- Fortran/gfortran/regression/goacc/goacc.exp | 2 +- .../regression/goacc/host_data-error.f90 | 6 + Fortran/gfortran/regression/goacc/if.f95 | 10 +- .../regression/goacc/kernels-tree.f95 | 7 +- .../regression/goacc/parallel-tree.f95 | 3 +- .../gfortran/regression/goacc/pr109622-5.f90 | 44 ++ .../gfortran/regression/goacc/pr109622-6.f90 | 8 + Fortran/gfortran/regression/goacc/pr71704.f90 | 5 +- .../gfortran/regression/goacc/readonly-1.f90 | 95 +++ Fortran/gfortran/regression/goacc/self.f95 | 61 ++ Fortran/gfortran/regression/goacc/tests.cmake | 8 +- .../regression/goacc/warn_truncated.f90 | 1 + .../regression/gomp/DisabledFiles.cmake | 54 +- .../gfortran/regression/gomp/allocate-10.f90 | 75 +++ .../gfortran/regression/gomp/allocate-11.f90 | 33 + .../gfortran/regression/gomp/allocate-12.f90 | 24 + .../gfortran/regression/gomp/allocate-13.f90 | 25 + .../gfortran/regression/gomp/allocate-13a.f90 | 34 + .../gfortran/regression/gomp/allocate-14.f90 | 136 ++++ .../gfortran/regression/gomp/allocate-15.f90 | 38 ++ .../gfortran/regression/gomp/allocate-16.f90 | 10 + .../gfortran/regression/gomp/allocate-2.f90 | 4 +- .../gfortran/regression/gomp/allocate-4.f90 | 54 ++ .../gfortran/regression/gomp/allocate-5.f90 | 94 +++ .../gfortran/regression/gomp/allocate-6.f90 | 103 +++ .../gfortran/regression/gomp/allocate-7.f90 | 221 +++++++ .../gfortran/regression/gomp/allocate-8.f90 | 29 + .../gfortran/regression/gomp/allocate-9.f90 | 112 ++++ .../regression/gomp/allocate-pinned-1.f90 | 16 + .../gfortran/regression/gomp/allocators-1.f90 | 28 + .../gfortran/regression/gomp/allocators-2.f90 | 22 + .../gfortran/regression/gomp/allocators-3.f90 | 36 ++ .../gfortran/regression/gomp/allocators-4.f90 | 9 + .../gfortran/regression/gomp/atomic-21.f90 | 4 +- .../regression/gomp/c_ptr_tests_20.f90 | 56 ++ .../regression/gomp/c_ptr_tests_21.f90 | 56 ++ .../gfortran/regression/gomp/collapse1.f90 | 6 +- .../gfortran/regression/gomp/collapse2.f90 | 10 +- .../regression/gomp/declare-simd-2.f90 | 4 +- .../gomp/declare-simd-coarray-lib.f90 | 2 +- .../regression/gomp/declare-target-4.f90 | 2 +- .../gomp/declare-target-indirect-1.f90 | 62 ++ .../gomp/declare-target-indirect-2.f90 | 25 + .../regression/gomp/declare-variant-1.f90 | 5 +- .../regression/gomp/declare-variant-11.f90 | 4 +- .../regression/gomp/declare-variant-12.f90 | 12 +- .../regression/gomp/declare-variant-13.f90 | 2 +- .../regression/gomp/declare-variant-14.f90 | 8 +- .../regression/gomp/declare-variant-2.f90 | 52 +- .../regression/gomp/declare-variant-20.f90 | 51 ++ .../regression/gomp/declare-variant-2a.f90 | 8 +- .../regression/gomp/declare-variant-3.f90 | 8 +- .../regression/gomp/declare-variant-4.f90 | 8 +- .../regression/gomp/declare-variant-6.f90 | 14 +- .../regression/gomp/declare-variant-8.f90 | 2 +- .../gomp/declare-variant-no-score.f90 | 30 + .../gfortran/regression/gomp/defaultmap-1.f90 | 4 +- .../regression/gomp/defaultmap-10.f90 | 116 ++++ .../gfortran/regression/gomp/defaultmap-8.f90 | 26 + .../gfortran/regression/gomp/defaultmap-9.f90 | 71 +++ Fortran/gfortran/regression/gomp/depobj-3.f90 | 18 + Fortran/gfortran/regression/gomp/gomp.exp | 2 +- .../regression/gomp/imperfect-gotos.f90 | 69 ++ .../gomp/imperfect-invalid-scope.f90 | 81 +++ .../gfortran/regression/gomp/imperfect1.f90 | 39 ++ .../gfortran/regression/gomp/imperfect2.f90 | 56 ++ .../gfortran/regression/gomp/imperfect3.f90 | 45 ++ .../gfortran/regression/gomp/imperfect4.f90 | 36 ++ .../gfortran/regression/gomp/imperfect5.f90 | 85 +++ .../regression/gomp/inner-loops-1.f90 | 60 ++ .../regression/gomp/inner-loops-2.f90 | 62 ++ Fortran/gfortran/regression/gomp/linear-2.f90 | 4 +- Fortran/gfortran/regression/gomp/loop-2.f90 | 10 +- Fortran/gfortran/regression/gomp/map-10.f90 | 69 ++ Fortran/gfortran/regression/gomp/map-11.f90 | 34 + Fortran/gfortran/regression/gomp/map-12.f90 | 68 ++ Fortran/gfortran/regression/gomp/map-7.f90 | 30 +- Fortran/gfortran/regression/gomp/map-8.f90 | 11 + Fortran/gfortran/regression/gomp/map-9.f90 | 2 +- .../regression/gomp/map-subarray-2.f90 | 57 ++ .../gfortran/regression/gomp/map-subarray.f90 | 40 ++ .../gfortran/regression/gomp/nothing-2.f90 | 2 +- Fortran/gfortran/regression/gomp/pr114825.f90 | 16 + Fortran/gfortran/regression/gomp/pr115103.f90 | 14 + .../gfortran/regression/gomp/pr78260-2.f90 | 6 +- .../gfortran/regression/gomp/pr79154-1.f90 | 4 +- .../gfortran/regression/gomp/pr79154-2.f90 | 24 +- .../gfortran/regression/gomp/pr79154-simd.f90 | 2 +- Fortran/gfortran/regression/gomp/pr83977.f90 | 2 +- Fortran/gfortran/regression/gomp/pr99226.f90 | 4 +- Fortran/gfortran/regression/gomp/pure-1.f90 | 112 ++++ Fortran/gfortran/regression/gomp/pure-2.f90 | 48 ++ Fortran/gfortran/regression/gomp/pure-3.f90 | 31 + Fortran/gfortran/regression/gomp/pure-4.f90 | 35 ++ .../gfortran/regression/gomp/reduction5.f90 | 2 +- .../gfortran/regression/gomp/reduction6.f90 | 4 +- .../gfortran/regression/gomp/requires-1.f90 | 2 - .../gfortran/regression/gomp/requires-10.f90 | 36 ++ .../gfortran/regression/gomp/requires-11.f90 | 31 + .../gfortran/regression/gomp/requires-2.f90 | 4 +- .../gfortran/regression/gomp/requires-3.f90 | 7 +- .../gfortran/regression/gomp/requires-4.f90 | 1 - .../gfortran/regression/gomp/requires-5.f90 | 4 +- .../gfortran/regression/gomp/requires-6.f90 | 2 - .../gfortran/regression/gomp/requires-7.f90 | 1 - Fortran/gfortran/regression/gomp/scan-1.f90 | 9 +- Fortran/gfortran/regression/gomp/scan-8.f90 | 96 +++ Fortran/gfortran/regression/gomp/scan-9.f90 | 47 ++ .../gomp/strictly-structured-block-5.f90 | 77 +++ .../gomp/target-enter-exit-data.f90 | 39 ++ .../regression/gomp/target-exit-data.f90 | 4 +- .../regression/gomp/target-update-1.f90 | 13 + .../gfortran/regression/gomp/taskloop-2.f90 | 12 +- Fortran/gfortran/regression/gomp/teams-5.f90 | 150 +++++ Fortran/gfortran/regression/gomp/teams-6.f90 | 88 +++ Fortran/gfortran/regression/gomp/tests.cmake | 111 +++- Fortran/gfortran/regression/gomp/tile-1.f90 | 39 ++ Fortran/gfortran/regression/gomp/tile-10.f90 | 70 +++ Fortran/gfortran/regression/gomp/tile-2.f90 | 61 ++ Fortran/gfortran/regression/gomp/tile-3.f90 | 17 + Fortran/gfortran/regression/gomp/tile-4.f90 | 89 +++ Fortran/gfortran/regression/gomp/tile-5.f90 | 73 +++ Fortran/gfortran/regression/gomp/tile-6.f90 | 9 + Fortran/gfortran/regression/gomp/tile-7.f90 | 128 ++++ Fortran/gfortran/regression/gomp/tile-8.f90 | 18 + Fortran/gfortran/regression/gomp/tile-9.f90 | 96 +++ .../regression/gomp/tile-imperfect-nest-1.f90 | 17 + .../regression/gomp/tile-imperfect-nest-2.f90 | 74 +++ .../regression/gomp/tile-inner-loops-1.f90 | 16 + .../regression/gomp/tile-inner-loops-2.f90 | 20 + .../regression/gomp/tile-inner-loops-3.f90 | 22 + .../regression/gomp/tile-inner-loops-4.f90 | 14 + .../regression/gomp/tile-inner-loops-5.f90 | 59 ++ .../regression/gomp/tile-inner-loops-6.f90 | 13 + .../regression/gomp/tile-inner-loops-7.f90 | 13 + .../regression/gomp/tile-inner-loops-8.f90 | 63 ++ .../gomp/tile-non-rectangular-1.f90 | 23 + .../gomp/tile-non-rectangular-2.f90 | 11 + .../gomp/tile-non-rectangular-3.f90 | 47 ++ .../regression/gomp/tile-unroll-1.f90 | 18 + .../regression/gomp/tile-unroll-2.f90 | 44 ++ Fortran/gfortran/regression/gomp/unroll-1.f90 | 35 ++ .../gfortran/regression/gomp/unroll-10.f90 | 6 + .../gfortran/regression/gomp/unroll-11.f90 | 75 +++ .../gfortran/regression/gomp/unroll-12.f90 | 29 + .../gfortran/regression/gomp/unroll-13.f90 | 43 ++ Fortran/gfortran/regression/gomp/unroll-2.f90 | 22 + Fortran/gfortran/regression/gomp/unroll-3.f90 | 15 + Fortran/gfortran/regression/gomp/unroll-4.f90 | 15 + Fortran/gfortran/regression/gomp/unroll-5.f90 | 14 + Fortran/gfortran/regression/gomp/unroll-6.f90 | 241 +++++++ Fortran/gfortran/regression/gomp/unroll-7.f90 | 35 ++ Fortran/gfortran/regression/gomp/unroll-8.f90 | 26 + Fortran/gfortran/regression/gomp/unroll-9.f90 | 22 + .../regression/gomp/unroll-inner-loop-1.f90 | 28 + .../regression/gomp/unroll-inner-loop-2.f90 | 28 + .../regression/gomp/unroll-no-clause-1.f90 | 21 + .../regression/gomp/unroll-non-rect-1.f90 | 13 + .../regression/gomp/unroll-non-rect-2.f90 | 22 + .../regression/gomp/unroll-simd-1.f90 | 37 ++ .../regression/gomp/unroll-simd-2.f90 | 56 ++ .../regression/gomp/unroll-simd-3.f90 | 208 +++++++ .../regression/gomp/unroll-tile-1.f90 | 35 ++ .../regression/gomp/unroll-tile-2.f90 | 40 ++ .../regression/gomp/unroll-tile-inner-1.f90 | 24 + .../regression/gomp/warn_truncated.f90 | 1 + .../gfortran/regression/graphite/graphite.exp | 2 +- .../gfortran/regression/graphite/pr107865.f90 | 2 +- .../regression/graphite/vect-pr40979.f90 | 1 + .../gfortran/regression/guality/guality.exp | 2 +- .../regression/ieee/DisabledFiles.cmake | 13 + .../regression/ieee/comparisons_1.f90 | 282 +++++++++ .../regression/ieee/comparisons_2.f90 | 282 +++++++++ .../regression/ieee/comparisons_3.F90 | 487 +++++++++++++++ Fortran/gfortran/regression/ieee/ieee.exp | 2 +- Fortran/gfortran/regression/ieee/ieee_6.f90 | 2 +- Fortran/gfortran/regression/ieee/minmax_1.f90 | 235 +++++++ Fortran/gfortran/regression/ieee/minmax_2.f90 | 235 +++++++ Fortran/gfortran/regression/ieee/minmax_3.f90 | 235 +++++++ Fortran/gfortran/regression/ieee/minmax_4.f90 | 235 +++++++ Fortran/gfortran/regression/ieee/modes_1.f90 | 2 +- .../gfortran/regression/ieee/signaling_2.f90 | 3 - .../gfortran/regression/ieee/signaling_2_c.c | 10 +- Fortran/gfortran/regression/ieee/tests.cmake | 7 + .../gfortran/regression/implied_do_io_8.f90 | 18 + Fortran/gfortran/regression/intent_out_16.f90 | 89 +++ Fortran/gfortran/regression/intent_out_17.f90 | 46 ++ Fortran/gfortran/regression/intent_out_18.f90 | 31 + Fortran/gfortran/regression/intent_out_19.f90 | 22 + Fortran/gfortran/regression/intent_out_20.f90 | 33 + Fortran/gfortran/regression/intent_out_21.f90 | 33 + Fortran/gfortran/regression/intent_out_22.f90 | 37 ++ Fortran/gfortran/regression/interface_50.f90 | 98 +++ .../regression/interface_procedure_1.f90 | 23 + .../gfortran/regression/is_contiguous_4.f90 | 81 +++ .../regression/ishftc_optional_size_1.f90 | 97 +++ .../gfortran/regression/iso_fortran_env_8.f90 | 32 + .../gfortran/regression/iso_fortran_env_9.f90 | 29 + .../gfortran/regression/line_length_10.f90 | 2 +- .../gfortran/regression/line_length_11.f90 | 2 +- .../gfortran/regression/line_length_12.f90 | 31 + .../gfortran/regression/line_length_13.f90 | 27 + Fortran/gfortran/regression/line_length_2.f90 | 2 +- Fortran/gfortran/regression/line_length_5.f90 | 2 +- Fortran/gfortran/regression/line_length_6.f90 | 2 +- Fortran/gfortran/regression/line_length_7.f90 | 2 +- Fortran/gfortran/regression/line_length_8.f90 | 2 +- Fortran/gfortran/regression/line_length_9.f90 | 2 +- Fortran/gfortran/regression/lto/lto.exp | 2 +- Fortran/gfortran/regression/maxloc_5.f90 | 257 ++++++++ Fortran/gfortran/regression/minloc_5.f90 | 257 ++++++++ Fortran/gfortran/regression/minmaxloc_17.f90 | 33 + .../regression/missing_optional_dummy_6a.f90 | 4 +- .../regression/missing_optional_dummy_7.f90 | 64 ++ Fortran/gfortran/regression/namelist_57.f90 | 2 +- Fortran/gfortran/regression/namelist_65.f90 | 2 +- Fortran/gfortran/regression/nint_p7.f90 | 3 +- Fortran/gfortran/regression/null_actual_4.f90 | 35 ++ Fortran/gfortran/regression/null_actual_5.f90 | 76 +++ Fortran/gfortran/regression/nullify_4.f90 | 1 + .../regression/optional_absent_10.f90 | 219 +++++++ .../regression/optional_absent_11.f90 | 99 +++ .../regression/optional_absent_12.f90 | 30 + .../gfortran/regression/optional_absent_9.f90 | 340 ++++++++++ .../regression/optional_deferred_char_1.f90 | 100 +++ Fortran/gfortran/regression/overload_5.f90 | 118 ++++ Fortran/gfortran/regression/pdt_33.f03 | 21 + Fortran/gfortran/regression/pdt_33.f90 | 15 + Fortran/gfortran/regression/pdt_34.f03 | 42 ++ Fortran/gfortran/regression/pdt_35.f03 | 45 ++ Fortran/gfortran/regression/pdt_36.f03 | 65 ++ Fortran/gfortran/regression/pdt_37.f03 | 74 +++ Fortran/gfortran/regression/pdt_4.f03 | 2 +- .../gfortran/regression/pointer_init_6.f90 | 2 +- Fortran/gfortran/regression/pr100193.f90 | 20 + Fortran/gfortran/regression/pr100988.f90 | 61 ++ Fortran/gfortran/regression/pr101026.f | 2 +- Fortran/gfortran/regression/pr101267.f90 | 2 +- Fortran/gfortran/regression/pr101329.f90 | 4 +- Fortran/gfortran/regression/pr102109.f90 | 20 + Fortran/gfortran/regression/pr102112.f90 | 23 + Fortran/gfortran/regression/pr102190.f90 | 74 +++ Fortran/gfortran/regression/pr102532.f90 | 16 + Fortran/gfortran/regression/pr102597.f90 | 9 + Fortran/gfortran/regression/pr102860.f90 | 2 +- Fortran/gfortran/regression/pr103312.f90 | 87 +++ Fortran/gfortran/regression/pr103389.f90 | 23 + Fortran/gfortran/regression/pr103471.f90 | 18 + Fortran/gfortran/regression/pr103628.f90 | 2 +- Fortran/gfortran/regression/pr103715.f90 | 12 + Fortran/gfortran/regression/pr103716.f90 | 15 + Fortran/gfortran/regression/pr104351.f90 | 14 + Fortran/gfortran/regression/pr104429.f90 | 35 ++ Fortran/gfortran/regression/pr104555.f90 | 32 + Fortran/gfortran/regression/pr104625.f90 | 35 ++ Fortran/gfortran/regression/pr104649.f90 | 44 ++ Fortran/gfortran/regression/pr104908.f90 | 32 + Fortran/gfortran/regression/pr105152.f90 | 19 + Fortran/gfortran/regression/pr105361.f90 | 41 ++ Fortran/gfortran/regression/pr105456-nmlr.f90 | 60 ++ Fortran/gfortran/regression/pr105456-nmlw.f90 | 60 ++ Fortran/gfortran/regression/pr105456-ruf.f90 | 36 ++ Fortran/gfortran/regression/pr105456-wf.f90 | 34 + Fortran/gfortran/regression/pr105456-wuf.f90 | 34 + Fortran/gfortran/regression/pr105456.f90 | 38 ++ Fortran/gfortran/regression/pr105473.f90 | 53 ++ Fortran/gfortran/regression/pr105847.f90 | 39 ++ Fortran/gfortran/regression/pr106999.f90 | 33 + Fortran/gfortran/regression/pr107068.f90 | 22 + Fortran/gfortran/regression/pr107397.f90 | 1 + Fortran/gfortran/regression/pr107821.f90 | 9 + Fortran/gfortran/regression/pr107900.f90 | 49 ++ Fortran/gfortran/regression/pr108889.f90 | 43 ++ Fortran/gfortran/regression/pr108961.f90 | 26 + Fortran/gfortran/regression/pr109358.f90 | 14 + Fortran/gfortran/regression/pr109662-a.f90 | 28 + Fortran/gfortran/regression/pr109662.f90 | 15 + Fortran/gfortran/regression/pr109948.f90 | 114 ++++ Fortran/gfortran/regression/pr110221.f | 17 + Fortran/gfortran/regression/pr110224.f90 | 29 + Fortran/gfortran/regression/pr110415.f90 | 20 + Fortran/gfortran/regression/pr110996.f90 | 16 + Fortran/gfortran/regression/pr111022.f90 | 72 +++ Fortran/gfortran/regression/pr111853.f90 | 16 + Fortran/gfortran/regression/pr111880.f90 | 22 + Fortran/gfortran/regression/pr111891.f90 | 21 + Fortran/gfortran/regression/pr112316.f90 | 79 +++ Fortran/gfortran/regression/pr112404.f90 | 23 + Fortran/gfortran/regression/pr112406.f90 | 21 + Fortran/gfortran/regression/pr112407a.f90 | 71 +++ Fortran/gfortran/regression/pr112407b.f90 | 58 ++ Fortran/gfortran/regression/pr112459.f90 | 37 ++ Fortran/gfortran/regression/pr113363.f90 | 86 +++ Fortran/gfortran/regression/pr113503_1.f90 | 18 + Fortran/gfortran/regression/pr113503_2.f90 | 12 + Fortran/gfortran/regression/pr113956.f90 | 21 + Fortran/gfortran/regression/pr114012.f90 | 81 +++ Fortran/gfortran/regression/pr114304-2.f90 | 82 +++ Fortran/gfortran/regression/pr114304.f90 | 114 ++++ Fortran/gfortran/regression/pr114535d.f90 | 42 ++ Fortran/gfortran/regression/pr114535iv.f90 | 18 + Fortran/gfortran/regression/pr114739.f90 | 11 + Fortran/gfortran/regression/pr114874_1.f90 | 32 + Fortran/gfortran/regression/pr114874_2.f90 | 53 ++ Fortran/gfortran/regression/pr114883.f90 | 53 ++ Fortran/gfortran/regression/pr114959.f90 | 33 + Fortran/gfortran/regression/pr115281.f90 | 39 ++ Fortran/gfortran/regression/pr25623-2.f90 | 19 + Fortran/gfortran/regression/pr25623.f90 | 19 + Fortran/gfortran/regression/pr43984.f90 | 2 +- Fortran/gfortran/regression/pr49213.f90 | 109 ++++ Fortran/gfortran/regression/pr67740.f90 | 32 + Fortran/gfortran/regression/pr68155.f90 | 29 + Fortran/gfortran/regression/pr78061.f | 2 +- Fortran/gfortran/regression/pr79315.f90 | 6 +- Fortran/gfortran/regression/pr82774.f90 | 15 + Fortran/gfortran/regression/pr84868.f90 | 84 +++ Fortran/gfortran/regression/pr87907.f90 | 8 +- Fortran/gfortran/regression/pr87946.f90 | 42 ++ Fortran/gfortran/regression/pr88138.f90 | 1 + Fortran/gfortran/regression/pr88552.f90 | 6 + Fortran/gfortran/regression/pr88624.f90 | 21 + Fortran/gfortran/regression/pr88688.f90 | 62 ++ Fortran/gfortran/regression/pr89462.f90 | 13 + Fortran/gfortran/regression/pr89943_3.f90 | 2 +- Fortran/gfortran/regression/pr89943_4.f90 | 2 +- Fortran/gfortran/regression/pr92586.f90 | 61 ++ Fortran/gfortran/regression/pr93635.f90 | 19 + Fortran/gfortran/regression/pr93678.f90 | 32 + Fortran/gfortran/regression/pr94380.f90 | 18 + Fortran/gfortran/regression/pr95398.f90 | 8 +- Fortran/gfortran/regression/pr95690.f90 | 4 +- Fortran/gfortran/regression/pr95710.f90 | 17 + Fortran/gfortran/regression/pr96436_4.f90 | 4 +- Fortran/gfortran/regression/pr96436_5.f90 | 4 +- Fortran/gfortran/regression/pr99139.f90 | 24 + Fortran/gfortran/regression/pr99210.f90 | 29 + Fortran/gfortran/regression/pr99326.f90 | 26 + Fortran/gfortran/regression/pr99350.f90 | 16 + Fortran/gfortran/regression/pr99368.f90 | 17 + Fortran/gfortran/regression/proc_ptr_53.f90 | 35 ++ .../gfortran/regression/proc_ptr_comp_53.f90 | 43 ++ Fortran/gfortran/regression/prof/prof.exp | 2 +- Fortran/gfortran/regression/ptr-func-5.f90 | 39 ++ Fortran/gfortran/regression/repeat_8.f90 | 123 ++++ Fortran/gfortran/regression/reshape_10.f90 | 34 + Fortran/gfortran/regression/reshape_11.f90 | 15 + Fortran/gfortran/regression/reshape_8.f90 | 2 +- Fortran/gfortran/regression/select_rank_6.f90 | 48 ++ .../regression/selected_logical_kind_1.f90 | 29 + .../regression/selected_logical_kind_2.f90 | 9 + .../regression/selected_logical_kind_3.f90 | 18 + .../regression/selected_logical_kind_4.f90 | 23 + .../gfortran/regression/set_exponent_1.f90 | 36 ++ Fortran/gfortran/regression/shape_12.f90 | 51 ++ Fortran/gfortran/regression/simd-builtins-1.h | 1 - .../gfortran/regression/simd-builtins-6.f90 | 1 - Fortran/gfortran/regression/size_dim_2.f90 | 19 + .../regression/size_optional_dim_2.f90 | 31 + Fortran/gfortran/regression/sizeof_2.f90 | 2 +- Fortran/gfortran/regression/spec_expr_10.f90 | 46 ++ Fortran/gfortran/regression/spec_expr_8.f90 | 24 + Fortran/gfortran/regression/spec_expr_9.f90 | 19 + .../regression/statement_function_5.f90 | 20 + .../gfortran/regression/storage_size_7.f90 | 91 +++ Fortran/gfortran/regression/streamio_9.f90 | 1 + .../regression/string_array_constructor_4.f90 | 59 ++ Fortran/gfortran/regression/submodule_33.f08 | 20 + .../gfortran/regression/system_clock_1.f90 | 1 + .../gfortran/regression/system_clock_3.f08 | 1 + .../gfortran/regression/system_clock_4.f90 | 24 + Fortran/gfortran/regression/tests.cmake | 267 +++++++- .../gfortran/regression/transfer_class_4.f90 | 87 +++ .../regression/ubsan/DisabledFiles.cmake | 8 +- .../ubsan/missing_optional_dummy_8.f90 | 108 ++++ Fortran/gfortran/regression/ubsan/tests.cmake | 3 +- Fortran/gfortran/regression/ubsan/ubsan.exp | 6 +- .../regression/unlimited_polymorphic_11.f90 | 2 +- Fortran/gfortran/regression/use_31.f90 | 26 + Fortran/gfortran/regression/value_9.f90 | 105 ++++ .../gfortran/regression/value_optional_1.f90 | 83 +++ .../regression/vect/DisabledFiles.cmake | 3 + .../regression/vect/fast-math-mgrid-resid.f | 3 +- Fortran/gfortran/regression/vect/pr107254.f90 | 2 - Fortran/gfortran/regression/vect/pr110451.f | 51 ++ Fortran/gfortran/regression/vect/pr114736.f90 | 14 + Fortran/gfortran/regression/vect/pr115528.f | 27 + Fortran/gfortran/regression/vect/pr115710.f90 | 18 + Fortran/gfortran/regression/vect/pr45714-b.f | 2 +- Fortran/gfortran/regression/vect/pr49955.f | 38 ++ Fortran/gfortran/regression/vect/pr60510.f | 2 +- Fortran/gfortran/regression/vect/pr68855.f90 | 16 + Fortran/gfortran/regression/vect/pr77848.f | 2 +- Fortran/gfortran/regression/vect/pr85853.f90 | 1 - Fortran/gfortran/regression/vect/pr90681.f | 2 +- Fortran/gfortran/regression/vect/pr90913.f90 | 2 +- Fortran/gfortran/regression/vect/pr97761.f90 | 2 +- Fortran/gfortran/regression/vect/pr99746.f90 | 2 +- Fortran/gfortran/regression/vect/tests.cmake | 20 +- Fortran/gfortran/regression/vect/vect-10.f90 | 71 +++ Fortran/gfortran/regression/vect/vect-8.f90 | 6 +- .../regression/vect/vect-alias-check-1.F90 | 1 - .../vect/vect-early-break_1-pr113808.f90 | 21 + Fortran/gfortran/regression/vect/vect.exp | 2 +- Fortran/gfortran/regression/zero_sized_13.f90 | 28 + Fortran/gfortran/regression/zero_sized_14.f90 | 181 ++++++ Fortran/gfortran/regression/zero_sized_15.f90 | 114 ++++ Fortran/gfortran/torture/compile/compile.exp | 2 +- .../torture/execute/DisabledFiles.cmake | 3 + Fortran/gfortran/torture/execute/execute.exp | 2 +- Fortran/gfortran/torture/execute/math.f90 | 24 +- 554 files changed, 22302 insertions(+), 485 deletions(-) create mode 100644 Fortran/gfortran/regression/20231103-1.f90 create mode 100644 Fortran/gfortran/regression/20231103-2.f90 create mode 100644 Fortran/gfortran/regression/PR105658.f90 create mode 100644 Fortran/gfortran/regression/PR113061.f90 create mode 100644 Fortran/gfortran/regression/allocatable_function_11.f90 create mode 100644 Fortran/gfortran/regression/allocatable_length.f90 create mode 100644 Fortran/gfortran/regression/allocatable_length_2.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_27.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_28.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_29.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_30.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_31.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_32.f90 create mode 100644 Fortran/gfortran/regression/allocate_with_source_33.f90 create mode 100644 Fortran/gfortran/regression/allocated_4.f90 create mode 100644 Fortran/gfortran/regression/arithmetic_overflow_2.f90 create mode 100644 Fortran/gfortran/regression/arithmetic_overflow_3.f90 create mode 100644 Fortran/gfortran/regression/array_memset_3.f90 create mode 100755 Fortran/gfortran/regression/asan/pr110415-2.f90 create mode 100755 Fortran/gfortran/regression/asan/pr110415-3.f90 create mode 100644 Fortran/gfortran/regression/asan/unlimited_polymorphic_34.f90 create mode 100644 Fortran/gfortran/regression/associate_61.f90 create mode 100644 Fortran/gfortran/regression/associate_62.f90 create mode 100644 Fortran/gfortran/regression/associate_63.f90 create mode 100644 Fortran/gfortran/regression/associate_64.f90 create mode 100644 Fortran/gfortran/regression/associate_65.f90 create mode 100644 Fortran/gfortran/regression/associate_66.f90 create mode 100644 Fortran/gfortran/regression/associate_67.f90 create mode 100644 Fortran/gfortran/regression/associate_68.f90 create mode 100644 Fortran/gfortran/regression/associate_69.f90 create mode 100644 Fortran/gfortran/regression/assumed_type_18.f90 create mode 100644 Fortran/gfortran/regression/bind_c_char_11.f90 create mode 100644 Fortran/gfortran/regression/bind_c_optional-2.f90 create mode 100644 Fortran/gfortran/regression/block_17.f90 create mode 100644 Fortran/gfortran/regression/bound_10.f90 create mode 100644 Fortran/gfortran/regression/bound_11.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_24.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_25.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_fail_5.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_fail_6.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_fail_7.f90 create mode 100644 Fortran/gfortran/regression/bounds_check_fail_8.f90 create mode 100644 Fortran/gfortran/regression/c_f_pointer_tests_9.f90 create mode 100644 Fortran/gfortran/regression/c_sizeof_7.f90 create mode 100644 Fortran/gfortran/regression/c_sizeof_8.f90 create mode 100644 Fortran/gfortran/regression/class_76.f90 create mode 100644 Fortran/gfortran/regression/class_77.f90 create mode 100644 Fortran/gfortran/regression/class_78.f90 create mode 100644 Fortran/gfortran/regression/class_dummy_11.f90 create mode 100644 Fortran/gfortran/regression/coarray/alloc_comp_6.f90 create mode 100644 Fortran/gfortran/regression/coarray/alloc_comp_7.f90 create mode 100644 Fortran/gfortran/regression/coarray/alloc_comp_8.f90 create mode 100644 Fortran/gfortran/regression/common_28.f90 create mode 100644 Fortran/gfortran/regression/contiguous_13.f90 create mode 100644 Fortran/gfortran/regression/contiguous_14.f90 create mode 100644 Fortran/gfortran/regression/contiguous_15.f90 create mode 100644 Fortran/gfortran/regression/continuation_17.f90 create mode 100644 Fortran/gfortran/regression/continuation_18.f90 create mode 100644 Fortran/gfortran/regression/continuation_19.f create mode 100644 Fortran/gfortran/regression/data_array_7.f90 create mode 100644 Fortran/gfortran/regression/data_bounds_2.f90 create mode 100644 Fortran/gfortran/regression/data_char_6.f90 create mode 100644 Fortran/gfortran/regression/data_initialized_4.f90 create mode 100644 Fortran/gfortran/regression/data_pointer_3.f90 create mode 100644 Fortran/gfortran/regression/data_vector_section.f90 create mode 100644 Fortran/gfortran/regression/date_and_time_2.f90 create mode 100644 Fortran/gfortran/regression/date_and_time_3.f90 create mode 100644 Fortran/gfortran/regression/date_and_time_4.f90 create mode 100644 Fortran/gfortran/regression/deferred_character_37.f90 create mode 100644 Fortran/gfortran/regression/deferred_character_38.f90 create mode 100644 Fortran/gfortran/regression/dependent_decls_2.f90 create mode 100644 Fortran/gfortran/regression/dependent_decls_3.f90 create mode 100644 Fortran/gfortran/regression/do_concurrent_7.f90 create mode 100644 Fortran/gfortran/regression/endfile_5.f90 create mode 100644 Fortran/gfortran/regression/finalize_53.f90 create mode 100644 Fortran/gfortran/regression/finalize_54.f90 create mode 100644 Fortran/gfortran/regression/finalize_55.f90 create mode 100644 Fortran/gfortran/regression/finalize_56.f90 create mode 100644 Fortran/gfortran/regression/finalize_57.f90 create mode 100644 Fortran/gfortran/regression/findloc_10.f90 create mode 100644 Fortran/gfortran/regression/findloc_9.f90 create mode 100644 Fortran/gfortran/regression/goacc/enter-exit-data-2.f90 create mode 100644 Fortran/gfortran/regression/goacc/host_data-error.f90 create mode 100644 Fortran/gfortran/regression/goacc/pr109622-5.f90 create mode 100644 Fortran/gfortran/regression/goacc/pr109622-6.f90 create mode 100644 Fortran/gfortran/regression/goacc/readonly-1.f90 create mode 100644 Fortran/gfortran/regression/goacc/self.f95 create mode 100644 Fortran/gfortran/regression/gomp/allocate-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-11.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-12.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-13.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-13a.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-14.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-15.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-16.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-6.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-7.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-9.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocate-pinned-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocators-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocators-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocators-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/allocators-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/c_ptr_tests_20.f90 create mode 100644 Fortran/gfortran/regression/gomp/c_ptr_tests_21.f90 create mode 100644 Fortran/gfortran/regression/gomp/declare-target-indirect-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/declare-target-indirect-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/declare-variant-20.f90 create mode 100644 Fortran/gfortran/regression/gomp/declare-variant-no-score.f90 create mode 100644 Fortran/gfortran/regression/gomp/defaultmap-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/defaultmap-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/defaultmap-9.f90 create mode 100644 Fortran/gfortran/regression/gomp/depobj-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect-gotos.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect-invalid-scope.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect1.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect2.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect3.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect4.f90 create mode 100644 Fortran/gfortran/regression/gomp/imperfect5.f90 create mode 100644 Fortran/gfortran/regression/gomp/inner-loops-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/inner-loops-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/map-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/map-11.f90 create mode 100644 Fortran/gfortran/regression/gomp/map-12.f90 create mode 100644 Fortran/gfortran/regression/gomp/map-subarray-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/map-subarray.f90 create mode 100644 Fortran/gfortran/regression/gomp/pr114825.f90 create mode 100644 Fortran/gfortran/regression/gomp/pr115103.f90 create mode 100644 Fortran/gfortran/regression/gomp/pure-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/pure-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/pure-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/pure-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/requires-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/requires-11.f90 create mode 100644 Fortran/gfortran/regression/gomp/scan-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/scan-9.f90 create mode 100644 Fortran/gfortran/regression/gomp/strictly-structured-block-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/target-enter-exit-data.f90 create mode 100644 Fortran/gfortran/regression/gomp/target-update-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/teams-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/teams-6.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-6.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-7.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-9.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-imperfect-nest-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-imperfect-nest-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-6.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-7.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-inner-loops-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-non-rectangular-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-non-rectangular-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-non-rectangular-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-unroll-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/tile-unroll-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-10.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-11.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-12.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-13.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-4.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-5.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-6.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-7.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-8.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-9.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-inner-loop-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-inner-loop-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-no-clause-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-non-rect-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-non-rect-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-simd-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-simd-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-simd-3.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-tile-1.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-tile-2.f90 create mode 100644 Fortran/gfortran/regression/gomp/unroll-tile-inner-1.f90 create mode 100644 Fortran/gfortran/regression/ieee/comparisons_1.f90 create mode 100644 Fortran/gfortran/regression/ieee/comparisons_2.f90 create mode 100644 Fortran/gfortran/regression/ieee/comparisons_3.F90 create mode 100644 Fortran/gfortran/regression/ieee/minmax_1.f90 create mode 100644 Fortran/gfortran/regression/ieee/minmax_2.f90 create mode 100644 Fortran/gfortran/regression/ieee/minmax_3.f90 create mode 100644 Fortran/gfortran/regression/ieee/minmax_4.f90 create mode 100644 Fortran/gfortran/regression/implied_do_io_8.f90 create mode 100644 Fortran/gfortran/regression/intent_out_16.f90 create mode 100644 Fortran/gfortran/regression/intent_out_17.f90 create mode 100644 Fortran/gfortran/regression/intent_out_18.f90 create mode 100644 Fortran/gfortran/regression/intent_out_19.f90 create mode 100644 Fortran/gfortran/regression/intent_out_20.f90 create mode 100644 Fortran/gfortran/regression/intent_out_21.f90 create mode 100644 Fortran/gfortran/regression/intent_out_22.f90 create mode 100644 Fortran/gfortran/regression/interface_50.f90 create mode 100644 Fortran/gfortran/regression/interface_procedure_1.f90 create mode 100644 Fortran/gfortran/regression/is_contiguous_4.f90 create mode 100644 Fortran/gfortran/regression/ishftc_optional_size_1.f90 create mode 100644 Fortran/gfortran/regression/iso_fortran_env_8.f90 create mode 100644 Fortran/gfortran/regression/iso_fortran_env_9.f90 create mode 100644 Fortran/gfortran/regression/line_length_12.f90 create mode 100644 Fortran/gfortran/regression/line_length_13.f90 create mode 100644 Fortran/gfortran/regression/maxloc_5.f90 create mode 100644 Fortran/gfortran/regression/minloc_5.f90 create mode 100644 Fortran/gfortran/regression/minmaxloc_17.f90 create mode 100644 Fortran/gfortran/regression/missing_optional_dummy_7.f90 create mode 100644 Fortran/gfortran/regression/null_actual_4.f90 create mode 100644 Fortran/gfortran/regression/null_actual_5.f90 create mode 100644 Fortran/gfortran/regression/optional_absent_10.f90 create mode 100644 Fortran/gfortran/regression/optional_absent_11.f90 create mode 100644 Fortran/gfortran/regression/optional_absent_12.f90 create mode 100644 Fortran/gfortran/regression/optional_absent_9.f90 create mode 100644 Fortran/gfortran/regression/optional_deferred_char_1.f90 create mode 100644 Fortran/gfortran/regression/overload_5.f90 create mode 100644 Fortran/gfortran/regression/pdt_33.f03 create mode 100644 Fortran/gfortran/regression/pdt_33.f90 create mode 100644 Fortran/gfortran/regression/pdt_34.f03 create mode 100644 Fortran/gfortran/regression/pdt_35.f03 create mode 100644 Fortran/gfortran/regression/pdt_36.f03 create mode 100644 Fortran/gfortran/regression/pdt_37.f03 create mode 100644 Fortran/gfortran/regression/pr100193.f90 create mode 100644 Fortran/gfortran/regression/pr100988.f90 create mode 100644 Fortran/gfortran/regression/pr102109.f90 create mode 100644 Fortran/gfortran/regression/pr102112.f90 create mode 100644 Fortran/gfortran/regression/pr102190.f90 create mode 100644 Fortran/gfortran/regression/pr102532.f90 create mode 100644 Fortran/gfortran/regression/pr102597.f90 create mode 100644 Fortran/gfortran/regression/pr103312.f90 create mode 100644 Fortran/gfortran/regression/pr103389.f90 create mode 100644 Fortran/gfortran/regression/pr103471.f90 create mode 100644 Fortran/gfortran/regression/pr103715.f90 create mode 100644 Fortran/gfortran/regression/pr103716.f90 create mode 100644 Fortran/gfortran/regression/pr104351.f90 create mode 100644 Fortran/gfortran/regression/pr104429.f90 create mode 100644 Fortran/gfortran/regression/pr104555.f90 create mode 100644 Fortran/gfortran/regression/pr104625.f90 create mode 100644 Fortran/gfortran/regression/pr104649.f90 create mode 100644 Fortran/gfortran/regression/pr104908.f90 create mode 100644 Fortran/gfortran/regression/pr105152.f90 create mode 100644 Fortran/gfortran/regression/pr105361.f90 create mode 100644 Fortran/gfortran/regression/pr105456-nmlr.f90 create mode 100644 Fortran/gfortran/regression/pr105456-nmlw.f90 create mode 100644 Fortran/gfortran/regression/pr105456-ruf.f90 create mode 100644 Fortran/gfortran/regression/pr105456-wf.f90 create mode 100644 Fortran/gfortran/regression/pr105456-wuf.f90 create mode 100644 Fortran/gfortran/regression/pr105456.f90 create mode 100644 Fortran/gfortran/regression/pr105473.f90 create mode 100644 Fortran/gfortran/regression/pr105847.f90 create mode 100644 Fortran/gfortran/regression/pr106999.f90 create mode 100644 Fortran/gfortran/regression/pr107068.f90 create mode 100644 Fortran/gfortran/regression/pr107821.f90 create mode 100644 Fortran/gfortran/regression/pr107900.f90 create mode 100644 Fortran/gfortran/regression/pr108889.f90 create mode 100644 Fortran/gfortran/regression/pr108961.f90 create mode 100644 Fortran/gfortran/regression/pr109358.f90 create mode 100644 Fortran/gfortran/regression/pr109662-a.f90 create mode 100644 Fortran/gfortran/regression/pr109662.f90 create mode 100644 Fortran/gfortran/regression/pr109948.f90 create mode 100644 Fortran/gfortran/regression/pr110221.f create mode 100644 Fortran/gfortran/regression/pr110224.f90 create mode 100644 Fortran/gfortran/regression/pr110415.f90 create mode 100644 Fortran/gfortran/regression/pr110996.f90 create mode 100644 Fortran/gfortran/regression/pr111022.f90 create mode 100644 Fortran/gfortran/regression/pr111853.f90 create mode 100644 Fortran/gfortran/regression/pr111880.f90 create mode 100644 Fortran/gfortran/regression/pr111891.f90 create mode 100644 Fortran/gfortran/regression/pr112316.f90 create mode 100644 Fortran/gfortran/regression/pr112404.f90 create mode 100644 Fortran/gfortran/regression/pr112406.f90 create mode 100644 Fortran/gfortran/regression/pr112407a.f90 create mode 100644 Fortran/gfortran/regression/pr112407b.f90 create mode 100644 Fortran/gfortran/regression/pr112459.f90 create mode 100644 Fortran/gfortran/regression/pr113363.f90 create mode 100644 Fortran/gfortran/regression/pr113503_1.f90 create mode 100644 Fortran/gfortran/regression/pr113503_2.f90 create mode 100644 Fortran/gfortran/regression/pr113956.f90 create mode 100644 Fortran/gfortran/regression/pr114012.f90 create mode 100644 Fortran/gfortran/regression/pr114304-2.f90 create mode 100644 Fortran/gfortran/regression/pr114304.f90 create mode 100644 Fortran/gfortran/regression/pr114535d.f90 create mode 100644 Fortran/gfortran/regression/pr114535iv.f90 create mode 100644 Fortran/gfortran/regression/pr114739.f90 create mode 100644 Fortran/gfortran/regression/pr114874_1.f90 create mode 100644 Fortran/gfortran/regression/pr114874_2.f90 create mode 100644 Fortran/gfortran/regression/pr114883.f90 create mode 100644 Fortran/gfortran/regression/pr114959.f90 create mode 100644 Fortran/gfortran/regression/pr115281.f90 create mode 100644 Fortran/gfortran/regression/pr25623-2.f90 create mode 100644 Fortran/gfortran/regression/pr25623.f90 create mode 100644 Fortran/gfortran/regression/pr49213.f90 create mode 100644 Fortran/gfortran/regression/pr67740.f90 create mode 100644 Fortran/gfortran/regression/pr68155.f90 create mode 100644 Fortran/gfortran/regression/pr82774.f90 create mode 100644 Fortran/gfortran/regression/pr84868.f90 create mode 100644 Fortran/gfortran/regression/pr87946.f90 create mode 100644 Fortran/gfortran/regression/pr88552.f90 create mode 100644 Fortran/gfortran/regression/pr88624.f90 create mode 100644 Fortran/gfortran/regression/pr88688.f90 create mode 100644 Fortran/gfortran/regression/pr89462.f90 create mode 100644 Fortran/gfortran/regression/pr92586.f90 create mode 100644 Fortran/gfortran/regression/pr93635.f90 create mode 100644 Fortran/gfortran/regression/pr93678.f90 create mode 100644 Fortran/gfortran/regression/pr94380.f90 create mode 100644 Fortran/gfortran/regression/pr95710.f90 create mode 100644 Fortran/gfortran/regression/pr99139.f90 create mode 100644 Fortran/gfortran/regression/pr99210.f90 create mode 100644 Fortran/gfortran/regression/pr99326.f90 create mode 100644 Fortran/gfortran/regression/pr99350.f90 create mode 100644 Fortran/gfortran/regression/pr99368.f90 create mode 100644 Fortran/gfortran/regression/proc_ptr_53.f90 create mode 100644 Fortran/gfortran/regression/proc_ptr_comp_53.f90 create mode 100644 Fortran/gfortran/regression/ptr-func-5.f90 create mode 100644 Fortran/gfortran/regression/repeat_8.f90 create mode 100644 Fortran/gfortran/regression/reshape_10.f90 create mode 100644 Fortran/gfortran/regression/reshape_11.f90 create mode 100644 Fortran/gfortran/regression/select_rank_6.f90 create mode 100644 Fortran/gfortran/regression/selected_logical_kind_1.f90 create mode 100644 Fortran/gfortran/regression/selected_logical_kind_2.f90 create mode 100644 Fortran/gfortran/regression/selected_logical_kind_3.f90 create mode 100644 Fortran/gfortran/regression/selected_logical_kind_4.f90 create mode 100644 Fortran/gfortran/regression/set_exponent_1.f90 create mode 100644 Fortran/gfortran/regression/shape_12.f90 create mode 100644 Fortran/gfortran/regression/size_dim_2.f90 create mode 100644 Fortran/gfortran/regression/size_optional_dim_2.f90 create mode 100644 Fortran/gfortran/regression/spec_expr_10.f90 create mode 100644 Fortran/gfortran/regression/spec_expr_8.f90 create mode 100644 Fortran/gfortran/regression/spec_expr_9.f90 create mode 100644 Fortran/gfortran/regression/statement_function_5.f90 create mode 100644 Fortran/gfortran/regression/storage_size_7.f90 create mode 100644 Fortran/gfortran/regression/string_array_constructor_4.f90 create mode 100644 Fortran/gfortran/regression/submodule_33.f08 create mode 100644 Fortran/gfortran/regression/system_clock_4.f90 create mode 100644 Fortran/gfortran/regression/transfer_class_4.f90 create mode 100644 Fortran/gfortran/regression/ubsan/missing_optional_dummy_8.f90 create mode 100644 Fortran/gfortran/regression/use_31.f90 create mode 100644 Fortran/gfortran/regression/value_9.f90 create mode 100644 Fortran/gfortran/regression/value_optional_1.f90 create mode 100644 Fortran/gfortran/regression/vect/pr110451.f create mode 100644 Fortran/gfortran/regression/vect/pr114736.f90 create mode 100644 Fortran/gfortran/regression/vect/pr115528.f create mode 100644 Fortran/gfortran/regression/vect/pr115710.f90 create mode 100644 Fortran/gfortran/regression/vect/pr49955.f create mode 100644 Fortran/gfortran/regression/vect/pr68855.f90 create mode 100644 Fortran/gfortran/regression/vect/vect-10.f90 create mode 100644 Fortran/gfortran/regression/vect/vect-early-break_1-pr113808.f90 create mode 100644 Fortran/gfortran/regression/zero_sized_13.f90 create mode 100644 Fortran/gfortran/regression/zero_sized_14.f90 create mode 100644 Fortran/gfortran/regression/zero_sized_15.f90 diff --git a/Fortran/gfortran/CMakeLists.txt b/Fortran/gfortran/CMakeLists.txt index 2ae7b67ed..b2896db62 100644 --- a/Fortran/gfortran/CMakeLists.txt +++ b/Fortran/gfortran/CMakeLists.txt @@ -109,6 +109,7 @@ set(FLANG_ERRORING_FFLAGS -fbounds-check -fcheck-array-temporaries -fcheck=all + -fcheck=array-temps -fcheck=bits -fcheck=bounds -fcheck=do @@ -131,6 +132,7 @@ set(FLANG_ERRORING_FFLAGS -fcheck-bounds -fcheck=all -fcheck=bits + -fcheck=no-bounds # Not sure if the -fdefault-* options will be supported. Maybe in a different # form in which case, this will have to be modified to accommodate those. -fdefault-real-10 @@ -666,9 +668,7 @@ function(gfortran_add_compile_test expect_error main others fflags ldflags) -DALWAYS_SAVE_DIAGS=OFF -DWORKING_DIRECTORY=${working_dir} -DOUTPUT_FILE=${out} - -P ${COMPILE_SCRIPT_BIN} - USES_TERMINAL - COMMENT "Compiling ${main}") + -P ${COMPILE_SCRIPT_BIN}) add_custom_target(${target} ALL diff --git a/Fortran/gfortran/regression/20231103-1.f90 b/Fortran/gfortran/regression/20231103-1.f90 new file mode 100644 index 000000000..61ccf5c5e --- /dev/null +++ b/Fortran/gfortran/regression/20231103-1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +SUBROUTINE sedi_1D(QX1d, DZ1d,kdir,BX1d,kbot,ktop) + real, dimension(:) :: QX1d,DZ1d + real, dimension(size(QX1d)) :: VVQ + logical BX_present + do k= kbot,ktop,kdir + VVQ= VV_Q0 + enddo + Vxmaxx= min0 + if (kdir==1) then + dzMIN = minval(DZ1d) + endif + npassx= Vxmaxx/dzMIN + DO nnn= 1,npassx + if (BX_present) then + do k= ktop,kdir + BX1d= iDZ1d0 + enddo + endif + ENDDO +END diff --git a/Fortran/gfortran/regression/20231103-2.f90 b/Fortran/gfortran/regression/20231103-2.f90 new file mode 100644 index 000000000..c510505d5 --- /dev/null +++ b/Fortran/gfortran/regression/20231103-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +subroutine shr_map_checkFldStrshr_map_mapSet_dest(ndst,max0,eps,sum0,maxval0,min0,nidnjd,renorm) + allocatable sum(:) + logical renorm + allocate(sum(ndst)) + do n=1,ndst + if (sum0 > eps) then + rmax = max0 + endif + enddo + if (renorm) then + rmin = maxval0 + rmax = minval(sum) + do n=1,nidnjd + if (sum0 > eps) then + rmin = min0 + endif + enddo + write(*,*) rmin,rmax + endif +end diff --git a/Fortran/gfortran/regression/DisabledFiles.cmake b/Fortran/gfortran/regression/DisabledFiles.cmake index 266f57669..95d297fbb 100644 --- a/Fortran/gfortran/regression/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/DisabledFiles.cmake @@ -165,6 +165,13 @@ file(GLOB UNIMPLEMENTED_FILES CONFIGURE_DEPENDS unlimited_polymorphic_1.f03 unlimited_polymorphic_32.f90 + # unimplemented: assumed-rank variable in procedure implemented in Fortran + associate_66.f90 + bind_c_optional-2.f90 + intent_out_19.f90 + intent_out_20.f90 + shape_12.f90 + # unimplemented: ASYNCHRONOUS in procedure interface assumed_rank_13.f90 asynchronous_3.f03 @@ -351,6 +358,7 @@ file(GLOB UNIMPLEMENTED_FILES CONFIGURE_DEPENDS pdt_25.f03 pdt_27.f03 pdt_28.f03 + pdt_36.f03 pdt_7.f03 pdt_9.f03 pr95826.f90 @@ -541,6 +549,7 @@ file(GLOB SKIPPED_FILES CONFIGURE_DEPENDS # error: No intrinsic or user-defined ASSIGNMENT(=) matches operand types # 'TYPE 1' and 'TYPE 2' + assumed_type_18.f90 dec-comparison-complex_1.f90 dec-comparison-complex_2.f90 dec-comparison-int_1.f90 @@ -853,6 +862,37 @@ file(GLOB SKIPPED_FILES CONFIGURE_DEPENDS include_19.f90 include_20.f90 include_8.f90 + + # ---------------------------------------------------------------------------- + # + # These tests require 128-bit integer support. Since we do not process + # DejaGNU directives to conditionally disable such tests, they are always + # disabled until we can conditionally run such tests + selected_logical_kind_3.f90 + + # error: conflicting debug info for argument + entry_6.f90 + + # error: Only -std=f2018 is allowed currently. + continuation_19.f + + # error: Must be a constant value + pdt_33.f03 + + # error: 'foo_size' is not a procedure + pr103312.f90 + + # error: Actual argument type '__builtin_c_ptr' is not compatible with dummy + # argument type 'c_ptr' + pr108961.f90 + + # error: Procedure pointer 'op' with implicit interface may not be associated + # with procedure designator 'new_t' with explicit interface that cannot be + # called via an implicit interface + pr112407a.f90 + + # This causes a segmentation fault at run-time. + ishftc_optional_size_1.f90 ) # These tests are disabled because they fail when they are expected to pass. @@ -973,6 +1013,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # anyway so the test-suite passes by default on AArch64. entry_23.f findloc_8.f90 + pr99210.f90 # These tests fail on Ubuntu because of a bug in the not utility. At least # some of these should work once the issue with not has been fixed. @@ -1438,6 +1479,9 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # error: No explicit type declared for 'arg4' unused_artificial_dummies_1.f90 + # Invalid specification expression: reference to OPTIONAL dummy argument + allocatable_length_2.f90 + # Valid errors # Valid out-of-bounds subscript errors, are warnings in gfortran bounds_check_3.f90 @@ -1730,7 +1774,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS bounds_check_17.f90 pr48958.f90 - # These files require the __truncsfbf2 intrinsic that is not available in + # These files require the __truncsfbf2 intrinsic that is not available # before GCC 13. Alternatively, it requires compiler-rt to be built and a # command line option provided to instruct the compiler to use it. Currently, # we do not support either a version check on GCC or require that compiler-rt @@ -1751,4 +1795,50 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # These are flaky tests, which may fail sometimes. random_init_2.f90 + + # The causes of failure of these tests need to be investigated + PR113061.f90 + allocate_with_source_29.f90 + boz_8.f90 + continuation_18.f90 + data_initialized_4.f90 + data_pointer_3.f90 + date_and_time_2.f90 + interface_50.f90 + interface_procedure_1.f90 + iso_fortran_env_9.f90 + line_length_12.f90 + oldstyle_5.f + pdt_34.f03 + pdt_35.f03 + pr104555.f90 + pr112407b.f90 + pr114883.f90 + pr25623-2.f90 + pr25623.f90 + pr43984.f90 + pr88624.f90 + pr99139.f90 + pr99368.f90 + reshape_10.f90 + selected_logical_kind_2.f90 + submodule_3.f08 + submodule_33.f08 + achar_2.f90 + allocate_with_source_30.f90 + allocate_with_source_31.f90 + backslash_1.f90 + bound_11.f90 + bounds_check_fail_6.f90 + bounds_check_fail_7.f90 + finalize_56.f90 + internal_dummy_2.f08 + iso_fortran_env_8.f90 + optional_absent_12.f90 + pr103389.f90 + pr105456-nmlr.f90 + pr105473.f90 + pr111022.f90 + pr114304.f90 + zero_sized_15.f90 ) diff --git a/Fortran/gfortran/regression/PR105658.f90 b/Fortran/gfortran/regression/PR105658.f90 new file mode 100644 index 000000000..8aacecf80 --- /dev/null +++ b/Fortran/gfortran/regression/PR105658.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! Test fix for incorrectly passing array component to unlimited polymorphic procedure + +module test_PR105658_mod + implicit none + type :: foo + integer :: member1 + integer :: member2 + end type foo +contains + subroutine print_poly(array) + class(*), dimension(:), intent(in) :: array + select type(array) + type is (integer) + print*, array + type is (character(*)) + print *, array + end select + end subroutine print_poly + + subroutine do_print(thing) + type(foo), dimension(3), intent(in) :: thing + type(foo), parameter :: y(3) = [foo(1,2),foo(3,4),foo(5,6)] + integer :: i, j, uu(5,6) + + call print_poly(thing%member1) ! { dg-warning "array temporary" } + call print_poly(y%member2) ! { dg-warning "array temporary" } + call print_poly(y(1::2)%member2) ! { dg-warning "array temporary" } + + ! The following array sections work without temporaries + uu = reshape([(((10*i+j),i=1,5),j=1,6)],[5,6]) + print *, uu(2,2::2) + call print_poly (uu(2,2::2)) ! no temp needed! + print *, uu(1::2,6) + call print_poly (uu(1::2,6)) ! no temp needed! + end subroutine do_print + + subroutine do_print2(thing2) + class(foo), dimension(:), intent(in) :: thing2 + call print_poly (thing2% member2) ! { dg-warning "array temporary" } + end subroutine do_print2 + + subroutine do_print3 () + character(3) :: c(3) = ["abc","def","ghi"] + call print_poly (c(1::2)) ! no temp needed! + call print_poly (c(1::2)(2:3)) ! { dg-warning "array temporary" } + end subroutine do_print3 + +end module test_PR105658_mod diff --git a/Fortran/gfortran/regression/PR113061.f90 b/Fortran/gfortran/regression/PR113061.f90 new file mode 100644 index 000000000..989bc385c --- /dev/null +++ b/Fortran/gfortran/regression/PR113061.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fno-move-loop-invariants -Oz" } +module module_foo + use iso_c_binding + contains + subroutine foo(a) bind(c) + type(c_ptr) a(..) + select rank(a) + end select + call bar + end +end diff --git a/Fortran/gfortran/regression/allocatable_function_1.f90 b/Fortran/gfortran/regression/allocatable_function_1.f90 index f96ebc499..e38953bd7 100644 --- a/Fortran/gfortran/regression/allocatable_function_1.f90 +++ b/Fortran/gfortran/regression/allocatable_function_1.f90 @@ -107,4 +107,4 @@ function bar (n) result(b) end function bar end program alloc_fun -! { dg-final { scan-tree-dump-times "free" 10 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free " 10 "original" } } diff --git a/Fortran/gfortran/regression/allocatable_function_11.f90 b/Fortran/gfortran/regression/allocatable_function_11.f90 new file mode 100644 index 000000000..1a2831e18 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_11.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR fortran/109500 - check F2018:8.5.3 Note 1 +! +! The result of referencing a function whose result variable has the +! ALLOCATABLE attribute is a value that does not itself have the +! ALLOCATABLE attribute. + +program main + implicit none + integer, allocatable :: p + procedure(f), pointer :: pp + pp => f + p = f() + print *, allocated (p) + print *, is_allocated (p) + print *, is_allocated (f()) ! { dg-error "is a function result" } + print *, is_allocated (pp()) ! { dg-error "is a function result" } + call s (p) + call s (f()) ! { dg-error "is a function result" } + call s (pp()) ! { dg-error "is a function result" } + +contains + subroutine s(p) + integer, allocatable :: p + end subroutine s + + function f() + integer, allocatable :: f + allocate (f, source=42) + end function + + logical function is_allocated(p) + integer, allocatable :: p + is_allocated = allocated(p) + end function +end program diff --git a/Fortran/gfortran/regression/allocatable_length.f90 b/Fortran/gfortran/regression/allocatable_length.f90 new file mode 100644 index 000000000..e8b638fac --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_length.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Werror -Wall" } +module foo + contains + subroutine bar + character(len=:), allocatable :: s(:) + call bah(s) + end subroutine bar +end module foo diff --git a/Fortran/gfortran/regression/allocatable_length_2.f90 b/Fortran/gfortran/regression/allocatable_length_2.f90 new file mode 100644 index 000000000..2fd64efdc --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_length_2.f90 @@ -0,0 +1,107 @@ +! { dg-do run } +! PR fortran/113911 +! +! Test that deferred length is not lost + +module m + integer, parameter :: n = 100, l = 10 + character(l) :: a = 'a234567890', b(n) = 'bcdefghijk' + character(:), allocatable :: c1, c2(:) +end + +program p + use m, only : l, n, a, b, x => c1, y => c2 + implicit none + character(:), allocatable :: d, e(:) + allocate (d, source=a) + allocate (e, source=b) + if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 12 + call plain_deferred (d, e) + call optional_deferred (d, e) + call optional_deferred_ar (d, e) + if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 13 + deallocate (d, e) + call alloc (d, e) + if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 14 + deallocate (d, e) + call alloc_host_assoc () + if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 15 + deallocate (d, e) + call alloc_use_assoc () + if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 16 + call indirect (x, y) + if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 17 + deallocate (x, y) +contains + subroutine plain_deferred (c1, c2) + character(:), allocatable :: c1, c2(:) + if (.not. allocated (c1) .or. .not. allocated (c2)) stop 1 + if (len (c1) /= l) stop 2 + if (len (c2) /= l) stop 3 + if (c1(1:3) /= "a23") stop 4 + if (c2(5)(1:3) /= "bcd") stop 5 + end + + subroutine optional_deferred (c1, c2) + character(:), allocatable, optional :: c1, c2(:) + if (.not. present (c1) .or. .not. present (c2)) stop 6 + if (.not. allocated (c1) .or. .not. allocated (c2)) stop 7 + if (len (c1) /= l) stop 8 + if (len (c2) /= l) stop 9 + if (c1(1:3) /= "a23") stop 10 + if (c2(5)(1:3) /= "bcd") stop 11 + end + + ! Assumed rank + subroutine optional_deferred_ar (c1, c2) + character(:), allocatable, optional :: c1(..) + character(:), allocatable, optional :: c2(..) + if (.not. present (c1) .or. & + .not. present (c2)) stop 21 + if (.not. allocated (c1) .or. & + .not. allocated (c2)) stop 22 + + select rank (c1) + rank (0) + if (len (c1) /= l) stop 23 + if (c1(1:3) /= "a23") stop 24 + rank default + stop 25 + end select + + select rank (c2) + rank (1) + if (len (c2) /= l) stop 26 + if (c2(5)(1:3) /= "bcd") stop 27 + rank default + stop 28 + end select + end + + ! Allocate dummy arguments + subroutine alloc (c1, c2) + character(:), allocatable :: c1, c2(:) + allocate (c1, source=a) + allocate (c2, source=b) + end + + ! Allocate host-associated variables + subroutine alloc_host_assoc () + allocate (d, source=a) + allocate (e, source=b) + end + + ! Allocate use-associated variables + subroutine alloc_use_assoc () + allocate (x, source=a) + allocate (y, source=b) + end + + ! Pass-through deferred-length + subroutine indirect (c1, c2) + character(:), allocatable :: c1, c2(:) + call plain_deferred (c1, c2) + call optional_deferred (c1, c2) + call optional_deferred_ar (c1, c2) + end +end diff --git a/Fortran/gfortran/regression/allocate_with_source_25.f90 b/Fortran/gfortran/regression/allocate_with_source_25.f90 index de20a1478..92dc50756 100644 --- a/Fortran/gfortran/regression/allocate_with_source_25.f90 +++ b/Fortran/gfortran/regression/allocate_with_source_25.f90 @@ -68,4 +68,4 @@ function func_foo_a (D) result (f) end function func_foo_a end program simple_leak -! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } } +! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_source_27.f90 b/Fortran/gfortran/regression/allocate_with_source_27.f90 new file mode 100644 index 000000000..d0f0f3c4a --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_27.f90 @@ -0,0 +1,20 @@ +! +! { dg-do run } +! +! fortran/PR114024 +! https://github.com/fujitsu/compiler-test-suite +! Modified from Fortran/0093/0093_0130.f90 +! +program foo + implicit none + complex :: cmp(3) + real, allocatable :: xx(:), yy(:), zz(:) + cmp = (3., 6.78) + allocate(xx, source = cmp%re) ! This caused an ICE. + allocate(yy, source = cmp(1:3)%re) ! This caused an ICE. + allocate(zz, source = (cmp%re)) + if (any(xx /= [3., 3., 3.])) stop 1 + if (any(yy /= [3., 3., 3.])) stop 2 + if (any(zz /= [3., 3., 3.])) stop 3 +end program foo + diff --git a/Fortran/gfortran/regression/allocate_with_source_28.f90 b/Fortran/gfortran/regression/allocate_with_source_28.f90 new file mode 100644 index 000000000..8548ccb34 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_28.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! PR fortran/114024 + +program foo + implicit none + complex :: cmp(3) = (3.,4.) + type ci ! pseudo "complex integer" type + integer :: re + integer :: im + end type ci + type cr ! pseudo "complex" type + real :: re + real :: im + end type cr + type u + type(ci) :: ii(3) + type(cr) :: rr(3) + end type u + type(u) :: cc + + cc% ii% re = nint (cmp% re) + cc% ii% im = nint (cmp% im) + cc% rr% re = cmp% re + cc% rr% im = cmp% im + + call test_substring () + call test_int_real () + call test_poly () + +contains + + subroutine test_substring () + character(4) :: str(3) = ["abcd","efgh","ijkl"] + character(:), allocatable :: ac(:) + allocate (ac, source=str(1::2)(2:4)) + if (size (ac) /= 2 .or. len (ac) /= 3) stop 11 + if (ac(2) /= "jkl") stop 12 + deallocate (ac) + allocate (ac, mold=str(1::2)(2:4)) + if (size (ac) /= 2 .or. len (ac) /= 3) stop 13 + deallocate (ac) + end + + subroutine test_int_real () + integer, allocatable :: aa(:) + real, pointer :: pp(:) + allocate (aa, source = cc% ii% im) + if (size (aa) /= 3) stop 21 + if (any (aa /= cmp% im)) stop 22 + allocate (pp, source = cc% rr% re) + if (size (pp) /= 3) stop 23 + if (any (pp /= cmp% re)) stop 24 + deallocate (aa, pp) + end + + subroutine test_poly () + class(*), allocatable :: uu(:), vv(:) + allocate (uu, source = cc% ii% im) + allocate (vv, source = cc% rr% re) + if (size (uu) /= 3) stop 31 + if (size (vv) /= 3) stop 32 + call check (uu) + call check (vv) + deallocate (uu, vv) + allocate (uu, mold = cc% ii% im) + allocate (vv, mold = cc% rr% re) + if (size (uu) /= 3) stop 33 + if (size (vv) /= 3) stop 34 + deallocate (uu, vv) + end + + subroutine check (x) + class(*), intent(in) :: x(:) + select type (x) + type is (integer) + if (any (x /= cmp% im)) then + print *, "'integer':", x + stop 41 + end if + type is (real) + if (any (x /= cmp% re)) then + print *, "'real':", x + stop 42 + end if + type is (character(*)) + print *, "'character':", x + end select + end +end diff --git a/Fortran/gfortran/regression/allocate_with_source_29.f90 b/Fortran/gfortran/regression/allocate_with_source_29.f90 new file mode 100644 index 000000000..b3d4c8ae5 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_29.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! PR fortran/113793 +! +! Static checks of string length for ALLOCATE with SOURCE= or MOLD= + +program p + implicit none + character(kind=1,len=8), allocatable :: a(:), d, b(:,:) + character(kind=4,len=6), allocatable :: c(:), e, f(:,:) + character(kind=1,len=2) :: c1 = "xx" + character(kind=1,len=8) :: c2 = "yy" + character(kind=4,len=6) :: c3 = 4_"ww" + character(kind=4,len=3) :: c4 = 4_"zz" + + ALLOCATE (a(1),source= "a") ! { dg-error "Unequal character lengths .8/1. " } + ALLOCATE (a(2),mold = "bb") ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (c(3),source=4_"yyy") ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (c(4),mold =4_"zzzz") ! { dg-error "Unequal character lengths .6/4. " } + ALLOCATE (d, source= "12345") ! { dg-error "Unequal character lengths .8/5. " } + ALLOCATE (d, source= "12345678") + ALLOCATE (d, mold = "123456") ! { dg-error "Unequal character lengths .8/6. " } + ALLOCATE (e, source=4_"654321") + ALLOCATE (e, mold =4_"7654321") ! { dg-error "Unequal character lengths .6/7. " } + ALLOCATE (a(5),source=c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (a(6),mold =c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (c(7),source=c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (c(8),mold =c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (a,source=[c1,c1,c1]) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (a,source=[c2,c2,c2]) + ALLOCATE (c,source=[c3,c3]) + ALLOCATE (c,source=[c4,c4]) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (d,source=c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (e,source=c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (b,source=reshape([c1],[1,1])) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (b,source=reshape([c2],[1,1])) + ALLOCATE (f,source=reshape([c3],[1,1])) + ALLOCATE (f,source=reshape([c4],[1,1])) ! { dg-error "Unequal character lengths .6/3. " } +contains + subroutine foo (s) + character(*), intent(in) :: s + character(len=8), allocatable :: f(:), g + ALLOCATE (f(3), source=s) + ALLOCATE (d, source=s) + ALLOCATE (f(3), mold=s) + ALLOCATE (d, mold=s) + end +end diff --git a/Fortran/gfortran/regression/allocate_with_source_30.f90 b/Fortran/gfortran/regression/allocate_with_source_30.f90 new file mode 100644 index 000000000..f8a71d117 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_30.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-options "-std=f2008 -fcheck=bounds -g -fdump-tree-original" } +! { dg-output "At line 43 .*" } +! { dg-shouldfail "Unequal character lengths .3/2. in ALLOCATE with SOURCE= or MOLD=" } +! +! PR fortran/113793 +! +! Test runtime checks of string length for ALLOCATE with SOURCE= or MOLD= + +program p + implicit none + character(kind=1,len=2) :: c1 = "xx" + character(kind=1,len=8) :: c2 = "yy" + character(kind=4,len=6) :: c3 = 4_"ww" + call sub1 (len (c2), c2) + call sub4 (len (c3), c3) + call test (len (c1) + 1, c1) +contains + subroutine sub1 (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=8), allocatable :: f(:), g + character(len=n), allocatable :: h(:), j + ALLOCATE (f(7), source=s) + ALLOCATE (g, source=s) + ALLOCATE (h(5), mold=s) + ALLOCATE (j, mold=s) + end + subroutine sub4 (n, s) + integer, intent(in) :: n + character(kind=4,len=*), intent(in) :: s + character(kind=4,len=6), allocatable :: f(:), g + character(kind=4,len=n), allocatable :: h(:), j + ALLOCATE (f(3), source=s) + ALLOCATE (g, source=s) + ALLOCATE (h(5), mold=s) + ALLOCATE (j, mold=s) + end + subroutine test (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: str + ALLOCATE (str, source=s) + end +end + +! { dg-final { scan-tree-dump-times "__builtin_malloc .72.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .24.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .56.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .8.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ALLOCATE with SOURCE= or MOLD=" 9 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_source_31.f90 b/Fortran/gfortran/regression/allocate_with_source_31.f90 new file mode 100644 index 000000000..50c609812 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_31.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-additional-options "-std=gnu -fcheck=no-bounds" } +! +! PR fortran/113793 +! +! Test extension for ALLOCATE with SOURCE= or MOLD= that strings +! are truncated or padded and no memory corruption occurs + +program p + implicit none + call test_pad (8, "12345") + call test_trunc (6, "123456789") +contains + subroutine test_pad (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: a(:), b(:,:) + if (len (s) >= n) stop 111 + ALLOCATE (a(100),source=s) + ALLOCATE (b(5,6),source=s) +! print *, ">", a(42), "<" +! print *, ">", b(3,4), "<" + if (a(42) /= s) stop 1 + if (b(3,4) /= s) stop 2 + end + subroutine test_trunc (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: a(:), b(:,:) + if (len (s) <= n) stop 222 + ALLOCATE (a(100),source=s) + ALLOCATE (b(5,6),source=s) +! print *, ">", a(42), "<" +! print *, ">", b(3,4), "<" + if (a(42) /= s(1:n)) stop 3 + if (b(3,4) /= s(1:n)) stop 4 + end +end diff --git a/Fortran/gfortran/regression/allocate_with_source_32.f90 b/Fortran/gfortran/regression/allocate_with_source_32.f90 new file mode 100644 index 000000000..4a9bd46da --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_32.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/83865 +! +! Test ALLOCATE with SOURCE= of deferred length character, where +! the source-expression is an array of character with length 0. + +program p + implicit none + character(:), allocatable :: z(:) + character(1) :: cc(4) = "" + allocate (z, source=['']) + if (len (z) /= 0 .or. size (z) /= 1) stop 1 + deallocate (z) + allocate (z, source=['','']) + if (len (z) /= 0 .or. size (z) /= 2) stop 2 + deallocate (z) + allocate (z, source=[ character(0) :: 'a','b','c']) + if (len (z) /= 0 .or. size (z) /= 3) stop 3 + deallocate (z) + allocate (z, source=[ character(0) :: cc ]) + if (len (z) /= 0 .or. size (z) /= 4) stop 4 + deallocate (z) + associate (x => f()) + if (len (x) /= 0 .or. size (x) /= 1) stop 5 + if (x(1) /= '') stop 6 + end associate +contains + function f() result(z) + character(:), allocatable :: z(:) + allocate (z, source=['']) + end function f +end diff --git a/Fortran/gfortran/regression/allocate_with_source_33.f90 b/Fortran/gfortran/regression/allocate_with_source_33.f90 new file mode 100644 index 000000000..43a036259 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_33.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! { dg-options "-O0" } +! +! PR fortran/114019 - allocation with source of deferred character length + +subroutine s + implicit none + character(1) :: w = "4" + character(*), parameter :: str = "123" + character(5), pointer :: chr_pointer1 + character(:), pointer :: chr_pointer2 + character(:), pointer :: chr_ptr_arr(:) + character(5), allocatable :: chr_alloc1 + character(:), allocatable :: chr_alloc2 + character(:), allocatable :: chr_all_arr(:) + allocate (chr_pointer1, source=w// str//w) + allocate (chr_pointer2, source=w// str//w) + allocate (chr_ptr_arr, source=w//[str//w]) + allocate (chr_alloc1, source=w// str//w) + allocate (chr_alloc2, source=w// str//w) + allocate (chr_all_arr, source=w//[str//w]) + allocate (chr_pointer2, source=str) + allocate (chr_pointer2, source=w) + allocate (chr_alloc2, source=str) + allocate (chr_alloc2, source=w) + allocate (chr_pointer1, mold =w// str//w) + allocate (chr_pointer2, mold =w// str//w) + allocate (chr_ptr_arr, mold =w//[str//w]) + allocate (chr_alloc1, mold =w// str//w) + allocate (chr_alloc2, mold =w// str//w) + allocate (chr_all_arr, mold =w//[str//w]) + allocate (chr_pointer2, mold =str) + allocate (chr_pointer2, mold =w) + allocate (chr_alloc2, mold =str) + allocate (chr_alloc2, mold =w) +end + +subroutine s2 + implicit none + integer, parameter :: ck=4 + character(kind=ck,len=1) :: w = ck_"4" + character(kind=ck,len=*), parameter :: str = ck_"123" + character(kind=ck,len=5), pointer :: chr_pointer1 + character(kind=ck,len=:), pointer :: chr_pointer2 + character(kind=ck,len=:), pointer :: chr_ptr_arr(:) + character(kind=ck,len=5), allocatable :: chr_alloc1 + character(kind=ck,len=:), allocatable :: chr_alloc2 + character(kind=ck,len=:), allocatable :: chr_all_arr(:) + allocate (chr_pointer1, source=w// str//w) + allocate (chr_pointer2, source=w// str//w) + allocate (chr_ptr_arr, source=w//[str//w]) + allocate (chr_alloc1, source=w// str//w) + allocate (chr_alloc2, source=w// str//w) + allocate (chr_all_arr, source=w//[str//w]) + allocate (chr_pointer2, source=str) + allocate (chr_pointer2, source=w) + allocate (chr_alloc2, source=str) + allocate (chr_alloc2, source=w) + allocate (chr_pointer1, mold =w// str//w) + allocate (chr_pointer2, mold =w// str//w) + allocate (chr_ptr_arr, mold =w//[str//w]) + allocate (chr_alloc1, mold =w// str//w) + allocate (chr_alloc2, mold =w// str//w) + allocate (chr_all_arr, mold =w//[str//w]) + allocate (chr_pointer2, mold =str) + allocate (chr_pointer2, mold =w) + allocate (chr_alloc2, mold =str) + allocate (chr_alloc2, mold =w) +end diff --git a/Fortran/gfortran/regression/allocated_4.f90 b/Fortran/gfortran/regression/allocated_4.f90 new file mode 100644 index 000000000..485806be2 --- /dev/null +++ b/Fortran/gfortran/regression/allocated_4.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! +! PR fortran/112412 +! The library used to not allocate memory for the result of transformational +! functions reducing an array along one dimension, if the result of the +! function was an empty array. This caused the result to be seen as +! an unallocated array. + +program p + implicit none + call check_iparity + call check_sum + call check_minloc_int + call check_minloc_char + call check_maxloc_char4 + call check_minval_char + call check_maxval_char4 + call check_any + call check_count4 +contains + subroutine check_iparity + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = iparity(a, dim=i) + if (.not. allocated(r)) stop 11 + deallocate(r) + i = 2 + r = iparity(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 12 + deallocate(r) + i = 4 + r = iparity(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 13 + deallocate(r) + end subroutine + subroutine check_sum + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 2 + r = sum(a, dim=i) + if (.not. allocated(r)) stop 21 + deallocate(r) + i = 4 + r = sum(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 22 + deallocate(r) + i = 1 + r = sum(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 23 + deallocate(r) + end subroutine + subroutine check_minloc_int + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 4 + r = minloc(a, dim=i) + if (.not. allocated(r)) stop 31 + deallocate(r) + i = 1 + r = minloc(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 32 + deallocate(r) + i = 2 + r = minloc(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 33 + deallocate(r) + end subroutine + subroutine check_minloc_char + character :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ character:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 4 + r = minloc(a, dim=i) + if (.not. allocated(r)) stop 41 + deallocate(r) + i = 2 + r = minloc(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 42 + deallocate(r) + i = 1 + r = minloc(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 43 + deallocate(r) + end subroutine + subroutine check_maxloc_char4 + character(kind=4) :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ character(kind=4):: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = maxloc(a, dim=i) + if (.not. allocated(r)) stop 51 + deallocate(r) + i = 4 + r = maxloc(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 52 + deallocate(r) + i = 2 + r = maxloc(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 53 + deallocate(r) + end subroutine + subroutine check_minval_char + character :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + character, allocatable :: r(:,:,:) + a = reshape((/ character:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 2 + r = minval(a, dim=i) + if (.not. allocated(r)) stop 61 + deallocate(r) + i = 1 + r = minval(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 62 + deallocate(r) + i = 4 + r = minval(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 63 + deallocate(r) + end subroutine + subroutine check_maxval_char4 + character(kind=4) :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + character(kind=4), allocatable :: r(:,:,:) + a = reshape((/ character(kind=4):: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = maxval(a, dim=i) + if (.not. allocated(r)) stop 71 + deallocate(r) + i = 2 + r = maxval(a, dim=i, mask=m1) + if (.not. allocated(r)) stop 72 + deallocate(r) + i = 4 + r = maxval(a, dim=i, mask=m4) + if (.not. allocated(r)) stop 73 + deallocate(r) + end subroutine + subroutine check_any + logical :: a(9,3,0,7) + integer :: i + logical, allocatable :: r(:,:,:) + a = reshape((/ logical:: /), shape(a)) + i = 2 + r = any(a, dim=i) + if (.not. allocated(r)) stop 81 + deallocate(r) + end subroutine + subroutine check_count4 + logical(kind=4) :: a(9,3,0,7) + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ logical(kind=4):: /), shape(a)) + i = 4 + r = count(a, dim=i) + if (.not. allocated(r)) stop 91 + deallocate(r) + end subroutine +end program diff --git a/Fortran/gfortran/regression/analyzer/analyzer.exp b/Fortran/gfortran/regression/analyzer/analyzer.exp index 88ddca8a1..bbb69df0f 100644 --- a/Fortran/gfortran/regression/analyzer/analyzer.exp +++ b/Fortran/gfortran/regression/analyzer/analyzer.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2020-2023 Free Software Foundation, Inc. +# Copyright (C) 2020-2024 Free Software Foundation, Inc. # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/arithmetic_overflow_2.f90 b/Fortran/gfortran/regression/arithmetic_overflow_2.f90 new file mode 100644 index 000000000..6ca27f742 --- /dev/null +++ b/Fortran/gfortran/regression/arithmetic_overflow_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-additional-options "-frange-check" } +! +! PR fortran/113799 - handle arithmetic overflow on unary minus + +program p + implicit none + real, parameter :: inf = real(z'7F800000') + real, parameter :: someInf(*) = [inf, 0.] + print *, -someInf ! { dg-error "Arithmetic overflow" } + print *, minval(-someInf) ! { dg-error "Arithmetic overflow" } +end diff --git a/Fortran/gfortran/regression/arithmetic_overflow_3.f90 b/Fortran/gfortran/regression/arithmetic_overflow_3.f90 new file mode 100644 index 000000000..4dc552742 --- /dev/null +++ b/Fortran/gfortran/regression/arithmetic_overflow_3.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-additional-options "-frange-check" } +! +! PR fortran/103707 +! PR fortran/106987 +! +! Check error recovery on arithmetic exceptions + +program p + implicit none + integer, parameter :: a(3) = [30,31,32] + integer, parameter :: e(1) = 2 + print *, 2 ** a ! { dg-error "Arithmetic overflow" } + print *, e ** 31 ! { dg-error "Arithmetic overflow" } +end + +! { dg-prune-output "Result of exponentiation" } + +subroutine s + implicit none + real, parameter :: inf = real (z'7F800000') + real, parameter :: nan = real (z'7FC00000') + + ! Unary operators + print *, -[inf,nan] ! { dg-error "Arithmetic overflow" } + print *, -[nan,inf] ! { dg-error "Arithmetic NaN" } + + ! Binary operators + print *, [1.]/[0.] ! { dg-error "Division by zero" } + print *, [0.]/[0.] ! { dg-error "Arithmetic NaN" } + print *, 0. / [(0.,0.)] ! { dg-error "Arithmetic NaN" } + print *, [1.,0.]/[0.,0.] ! { dg-error "Division by zero" } + print *, [(1.,1.)]/[0.] ! { dg-error "Division by zero" } + print *, [(1.,0.)]/[0.] ! { dg-error "Division by zero" } + print *, [(0.,0.)]/[0.] ! { dg-error "Arithmetic NaN" } + print *, - [1./0.]/[0.] ! { dg-error "Division by zero" } + print *, - [ 1/0 ] * 1 ! { dg-error "Division by zero" } + + ! Binary operators, exceptional input + print *, 1. / nan ! { dg-error "Arithmetic NaN" } + print *, [inf] / inf ! { dg-error "Arithmetic NaN" } + print *, inf + [nan] ! { dg-error "Arithmetic NaN" } + print *, [(1.,0.)]/[(nan,0.)] ! { dg-error "Arithmetic NaN" } + print *, [(1.,0.)]/[(0.,nan)] ! { dg-error "Arithmetic NaN" } + print *, [(1.,0.)]/[(inf,0.)] ! OK + print *, [nan,inf] / (0.) ! { dg-error "Arithmetic NaN" } + print *, [inf,nan] / (0.) ! { dg-error "Arithmetic overflow" } +end diff --git a/Fortran/gfortran/regression/array_memset_3.f90 b/Fortran/gfortran/regression/array_memset_3.f90 new file mode 100644 index 000000000..f3945aacb --- /dev/null +++ b/Fortran/gfortran/regression/array_memset_3.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + +subroutine test1(n) + implicit none + integer(8) :: n + real(4), allocatable :: z(:,:,:) + + allocate(z(n, 100, 200)) + z = 0 +end subroutine + +subroutine test2(n) + implicit none + integer(8) :: n + integer, allocatable :: z(:,:,:) + + allocate(z(n, 100, 200)) + z = 0 +end subroutine + +subroutine test3(n) + implicit none + integer(8) :: n + logical, allocatable :: z(:,:,:) + + allocate(z(n, 100, 200)) + z = .false. +end subroutine + +subroutine test4(n, z) + implicit none + integer :: n + real, pointer :: z(:,:,:) ! need not be contiguous! + z = 0 +end subroutine + +subroutine test5(n, z) + implicit none + integer :: n + real, contiguous, pointer :: z(:,:,:) + z = 0 +end subroutine + +subroutine test6 (n, z) + implicit none + integer :: n + real, contiguous, pointer :: z(:,:,:) + z(:,::1,:) = 0 +end subroutine + +! { dg-final { scan-tree-dump-times "__builtin_memset" 5 "original" } } diff --git a/Fortran/gfortran/regression/asan/asan.exp b/Fortran/gfortran/regression/asan/asan.exp index 1b2104d4a..a1576381e 100644 --- a/Fortran/gfortran/regression/asan/asan.exp +++ b/Fortran/gfortran/regression/asan/asan.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2020-2023 Free Software Foundation, Inc. +# Copyright (C) 2020-2024 Free Software Foundation, Inc. # # This file is part of GCC. # @@ -27,7 +27,8 @@ load_lib asan-dg.exp # Initialize `dg'. dg-init -asan_init +# libasan uses libstdc++ so make sure we provide paths for it. +asan_init 1 # Main loop. if [check_effective_target_fsanitize_address] { diff --git a/Fortran/gfortran/regression/asan/pr110415-2.f90 b/Fortran/gfortran/regression/asan/pr110415-2.f90 new file mode 100755 index 000000000..f4ff1823e --- /dev/null +++ b/Fortran/gfortran/regression/asan/pr110415-2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +implicit none + type, abstract :: p + integer :: a = 4 + end type p + + type, extends(p) :: c + integer :: b = 7 + character(len=:), allocatable :: str, str2(:) + end type c + + type, extends(p) :: d + integer :: ef = 7 + end type d + + class(p), allocatable :: a + + a = func() + + a = func2() + + a = func() + + deallocate(a) + +contains + function func2() result(a) + class(p), allocatable :: a + a = d() + end function func2 + + function func() result(a) + class(p), allocatable :: a + + a = c() + select type(a) + type is (c) + a%str = 'abcd' + a%str2 = ['abcd','efgh'] + end select + end function func +end program diff --git a/Fortran/gfortran/regression/asan/pr110415-3.f90 b/Fortran/gfortran/regression/asan/pr110415-3.f90 new file mode 100755 index 000000000..65c018d80 --- /dev/null +++ b/Fortran/gfortran/regression/asan/pr110415-3.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! +implicit none + type, abstract :: p + integer :: a = 4 + end type p + + type, extends(p) :: c + integer :: b = 7 + character(len=:), allocatable :: str, str2(:) + end type c + + type, extends(p) :: d + integer :: ef = 7 + end type d + + class(p), allocatable :: a(:) + + a = func() + + a = func2() + + a = func() + + deallocate(a) + +contains + function func2() result(a) + class(p), allocatable :: a(:) + a = [d(),d()] + end function func2 + + function func() result(a) + class(p), allocatable :: a(:) + + a = [c(),c(),c()] + select type(a) + type is (c) + a(1)%str = 'abcd' + a(2)%str = 'abc' + a(3)%str = 'abcd4' + a(1)%str2 = ['abcd','efgh'] + a(2)%str2 = ['bcd','fgh'] + a(3)%str2 = ['abcd6','efgh7'] + end select + end function func +end program diff --git a/Fortran/gfortran/regression/asan/tests.cmake b/Fortran/gfortran/regression/asan/tests.cmake index fdc5fa196..af9fee7b6 100644 --- a/Fortran/gfortran/regression/asan/tests.cmake +++ b/Fortran/gfortran/regression/asan/tests.cmake @@ -33,4 +33,7 @@ # compile;associate_58.f90;;-O0;; compile;associate_59.f90;;-O0;; -run;pointer_assign_16.f90;;;; \ No newline at end of file +run;pointer_assign_16.f90;;;; +run;pr110415-2.f90;;;; +run;pr110415-3.f90;;;; +run;unlimited_polymorphic_34.f90;;;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/asan/unlimited_polymorphic_34.f90 b/Fortran/gfortran/regression/asan/unlimited_polymorphic_34.f90 new file mode 100644 index 000000000..c69158a1b --- /dev/null +++ b/Fortran/gfortran/regression/asan/unlimited_polymorphic_34.f90 @@ -0,0 +1,135 @@ +! { dg-do run } +! PR fortran/114827 - issues with class(*) assignment found by valgrind +! +! Contributed by Neil Carlson + +program main + implicit none + call run + call run1 + call run2 +contains + ! Scalar tests + subroutine run () + character(*), parameter :: c = 'fubarfubarfubarfubarfubarfu' + character(*,kind=4), parameter :: d = 4_"abcdef" + complex, parameter :: z = (1.,2.) + class(*), allocatable :: y + + call foo (c, y) + select type (y) + type is (character(*)) +! print *, y(5:6) ! ICE (-> pr114874) + if (y /= c) stop 1 + class default + stop 2 + end select + + call foo (z, y) + select type (y) + type is (complex) + if (y /= z) stop 3 + class default + stop 4 + end select + + call foo (d, y) + select type (y) + type is (character(*,kind=4)) +! print *, y ! NAG fails here + if (y /= d) stop 5 + class default + stop 6 + end select + end subroutine + ! + subroutine foo (a, b) + class(*), intent(in) :: a + class(*), allocatable :: b + b = a + end subroutine + + ! Rank-1 tests + subroutine run1 () + character(*), parameter :: c(*) = ['fubar','snafu'] + character(*,kind=4), parameter :: d(*) = [4_"abc",4_"def"] + real, parameter :: r(*) = [1.,2.,3.] + class(*), allocatable :: y(:) + + call foo1 (c, y) + select type (y) + type is (character(*)) +! print *, ">",y(2)(1:3),"< >", c(2)(1:3), "<" + if (any (y /= c)) stop 11 + if (y(2)(1:3) /= c(2)(1:3)) stop 12 + class default + stop 13 + end select + + call foo1 (r, y) + select type (y) + type is (real) + if (any (y /= r)) stop 14 + class default + stop 15 + end select + + call foo1 (d, y) + select type (y) + type is (character(*,kind=4)) +! print *, ">",y(2)(2:3),"< >", d(2)(2:3), "<" + if (any (y /= d)) stop 16 + class default + stop 17 + end select + end subroutine + ! + subroutine foo1 (a, b) + class(*), intent(in) :: a(:) + class(*), allocatable :: b(:) + b = a + end subroutine + + ! Rank-2 tests + subroutine run2 () + character(7) :: c(2,3) + complex :: z(3,3) + integer :: i, j + class(*), allocatable :: y(:,:) + + c = reshape (['fubar11','snafu21',& + 'fubar12','snafu22',& + 'fubar13','snafu23'],shape(c)) + call foo2 (c, y) + select type (y) + type is (character(*)) +! print *, y(2,1) + if (y(2,1) /= c(2,1)) stop 21 + if (any (y /= c)) stop 22 + class default + stop 23 + end select + + do j = 1, size (z,2) + do i = 1, size (z,1) + z(i,j) = cmplx (i,j) + end do + end do + call foo2 (z, y) + select type (y) + type is (complex) +! print *, y(2,1) + if (any (y%re /= z%re)) stop 24 + if (any (y%im /= z%im)) stop 25 + class default + stop 26 + end select + end subroutine + ! + subroutine foo2 (a, b) + class(*), intent(in) :: a(:,:) + class(*), allocatable :: b(:,:) + b = a + end subroutine + +end program diff --git a/Fortran/gfortran/regression/associate_5.f03 b/Fortran/gfortran/regression/associate_5.f03 index 64345d323..c91f88f4e 100644 --- a/Fortran/gfortran/regression/associate_5.f03 +++ b/Fortran/gfortran/regression/associate_5.f03 @@ -11,7 +11,7 @@ PROGRAM main INTEGER, POINTER :: ptr ASSOCIATE (a => 5) ! { dg-error "is used as array" } - PRINT *, a(3) + PRINT *, a(3) ! { dg-error "has an array reference" } END ASSOCIATE ASSOCIATE (a => nontarget) diff --git a/Fortran/gfortran/regression/associate_54.f90 b/Fortran/gfortran/regression/associate_54.f90 index 680ad5d14..8eb95a710 100644 --- a/Fortran/gfortran/regression/associate_54.f90 +++ b/Fortran/gfortran/regression/associate_54.f90 @@ -24,7 +24,7 @@ end subroutine test_allocate subroutine test_alter_state1 (obj, a) class(test_t), intent(inout) :: obj integer, intent(in) :: a - associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" } + associate (state => obj%state(TEST_STATES)) ! { dg-error "as array|no IMPLICIT type" } ! state = a state(TEST_STATE) = a ! { dg-error "array reference of a non-array" } end associate diff --git a/Fortran/gfortran/regression/associate_55.f90 b/Fortran/gfortran/regression/associate_55.f90 index 2b9e8c727..245dbfc72 100644 --- a/Fortran/gfortran/regression/associate_55.f90 +++ b/Fortran/gfortran/regression/associate_55.f90 @@ -26,7 +26,7 @@ subroutine test_alter_state2 (obj, a) class(test_t), intent(inout) :: obj integer, intent(in) :: a associate (state => obj%state(TEST_STATES)) ! { dg-error "no IMPLICIT type" } - state = a ! { dg-error "vector-indexed target" } + state = a ! { dg-error "cannot be used in a variable definition context" } ! state(TEST_STATE) = a end associate end subroutine test_alter_state2 diff --git a/Fortran/gfortran/regression/associate_61.f90 b/Fortran/gfortran/regression/associate_61.f90 new file mode 100644 index 000000000..da5528834 --- /dev/null +++ b/Fortran/gfortran/regression/associate_61.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Test fixes for PR109451 +! Contributed by Harald Anlauf +! +program p + implicit none + character(4) :: c(2) = ["abcd","efgh"] + call dcs3 (c) + call dcs0 (c) +contains + subroutine dcs3 (a) + character(len=*), intent(in) :: a(:) + character(:), allocatable :: b(:) + b = a(:) + call test (b, a, 1) + associate (q => b(:)) ! no ICE but print repeated first element + call test (q, a, 2) + print *, q ! Checked with dg-output + q = q(:)(2:3) + end associate + call test (b, ["bc ","fg "], 4) + b = a(:) + associate (q => b(:)(:)) ! ICE + call test (q, a, 3) + associate (r => q(:)(1:3)) + call test (r, a(:)(1:3), 5) + end associate + end associate + associate (q => b(:)(2:3)) + call test (q, a(:)(2:3), 6) + end associate + end subroutine dcs3 + +! The associate vars in dsc0 had string length not set + subroutine dcs0 (a) + character(len=*), intent(in) :: a(:) + associate (q => a) + call test (q, a, 7) + end associate + associate (q => a(:)) + call test (q, a, 8) + end associate + associate (q => a(:)(:)) + call test (q, a, 9) + end associate + end subroutine dcs0 + + subroutine test (x, y, i) + character(len=*), intent(in) :: x(:), y(:) + integer, intent(in) :: i + if (any (x .ne. y)) stop i + end subroutine test +end program p +! { dg-output " abcdefgh" } diff --git a/Fortran/gfortran/regression/associate_62.f90 b/Fortran/gfortran/regression/associate_62.f90 new file mode 100644 index 000000000..ce5bf286e --- /dev/null +++ b/Fortran/gfortran/regression/associate_62.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/112764 +! Contributed by martin + +program assoc_target + implicit none + integer, dimension(:,:), pointer :: x + integer, pointer :: j + integer, allocatable, target :: z(:) + allocate (x(1:100,1:2), source=1) + associate (i1 => x(:,1)) + j => i1(1) + print *, j + if (j /= 1) stop 1 + end associate + deallocate (x) + allocate (z(3)) + z(:) = [1,2,3] + associate (i2 => z(2:3)) + j => i2(1) + print *, j + if (j /= 2) stop 2 + end associate + deallocate (z) +end program assoc_target diff --git a/Fortran/gfortran/regression/associate_63.f90 b/Fortran/gfortran/regression/associate_63.f90 new file mode 100644 index 000000000..67c7559fd --- /dev/null +++ b/Fortran/gfortran/regression/associate_63.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! +! Test the fix for PR112834 in which class array function selectors caused +! problems for both ASSOCIATE and SELECT_TYPE. +! +! Contributed by Paul Thomas +! +module m + implicit none + type t + integer :: i = 0 + end type t + integer :: i = 0 + type(t), parameter :: test_array (2) = [t(42),t(84)], & + test_scalar = t(99) +end module m +module class_selectors + use m + implicit none + private + public foo2 +contains + function bar3() result(res) + class(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + subroutine foo2() + associate (var1 => bar3()) + if (any (var1%i .ne. test_array%i)) stop 1 + if (var1(2)%i .ne. test_array(2)%i) stop 2 + associate (zzz3 => var1%i) + if (any (zzz3 .ne. test_array%i)) stop 3 + if (zzz3(2) .ne. test_array(2)%i) stop 4 + end associate + select type (x => var1) + type is (t) + if (any (x%i .ne. test_array%i)) stop 5 + if (x(2)%i .ne. test_array(2)%i) stop 6 + class default + stop 7 + end select + end associate + + select type (y => bar3 ()) + type is (t) + if (any (y%i .ne. test_array%i)) stop 8 + if (y(2)%i .ne. test_array(2)%i) stop 9 + class default + stop 10 + end select + end subroutine foo2 +end module class_selectors + + use class_selectors + call foo2 +end diff --git a/Fortran/gfortran/regression/associate_64.f90 b/Fortran/gfortran/regression/associate_64.f90 new file mode 100644 index 000000000..d7fde185b --- /dev/null +++ b/Fortran/gfortran/regression/associate_64.f90 @@ -0,0 +1,345 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR89645 and 99065, in which derived type or class functions, +! used as associate selectors and which were parsed after the containing scope +! of the associate statement, caused "no IMPLICIT type" and "Syntax" errors. +! +! Contributed by Ian Harvey +! +module m + implicit none + type t + integer :: i = 0 + end type t + integer :: i = 0 + type(t), parameter :: test_array (2) = [t(42),t(84)], & + test_scalar = t(99) +end module m + +! DERIVED TYPE VERSION OF THE PROBLEM, AS REPORTED IN THE PRs +module type_selectors + use m + implicit none + private + public foo1 +contains +! Since these functions are parsed first, the symbols are available for +! parsing in 'foo'. + function bar1() result(res) ! The array version caused syntax errors in foo + type(t), allocatable :: res(:) + allocate (res, source = test_array) + end + function bar2() result(res) ! Scalar class functions were OK - test anyway + type(t), allocatable :: res + allocate (res, source = test_scalar) + end + subroutine foo1() +! First the array selector + associate (var1 => bar1()) + if (any (var1%i .ne. test_array%i)) stop 1 + if (var1(2)%i .ne. test_array(2)%i) stop 2 + end associate +! Now the scalar selector + associate (var2 => bar2()) + if (var2%i .ne. test_scalar%i) stop 3 + end associate + +! Now the array selector that needed fixing up because the function follows.... + associate (var1 => bar3()) + if (any (var1%i .ne. test_array%i)) stop 4 + if (var1(2)%i .ne. test_array(2)%i) stop 5 + end associate +! ....and equivalent scalar selector + associate (var2 => bar4()) + if (var2%i .ne. test_scalar%i) stop 6 + end associate + end subroutine foo1 + +! These functions are parsed after 'foo' so the symbols were not available +! for the selectors and the fixup, tested here, was necessary. + function bar3() result(res) + class(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + function bar4() result(res) + class(t), allocatable :: res + allocate (res, source = t(99)) + end +end module type_selectors + +! CLASS VERSION OF THE PROBLEM, WHICH REQUIRED MOST OF THE WORK! +module class_selectors + use m + implicit none + private + public foo2 +contains + +! Since these functions are parsed first, the symbols are available for +! parsing in 'foo'. + function bar1() result(res) ! The array version caused syntax errors in foo + class(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + function bar2() result(res) ! Scalar class functions were OK - test anyway + class(t), allocatable :: res + allocate (res, source = t(99)) + end + + subroutine foo2() +! First the array selector + associate (var1 => bar1()) + if (any (var1%i .ne. test_array%i)) stop 7 + if (var1(2)%i .ne. test_array(2)%i) stop 8 + select type (x => var1) + type is (t) + if (any (x%i .ne. test_array%i)) stop 9 + if (x(1)%i .ne. test_array(1)%i) stop 10 + class default + stop 11 + end select + end associate + +! Now scalar selector + associate (var2 => bar2()) + select type (z => var2) + type is (t) + if (z%i .ne. test_scalar%i) stop 12 + class default + stop 13 + end select + end associate + +! This is the array selector that needed the fixup. + associate (var1 => bar3()) + if (any (var1%i .ne. test_array%i)) stop 14 + if (var1(2)%i .ne. test_array(2)%i) stop 15 + select type (x => var1) + type is (t) + if (any (x%i .ne. test_array%i)) stop 16 + if (x(1)%i .ne. test_array(1)%i) stop 17 + class default + stop 18 + end select + end associate + +! Now the equivalent scalar selector + associate (var2 => bar4()) + select type (z => var2) + type is (t) + if (z%i .ne. test_scalar%i) stop 19 + class default + stop 20 + end select + end associate + + end subroutine foo2 + +! These functions are parsed after 'foo' so the symbols were not available +! for the selectors and the fixup, tested here, was necessary. + function bar3() result(res) + class(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + function bar4() result(res) + class(t), allocatable :: res + allocate (res, source = t(99)) + end +end module class_selectors + +! THESE TESTS CAUSED PROBLEMS DURING DEVELOPMENT FOR BOTH PARSING ORDERS. +module problem_selectors + implicit none + private + public foo3, foo4 + type t + integer :: i + end type t + type s + integer :: i + type(t) :: dt + end type s + type(t), parameter :: test_array (2) = [t(42),t(84)], & + test_scalar = t(99) + type(s), parameter :: test_sarray (2) = [s(142,t(42)),s(184,t(84))] +contains + + subroutine foo3() + integer :: i + block + associate (var1 => bar7()) + if (any (var1%i .ne. test_array%i)) stop 21 + if (var1(2)%i .ne. test_array(2)%i) stop 22 + associate (z => var1(1)%i) + if (z .ne. 42) stop 23 + end associate + end associate + end block + + associate (var2 => bar8()) + i = var2(2)%i + associate (var3 => var2%dt) + if (any (var3%i .ne. test_sarray%dt%i)) stop 24 + end associate + associate (var4 => var2(2)) + if (var4%i .ne. 184) stop 25 + end associate + end associate + end subroutine foo3 + + function bar7() result(res) + type(t), allocatable :: res(:) + allocate (res, source = test_array) + end + + function bar8() result(res) + type(s), allocatable :: res(:) + allocate (res, source = test_sarray) + end + + subroutine foo4() + integer :: i + block + associate (var1 => bar7()) + if (any (var1%i .ne. test_array%i)) stop 26 + if (var1(2)%i .ne. test_array(2)%i) stop 27 + associate (z => var1(1)%i) + if (z .ne. 42) stop 28 + end associate + end associate + end block + + associate (var2 => bar8()) + i = var2(2)%i + associate (var3 => var2%dt) + if (any (var3%i .ne. test_sarray%dt%i)) stop 29 + end associate + associate (var4 => var2(2)) + if (var4%i .ne. 184) stop 30 + end associate + end associate + end subroutine foo4 + +end module problem_selectors + +module more_problem_selectors + implicit none + private + public foo5, foo6 + type t + integer :: i = 0 + end type t + type s + integer :: i = 0 + type(t) :: dt + end type s +contains +! In this version, the order of declarations of 't' and 's' is such that +! parsing var%i sets the type of var to 't' and this is corrected to 's' +! on parsing var%dt%i + subroutine foo5() + associate (var3 => bar3()) + if (var3%i .ne. 42) stop 31 + if (var3%dt%i .ne. 84) stop 32 + end associate + +! Repeat with class version + associate (var4 => bar4()) + if (var4%i .ne. 84) stop 33 + if (var4%dt%i .ne. 168) stop 34 + select type (x => var4) + type is (s) + if (x%i .ne. var4%i) stop 35 + if (x%dt%i .ne. var4%dt%i) stop 36 + class default + stop 37 + end select + end associate + +! Ditto with no type component clues for select type + associate (var5 => bar4()) + select type (z => var5) + type is (s) + if (z%i .ne. 84) stop 38 + if (z%dt%i .ne. 168) stop 39 + class default + stop 40 + end select + end associate + end subroutine foo5 + +! Now the array versions + subroutine foo6() + class(s), allocatable :: elem + associate (var6 => bar5()) + if (var6(1)%i .ne. 42) stop 41 + if (any (var6%dt%i .ne. [84])) stop 42 + end associate + +! Class version with an assignment to a named variable + associate (var7 => bar6()) + elem = var7(2) + if (any (var7%i .ne. [84, 168])) stop 43 + if (any (var7%dt%i .ne. [168, 336])) stop 44 + end associate + if (elem%i .ne. 168) stop 45 + if (elem%dt%i .ne. 336) stop 46 + + select type (z => elem) + type is (s) + if (z%i .ne. 168) stop 47 + if (z%dt%i .ne. 336) stop 48 + class default + stop 49 + end select + +! Array version without type clues before select type + associate (var8 => bar6()) + select type (z => var8) + type is (s) + if (any (z%i .ne. [84,168])) stop 50 + if (any (z%dt%i .ne. [168,336])) stop 51 + class default + stop 52 + end select + end associate + end subroutine foo6 + + type(s) function bar3() + bar3= s(42, t(84)) + end + + function bar4() result(res) + class(s), allocatable :: res + res = s(84, t(168)) + end + + function bar5() result (res) + type(s), allocatable :: res(:) + res = [s(42, t(84))] + end + + function bar6() result (res) + class(s), allocatable :: res(:) + res = [s(84, t(168)),s(168, t(336))] + end + +end module more_problem_selectors + +program test + use type_selectors + use class_selectors + use problem_selectors + use more_problem_selectors + call foo1() + call foo2() + call foo3() + call foo4() + call foo5() + call foo6() +end program test +! { dg-final { scan-tree-dump-times "__builtin_free" 18 "original" } } diff --git a/Fortran/gfortran/regression/associate_65.f90 b/Fortran/gfortran/regression/associate_65.f90 new file mode 100644 index 000000000..04a143795 --- /dev/null +++ b/Fortran/gfortran/regression/associate_65.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! Test fix for PR114141 +! Contributed by Steve Kargl +program foo + implicit none + real :: y = 0.0 + associate (x => log(cmplx(-1,0))) + y = x%im ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type' + if (int(100*y)-314 /= 0) stop 1 + end associate + +! Check wrinkle in comment 1 (parentheses around selector) of the PR is fixed. + associate (x => ((log(cmplx(-1,1))))) + y = x%im ! Gave 'The RE or IM part_ref at (1) must be applied to a + ! COMPLEX expression' + if (int(100*y)-235 /= 0) stop 2 + end associate + +! Check that more complex(pun intended!) expressions are OK. + associate (x => exp (log(cmplx(-1,0))+cmplx(0,0.5))) + y = x%re ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type' + if (int(1000*y)+877 /= 0) stop 3 + end associate + +! Make sure that AIMAG intrinsic is OK. + associate (x => ((log(cmplx(-1,0.5))))) + y = aimag (x) + if (int(100*y)-267 /= 0) stop 4 + end associate +end program diff --git a/Fortran/gfortran/regression/associate_66.f90 b/Fortran/gfortran/regression/associate_66.f90 new file mode 100644 index 000000000..d507eb628 --- /dev/null +++ b/Fortran/gfortran/regression/associate_66.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Tests unlimited polymorphic function selectors in ASSOCIATE. +! +! Contributed by Harald Anlauf in +! https://gcc.gnu.org/pipermail/fortran/2024-January/060098.html +! +program p + implicit none +! scalar array + associate (var1 => foo1(), var2 => foo2()) + call prt (var1); call prt (var2) + end associate +contains +! Scalar value + function foo1() result(res) + class(*), allocatable :: res + res = 42.0 + end function foo1 +! Array value + function foo2() result(res) + class(*), allocatable :: res(:) + res = [42, 84] + end function foo2 +! Test the associate-name value + subroutine prt (x) + class(*), intent(in) :: x(..) + logical :: ok = .false. + select rank(x) + rank (0) + select type (x) + type is (real) + if (int(x*10) .eq. 420) ok = .true. + end select + rank (1) + select type (x) + type is (integer) + if (all (x .eq. [42, 84])) ok = .true. + end select + end select + if (.not.ok) stop 1 + end subroutine prt +end +! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } } diff --git a/Fortran/gfortran/regression/associate_67.f90 b/Fortran/gfortran/regression/associate_67.f90 new file mode 100644 index 000000000..6bc3bc5f4 --- /dev/null +++ b/Fortran/gfortran/regression/associate_67.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Tests pointer function selectors in ASSOCIATE. +! +! Contributed by Harald Anlauf in +! https://gcc.gnu.org/pipermail/fortran/2024-March/060294.html +program paul + implicit none + type t + integer :: i + end type t + type(t), pointer :: p(:) + integer :: j + allocate (p(-3:3)) + p% i = [(j,j=-3,3)] + + associate (q => p) + print *, lbound (q), ubound (q) ! Should print -3 3 (OK) + print *, q% i + end associate + + associate (q => set_ptr()) + print *, lbound (q), ubound (q) ! Should print -3 3 (OK) + print *, q(:)% i ! <<< ... has no IMPLICIT type + end associate + + associate (q => (p)) + print *, lbound (q), ubound (q) ! Should print 1 7 (OK) + print *, q% i + end associate + + associate (q => (set_ptr())) + print *, lbound (q), ubound (q) ! Should print 1 7 (OK) + print *, q(:)% i ! <<< ... has no IMPLICIT type + end associate +contains + function set_ptr () result (res) + type(t), pointer :: res(:) + res => p + end function set_ptr +end diff --git a/Fortran/gfortran/regression/associate_68.f90 b/Fortran/gfortran/regression/associate_68.f90 new file mode 100644 index 000000000..f05ecd8e2 --- /dev/null +++ b/Fortran/gfortran/regression/associate_68.f90 @@ -0,0 +1,79 @@ +! { dg-do run } +! Test the fix for PR114280 in which inquiry references of associate names +! of as yet unparsed function selectors failed. +! Contributed by Steve Kargl <> +program paul2 + implicit none + type t + real :: re + end type t + real :: comp = 1, repart = 10, impart =100 + call foo +contains + subroutine foo () + associate (x => bar1()) +! 'x' identified as complex from outset + if (int(x%im) .ne. 100) stop 1 ! Has no IMPLICIT type + if (int(x%re) .ne. 10) stop 2 + end associate + + associate (x => bar1()) +! 'x' identified as derived then corrected to complex + if (int(x%re) .ne. 11) stop 3 ! Has no IMPLICIT type + if (int(x%im) .ne. 101) stop 4 + if (x%kind .ne. kind(1.0)) stop 5 + end associate + + associate (x => bar1()) + if (x%kind .ne. kind(1.0)) stop 6 ! Invalid character in name + end associate + + associate (x => bar2()) + if (int(x%re) .ne. 1) stop 7 ! Invalid character in name + end associate + + associate (xx => bar3()) + if (xx%len .ne. 8) stop 8 ! Has no IMPLICIT type + if (trim (xx) .ne. "Nice one") stop 9 + if (xx(6:8) .ne. "one") stop 10 + end associate + +! Now check the array versions + associate (x => bar4()) + if (any (int(abs (x(:) + 2.0)) .ne. [104,105])) stop 0 + if (int(x(2)%re) .ne. 14) stop 11 + if (any (int(x%im) .ne. [103,104])) stop 12 + if (any (int(abs(x)) .ne. [103,104])) stop 13 + end associate + + associate (x => bar5()) + if (x(:)%kind .ne. kind("A")) stop 14 + if (x(2)%len .ne. 4) stop 15 + if (x%len .ne. 4) stop 16 + if (x(2)(1:3) .ne. "two") stop 17 + if (any(x .ne. ["one ", "two "])) stop 18 + end associate + end + complex function bar1 () + bar1 = cmplx(repart, impart) + repart = repart + 1 + impart = impart + 1 + end + type(t) function bar2 () + bar2% re = comp + comp = comp + 1 + end + character(8) function bar3 () + bar3 = "Nice one!" + end + function bar4 () result (res) + complex, allocatable, dimension(:) :: res + res = [cmplx(repart, impart),cmplx(repart+1, impart+1)] + repart = repart + 2 + impart = impart + 2 + end + function bar5 () result (res) + character(4), allocatable, dimension(:) :: res + res = ["one ", "two "] + end +end diff --git a/Fortran/gfortran/regression/associate_69.f90 b/Fortran/gfortran/regression/associate_69.f90 new file mode 100644 index 000000000..28f488bb2 --- /dev/null +++ b/Fortran/gfortran/regression/associate_69.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-Og -Wuninitialized -Wmaybe-uninitialized -fdump-tree-optimized" } +! +! PR fortran/115700 - Bogus warning for associate with assumed-length character array +! +subroutine mvce(x) + implicit none + character(len=*), dimension(:), intent(in) :: x + + associate (tmp1 => x) + if (len (tmp1) /= len (x)) stop 1 + end associate + + associate (tmp2 => x(1:)) + if (len (tmp2) /= len (x)) stop 2 + end associate + + associate (tmp3 => x(1:)(:)) + if (len (tmp3) /= len (x)) stop 3 + end associate + +! The following associate blocks still produce bogus warnings: + +! associate (tmp4 => x(:)(1:)) +! if (len (tmp4) /= len (x)) stop 4 +! end associate +! +! associate (tmp5 => x(1:)(1:)) +! if (len (tmp5) /= len (x)) stop 5 +! end associate +end + +! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } } diff --git a/Fortran/gfortran/regression/assumed_rank_10.f90 b/Fortran/gfortran/regression/assumed_rank_10.f90 index 6a3cc9448..f22d43ab9 100644 --- a/Fortran/gfortran/regression/assumed_rank_10.f90 +++ b/Fortran/gfortran/regression/assumed_rank_10.f90 @@ -50,9 +50,9 @@ program test is_present = .false. - call fpa(null(), null()) ! No copy back - call fpi(null(), null()) ! No copy back - call fno(null(), null()) ! No copy back + call fpa(null(iip), null(jjp)) ! No copy back + call fpi(null(iip), null(jjp)) ! No copy back + call fno(null(iip), null(jjp)) ! No copy back call fno() ! No copy back diff --git a/Fortran/gfortran/regression/assumed_rank_8.f90 b/Fortran/gfortran/regression/assumed_rank_8.f90 index 5873296a7..34ff42c0b 100644 --- a/Fortran/gfortran/regression/assumed_rank_8.f90 +++ b/Fortran/gfortran/regression/assumed_rank_8.f90 @@ -22,13 +22,13 @@ end subroutine check call f (ii) call f (489) call f () - call f (null()) + call f (null(kk)) call f (kk) if (j /= 2) STOP 1 j = 0 nullify (ll) - call g (null()) + call g (null(ll)) call g (ll) call g (ii) if (j /= 1) STOP 2 diff --git a/Fortran/gfortran/regression/assumed_rank_9.f90 b/Fortran/gfortran/regression/assumed_rank_9.f90 index 1296d0689..5e59ec136 100644 --- a/Fortran/gfortran/regression/assumed_rank_9.f90 +++ b/Fortran/gfortran/regression/assumed_rank_9.f90 @@ -26,19 +26,20 @@ end subroutine check2 type(t), target :: y class(t), allocatable, target :: yac - + type(t), pointer :: ypt + y%i = 489 allocate (yac) yac%i = 489 j = 0 call fc() - call fc(null()) + call fc(null(yac)) call fc(y) call fc(yac) if (j /= 2) STOP 1 j = 0 - call gc(null()) +! call gc(null(yac)) ! ICE call gc(y) call gc(yac) deallocate (yac) @@ -54,13 +55,14 @@ end subroutine check2 j = 0 call ft() - call ft(null()) + call ft(null(yac)) call ft(y) call ft(yac) if (j /= 2) STOP 4 j = 0 - call gt(null()) + call gt(null(ypt)) +! call gt(null(yac)) ! ICE call gt(y) call gt(yac) deallocate (yac) @@ -73,6 +75,7 @@ end subroutine check2 yac%i = 489 call ht(yac) if (j /= 1) STOP 6 + deallocate (yac) contains diff --git a/Fortran/gfortran/regression/assumed_type_18.f90 b/Fortran/gfortran/regression/assumed_type_18.f90 new file mode 100644 index 000000000..a3d791919 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_18.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! PR fortran/110825 - TYPE(*) and character actual arguments + +program foo + use iso_c_binding, only: c_loc, c_ptr, c_associated + implicit none + character(100) :: not_used = "" + character(:), allocatable :: deferred + character :: c42(6,7) = "*" + call sub (not_used, "123") + call sub ("0" , "123") + deferred = "d" + call sub (deferred , "123") + call sub2 ([1.0,2.0], "123") + call sub2 (["1","2"], "123") + call sub3 (c42 , "123") + +contains + + subroutine sub (useless_var, print_this) + type(*), intent(in) :: useless_var + character(*), intent(in) :: print_this + if (len (print_this) /= 3) stop 1 + if (len_trim (print_this) /= 3) stop 2 + end + + subroutine sub2 (a, c) + type(*), intent(in) :: a(:) + character(*), intent(in) :: c + if (len (c) /= 3) stop 10 + if (len_trim (c) /= 3) stop 11 + if (size (a) /= 2) stop 12 + end + + subroutine sub3 (a, c) + type(*), intent(in), target, optional :: a(..) + character(*), intent(in) :: c + type(c_ptr) :: cpt + if (len (c) /= 3) stop 20 + if (len_trim (c) /= 3) stop 21 + if (.not. present (a)) stop 22 + if (rank (a) /= 2) stop 23 + if (size (a) /= 42) stop 24 + if (any (shape (a) /= [6,7])) stop 25 + if (any (lbound (a) /= [1,1])) stop 26 + if (any (ubound (a) /= [6,7])) stop 27 + if (.not. is_contiguous (a)) stop 28 + cpt = c_loc (a) + if (.not. c_associated (cpt)) stop 29 + end + +end diff --git a/Fortran/gfortran/regression/bind_c_array_params_2.f90 b/Fortran/gfortran/regression/bind_c_array_params_2.f90 index 04faa4334..aa6a37b48 100644 --- a/Fortran/gfortran/regression/bind_c_array_params_2.f90 +++ b/Fortran/gfortran/regression/bind_c_array_params_2.f90 @@ -2,6 +2,7 @@ ! { dg-options "-std=f2008ts -fdump-tree-original" } ! { dg-additional-options "-mno-explicit-relocs" { target alpha*-*-* } } ! { dg-additional-options "-mno-relax-pic-calls" { target mips*-*-* } } +! { dg-additional-options "-fplt -mcmodel=normal" { target loongarch*-*-* } } ! ! Check that assumed-shape variables are correctly passed to BIND(C) ! as defined in TS 29913 @@ -16,7 +17,8 @@ end subroutine test call test(aa) end -! { dg-final { scan-assembler-times "\[ \t\]\[$,_0-9\]*myBindC" 1 { target { ! { hppa*-*-* s390*-*-* *-*-cygwin* amdgcn*-*-* powerpc-ibm-aix* *-*-ming* } } } } } +! { dg-final { scan-assembler-times "\[ \t\]\[$,_0-9\]*myBindC" 1 { target { ! { hppa*-*-* s390*-*-* *-*-cygwin* amdgcn*-*-* powerpc-ibm-aix* *-*-ming* loongarch*-*-* } } } } } +! { dg-final { scan-assembler-times "bl\t%plt\\(myBindC\\)" 1 { target loongarch*-*-* } } } ! { dg-final { scan-assembler-times "myBindC,%r2" 1 { target { hppa*-*-* } } } } ! { dg-final { scan-assembler-times "call\tmyBindC" 1 { target { *-*-cygwin* *-*-ming* } } } } ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } } @@ -25,7 +27,7 @@ end subroutine test ! { dg-final { scan-tree-dump "parm...span = 4;" "original" } } -! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } } +! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .version=0, .rank=2, .type=1};" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } } diff --git a/Fortran/gfortran/regression/bind_c_char_11.f90 b/Fortran/gfortran/regression/bind_c_char_11.f90 new file mode 100644 index 000000000..5ed8e8285 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_char_11.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } +! +! PR fortran/115390 - fixes for CHARACTER(len=*) dummies with bind(C) + +module test + implicit none +contains + subroutine bar(s,t) bind(c) + character(*), intent(in) :: s,t + optional :: t + call foo(s,t) + end + subroutine bar1(s,t) bind(c) + character(*), intent(in) :: s(:),t(:) + optional :: t + call foo1(s,t) + end + subroutine bar4(s,t) bind(c) + character(len=*,kind=4), intent(in) :: s,t + optional :: t + call foo4(s,t) + end + subroutine bar5(s,t) bind(c) + character(len=*,kind=4), intent(in) :: s(:),t(:) + optional :: t + call foo5(s,t) + end + subroutine foo(s,t) + character(*), intent(in) :: s,t + optional :: t + end + subroutine foo1(s,t) + character(*), intent(in) :: s(:),t(:) + optional :: t + end + subroutine foo4(s,t) + character(len=*,kind=4), intent(in) :: s,t + optional :: t + end + subroutine foo5(s,t) + character(len=*,kind=4), intent(in) :: s(:),t(:) + optional :: t + end +end diff --git a/Fortran/gfortran/regression/bind_c_coms.f90 b/Fortran/gfortran/regression/bind_c_coms.f90 index 85ead9fb6..2f9714947 100644 --- a/Fortran/gfortran/regression/bind_c_coms.f90 +++ b/Fortran/gfortran/regression/bind_c_coms.f90 @@ -3,6 +3,7 @@ ! { dg-options "-w" } ! the -w option is to prevent the warning about long long ints module bind_c_coms +! { dg-additional-options "-fcommon" { target hppa*-*-hpux* } } use, intrinsic :: iso_c_binding implicit none diff --git a/Fortran/gfortran/regression/bind_c_optional-2.f90 b/Fortran/gfortran/regression/bind_c_optional-2.f90 new file mode 100644 index 000000000..8bbdc95c6 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_optional-2.f90 @@ -0,0 +1,104 @@ +! { dg-do run } +! PR fortran/113866 +! +! Check interoperability of assumed-length character (optional and +! non-optional) dummies between bind(c) and non-bind(c) procedures + +module bindcchar + implicit none + integer, parameter :: n = 100, l = 10 +contains + subroutine bindc_optional (c2, c4) bind(c) + character(*), optional :: c2, c4(n) +! print *, c2(1:3) +! print *, c4(5)(1:3) + if (.not. present (c2) .or. .not. present (c4)) stop 8 + if (len (c2) /= l .or. len (c4) /= l) stop 81 + if (c2(1:3) /= "a23") stop 1 + if (c4(5)(1:3) /= "bcd") stop 2 + end + + subroutine bindc (c2, c4) bind(c) + character(*) :: c2, c4(n) + if (len (c2) /= l .or. len (c4) /= l) stop 82 + if (c2(1:3) /= "a23") stop 3 + if (c4(5)(1:3) /= "bcd") stop 4 + call bindc_optional (c2, c4) + end + + subroutine not_bindc_optional (c1, c3) + character(*), optional :: c1, c3(n) + if (.not. present (c1) .or. .not. present (c3)) stop 5 + if (len (c1) /= l .or. len (c3) /= l) stop 83 + call bindc_optional (c1, c3) + call bindc (c1, c3) + end + + subroutine not_bindc_optional_deferred (c5, c6) + character(:), allocatable, optional :: c5, c6(:) + if (.not. present (c5) .or. .not. present (c6)) stop 6 + if (len (c5) /= l .or. len (c6) /= l) stop 84 + call not_bindc_optional (c5, c6) + call bindc_optional (c5, c6) + call bindc (c5, c6) + end + + subroutine not_bindc_optional2 (c7, c8) + character(*), optional :: c7, c8(:) + if (.not. present (c7) .or. .not. present (c8)) stop 7 + if (len (c7) /= l .or. len (c8) /= l) stop 85 + call bindc_optional (c7, c8) + call bindc (c7, c8) + end + + subroutine bindc_optional2 (c2, c4) bind(c) + character(*), optional :: c2, c4(n) + if (.not. present (c2) .or. .not. present (c4)) stop 8 + if (len (c2) /= l .or. len (c4) /= l) stop 86 + if (c2(1:3) /= "a23") stop 9 + if (c4(5)(1:3) /= "bcd") stop 10 + call bindc_optional (c2, c4) + call not_bindc_optional (c2, c4) + end + + subroutine bindc_optional_missing (c1, c2, c3, c4, c5) bind(c) + character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*) + if (present (c1)) stop 11 + if (present (c2)) stop 12 + if (present (c3)) stop 13 + if (present (c4)) stop 14 + if (present (c5)) stop 15 + end + + subroutine non_bindc_optional_missing (c1, c2, c3, c4, c5) + character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*) + if (present (c1)) stop 21 + if (present (c2)) stop 22 + if (present (c3)) stop 23 + if (present (c4)) stop 24 + if (present (c5)) stop 25 + end +end module + +program p + use bindcchar + implicit none + character(l) :: a, b(n) + character(:), allocatable :: d, e(:) + a = 'a234567890' + b = 'bcdefghijk' + call not_bindc_optional (a, b) + call bindc_optional (a, b) + call not_bindc_optional2 (a, b) + call bindc_optional2 (a, b) + allocate (d, source=a) + allocate (e, source=b) + call not_bindc_optional (d, e) + call bindc_optional (d, e) + call not_bindc_optional2 (d, e) + call bindc_optional2 (d, e) + call not_bindc_optional_deferred (d, e) + deallocate (d, e) + call non_bindc_optional_missing () + call bindc_optional_missing () +end diff --git a/Fortran/gfortran/regression/bind_c_usage_13.f03 b/Fortran/gfortran/regression/bind_c_usage_13.f03 index 470bd59ed..3cc9f8e0f 100644 --- a/Fortran/gfortran/regression/bind_c_usage_13.f03 +++ b/Fortran/gfortran/regression/bind_c_usage_13.f03 @@ -130,9 +130,9 @@ end program test ! { dg-final { scan-tree-dump "multiso .&.v..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } ! { dg-final { scan-tree-dump "multiso2 .&.w..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } ! -! { dg-final { scan-tree-dump "mult_val ..x., .x., 1, 1.;" "original" } } +! { dg-final { scan-tree-dump "mult_val .120, 120, 1, 1.;" "original" } } ! { dg-final { scan-tree-dump "multiso_val .121, 120.;" "original" } } -! { dg-final { scan-tree-dump "multiso2_val ..z., .x..;" "original" } } +! { dg-final { scan-tree-dump "multiso2_val .122, 120.;" "original" } } ! ! Single argument dump: ! @@ -144,7 +144,7 @@ end program test ! { dg-final { scan-tree-dump "subiso .&.v..1..lb: 1 sz: 1..;" "original" } } ! { dg-final { scan-tree-dump "subiso2 .&.w..1..lb: 1 sz: 1..;" "original" } } ! -! { dg-final { scan-tree-dump "sub_val ..x., 1.;" "original" } } +! { dg-final { scan-tree-dump "sub_val .120, 1.;" "original" } } ! { dg-final { scan-tree-dump "subiso_val .121.;" "original" } } -! { dg-final { scan-tree-dump "subiso2_val ..z..;" "original" } } +! { dg-final { scan-tree-dump "subiso2_val .122.;" "original" } } ! diff --git a/Fortran/gfortran/regression/bind_c_vars.f90 b/Fortran/gfortran/regression/bind_c_vars.f90 index 4f4a0cfd7..ede3ffd8c 100644 --- a/Fortran/gfortran/regression/bind_c_vars.f90 +++ b/Fortran/gfortran/regression/bind_c_vars.f90 @@ -1,6 +1,7 @@ ! { dg-do run } ! { dg-additional-sources bind_c_vars_driver.c } module bind_c_vars +! { dg-additional-options "-fcommon" { target hppa*-*-hpux* } } use, intrinsic :: iso_c_binding implicit none diff --git a/Fortran/gfortran/regression/block_17.f90 b/Fortran/gfortran/regression/block_17.f90 new file mode 100644 index 000000000..6ab3106eb --- /dev/null +++ b/Fortran/gfortran/regression/block_17.f90 @@ -0,0 +1,9 @@ +subroutine foo() + block + end block +end + +subroutine bar() + my_name: block + end block my_name +end diff --git a/Fortran/gfortran/regression/bound_10.f90 b/Fortran/gfortran/regression/bound_10.f90 new file mode 100644 index 000000000..cbe065cf2 --- /dev/null +++ b/Fortran/gfortran/regression/bound_10.f90 @@ -0,0 +1,207 @@ +! { dg-do run } +! +! PR fortran/112371 +! The library used to not set the bounds and content of the resulting array +! of a reduction function if the input array had zero extent along the +! reduction dimension. + +program p + implicit none + call check_iall + call check_iany + call check_iparity + call check_minloc_int + call check_minloc_char + call check_maxloc_real + call check_maxloc_char + call check_minval_int + call check_minval_char + call check_maxval_real + call check_maxval_char + call check_sum + call check_product +contains + subroutine check_iall + integer :: a(3,0,2) + logical(kind=1) :: m(3,0,2) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 2 + r = iall(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 11 + if (any(ubound(r) /= (/ 3, 2 /))) stop 12 + if (any(shape(r) /= (/ 3, 2 /))) stop 13 + if (any(r /= int(z'FFFFFFFF'))) stop 14 + end subroutine + subroutine check_iany + integer(kind=8) :: a(2,3,0) + logical(kind=1) :: m(2,3,0) + integer :: i + integer(kind=8), allocatable :: r(:,:) + a = reshape((/ integer(kind=8):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 3 + r = iany(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 21 + if (any(ubound(r) /= (/ 2, 3 /))) stop 22 + if (any(shape(r) /= (/ 2, 3 /))) stop 23 + if (any(r /= 0)) stop 24 + end subroutine + subroutine check_iparity + integer(kind=2) :: a(0,2,3) + logical(kind=1) :: m(0,2,3) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ integer(kind=2):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 1 + r = iparity(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 31 + if (any(ubound(r) /= (/ 2, 3 /))) stop 32 + if (any(shape(r) /= (/ 2, 3 /))) stop 33 + if (any(r /= 0)) stop 34 + end subroutine + subroutine check_minloc_int + integer :: a(3,0,2) + logical(kind=1) :: m(3,0,2) + integer :: i, j + integer, allocatable :: r(:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 2 + r = minloc(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 41 + if (any(ubound(r) /= (/ 3, 2 /))) stop 42 + if (any(shape(r) /= (/ 3, 2 /))) stop 43 + if (any(r /= 0)) stop 44 + end subroutine + subroutine check_minloc_char + character :: a(2,3,0) + logical(kind=1) :: m(2,3,0) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ character:: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 3 + r = minloc(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 51 + if (any(ubound(r) /= (/ 2, 3 /))) stop 52 + if (any(shape(r) /= (/ 2, 3 /))) stop 53 + if (any(r /= 0)) stop 54 + end subroutine + subroutine check_maxloc_real + real :: a(0,2,3) + logical(kind=1) :: m(0,2,3) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ real:: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 1 + r = maxloc(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 61 + if (any(ubound(r) /= (/ 2, 3 /))) stop 62 + if (any(shape(r) /= (/ 2, 3 /))) stop 63 + if (any(r /= 0)) stop 64 + end subroutine + subroutine check_maxloc_char + character(len=2) :: a(3,0,2) + logical(kind=1) :: m(3,0,2) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ character(len=2):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 2 + r = maxloc(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 71 + if (any(ubound(r) /= (/ 3, 2 /))) stop 72 + if (any(shape(r) /= (/ 3, 2 /))) stop 73 + if (any(r /= 0)) stop 74 + end subroutine + subroutine check_minval_int + integer(kind=2) :: a(3,2,0) + logical(kind=1) :: m(3,2,0) + integer :: i, j + integer, allocatable :: r(:,:) + a = reshape((/ integer(kind=2):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 3 + r = minval(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 81 + if (any(ubound(r) /= (/ 3, 2 /))) stop 82 + if (any(shape(r) /= (/ 3, 2 /))) stop 83 + if (any(r /= huge(1_2))) stop 84 + end subroutine + subroutine check_minval_char + character(kind=4) :: a(0,3,2) + logical(kind=1) :: m(0,3,2) + integer :: i + character(kind=4), allocatable :: r(:,:) + a = reshape((/ character(kind=4):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 1 + r = minval(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 91 + if (any(ubound(r) /= (/ 3, 2 /))) stop 92 + if (any(shape(r) /= (/ 3, 2 /))) stop 93 + if (any(r /= char(int(z'FFFFFFFF', kind=8), kind=4))) stop 94 + end subroutine + subroutine check_maxval_real + real(kind=8) :: a(0,2,3) + logical(kind=1) :: m(0,2,3) + integer :: i + real(kind=8), allocatable :: r(:,:) + a = reshape((/ real(kind=8):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 1 + r = maxval(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 101 + if (any(ubound(r) /= (/ 2, 3 /))) stop 102 + if (any(shape(r) /= (/ 2, 3 /))) stop 103 + if (any(r /= -huge(1._8))) stop 104 + end subroutine + subroutine check_maxval_char + character(kind=4,len=2) :: a(3,0,2), e + logical(kind=1) :: m(3,0,2) + integer :: i + character(len=2,kind=4), allocatable :: r(:,:) + a = reshape((/ character(kind=4,len=2):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 2 + r = maxval(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 111 + if (any(ubound(r) /= (/ 3, 2 /))) stop 112 + if (any(shape(r) /= (/ 3, 2 /))) stop 113 + e = repeat(char(0, kind=4), len(a)) + if (any(r /= e)) stop 114 + end subroutine + subroutine check_sum + integer(kind=1) :: a(2,3,0) + logical(kind=1) :: m(2,3,0) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 3 + r = sum(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 121 + if (any(ubound(r) /= (/ 2, 3 /))) stop 122 + if (any(shape(r) /= (/ 2, 3 /))) stop 123 + if (any(r /= 0)) stop 124 + end subroutine + subroutine check_product + real(kind=8) :: a(0,2,3) + logical(kind=1) :: m(0,2,3) + integer :: i + integer, allocatable :: r(:,:) + a = reshape((/ real(kind=8):: /), shape(a)) + m = reshape((/ logical(kind=1):: /), shape(m)) + i = 1 + r = product(a, dim=i, mask=m) + if (any(lbound(r) /= 1)) stop 131 + if (any(ubound(r) /= (/ 2, 3 /))) stop 132 + if (any(shape(r) /= (/ 2, 3 /))) stop 133 + if (any(r /= 1.0_8)) stop 134 + end subroutine +end program diff --git a/Fortran/gfortran/regression/bound_11.f90 b/Fortran/gfortran/regression/bound_11.f90 new file mode 100644 index 000000000..170eba4dd --- /dev/null +++ b/Fortran/gfortran/regression/bound_11.f90 @@ -0,0 +1,588 @@ +! { dg-do run } +! +! PR fortran/112371 +! The library used to incorrectly set an extent of zero for the first +! dimension of the resulting array of a reduction function if that array was +! empty. + +program p + implicit none + call check_iparity + call check_sum + call check_minloc_int + call check_minloc_char + call check_maxloc_char4 + call check_minval_char + call check_maxval_char4 + call check_any + call check_count4 + call check_findloc_int + call check_findloc_char +contains + subroutine check_iparity + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = iparity(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 111 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 112 + i = 2 + r = iparity(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 113 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 114 + i = 3 + r = iparity(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 115 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 116 + i = 4 + r = iparity(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 117 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 118 + i = 1 + r = iparity(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 121 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 122 + i = 2 + r = iparity(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 123 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 124 + i = 3 + r = iparity(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 125 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 126 + i = 4 + r = iparity(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 127 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 128 + i = 1 + r = iparity(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 131 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 132 + i = 2 + r = iparity(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 133 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 134 + i = 3 + r = iparity(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 135 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 136 + i = 4 + r = iparity(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 137 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 138 + end subroutine + subroutine check_sum + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = sum(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 211 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 212 + i = 2 + r = sum(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 213 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 214 + i = 3 + r = sum(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 215 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 216 + i = 4 + r = sum(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 217 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 218 + i = 1 + r = sum(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 221 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 222 + i = 2 + r = sum(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 223 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 224 + i = 3 + r = sum(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 225 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 226 + i = 4 + r = sum(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 227 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 228 + i = 1 + r = sum(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 231 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 232 + i = 2 + r = sum(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 233 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 234 + i = 3 + r = sum(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 235 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 236 + i = 4 + r = sum(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 237 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 238 + end subroutine + subroutine check_minloc_int + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 311 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 312 + i = 2 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 313 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 314 + i = 3 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 315 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 316 + i = 4 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 317 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 318 + i = 1 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 321 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 322 + i = 2 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 323 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 324 + i = 3 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 325 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 326 + i = 4 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 327 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 328 + i = 1 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 331 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 332 + i = 2 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 333 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 334 + i = 3 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 335 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 336 + i = 4 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 337 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 338 + end subroutine + subroutine check_minloc_char + character :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ character:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 411 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 412 + i = 2 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 413 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 414 + i = 3 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 415 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 416 + i = 4 + r = minloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 417 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 418 + i = 1 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 421 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 422 + i = 2 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 423 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 424 + i = 3 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 425 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 426 + i = 4 + r = minloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 427 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 428 + i = 1 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 431 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 432 + i = 2 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 433 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 434 + i = 3 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 435 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 436 + i = 4 + r = minloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 437 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 438 + end subroutine + subroutine check_maxloc_char4 + character(kind=4) :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ character(kind=4):: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = maxloc(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 511 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 512 + i = 2 + r = maxloc(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 513 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 514 + i = 3 + r = maxloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 515 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 516 + i = 4 + r = maxloc(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 517 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 518 + i = 1 + r = maxloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 521 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 522 + i = 2 + r = maxloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 523 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 524 + i = 3 + r = maxloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 525 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 526 + i = 4 + r = maxloc(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 527 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 528 + i = 1 + r = maxloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 531 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 532 + i = 2 + r = maxloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 533 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 534 + i = 3 + r = maxloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 535 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 536 + i = 4 + r = maxloc(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 537 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 538 + end subroutine + subroutine check_minval_char + character :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + character, allocatable :: r(:,:,:) + a = reshape((/ character:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = minval(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 611 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 612 + i = 2 + r = minval(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 613 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 614 + i = 3 + r = minval(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 615 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 616 + i = 4 + r = minval(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 617 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 618 + i = 1 + r = minval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 621 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 622 + i = 2 + r = minval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 623 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 624 + i = 3 + r = minval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 625 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 626 + i = 4 + r = minval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 627 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 628 + i = 1 + r = minval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 631 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 632 + i = 2 + r = minval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 633 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 634 + i = 3 + r = minval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 635 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 636 + i = 4 + r = minval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 637 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 638 + end subroutine + subroutine check_maxval_char4 + character(kind=4) :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + character(kind=4), allocatable :: r(:,:,:) + a = reshape((/ character(kind=4):: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = maxval(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 711 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 712 + i = 2 + r = maxval(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 713 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 714 + i = 3 + r = maxval(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 715 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 716 + i = 4 + r = maxval(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 717 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 718 + i = 1 + r = maxval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 721 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 722 + i = 2 + r = maxval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 723 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 724 + i = 3 + r = maxval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 725 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 726 + i = 4 + r = maxval(a, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 727 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 728 + i = 1 + r = maxval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 731 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 732 + i = 2 + r = maxval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 733 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 734 + i = 3 + r = maxval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 735 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 736 + i = 4 + r = maxval(a, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 737 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 738 + end subroutine + subroutine check_any + logical :: a(9,3,0,7) + integer :: i + logical, allocatable :: r(:,:,:) + a = reshape((/ logical:: /), shape(a)) + i = 1 + r = any(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 811 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 812 + i = 2 + r = any(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 813 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 814 + i = 3 + r = any(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 815 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 816 + i = 4 + r = any(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 817 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 818 + end subroutine + subroutine check_count4 + logical(kind=4) :: a(9,3,0,7) + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ logical(kind=4):: /), shape(a)) + i = 1 + r = count(a, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 911 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 912 + i = 2 + r = count(a, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 913 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 914 + i = 3 + r = count(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 915 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 916 + i = 4 + r = count(a, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 917 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 918 + end subroutine + subroutine check_findloc_int + integer :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = findloc(a, 10, dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1011 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1012 + i = 2 + r = findloc(a, 10, dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1013 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1014 + i = 3 + r = findloc(a, 10, dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1015 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1016 + i = 4 + r = findloc(a, 10, dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1017 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1018 + i = 1 + r = findloc(a, 10, dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1021 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1022 + i = 2 + r = findloc(a, 10, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1023 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1024 + i = 3 + r = findloc(a, 10, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1025 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1026 + i = 4 + r = findloc(a, 10, dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1027 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1028 + i = 1 + r = findloc(a, 10, dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1031 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1032 + i = 2 + r = findloc(a, 10, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1033 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1034 + i = 3 + r = findloc(a, 10, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1035 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1036 + i = 4 + r = findloc(a, 10, dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1037 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1038 + end subroutine + subroutine check_findloc_char + character :: a(9,3,0,7) + logical :: m1(9,3,0,7) + logical(kind=4) :: m4 + integer :: i + integer, allocatable :: r(:,:,:) + a = reshape((/ character:: /), shape(a)) + m1 = reshape((/ logical:: /), shape(m1)) + m4 = .false. + i = 1 + r = findloc(a, "a", dim=i) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1111 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1112 + i = 2 + r = findloc(a, "a", dim=i) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1113 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1114 + i = 3 + r = findloc(a, "a", dim=i) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1115 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1116 + i = 4 + r = findloc(a, "a", dim=i) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1117 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1118 + i = 1 + r = findloc(a, "a", dim=i, mask=m1) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1121 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1122 + i = 2 + r = findloc(a, "a", dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1123 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1124 + i = 3 + r = findloc(a, "a", dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1125 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1126 + i = 4 + r = findloc(a, "a", dim=i, mask=m1) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1127 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1128 + i = 1 + r = findloc(a, "a", dim=i, mask=m4) + if (any(shape(r) /= (/ 3, 0, 7 /))) stop 1131 + if (any(ubound(r) /= (/ 3, 0, 7 /))) stop 1132 + i = 2 + r = findloc(a, "a", dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 0, 7 /))) stop 1133 + if (any(ubound(r) /= (/ 9, 0, 7 /))) stop 1134 + i = 3 + r = findloc(a, "a", dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 7 /))) stop 1135 + if (any(ubound(r) /= (/ 9, 3, 7 /))) stop 1136 + i = 4 + r = findloc(a, "a", dim=i, mask=m4) + if (any(shape(r) /= (/ 9, 3, 0 /))) stop 1137 + if (any(ubound(r) /= (/ 9, 3, 0 /))) stop 1138 + end subroutine +end program diff --git a/Fortran/gfortran/regression/bounds_check_17.f90 b/Fortran/gfortran/regression/bounds_check_17.f90 index 50d66c75a..e970727d7 100644 --- a/Fortran/gfortran/regression/bounds_check_17.f90 +++ b/Fortran/gfortran/regression/bounds_check_17.f90 @@ -23,4 +23,4 @@ END -! { dg-output "At line 22 of file .*bounds_check_17.f90.*Fortran runtime error: Index '11' of dimension 1 of array 'z%y%x' above upper bound of 10" } +! { dg-output "At line 22 of file .*bounds_check_17.f90.*Fortran runtime error: Index '11' of dimension 1 of array 'z\.\.\.%x' above upper bound of 10" } diff --git a/Fortran/gfortran/regression/bounds_check_24.f90 b/Fortran/gfortran/regression/bounds_check_24.f90 new file mode 100644 index 000000000..d0251e845 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_24.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-additional-options "-fcheck=bounds -fdump-tree-original" } +! +! PR fortran/113471 - wrong array bounds check + +program pr113471 + implicit none + type t + integer, dimension(2) :: c1 = 0 + end type t + type(t) :: cc(7), bb(7) + integer :: kk = 1 + + ! no bounds check (can be determined at compile time): + call foo (cc(7)% c1) + + ! bounds check involving kk, but no "outside of expected range" + call foo (bb(kk)% c1) + +contains + subroutine foo (c) + integer, intent(in) :: c(:) + end +end + +! { dg-final { scan-tree-dump-times "below lower bound" 2 "original" } } +! { dg-final { scan-tree-dump-times "above upper bound" 2 "original" } } +! { dg-final { scan-tree-dump-not "outside of expected range" "original" } } diff --git a/Fortran/gfortran/regression/bounds_check_25.f90 b/Fortran/gfortran/regression/bounds_check_25.f90 new file mode 100644 index 000000000..cc2247597 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_25.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds -fdump-tree-original" } +! +! PR fortran/86100 - bogus bounds check with assignment, class component + +program p + implicit none + type any_matrix + class(*), allocatable :: m(:,:) + end type any_matrix + type(any_matrix) :: a, b + allocate (a%m, source=reshape([3,5],shape=[1,2])) + + ! The following assignment did create a bogus bounds violation: + b = a ! Line 15 + if (any (shape (b%m) /= shape (a%m))) stop 1 + +contains + + ! Verify improved array name in array name + subroutine bla () + type(any_matrix) :: c, d + allocate (real :: c%m(3,5)) + allocate (d%m(7,9),source=c%m) ! Line 24 + end subroutine bla +end + +! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 1 of array .'.*.'" 1 "original" } } +! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 2 of array .'.*.'" 1 "original" } } + +! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 1 of array .'d%%m.'" 1 "original" } } +! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 2 of array .'d%%m.'" 1 "original" } } diff --git a/Fortran/gfortran/regression/bounds_check_fail_5.f90 b/Fortran/gfortran/regression/bounds_check_fail_5.f90 new file mode 100644 index 000000000..436cc9662 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_5.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds -g -fdump-tree-original" } +! { dg-output "At line 13 .*" } +! { dg-shouldfail "Array bound mismatch for dimension 1 of array 'ivec' (2/3)" } +! +! PR fortran/31059 - runtime bounds-checking in presence of array constructors + +program p + integer :: jvec(3) = [1,2,3] + integer, allocatable :: ivec(:), kvec(:), lvec(:), mvec(:), nvec(:) + ivec = [1,2] ! (re)allocation + kvec = [4,5,6] ! (re)allocation + ivec(:) = [4,5,6] ! runtime error (->dump) + ! not reached ... + print *, jvec + [1,2,3] ! OK & no check generated + print *, [4,5,6] + jvec ! OK & no check generated + print *, lvec + [1,2,3] ! check generated (->dump) + print *, [4,5,6] + mvec ! check generated (->dump) + nvec(:) = jvec ! check generated (->dump) +end + +! { dg-final { scan-tree-dump-times "Array bound mismatch " 4 "original" } } +! { dg-final { scan-tree-dump-times "Array bound mismatch .*ivec" 1 "original" } } +! { dg-final { scan-tree-dump-times "Array bound mismatch .*lvec" 1 "original" } } +! { dg-final { scan-tree-dump-times "Array bound mismatch .*mvec" 1 "original" } } +! { dg-final { scan-tree-dump-times "Array bound mismatch .*nvec" 1 "original" } } diff --git a/Fortran/gfortran/regression/bounds_check_fail_6.f90 b/Fortran/gfortran/regression/bounds_check_fail_6.f90 new file mode 100644 index 000000000..903291311 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_6.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds -g -fdump-tree-original" } +! { dg-output "At line 18 .*" } +! { dg-shouldfail "dimension 3 of array 'u%z' outside of expected range" } +! +! PR fortran/30802 - improve bounds-checking for array sections + +program test + implicit none + integer :: k = 0 + integer, dimension(10,20,30) :: x = 42 + type t + real, dimension(10,20,30) :: z = 23 + end type t + type(t) :: u + + ! pr30802 + print *, u% z(1,:,k) ! runtime check only for dimension 3 + + ! pr97039 + call foo (x(k,:,k+1)) ! runtime checks for dimensions 1,3 +contains + subroutine foo (a) + integer, intent(in) :: a(:) + end subroutine foo +end program test + +! { dg-final { scan-tree-dump-times "'u%%z.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "'x.' outside of expected range" 4 "original" } } diff --git a/Fortran/gfortran/regression/bounds_check_fail_7.f90 b/Fortran/gfortran/regression/bounds_check_fail_7.f90 new file mode 100644 index 000000000..6a8dafc27 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_7.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds -g" } +! { dg-output "At line 18 .*" } +! { dg-shouldfail "Different CHARACTER lengths (32/0) in array constructor" } +! +! PR fortran/70231 - CHARACTER lengths in array constructors + +program p + implicit none + integer, parameter :: char_len = 32 + integer :: l = 0 + character(char_len) :: ch = "a" + character(char_len), allocatable :: ch_array(:), res1(:), res2(:) + + allocate(ch_array(0)) + res1 = [ ch_array, ch ] ! was false positive + print *, res1 + res2 = [[ch_array, ch(1:l)], ch(1:l)] ! was false negative on x86 + print *, res2 +end diff --git a/Fortran/gfortran/regression/bounds_check_fail_8.f90 b/Fortran/gfortran/regression/bounds_check_fail_8.f90 new file mode 100644 index 000000000..7ee659f0c --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_8.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! { dg-additional-options "-fcheck=bounds -g -fdump-tree-original" } +! +! PR fortran/30802 - improve bounds-checking for array references +! +! Use proper array component references in runtime error message. + +program test + implicit none + integer :: k = 0 + type t + real, dimension(10,20,30) :: z = 23 + end type t + type u + type(t) :: vv(4,5) + complex :: cc(6,7) + end type u + type vec + integer :: xx(3) = [2,4,6] + end type vec + type(t) :: uu, ww(1) + type(u) :: x1, x2, y1(1), y2(1) + + print *, uu % z(1,k,:) ! runtime check for dimension 2 of uu%z + print *, ww(1)% z(1,:,k) ! runtime check for dimension 3 of ww...%z + print *, x1 % vv(2,3)% z(1,:,k) ! runtime check for dimension 3 of x1...%z + print *, x2 % vv(k,:)% z(1,2,3) ! runtime check for dimension 1 of x2%vv + print *, y1(k)% vv(2,3)% z(k,:,1) ! runtime check for dimension 1 of y1 + ! and for dimension 1 of y1...%z + print *, y2(1)% vv(:,k)% z(1,2,k) ! runtime check for dimension 2 of y2...%vv + ! and for dimension 3 of y2...%z + print *, y1(1)% cc(k,:)% re ! runtime check for dimension 1 of y1...%cc +contains + subroutine sub (yy, k) + class(vec), intent(in) :: yy(:) + integer, intent(in) :: k + print *, yy(1)%xx(k) ! runtime checks for yy and yy...%xx + end +end program test + +! { dg-final { scan-tree-dump-times "dimension 2 of array .'uu%%z.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 3 of array .'ww\.\.\.%%z.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 3 of array .'x1\.\.\.%%z.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'x2%%vv.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1\.\.\.%%z.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 2 of array .'y2\.\.\.%%vv.' outside of expected range" 2 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1\.\.\.%%cc.' outside of expected range" 2 "original" } } + +! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1.' above upper bound" 1 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1.' below lower bound" 1 "original" } } +! { dg-final { scan-tree-dump-times "dimension 3 of array .'y2\.\.\.%%z.' above upper bound" 1 "original" } } +! { dg-final { scan-tree-dump-times "dimension 3 of array .'y2\.\.\.%%z.' below lower bound" 1 "original" } } + +! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy.' above upper bound" 1 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy\.\.\.%%xx.' above upper bound" 1 "original" } } +! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy\.\.\.%%xx.' below lower bound" 1 "original" } } diff --git a/Fortran/gfortran/regression/c-interop/c-interop.exp b/Fortran/gfortran/regression/c-interop/c-interop.exp index 8e8b2ee8e..0dc9bd7f1 100644 --- a/Fortran/gfortran/regression/c-interop/c-interop.exp +++ b/Fortran/gfortran/regression/c-interop/c-interop.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# Copyright (C) 2005-2024 Free Software Foundation, Inc. # # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/c-interop/c1255-2.f90 b/Fortran/gfortran/regression/c-interop/c1255-2.f90 index 0e5505a01..feed2e764 100644 --- a/Fortran/gfortran/regression/c-interop/c1255-2.f90 +++ b/Fortran/gfortran/regression/c-interop/c1255-2.f90 @@ -92,12 +92,12 @@ function f (x) bind (c) ! { dg-error "not C interoperable" } end function ! function result is a type that is not interoperable - function g (x) bind (c) ! { dg-error "BIND\\(C\\)" } + function g (x) bind (c) ! { dg-error "has no IMPLICIT type" } use ISO_C_BINDING use m1 implicit none integer(C_INT) :: x - integer(C_INT), allocatable :: g + integer(C_INT), allocatable :: g ! { dg-error "BIND\\(C\\) attribute conflicts with ALLOCATABLE" } end function end interface diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_9.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_9.f90 new file mode 100644 index 000000000..8c8b4a713 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_9.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! A function returning a pointer cannot be interoperable +! and cannot be used as FPTR argument to C_F_POINTER. + +subroutine s () + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr) :: cPtr + call c_f_pointer (cPtr, p0) ! { dg-error "function returning a pointer" } + call c_f_pointer (cPtr, p1, shape=[2]) ! { dg-error "function returning a pointer" } +contains + function p0 () + integer, pointer :: p0 + nullify (p0) + end + function p1 () + integer, pointer :: p1(:) + nullify (p1) + end + function fp0 () + integer, pointer :: fp0 + call c_f_pointer (cPtr, fp0) ! valid here + end + function fp1 () + integer, pointer :: fp1(:) + call c_f_pointer (cPtr, fp1, shape=[2]) ! valid here + end + function ffp0 () result (fp0) + integer, pointer :: fp0 + call c_f_pointer (cPtr, fp0) ! valid here + end + function ffp1 () result (fp1) + integer, pointer :: fp1(:) + call c_f_pointer (cPtr, fp1, shape=[2]) ! valid here + end +end diff --git a/Fortran/gfortran/regression/c_sizeof_6.f90 b/Fortran/gfortran/regression/c_sizeof_6.f90 index a676a5b89..7043ac6ca 100644 --- a/Fortran/gfortran/regression/c_sizeof_6.f90 +++ b/Fortran/gfortran/regression/c_sizeof_6.f90 @@ -8,7 +8,7 @@ program foo character(kind=c_char,len=1),parameter :: str2(4) = ["a","b","c","d"] - i = c_sizeof(str2(1:3)) ! { dg-error "must be an interoperable data" } + i = c_sizeof(str2(1:3)) if (i /= 3) STOP 1 diff --git a/Fortran/gfortran/regression/c_sizeof_7.f90 b/Fortran/gfortran/regression/c_sizeof_7.f90 new file mode 100644 index 000000000..04a0bddbc --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_7.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! PR fortran/106500 - fix checking of arguments to C_SIZEOF +! +! Check support of the following EDIT to 18-007r1: +! https://j3-fortran.org/doc/year/22/22-101r1.txt + +subroutine foo (n, x, y, z, w, u) + use, intrinsic :: iso_c_binding + implicit none + integer, intent(in) :: n + real :: x(n) + real :: y(:) + real :: z(2,*) + real :: w(..) + real, allocatable :: a(:) + real, pointer :: b(:) + type t + real, allocatable :: a(:) + end type t + type(t) :: u + + print *, c_sizeof (x) + print *, c_sizeof (x(::2)) + print *, c_sizeof (x+1) + print *, c_sizeof (y) + print *, c_sizeof (y(1:2)) + print *, c_sizeof (z(:,1:2)) + print *, c_sizeof (w) + print *, c_sizeof (1._c_float) + ! + allocate (a(n)) + allocate (b(n)) + if (.not. allocated (u%a)) allocate (u%a(n)) + print *, c_sizeof (a) + print *, c_sizeof (b) + ! + print *, c_sizeof (u%a) + print *, c_sizeof (u%a(1:2)) + ! + print *, c_sizeof (z) ! { dg-error "Assumed-size arrays are not interoperable" } + print *, c_sizeof (u) ! { dg-error "Expression is a noninteroperable derived type" } +end diff --git a/Fortran/gfortran/regression/c_sizeof_8.f90 b/Fortran/gfortran/regression/c_sizeof_8.f90 new file mode 100644 index 000000000..0ae284436 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_8.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR fortran/103496 +! +! Test that C_SIZEOF returns the expected results + +program pr103496 + use iso_c_binding + implicit none + integer :: a(6) + integer, pointer :: p(:) + + if (c_sizeof(a) /= 6*4) stop 1 + if (c_sizeof(a(1)) /= 4) stop 2 + if (c_sizeof(a(:)) /= 6*4) stop 3 + if (c_sizeof(a(2::2)) /= 3*4) stop 4 + + allocate(p(5)) + if (c_sizeof(p) /= 5*4) stop 5 + if (c_sizeof(p(1)) /= 4) stop 6 + if (c_sizeof(p(:)) /= 5*4) stop 7 + if (c_sizeof(p(2::2)) /= 2*4) stop 8 +end diff --git a/Fortran/gfortran/regression/class_76.f90 b/Fortran/gfortran/regression/class_76.f90 new file mode 100644 index 000000000..c9842a15f --- /dev/null +++ b/Fortran/gfortran/regression/class_76.f90 @@ -0,0 +1,66 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/90069 +! +! Contributed by Brad Richardson +! + +program returned_memory_leak + implicit none + + type, abstract :: base + end type base + + type, extends(base) :: extended + end type extended + + type :: container + class(*), allocatable :: thing + end type + + call run() +contains + subroutine run() + type(container) :: a_container + + a_container = theRightWay() + a_container = theWrongWay() + end subroutine + + function theRightWay() + type(container) :: theRightWay + + class(base), allocatable :: thing + + allocate(thing, source = newAbstract()) + theRightWay = newContainer(thing) + end function theRightWay + + function theWrongWay() + type(container) :: theWrongWay + + theWrongWay = newContainer(newAbstract()) + end function theWrongWay + + function newAbstract() + class(base), allocatable :: newAbstract + + allocate(newAbstract, source = newExtended()) + end function newAbstract + + function newExtended() + type(extended) :: newExtended + end function newExtended + + function newContainer(thing) + class(*), intent(in) :: thing + type(container) :: newContainer + + allocate(newContainer%thing, source = thing) + end function newContainer +end program returned_memory_leak + +! { dg-final { scan-tree-dump-times "newabstract" 15 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } } + diff --git a/Fortran/gfortran/regression/class_77.f90 b/Fortran/gfortran/regression/class_77.f90 new file mode 100644 index 000000000..ef38dd677 --- /dev/null +++ b/Fortran/gfortran/regression/class_77.f90 @@ -0,0 +1,83 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/90072 +! +! Contributed by Brad Richardson +! + +module types + implicit none + + type, abstract :: base_returned + end type base_returned + + type, extends(base_returned) :: first_returned + end type first_returned + + type, extends(base_returned) :: second_returned + end type second_returned + + type, abstract :: base_called + contains + procedure(get_), deferred :: get + end type base_called + + type, extends(base_called) :: first_extended + contains + procedure :: get => getFirst + end type first_extended + + type, extends(base_called) :: second_extended + contains + procedure :: get => getSecond + end type second_extended + + abstract interface + function get_(self) result(returned) + import base_called + import base_returned + class(base_called), intent(in) :: self + class(base_returned), allocatable :: returned + end function get_ + end interface +contains + function getFirst(self) result(returned) + class(first_extended), intent(in) :: self + class(base_returned), allocatable :: returned + + allocate(returned, source = first_returned()) + end function getFirst + + function getSecond(self) result(returned) + class(second_extended), intent(in) :: self + class(base_returned), allocatable :: returned + + allocate(returned, source = second_returned()) + end function getSecond +end module types + +program dispatch_memory_leak + implicit none + + call run() +contains + subroutine run() + use types, only: base_returned, base_called, first_extended + + class(base_called), allocatable :: to_call + class(base_returned), allocatable :: to_get + + allocate(to_call, source = first_extended()) + allocate(to_get, source = to_call%get()) + + deallocate(to_get) + select type(to_call) + type is (first_extended) + allocate(to_get, source = to_call%get()) + end select + end subroutine run +end program dispatch_memory_leak + +! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } + diff --git a/Fortran/gfortran/regression/class_78.f90 b/Fortran/gfortran/regression/class_78.f90 new file mode 100644 index 000000000..3e2a0245a --- /dev/null +++ b/Fortran/gfortran/regression/class_78.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/90076 +! +! Contributed by Brad Richardson +! + +program assignment_memory_leak + implicit none + + type, abstract :: base + end type base + + type, extends(base) :: extended + end type extended + + call run() +contains + subroutine run() + class(base), allocatable :: var + + var = newVar() ! Crash fixed + end subroutine run + + function newVar() + class(extended), allocatable :: newVar + end function newVar +end program assignment_memory_leak + diff --git a/Fortran/gfortran/regression/class_dummy_11.f90 b/Fortran/gfortran/regression/class_dummy_11.f90 new file mode 100644 index 000000000..a5c0fa6d5 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_11.f90 @@ -0,0 +1,194 @@ +! { dg-do run } + +! PR fortran/96992 + +! Contributed by Thomas Koenig + +! From the standard: +! An actual argument that represents an element sequence and +! corresponds to a dummy argument that is an array is sequence +! associated with the dummy argument. The rank and shape of the +! actual argument need not agree with the rank and shape of the +! dummy argument, but the number of elements in the dummy argument +! shall not exceed the number of elements in the element sequence +! of the actual argument. If the dummy argument is assumed-size, +! the number of elements in the dummy argument is exactly +! the number of elements in the element sequence. + +! Check that walking the sequence starts with an initialized stride +! for dim == 0. + +module foo_mod + + implicit none + + type foo + integer :: i + end type foo + +contains + + subroutine d1(x,n) + integer, intent(in) :: n + integer :: i + class (foo), intent(out), dimension(n) :: x + + x(:)%i = (/ (42 + i, i = 1, n ) /) + end subroutine d1 + + subroutine d2(x,n,sb) + integer, intent(in) :: n + integer :: i, sb + class (foo), intent(in), dimension(n,n,n) :: x + + if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 1 + end subroutine d2 + + subroutine d3(x,n) + integer, intent(in) :: n + integer :: i + class (foo), intent(inout) :: x(n) + + x%i = -x%i ! Simply negate elements + end subroutine d3 + + subroutine d4(a,n) + integer, intent(in) :: n + class (foo), intent(inout) :: a(*) + + call d3(a,n) + end subroutine d4 + + subroutine d1s(x,n, sb) + integer, intent(in) :: n, sb + integer :: i + class (*), intent(out), dimension(n) :: x + + select type(x) + class is(foo) + x(:)%i = (/ (42 + i, i = 1, n ) /) + class default + stop sb + 2 + end select + end subroutine d1s + + subroutine d2s(x,n,sb) + integer, intent(in) :: n,sb + integer :: i + class (*), intent(in), dimension(n,n,n) :: x + + select type (x) + class is (foo) + if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 3 + class default + stop sb + 4 + end select + end subroutine d2s + + subroutine d3s(x,n,sb) + integer, intent(in) :: n, sb + integer :: i + class (*), intent(inout) :: x(n) + + select type (x) + class is (foo) + x%i = -x%i ! Simply negate elements + class default + stop sb + 5 + end select + end subroutine d3s + +end module foo_mod + +program main + + use foo_mod + + implicit none + + type (foo), dimension(:), allocatable :: f + type (foo), dimension(27) :: g + type (foo), dimension(3, 9) :: td + integer :: n,i,np3 + + n = 3 + np3 = n **3 + allocate (f(np3)) + call d1(f, np3) + call d2(f, n, 0) + + call d1s(f, np3, 0) + call d2s(f, n, 0) + + ! Use negative stride + call d1(f(np3:1:-1), np3) + if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 6 + call d2(f(np3:1:-1), n, 0) + call d3(f(1:np3:4), np3/4) + if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), & + 42 + (np3 - i), & + MOD(i, 4) == 0 .AND. i < 21), & + i = 0, np3 - 1 ) /) )) & + stop 7 + call d4(f(1:np3:4), np3/4) + if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 8 + + call d1s(f(np3:1:-1), np3, 0) + if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 9 + call d2s(f(np3:1:-1), n, 0) + call d3s(f(1:np3:4), np3/4, 0) + if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), & + 42 + (np3 - i), & + MOD(i, 4) == 0 .AND. i < 21), & + i = 0, np3 - 1 ) /) )) & + stop 10 + + deallocate (f) + + call d1(g, np3) + call d2(g, n, 11) + + call d1s(g, np3, 11) + call d2s(g, n, 11) + + ! Use negative stride + call d1(g(np3:1:-1), np3) + if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 17 + call d2(g(np3:1:-1), n, 11) + call d3(g(1:np3:4), np3/4) + if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), & + 42 + (np3 - i), & + MOD(i, 4) == 0 .AND. i < 21), & + i = 0, np3 - 1 ) /) )) & + stop 18 + + call d1s(g(np3:1:-1), np3, 11) + if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 19 + call d2s(g(np3:1:-1), n, 11) + call d3s(g(1:np3:4), np3/4, 11) + if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), & + 42 + (np3 - i), & + MOD(i, 4) == 0 .AND. i < 21), & + i = 0, np3 - 1 ) /) )) & + stop 20 + + ! Check for 2D + call d1(td, np3) + call d2(td, n, 21) + + call d1s(td, np3, 21) + call d2s(td, n, 21) + + ! Use negative stride + call d1(td(3:1:-1,9:1:-1), np3) + if ( any( reshape(td%i, [np3]) /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 26 + call d2(td(3:1:-1,9:1:-1), n, 21) + call d3(td(2,1:n), n) + if ( any( reshape(td%i, [np3]) /= (/ (merge(-(42 + (np3 - i)), & + 42 + (np3 - i), & + MOD(i, 3) == 1 .AND. i < 9), & + i = 0, np3 - 1 ) /) )) & + stop 27 + +end program main + diff --git a/Fortran/gfortran/regression/coarray/DisabledFiles.cmake b/Fortran/gfortran/regression/coarray/DisabledFiles.cmake index 173be3b33..2f06d9877 100644 --- a/Fortran/gfortran/regression/coarray/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/coarray/DisabledFiles.cmake @@ -15,6 +15,9 @@ file(GLOB UNIMPLEMENTED_FILES CONFIGURE_DEPENDS poly_run_3.f90 # unimplemented: coarray allocation + alloc_comp_6.f90 + alloc_comp_7.f90 + alloc_comp_8.f90 allocate_errgmsg.f90 array_temporary.f90 get_array.f90 diff --git a/Fortran/gfortran/regression/coarray/alloc_comp_6.f90 b/Fortran/gfortran/regression/coarray/alloc_comp_6.f90 new file mode 100644 index 000000000..e8a74db2c --- /dev/null +++ b/Fortran/gfortran/regression/coarray/alloc_comp_6.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program alloc_comp_6 + + implicit none + + type :: foo + real :: x + integer, allocatable :: y(:) + end type + + call check() + +contains + + subroutine check() + block + type(foo), allocatable :: example[:] ! needs to be a coarray + + allocate(example[*]) + allocate(example%y(10)) + example%x = 3.4 + example%y = 4 + + deallocate(example) + end block ! example%y shall not be accessed here by the finalizer, + ! because example is already deallocated + end subroutine check +end program alloc_comp_6 diff --git a/Fortran/gfortran/regression/coarray/alloc_comp_7.f90 b/Fortran/gfortran/regression/coarray/alloc_comp_7.f90 new file mode 100644 index 000000000..5ebd31f3d --- /dev/null +++ b/Fortran/gfortran/regression/coarray/alloc_comp_7.f90 @@ -0,0 +1,49 @@ +! { dg-do run } + +module alloc_comp_module_7 + + public :: check + + type :: foo + real :: x + integer, allocatable :: y(:) + contains + final :: foo_final + end type + +contains + + subroutine foo_final(f) + type(foo), intent(inout) :: f + + if (allocated(f%y)) then + f%y = -1 + end if + end subroutine foo_final + + subroutine check() + block + type(foo), allocatable :: example[:] ! needs to be a coarray + + allocate(example[*]) + allocate(example%y(10)) + example%x = 3.4 + example%y = 4 + + deallocate(example%y) + deallocate(example) + end block ! example%y shall not be accessed here by the finalizer, + ! because example is already deallocated + end subroutine check +end module alloc_comp_module_7 + +program alloc_comp_7 + + use alloc_comp_module_7, only: check + + implicit none + + call check() + +end program alloc_comp_7 + diff --git a/Fortran/gfortran/regression/coarray/alloc_comp_8.f90 b/Fortran/gfortran/regression/coarray/alloc_comp_8.f90 new file mode 100644 index 000000000..8b1539251 --- /dev/null +++ b/Fortran/gfortran/regression/coarray/alloc_comp_8.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Contributed by Andre Vehreschild +! Check that manually freeing components does not lead to a runtime crash, +! when the auto-deallocation is taking care. + +program alloc_comp_6 + implicit none + + type dt + integer, allocatable :: i + end type dt + + type linktype + type(dt), allocatable :: link + end type linktype + + type(linktype), allocatable :: obj[:] + + allocate(obj[*]) + allocate(obj%link) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." + + allocate(obj%link%i, source = 42) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." + if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." + + deallocate(obj%link%i) + + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! Freeing this object, lead to crash with older gfortran... + deallocate(obj%link) + + if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! ... when auto-deallocating the allocated components. + deallocate(obj) + + if (allocated(obj)) error stop "Test failed. 'obj' still allocated." +end program diff --git a/Fortran/gfortran/regression/coarray/caf.exp b/Fortran/gfortran/regression/coarray/caf.exp index d232be2fa..31c13cd34 100644 --- a/Fortran/gfortran/regression/coarray/caf.exp +++ b/Fortran/gfortran/regression/coarray/caf.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2011-2023 Free Software Foundation, Inc. +# Copyright (C) 2011-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -28,6 +28,7 @@ # Load procedures from common libraries. load_lib gfortran-dg.exp +load_lib atomic-dg.exp # If a testcase doesn't have special options, use these. global DEFAULT_FFLAGS @@ -47,6 +48,7 @@ global gfortran_test_path global gfortran_aux_module_flags set gfortran_test_path $srcdir/$subdir set gfortran_aux_module_flags $DEFAULT_FFLAGS + proc dg-compile-aux-modules { args } { global gfortran_test_path global gfortran_aux_module_flags @@ -68,12 +70,6 @@ proc dg-compile-aux-modules { args } { } } -# Add -latomic only where supported. Assume built-in support elsewhere. -set maybe_atomic_lib "" -if [check_effective_target_libatomic_available] { - set maybe_atomic_lib "-latomic" -} - # Main loop. foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] { # If we're only testing specific files and this isn't one of them, skip it. @@ -97,14 +93,14 @@ foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] foreach flags $option_list { verbose "Testing $nshort (single), $flags" 1 set gfortran_aux_module_flags "-fcoarray=single $flags" - dg-test $test "-fcoarray=single $flags $maybe_atomic_lib" "" + dg-test $test "-fcoarray=single $flags" {} cleanup-modules "" } foreach flags $option_list { verbose "Testing $nshort (libcaf_single), $flags" 1 set gfortran_aux_module_flags "-fcoarray=lib $flags -lcaf_single" - dg-test $test "-fcoarray=lib $flags -lcaf_single $maybe_atomic_lib" "" + dg-test $test "-fcoarray=lib $flags -lcaf_single" {} cleanup-modules "" } } diff --git a/Fortran/gfortran/regression/coarray/dummy_1.f90 b/Fortran/gfortran/regression/coarray/dummy_1.f90 index 33e95853a..c437b2a10 100644 --- a/Fortran/gfortran/regression/coarray/dummy_1.f90 +++ b/Fortran/gfortran/regression/coarray/dummy_1.f90 @@ -66,5 +66,7 @@ subroutine sub5(A) if (lcobound(A, dim=1) /= 2) STOP 13 if (ucobound(A, dim=1) /= 3) STOP 14 if (lcobound(A, dim=2) /= 5) STOP 15 + + call sub4(A) ! Check PR88624 is fixed. end subroutine sub5 end diff --git a/Fortran/gfortran/regression/coarray/poly_run_1.f90 b/Fortran/gfortran/regression/coarray/poly_run_1.f90 index 43525d966..f5354b89c 100644 --- a/Fortran/gfortran/regression/coarray/poly_run_1.f90 +++ b/Fortran/gfortran/regression/coarray/poly_run_1.f90 @@ -14,7 +14,7 @@ end if if (allocated(A)) i = 5 call s(A) -!call st(A) ! FIXME +call st(A) ! FIXME contains @@ -30,22 +30,21 @@ end subroutine s subroutine st(x) class(t) :: x(:)[4,2:*] -! FIXME -! if (any (lcobound(x) /= [1, 2])) STOP 7 -! if (lcobound(x, dim=1) /= 1) STOP 8 -! if (lcobound(x, dim=2) /= 2) STOP 9 -! if (this_image() == 1) then -! if (any (this_image(x) /= lcobound(x))) STOP 10 -! if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11 -! if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12 -! end if -! if (num_images() == 1) then -! if (any (ucobound(x) /= [4, 2])) STOP 13 -! if (ucobound(x, dim=1) /= 4) STOP 14 -! if (ucobound(x, dim=2) /= 2) STOP 15 -! else -! if (ucobound(x,dim=1) /= 4) STOP 16 -! end if + if (any (lcobound(x) /= [1, 2])) STOP 7 + if (lcobound(x, dim=1) /= 1) STOP 8 + if (lcobound(x, dim=2) /= 2) STOP 9 + if (this_image() == 1) then + if (any (this_image(x) /= lcobound(x))) STOP 10 + if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11 + if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12 + end if + if (num_images() == 1) then + if (any (ucobound(x) /= [4, 2])) STOP 13 + if (ucobound(x, dim=1) /= 4) STOP 14 + if (ucobound(x, dim=2) /= 2) STOP 15 + else + if (ucobound(x,dim=1) /= 4) STOP 16 + end if end subroutine st end diff --git a/Fortran/gfortran/regression/coarray/poly_run_2.f90 b/Fortran/gfortran/regression/coarray/poly_run_2.f90 index 48a6f7b4c..37347cba6 100644 --- a/Fortran/gfortran/regression/coarray/poly_run_2.f90 +++ b/Fortran/gfortran/regression/coarray/poly_run_2.f90 @@ -6,16 +6,16 @@ end type t class(t), allocatable :: A[:,:] allocate (A[1:4,-5:*]) -if (allocated(A)) stop if (any (lcobound(A) /= [1, -5])) STOP 1 if (num_images() == 1) then if (any (ucobound(A) /= [4, -5])) STOP 2 else if (ucobound(A,dim=1) /= 4) STOP 3 end if -if (allocated(A)) i = 5 + call s(A) -call st(A) +call s2(A) +call sa(A) contains subroutine s(x) class(t) :: x[4,2:*] @@ -26,14 +26,24 @@ subroutine s(x) if (ucobound(x,dim=1) /= 4) STOP 6 end if end subroutine s -subroutine st(x) - class(t) :: x[:,:] - if (any (lcobound(x) /= [1, -5])) STOP 7 +subroutine s2(x) + ! Check that different cobounds are set correctly. + class(t) :: x[2:5,7:*] + if (any (lcobound(x) /= [2, 7])) STOP 7 + if (num_images() == 1) then + if (any (ucobound(x) /= [5, 7])) STOP 8 + else + if (ucobound(x,dim=1) /= 5) STOP 9 + end if +end subroutine s2 +subroutine sa(x) + class(t), allocatable :: x[:,:] + if (any (lcobound(x) /= [1, -5])) STOP 10 if (num_images() == 1) then - if (any (ucobound(x) /= [4, -5])) STOP 8 + if (any (ucobound(x) /= [4, -5])) STOP 11 else - if (ucobound(x,dim=1) /= 4) STOP 9 + if (ucobound(x,dim=1) /= 4) STOP 12 end if -end subroutine st +end subroutine sa end diff --git a/Fortran/gfortran/regression/coarray/tests.cmake b/Fortran/gfortran/regression/coarray/tests.cmake index 723c436a8..65664d5a5 100644 --- a/Fortran/gfortran/regression/coarray/tests.cmake +++ b/Fortran/gfortran/regression/coarray/tests.cmake @@ -45,6 +45,9 @@ link;codimension_2.f90 codimension_2a.f90 codimension_2b.f90;;;; run;alloc_comp_1.f90;;;; run;alloc_comp_4.f90;;;; run;alloc_comp_5.f90;;;; +run;alloc_comp_6.f90;;;; +run;alloc_comp_7.f90;;;; +run;alloc_comp_8.f90;;;; run;allocate_errgmsg.f90;;;; run;atomic_1.f90;;;; run;atomic_2.f90;;;; diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 index 6586ec651..4c71a90af 100644 --- a/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 +++ b/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 @@ -5,7 +5,7 @@ ! Contributed by Andre Vehreschild ! Check that sub-components are caf_deregistered and not freed. -program coarray_alloc_comp_3 +program coarray_alloc_comp_4 implicit none type dt diff --git a/Fortran/gfortran/regression/coarray_poly_6.f90 b/Fortran/gfortran/regression/coarray_poly_6.f90 index 53b80e442..344e12b4e 100644 --- a/Fortran/gfortran/regression/coarray_poly_6.f90 +++ b/Fortran/gfortran/regression/coarray_poly_6.f90 @@ -16,6 +16,6 @@ subroutine foo(x) end subroutine foo end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_7.f90 b/Fortran/gfortran/regression/coarray_poly_7.f90 index 44f98e16e..d8d83aea3 100644 --- a/Fortran/gfortran/regression/coarray_poly_7.f90 +++ b/Fortran/gfortran/regression/coarray_poly_7.f90 @@ -16,6 +16,6 @@ subroutine foo(x) end subroutine foo end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_8.f90 b/Fortran/gfortran/regression/coarray_poly_8.f90 index cac305f03..abdfc0ca5 100644 --- a/Fortran/gfortran/regression/coarray_poly_8.f90 +++ b/Fortran/gfortran/regression/coarray_poly_8.f90 @@ -16,6 +16,6 @@ subroutine foo(x) end subroutine foo end ! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/common_28.f90 b/Fortran/gfortran/regression/common_28.f90 new file mode 100644 index 000000000..9b583b994 --- /dev/null +++ b/Fortran/gfortran/regression/common_28.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/32986 - Improve diagnostic message for COMMON with automatic object + +function a(n) + real :: x(n) ! { dg-error "Automatic object" } + common /c/ x ! { dg-error "cannot appear in COMMON" } +end function diff --git a/Fortran/gfortran/regression/contiguous_13.f90 b/Fortran/gfortran/regression/contiguous_13.f90 new file mode 100644 index 000000000..8c6784432 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_13.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/105543 - function returning contiguous class array +! Contributed by martin + +module func_contiguous + implicit none + type :: a + end type a +contains + function create1 () result(x) + class(a), dimension(:), contiguous, pointer :: x + end + function create2 () + class(a), dimension(:), contiguous, pointer :: create2 + end + function create3 () result(x) + class(*), dimension(:), contiguous, pointer :: x + end + function create4 () + class(*), dimension(:), contiguous, pointer :: create4 + end +end module func_contiguous diff --git a/Fortran/gfortran/regression/contiguous_14.f90 b/Fortran/gfortran/regression/contiguous_14.f90 new file mode 100644 index 000000000..21e42311e --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_14.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! PR fortran/111503 - passing NULL() to POINTER, OPTIONAL, CONTIGUOUS dummy + +program test + implicit none + integer, pointer, contiguous :: p(:) => null() + integer, allocatable, target :: a(:) + type t + integer, pointer, contiguous :: p(:) => null() + integer, allocatable :: a(:) + end type t + type(t), target :: z + class(t), allocatable, target :: c + print *, is_contiguous (p) + allocate (t :: c) + call one (p) + call one () + call one (null ()) + call one (null (p)) + call one (a) + call one (null (a)) + call one (z% p) + call one (z% a) + call one (null (z% p)) + call one (null (z% a)) + call one (c% p) + call one (c% a) + call one (null (c% p)) + call one (null (c% a)) +contains + subroutine one (x) + integer, pointer, optional, contiguous, intent(in) :: x(:) + print *, present (x) + if (present (x)) then + print *, "->", associated (x) + if (associated (x)) stop 99 + end if + end subroutine one +end diff --git a/Fortran/gfortran/regression/contiguous_15.f90 b/Fortran/gfortran/regression/contiguous_15.f90 new file mode 100644 index 000000000..424eb080f --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_15.f90 @@ -0,0 +1,234 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/97592 - fix argument passing to CONTIGUOUS,TARGET dummy +! +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&b_2d" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&p1" 3 "original" } } +! +! N.B.: there is no reliable count of _gfortran_internal_pack on temporaries parm.* + +program pr97592 + implicit none + integer :: i, k + integer, target :: a(10) + integer, pointer :: p1(:), p2(:), tgt(:), expect(:) + integer, pointer, contiguous :: cp(:) + integer, allocatable, target :: b(:) + + !---------------------- + ! Code from original PR + !---------------------- + call RemappingTest () + + !--------------------- + ! Additional 1-d tests + !--------------------- + a = [(i, i=1,size(a))] + b = a + + ! Set p1 to an actually contiguous pointer + p1(13:) => a(3::2) + print *, lbound (p1), ubound (p1), is_contiguous (p1) + + ! non-contiguous pointer actual argument + expect => p1 + call chk_cont (p1) + + expect => p1 + call chk_tgt_cont (p1) + + expect => p1 + call chk_ptr (p1, p2) + if (any (p2 /= p1)) stop 1 + + expect => p1 + call chk_tgt (p1, p2) + if (any (p2 /= p1)) stop 2 + + ! non-contiguous target actual argument + expect => b(3::2) + call chk_tgt_cont (b(3::2)) + + expect => b(3::2) + call chk_tgt (b(3::2), p2) + if (any (p2 /= p1)) stop 3 + + expect => b(3::2) + call chk_ptr (b(3::2), p2) + if (any (p2 /= p1)) stop 4 + + ! Set p1 to an actually contiguous pointer + cp(17:) => a(3:9:1) + p1 => cp + print *, lbound (cp), ubound (cp), is_contiguous (cp) + print *, lbound (p1), ubound (p1), is_contiguous (p1) + + expect => p1 + call chk_tgt (p1, p2) + if (any (p2 /= cp)) stop 31 + + expect => cp + call chk_tgt (cp, p2) + if (any (p2 /= cp)) stop 32 + + expect => cp + call chk_tgt_cont (cp, p2) + if (any (p2 /= cp)) stop 33 + + expect => cp + call chk_tgt_expl (cp, p2, size (cp)) + if (any (p2 /= cp)) stop 34 + + ! See F2018:15.5.2.4 and F2018:C.10.4 + expect => p1 + call chk_tgt_cont (p1, p2) +! print *, p2 + if (any (p2 /= cp)) stop 35 + + expect => p1 + call chk_tgt_expl (p1, p2, size (p1)) + if (any (p2 /= cp)) stop 36 + + expect => cp + call chk_ptr_cont (cp, p2) + if (any (p2 /= cp)) stop 37 + + ! Pass array section which is actually contigous + k = 1 + expect => cp(::k) + call chk_ptr (cp(::k), p2) + if (any (p2 /= cp(::k))) stop 38 + + expect => p1(::k) + call chk_tgt_cont (p1(::k), p2) + if (any (p2 /= p1(::k))) stop 39 + + expect => p1(::k) + call chk_tgt (p1(::k), p2) + if (any (p2 /= p1(::k))) stop 40 + + expect => p1(::k) + call chk_tgt_expl (p1(::k), p2, size (p1(::k))) + if (any (p2 /= p1(::k))) stop 41 + + expect => b(3::k) + call chk_tgt_cont (b(3::k), p2) + if (any (p2 /= b(3::k))) stop 42 + + expect => b(3::k) + call chk_tgt (b(3::k), p2) + if (any (p2 /= b(3::k))) stop 43 + + expect => b(3::k) + call chk_tgt_expl (b(3::k), p2, size (b(3::k))) + if (any (p2 /= b(3::k))) stop 44 + + if (any (a /= [(i, i=1,size(a))])) stop 66 + if (any (a /= b)) stop 77 + deallocate (b) + +contains + ! Contiguous pointer dummy + subroutine chk_ptr_cont (x, y) + integer, contiguous, pointer, intent(in) :: x(:) + integer, pointer, optional :: y(:) + print *, lbound (x), ubound (x) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 10 + if (any (x /= expect)) stop 11 + if (lbound(expect,1) /= 1 .and. & + lbound(expect,1) /= lbound (x,1)) stop 20 + end if + end + + ! Pointer dummy + subroutine chk_ptr (x, y) + integer, pointer, intent(in) :: x(:) + integer, pointer, optional :: y(:) + print *, lbound (x), ubound (x) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 12 + if (any (x /= expect)) stop 13 + if (lbound(expect,1) /= 1 .and. & + lbound(expect,1) /= lbound (x,1)) stop 22 + end if + end + + ! Dummy with target attribute + subroutine chk_tgt_cont (x, y) + integer, contiguous, target, intent(in) :: x(:) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 14 + if (any (x /= expect)) stop 15 + end if + end + + subroutine chk_tgt (x, y) + integer, target, intent(in) :: x(:) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 16 + if (any (x /= expect)) stop 17 + end if + end + + ! Explicit-shape dummy with target attribute + subroutine chk_tgt_expl (x, y, n) + integer, intent(in) :: n + integer, target, intent(in) :: x(n) + integer, pointer, optional :: y(:) + if (present (y)) y => x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 18 + if (any (x /= expect)) stop 19 + end if + end + + ! Dummy without pointer or target attribute + subroutine chk_cont (x) + integer, contiguous, intent(in) :: x(:) + if (associated (expect)) then + if (size (x) /= size (expect)) stop 23 + if (any (x /= expect)) stop 24 + end if + end + + !------------------------------------------------------------------------ + + subroutine RemappingTest () + real, pointer :: B_2D(:,:) + real, pointer :: B_3D(:,:,:) => NULL() + integer, parameter :: n1=4, n2=4, n3=3 + !-- Prepare B_2D + allocate (B_2D(n1*n2, n3)) + B_2D = - huge (1.0) + if (.not. is_contiguous (B_2D)) stop 101 + !-- Point B_3D to Storage + call SetPointer (B_2D, n1, n2, n3, B_3D) + !print *,"is_contiguous (B_3D) =", is_contiguous (B_3D) + if (.not. is_contiguous (B_3D)) stop 102 + !-- Set B_3D + B_3D = 2.0 + !-- See if the result is reflected in Storage + if (any (B_2D /= 2.0)) then + print *, "B_2D = ", B_2D !-- expect 2.0 for all elements + stop 103 + end if + print *,"RemappingTest passed" + end + + subroutine SetPointer (C_2D, n1, n2, n3, C_3D) + integer, intent(in) :: n1, n2, n3 + real, target, contiguous :: C_2D(:,:) + real, pointer :: C_3D(:,:,:) + intent(in) :: C_2D + C_3D(1:n1,1:n2,1:n3) => C_2D + end + +end diff --git a/Fortran/gfortran/regression/continuation_17.f90 b/Fortran/gfortran/regression/continuation_17.f90 new file mode 100644 index 000000000..6f2b11dbe --- /dev/null +++ b/Fortran/gfortran/regression/continuation_17.f90 @@ -0,0 +1,267 @@ +! { dg-do compile } +! { dg-options -std=f2018 } +! +! copied from continuation_4.f90 - but use -std=f2018 +! Fortran 2018: Continuation-line limit is 255 <<< TESTED +! Fortran 2023: Maximally 1,000,000 characters per statement (implied but no explicit continuation-line line limit) +! +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle +print *, & + "1" // & ! 1 Counting in groups of 40. + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 40 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 80 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 120 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 160 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 200 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 240 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 255 + "0" ! { dg-warning "Limit of 255 continuations exceeded" } +end diff --git a/Fortran/gfortran/regression/continuation_18.f90 b/Fortran/gfortran/regression/continuation_18.f90 new file mode 100644 index 000000000..7ad887d70 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_18.f90 @@ -0,0 +1,267 @@ +! { dg-do compile } +! { dg-options -std=f2023 } +! +! copied from continuation_4.f90 - but use -std=f2023 +! Fortran 2018: Continuation-line limit is 255 +! Fortran 2023: Maximally 1,000,000 characters per statement (implied but no explicit continuation-line line limit) <<< TESTED +! +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle +print *, & + "1" // & ! 1 Counting in groups of 40. + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 40 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 80 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 120 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 160 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 200 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 240 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 255 + "0" ! No warning with -std=f2023 +end diff --git a/Fortran/gfortran/regression/continuation_19.f b/Fortran/gfortran/regression/continuation_19.f new file mode 100644 index 000000000..2b32a333f --- /dev/null +++ b/Fortran/gfortran/regression/continuation_19.f @@ -0,0 +1,267 @@ +! { dg-do run } +! { dg-options "-std=f2023" } + + implicit none + integer :: x + + ! 256 continuation lines - but less than 1,000,000 character + ! => Valid since Fortran 2023 + x = + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + & + 2 + + end diff --git a/Fortran/gfortran/regression/data_array_7.f90 b/Fortran/gfortran/regression/data_array_7.f90 new file mode 100644 index 000000000..56cd6ad3e --- /dev/null +++ b/Fortran/gfortran/regression/data_array_7.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Checking for "The new features of Fortran 2008" feature 5.6 + + implicit none + integer :: a(6) + integer :: b(6) + integer(kind=4) :: i + + ! Fortran 2008: Subscripts in a data statement can be any constant expression + data a(kind("foo")) / 1 / + data a(sum([1, 2, 3]) / 3) / 2 / + data a(len("foo")) / 3 / + data a(kind(i)) / 4 / + data a(int(7.0 * atan(1.0)):6) / 5, 6 / + + ! Fortran 2008: nested implied-do limits in a data statement can be any constant expression + data (b(i), i = kind("foo"), sum([-1, 1, 2])) / 1, 2 / + data (b(i), i = len("foo"), kind(i)) / 3, 4 / + data (b(i), i = int(7.0 * atan(1.0)), 6) / 5, 6 / + + ! Check that data was correctly filled + if (any(a /= [(i, i = 1, 6)])) stop 1 + if (any(b /= [(i, i = 1, 6)])) stop 1 + +end diff --git a/Fortran/gfortran/regression/data_bounds_1.f90 b/Fortran/gfortran/regression/data_bounds_1.f90 index 24cdc7c98..1e6321a28 100644 --- a/Fortran/gfortran/regression/data_bounds_1.f90 +++ b/Fortran/gfortran/regression/data_bounds_1.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-std=gnu" } +! { dg-options "-std=gnu -w" } ! Checks the fix for PR32315, in which the bounds checks below were not being done. ! ! Contributed by Tobias Burnus diff --git a/Fortran/gfortran/regression/data_bounds_2.f90 b/Fortran/gfortran/regression/data_bounds_2.f90 new file mode 100644 index 000000000..1aa9fd4c4 --- /dev/null +++ b/Fortran/gfortran/regression/data_bounds_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/35095 - Improve bounds checking for DATA with implied-do + +program chkdata + character(len=2), dimension(2,2) :: str + data (str(i,1),i=1,3) / 'A','B','C' / ! { dg-error "above array upper bound" } + data (str(j,2),j=0,2) / 'A','B','C' / ! { dg-error "below array lower bound" } +end program chkdata diff --git a/Fortran/gfortran/regression/data_char_4.f90 b/Fortran/gfortran/regression/data_char_4.f90 index ed0782ce8..fa5e0a013 100644 --- a/Fortran/gfortran/regression/data_char_4.f90 +++ b/Fortran/gfortran/regression/data_char_4.f90 @@ -4,7 +4,7 @@ program p character(l) :: c(2) ! { dg-error "must have constant character length" } - data c /'a', 'b'/ + data c /'a', 'b'/ ! { dg-error "Non-constant character length" } common c end diff --git a/Fortran/gfortran/regression/data_char_5.f90 b/Fortran/gfortran/regression/data_char_5.f90 index ea26687e3..7556e63c0 100644 --- a/Fortran/gfortran/regression/data_char_5.f90 +++ b/Fortran/gfortran/regression/data_char_5.f90 @@ -4,12 +4,12 @@ subroutine sub () integer :: ll = 4 block - character(ll) :: c(2) ! { dg-error "non-constant" } - data c /'a', 'b'/ + character(ll) :: c(2) + data c /'a', 'b'/ ! { dg-error "Non-constant character length" } end block contains subroutine sub1 () - character(ll) :: d(2) ! { dg-error "non-constant" } - data d /'a', 'b'/ + character(ll) :: d(2) + data d /'a', 'b'/ ! { dg-error "Non-constant character length" } end subroutine sub1 end subroutine sub diff --git a/Fortran/gfortran/regression/data_char_6.f90 b/Fortran/gfortran/regression/data_char_6.f90 new file mode 100644 index 000000000..4e32c647d --- /dev/null +++ b/Fortran/gfortran/regression/data_char_6.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/68569 - ICE with automatic character object and DATA +! Contributed by G. Steinmetz + +subroutine s1 (n) + implicit none + integer, intent(in) :: n + character(n) :: x + data x /'a'/ ! { dg-error "Non-constant character length" } +end + +subroutine s2 (n) + implicit none + integer, intent(in) :: n + character(n) :: x + data x(1:1) /'a'/ ! { dg-error "Non-constant character length" } +end + +subroutine s3 () + implicit none + type t + character(:) :: c ! { dg-error "must be a POINTER or ALLOCATABLE" } + end type t + type(t) :: tp + data tp%c /'a'/ ! { dg-error "Non-constant character length" } +end diff --git a/Fortran/gfortran/regression/data_initialized_4.f90 b/Fortran/gfortran/regression/data_initialized_4.f90 new file mode 100644 index 000000000..156b6607e --- /dev/null +++ b/Fortran/gfortran/regression/data_initialized_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } +! +! PR fortran/50410 +! +! Silently allow overlapping initialization in legacy mode (used to ICE) + +program p + implicit none + type t + integer :: g = 1 + end type t + type(t) :: u = t(2) + data u%g /3/ + print *, u ! this might print "2" +end diff --git a/Fortran/gfortran/regression/data_pointer_3.f90 b/Fortran/gfortran/regression/data_pointer_3.f90 new file mode 100644 index 000000000..49c288e93 --- /dev/null +++ b/Fortran/gfortran/regression/data_pointer_3.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! PR fortran/114474 - DATA and derived types with pointer components + +program pr114474 + implicit none + integer, target :: ii = 42 ! initial data target + + integer, target :: jj = 24 + integer, pointer :: qq => jj + ! ii and jj resolve slightly differently when the data statement below + ! is reached, as jj is resolved outside the structure constructor first + + type t + integer, pointer :: h + end type t + + integer, target :: kk(7) = 23 + integer, pointer :: ll(:) => kk + + type t1 + integer :: m(7) + end type t1 + + type(t) :: x1, x2, x3, x4, x5 + type(t), parameter :: z1 = t(null()) + + type(t1), target :: tt = t1([1,2,3,4,5,6,7]) + type(t1), parameter :: vv = t1(22) + type(t1) :: w1, w2 + integer, pointer :: p1(:) => tt% m + + data x1 / t(null()) / + data x2 / t(ii) / ! ii is initial data target + data x3 / t(jj) / ! jj is resolved differently... + data x4 / t(tt%m(3)) / ! pointer association with 3rd element + + data w1 / t1(12) / + data w2 / t1(vv%m) / + + if ( associated (x1% h)) stop 1 + if (.not. associated (x2% h)) stop 2 + if (.not. associated (x3% h)) stop 3 + if (.not. associated (x4% h)) stop 4 + if (x2% h /= 42) stop 5 + if (x3% h /= 24) stop 6 + if (x4% h /= 3) stop 7 + + if (any (w1%m /= 12 )) stop 8 + if (any (w2%m /= vv%m)) stop 9 +end + + +subroutine sub + implicit none + + interface + real function myfun (x) + real, intent(in) :: x + end function myfun + end interface + + type u + procedure(myfun), pointer, nopass :: p + end type u + + type(u) :: u3 = u(null()) + type(u), parameter :: u4 = u(null()) + type(u) :: u1, u2 + + data u1 / u(null()) / + data u2 / u(myfun) / +end + +real function myfun (x) + real, intent(in) :: x + myfun = x +end function myfun diff --git a/Fortran/gfortran/regression/data_vector_section.f90 b/Fortran/gfortran/regression/data_vector_section.f90 new file mode 100644 index 000000000..3e099de99 --- /dev/null +++ b/Fortran/gfortran/regression/data_vector_section.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! PR fortran/49588 - vector sections in data statements + +block data + implicit none + integer :: a(8), b(3,2), i + data a(::2) /4*1/ + data a([2,6]) /2*2/ + data a([4]) /3/ + data a([(6+2*i,i=1,1)]) /1*5/ + data b( 1 ,[1,2]) /11,12/ + data b([2,3],[2,1]) /22,32,21,31/ + common /com/ a, b +end block data + +program test + implicit none + integer :: a(8), b(3,2), i, j + common /com/ a, b + print *, a + print *, b +! print *, a - [1,2,1,3,1,2,1,5] +! print *, ((b(i,j)-(10*i+j),i=1,3),j=1,2) + if (.not. all (a == [1,2,1,3,1,2,1,5])) stop 1 + if (.not. all (b == reshape ([((10*i+j,i=1,3),j=1,2)], shape (b)))) stop 2 +end program test diff --git a/Fortran/gfortran/regression/date_and_time_2.f90 b/Fortran/gfortran/regression/date_and_time_2.f90 new file mode 100644 index 000000000..663611a3e --- /dev/null +++ b/Fortran/gfortran/regression/date_and_time_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018" } +! +! PR fortran/96580 - constraints on VALUES argument of DATE_AND_TIME intrinsic + +program test_time_and_date + implicit none + integer(1), dimension(8) :: values1 + integer(2), dimension(8) :: values2 + integer(4), dimension(8) :: values + integer(4), dimension(9) :: values4 + integer(8), dimension(8) :: values8 + integer , dimension(7) :: values7 + + call date_and_time(VALUES=values1) ! { dg-error "decimal exponent range" } + call date_and_time(VALUES=values2) + call date_and_time(VALUES=values) + call date_and_time(VALUES=values4) + call date_and_time(VALUES=values8) + call date_and_time(VALUES=values7) ! { dg-error "at .1. too small \\(7/8\\)" } +end program test_time_and_date diff --git a/Fortran/gfortran/regression/date_and_time_3.f90 b/Fortran/gfortran/regression/date_and_time_3.f90 new file mode 100644 index 000000000..020266d87 --- /dev/null +++ b/Fortran/gfortran/regression/date_and_time_3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-additional-options "-std=f2018" } +! +! PR fortran/96580 - integer kind of VALUES argument of DATE_AND_TIME intrinsic + +program test_time_and_date + implicit none + integer(2), dimension(8) :: values2 + integer(4), dimension(8) :: values4 + integer(8), dimension(8) :: values8 + + call date_and_time(VALUES=values2) + call date_and_time(VALUES=values4) + call date_and_time(VALUES=values8) + + ! Check consistency of year and of time difference from UTC + if (values2(1) /= -HUGE(0_2) .and. values4(1) /= -HUGE(0_4)) then + if (abs (values4(1) - values2(1)) > 1) stop 1 + end if + if (values2(4) /= -HUGE(0_2) .and. values4(4) /= -HUGE(0_4)) then + if (values2(4) /= values4(4)) stop 2 + end if + if (values4(1) /= -HUGE(0_4) .and. values8(1) /= -HUGE(0_8)) then + if (abs (values8(1) - values4(1)) > 1) stop 3 + end if + if (values4(4) /= -HUGE(0_4) .and. values8(4) /= -HUGE(0_8)) then + if (values4(4) /= values8(4)) stop 4 + end if +end program test_time_and_date diff --git a/Fortran/gfortran/regression/date_and_time_4.f90 b/Fortran/gfortran/regression/date_and_time_4.f90 new file mode 100644 index 000000000..6039c85ec --- /dev/null +++ b/Fortran/gfortran/regression/date_and_time_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-additional-options "-std=f2018" } +! { dg-require-effective-target fortran_integer_16 } +! +! PR fortran/96580 - integer kind of VALUES argument of DATE_AND_TIME intrinsic + +program test_time_and_date + implicit none + integer(4), dimension(8) :: values4 + integer(8), dimension(8) :: values8 + integer(16),dimension(8) :: values16 + + call date_and_time(VALUES=values4) + call date_and_time(VALUES=values8) + call date_and_time(VALUES=values16) + + ! Check consistency of year and of time difference from UTC + if (values16(1) /= -HUGE(0_16) .and. values4(1) /= -HUGE(0_4)) then + if (abs (values4(1) - values16(1)) > 1) stop 1 + end if + if (values16(4) /= -HUGE(0_16) .and. values4(4) /= -HUGE(0_4)) then + if (values16(4) /= values4(4)) stop 2 + end if + if (values4(1) /= -HUGE(0_4) .and. values8(1) /= -HUGE(0_8)) then + if (abs (values8(1) - values4(1)) > 1) stop 3 + end if + if (values4(4) /= -HUGE(0_4) .and. values8(4) /= -HUGE(0_8)) then + if (values4(4) /= values8(4)) stop 4 + end if +end program test_time_and_date diff --git a/Fortran/gfortran/regression/debug/debug.exp b/Fortran/gfortran/regression/debug/debug.exp index 48737d6eb..1f92a4c1b 100644 --- a/Fortran/gfortran/regression/debug/debug.exp +++ b/Fortran/gfortran/regression/debug/debug.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2008-2023 Free Software Foundation, Inc. +# Copyright (C) 2008-2024 Free Software Foundation, Inc. # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/dec_math.f90 b/Fortran/gfortran/regression/dec_math.f90 index d95233a51..393e7def8 100644 --- a/Fortran/gfortran/regression/dec_math.f90 +++ b/Fortran/gfortran/regression/dec_math.f90 @@ -1,5 +1,6 @@ ! { dg-options "-cpp -std=gnu" } ! { dg-do run { xfail i?86-*-freebsd* } } +! { dg-skip-if "No long double libc functions" { hppa*-*-hpux* } } ! ! Test extra math intrinsics formerly offered by -fdec-math, ! now included with -std=gnu or -std=legacy. diff --git a/Fortran/gfortran/regression/deferred_character_37.f90 b/Fortran/gfortran/regression/deferred_character_37.f90 new file mode 100644 index 000000000..8a5a8c5da --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_37.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! PR fortran/95947 +! PR fortran/110658 +! +! Test deferred-length character arguments to selected intrinsics +! that may return a character result of same length as first argument: +! CSHIFT, EOSHIFT, MAXVAL, MERGE, MINVAL, PACK, SPREAD, TRANSPOSE, UNPACK + +program p + implicit none + call pr95947 () + call pr110658 () + call s () + +contains + + subroutine pr95947 + character(len=:), allocatable :: m(:) + + m = [ character(len=10) :: 'ape','bat','cat','dog','eel','fly','gnu'] + m = pack (m, mask=(m(:)(2:2) == 'a')) + +! print *, "m = '", m,"' ", "; expected is ['bat','cat']" + if (.not. all (m == ['bat','cat'])) stop 1 + +! print *, "size(m) = ", size(m), "; expected is 2" + if (size (m) /= 2) stop 2 + +! print *, "len(m) = ", len(m), "; expected is 10" + if (len (m) /= 10) stop 3 + +! print *, "len_trim(m) = ", len_trim(m), "; expected is 3 3" + if (.not. all (len_trim(m) == [3,3])) stop 4 + end + + subroutine pr110658 + character(len=:), allocatable :: array(:), array2(:,:) + character(len=:), allocatable :: res, res1(:), res2(:) + + array = ["bb", "aa", "cc"] + + res = minval (array) + if (res /= "aa") stop 11 + + res = maxval (array, mask=[.true.,.true.,.false.]) + if (res /= "bb") stop 12 + + res1 = cshift (array, 1) + if (any (res1 /= ["aa","cc","bb"])) stop 13 + + res2 = eoshift (res1, -1) + if (any (res2 /= [" ", "aa", "cc"])) stop 14 + + res2 = pack (array, mask=[.true.,.false.,.true.]) + if (any (res2 /= ["bb","cc"])) stop 15 + + res2 = unpack (res2, mask=[.true.,.false.,.true.], field="aa") + if (any (res2 /= array)) stop 16 + + res2 = merge (res2, array, [.true.,.false.,.true.]) + if (any (res2 /= array)) stop 17 + + array2 = spread (array, dim=2, ncopies=2) + array2 = transpose (array2) + if (any (shape (array2) /= [2,3])) stop 18 + if (any (array2(2,:) /= array)) stop 19 + end + + subroutine s + character(:), allocatable :: array1(:), array2(:) + array1 = ["aa","cc","bb"] + array2 = copy (array1) + if (any (array1 /= array2)) stop 20 + end + + function copy (arg) result (res) + character(:), allocatable :: res(:) + character(*), intent(in) :: arg(:) + integer :: i, k, n + k = len (arg) + n = size (arg) + allocate (character(k) :: res(n)) + do i = 1, n + res(i) = arg(i) + end do + end + +end diff --git a/Fortran/gfortran/regression/deferred_character_38.f90 b/Fortran/gfortran/regression/deferred_character_38.f90 new file mode 100644 index 000000000..d5a6c0e50 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_38.f90 @@ -0,0 +1,20 @@ +! { dg-do run } + +! Check for PR fortran/82904 +! Contributed by G.Steinmetz + +! This test checks that 'IPA pass: inline' passes. +! The initial version of the testcase contained coarrays, which does not work +! yet. + +program p + save + character(:), allocatable :: x + character(:), allocatable :: y + allocate (character(3) :: y) + allocate (x, source='abc') + y = x + + if (y /= 'abc') stop 1 +end + diff --git a/Fortran/gfortran/regression/dependent_decls_2.f90 b/Fortran/gfortran/regression/dependent_decls_2.f90 new file mode 100644 index 000000000..73c84ea3b --- /dev/null +++ b/Fortran/gfortran/regression/dependent_decls_2.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! Fix for PR59104 in which the dependence on the old style function result +! was not taken into account in the ordering of auto array allocation and +! characters with dependent lengths. +! +! Contributed by Tobias Burnus +! +module m + implicit none + integer, parameter :: dp = kind([double precision::]) + contains + function f(x) + integer, intent(in) :: x + real(dp) f(x/2) + real(dp) g(x/2) + integer y(size (f)+1) ! This was the original problem + integer z(size (f) + size (y)) ! Found in development of the fix + integer w(size (f) + size (y) + x) ! Check dummy is OK + integer :: l1(size(y)) + integer :: l2(size(z)) + integer :: l3(size(w)) + f = 10.0 + y = 1 ! Stop -Wall from complaining + z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1 + if (size (f) .ne. 1) stop 1 + if (size (g) .ne. 1) stop 2 + if (size (y) .ne. 2) stop 3 + if (size (z) .ne. 3) stop 4 + if (size (w) .ne. 5) stop 5 + if (size (l1) .ne. 2) stop 6 ! Check indirect dependencies + if (size (l2) .ne. 3) stop 7 + if (size (l3) .ne. 5) stop 8 + + end function f + function e(x) result(f) + integer, intent(in) :: x + real(dp) f(x/2) + real(dp) g(x/2) + integer y(size (f)+1) + integer z(size (f) + size (y)) ! As was this. + integer w(size (f) + size (y) + x) + integer :: l1(size(y)) + integer :: l2(size(z)) + integer :: l3(size(w)) + f = 10.0 + y = 1; z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1 + if (size (f) .ne. 2) stop 9 + if (size (g) .ne. 2) stop 10 + if (size (y) .ne. 3) stop 11 + if (size (z) .ne. 5) stop 12 + if (size (w) .ne. 9) stop 13 + if (size (l1) .ne. 3) stop 14 ! Check indirect dependencies + if (size (l2) .ne. 5) stop 15 + if (size (l3) .ne. 9) stop 16 + end function + function d(x) ! After fixes to arrays, what was needed was known! + integer, intent(in) :: x + character(len = x/2) :: d + character(len = len (d)) :: line + character(len = len (d) + len (line)) :: line2 + character(len = len (d) + len (line) + x) :: line3 +! Commented out lines give implicit type warnings with gfortran and nagfor +! character(len = len (d)) :: line4 (len (line3)) + character(len = len (line3)) :: line4 (len (line3)) +! character(len = size(len4, 1)) :: line5 + line = repeat ("a", len (d)) + line2 = repeat ("b", x) + line3 = repeat ("c", len (line3)) + if (len (line2) .ne. x) stop 17 + if (line3 .ne. "cccccccc") stop 18 + d = line + line4 = line3 + if (size (line4) .ne. 8) stop 19 + if (any (line4 .ne. "cccccccc")) stop 20 + end +end module m + +program p + use m + implicit none + real(dp) y + + y = sum (f (2)) + if (int (y) .ne. 10) stop 21 + y = sum (e (4)) + if (int (y) .ne. 20) stop 22 + if (d (4) .ne. "aa") stop 23 +end program p diff --git a/Fortran/gfortran/regression/dependent_decls_3.f90 b/Fortran/gfortran/regression/dependent_decls_3.f90 new file mode 100644 index 000000000..93862b8cc --- /dev/null +++ b/Fortran/gfortran/regression/dependent_decls_3.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Fix a regression caused by the fix for PR59104. +! +! Contributed by Harald Anlauf +! +program p + implicit none + integer, parameter :: nx = 64, ny = 32 + real :: x(nx,ny), s(nx/2,ny), d(nx/2,ny) + + s = 0.0 + d = 0.0 + call sub (x,s,d) + if (sum(s) .ne. 256) stop 1 + if (sum(d) .ne. 256) stop 2 ! Stopped with sum(d) == 0. +contains + subroutine sub (v, w, d) + real, intent(in) :: v(:,:) + real, intent(out), dimension (size (v,dim=1)/4,size (v,dim=2)/2) :: w, d + w = 1.0 + d = 1.0 + if (any (shape (w) .ne. [nx/4, ny/2])) stop 3 + if (any (shape (d) .ne. [nx/4, ny/2])) print *, shape (d) ! Printed "0 0" here + end subroutine sub +end diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 index 739f4adfb..22dfdc668 100644 --- a/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 +++ b/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 @@ -2,6 +2,7 @@ ! ! PR fortran/52325 ! +implicit none real :: f cc%a = 5 ! { dg-error "Symbol 'cc' at .1. has no IMPLICIT type" } f%a = 5 ! { dg-error "Unexpected '%' for nonderived-type variable 'f' at" } diff --git a/Fortran/gfortran/regression/derived_function_interface_1.f90 b/Fortran/gfortran/regression/derived_function_interface_1.f90 index 24a009509..5438ad49c 100644 --- a/Fortran/gfortran/regression/derived_function_interface_1.f90 +++ b/Fortran/gfortran/regression/derived_function_interface_1.f90 @@ -38,7 +38,7 @@ end function ext_fun contains - type(foo) function fun() ! { dg-error "already has an explicit interface" } + type(foo) function fun() ! { dg-error "has an explicit interface" } end function fun ! { dg-error "Expecting END PROGRAM" } end diff --git a/Fortran/gfortran/regression/dg.exp b/Fortran/gfortran/regression/dg.exp index ee2760327..7a9cb89c1 100644 --- a/Fortran/gfortran/regression/dg.exp +++ b/Fortran/gfortran/regression/dg.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2004-2023 Free Software Foundation, Inc. +# Copyright (C) 2004-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -18,6 +18,7 @@ # Load support procs. load_lib gfortran-dg.exp +load_lib atomic-dg.exp # If a testcase doesn't have special options, use these. global DEFAULT_FFLAGS @@ -53,13 +54,14 @@ proc dg-compile-aux-modules { args } { } } +set all_flags $DEFAULT_FFLAGS + # Main loop. gfortran-dg-runtest [lsort \ - [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "" $DEFAULT_FFLAGS + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "" $all_flags gfortran-dg-runtest [lsort \ - [glob -nocomplain $srcdir/$subdir/g77/*.\[fF\] ] ] "" $DEFAULT_FFLAGS - + [glob -nocomplain $srcdir/$subdir/g77/*.\[fF\] ] ] "" $all_flags # All done. dg-finish diff --git a/Fortran/gfortran/regression/diagnostic-format-json-1.F90 b/Fortran/gfortran/regression/diagnostic-format-json-1.F90 index 2993f7c85..b8cd61cff 100644 --- a/Fortran/gfortran/regression/diagnostic-format-json-1.F90 +++ b/Fortran/gfortran/regression/diagnostic-format-json-1.F90 @@ -3,29 +3,22 @@ #error message -! Use dg-regexp to consume the JSON output starting with -! the innermost values, and working outwards. -! We can't rely on any ordering of the keys. - -! { dg-regexp "\"kind\": \"error\"" } -! { dg-regexp "\"column-origin\": 1" } -! { dg-regexp "\"escape-source\": false" } -! { dg-regexp "\"message\": \"#error message\"" } - -! { dg-regexp "\"caret\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-1.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 2" } -! { dg-regexp "\"display-column\": 2" } -! { dg-regexp "\"byte-column\": 2" } - -! { dg-regexp "\"finish\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-1.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 6" } -! { dg-regexp "\"display-column\": 6" } -! { dg-regexp "\"byte-column\": 6" } - -! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } -! { dg-regexp "\"children\": \[\[\]\[\]\]" } -! { dg-regexp "\[\[\{\}, \]*\]" } +#if 0 +{ dg-begin-multiline-output "" } +[{"kind": "error", + "message": "#error message", + "children": [], + "column-origin": 1, + "locations": [{"caret": {"file": + "line": 4, + "display-column": 2, + "byte-column": 2, + "column": 2}, + "finish": {"file": + "line": 4, + "display-column": 6, + "byte-column": 6, + "column": 6}}], + "escape-source": false}] +{ dg-end-multiline-output "" } +#endif diff --git a/Fortran/gfortran/regression/diagnostic-format-json-2.F90 b/Fortran/gfortran/regression/diagnostic-format-json-2.F90 index 1681462fa..9ff1ef59b 100644 --- a/Fortran/gfortran/regression/diagnostic-format-json-2.F90 +++ b/Fortran/gfortran/regression/diagnostic-format-json-2.F90 @@ -3,31 +3,24 @@ #warning message -! Use dg-regexp to consume the JSON output starting with -! the innermost values, and working outwards. -! We can't rely on any ordering of the keys. - -! { dg-regexp "\"kind\": \"warning\"" } -! { dg-regexp "\"column-origin\": 1" } -! { dg-regexp "\"escape-source\": false" } -! { dg-regexp "\"message\": \"#warning message\"" } -! { dg-regexp "\"option\": \"-Wcpp\"" } -! { dg-regexp "\"option_url\": \"\[^\n\r\"\]*#index-Wcpp\"" } - -! { dg-regexp "\"caret\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-2.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 2" } -! { dg-regexp "\"display-column\": 2" } -! { dg-regexp "\"byte-column\": 2" } - -! { dg-regexp "\"finish\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-2.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 8" } -! { dg-regexp "\"display-column\": 8" } -! { dg-regexp "\"byte-column\": 8" } - -! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } -! { dg-regexp "\"children\": \[\[\]\[\]\]" } -! { dg-regexp "\[\[\{\}, \]*\]" } +#if 0 +{ dg-begin-multiline-output "" } +[{"kind": "warning", + "message": "#warning message", + "option": "-Wcpp", + "option_url": + "children": [], + "column-origin": 1, + "locations": [{"caret": {"file": + "line": 4, + "display-column": 2, + "byte-column": 2, + "column": 2}, + "finish": {"file": + "line": 4, + "display-column": 8, + "byte-column": 8, + "column": 8}}], + "escape-source": false}] +{ dg-end-multiline-output "" } +#endif diff --git a/Fortran/gfortran/regression/diagnostic-format-json-3.F90 b/Fortran/gfortran/regression/diagnostic-format-json-3.F90 index f0a67de76..750e186c8 100644 --- a/Fortran/gfortran/regression/diagnostic-format-json-3.F90 +++ b/Fortran/gfortran/regression/diagnostic-format-json-3.F90 @@ -3,31 +3,24 @@ #warning message -! Use dg-regexp to consume the JSON output starting with -! the innermost values, and working outwards. -! We can't rely on any ordering of the keys. - -! { dg-regexp "\"kind\": \"error\"" } -! { dg-regexp "\"column-origin\": 1" } -! { dg-regexp "\"escape-source\": false" } -! { dg-regexp "\"message\": \"#warning message\"" } -! { dg-regexp "\"option\": \"-Werror=cpp\"" } -! { dg-regexp "\"option_url\": \"\[^\n\r\"\]*#index-Wcpp\"" } - -! { dg-regexp "\"caret\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-3.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 2" } -! { dg-regexp "\"display-column\": 2" } -! { dg-regexp "\"byte-column\": 2" } - -! { dg-regexp "\"finish\": \{" } -! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-3.F90\"" } -! { dg-regexp "\"line\": 4" } -! { dg-regexp "\"column\": 8" } -! { dg-regexp "\"display-column\": 8" } -! { dg-regexp "\"byte-column\": 8" } - -! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } -! { dg-regexp "\"children\": \[\[\]\[\]\]" } -! { dg-regexp "\[\[\{\}, \]*\]" } +#if 0 +{ dg-begin-multiline-output "" } +[{"kind": "error", + "message": "#warning message", + "option": "-Werror=cpp", + "option_url": + "children": [], + "column-origin": 1, + "locations": [{"caret": {"file": + "line": 4, + "display-column": 2, + "byte-column": 2, + "column": 2}, + "finish": {"file": + "line": 4, + "display-column": 8, + "byte-column": 8, + "column": 8}}], + "escape-source": false}] +{ dg-end-multiline-output "" } +#endif diff --git a/Fortran/gfortran/regression/do_concurrent_7.f90 b/Fortran/gfortran/regression/do_concurrent_7.f90 new file mode 100644 index 000000000..604f6712d --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_7.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/113305 + +program dc + implicit none + real :: a(12), b(12), c(16,8), d(16,8) + integer :: i, j + call random_number(b) +!GCC$ ivdep +!GCC$ vector + do concurrent (i=1:12) + a(i) = 2*b(i) + end do + c = b(1) + d = a(2) +!GCC$ novector +!GCC$ unroll 4 + do concurrent (i=1:16:2,j=1:8:2) + d(i,j) = 3*c(i,j) + end do +end program + +! { dg-final { scan-tree-dump "ANNOTATE_EXPR .* ivdep>, vector" "original" } } +! { dg-final { scan-tree-dump "ANNOTATE_EXPR .* ivdep>, no-vector" "original" } } +! { dg-final { scan-tree-dump "ANNOTATE_EXPR .* ivdep>, unroll 4>, no-vector" "original" } } diff --git a/Fortran/gfortran/regression/dtio_25.f90 b/Fortran/gfortran/regression/dtio_25.f90 index 8ca084899..1de7dc0bd 100644 --- a/Fortran/gfortran/regression/dtio_25.f90 +++ b/Fortran/gfortran/regression/dtio_25.f90 @@ -50,7 +50,7 @@ program p namelist /nml/ x x = t('a', 5) write (buffer, nml) - if (buffer.ne.'&NML X=a, 5 /') STOP 1 + if (buffer.ne.' &NML X=a, 5 /') STOP 1 x = t('x', 0) read (buffer, nml) if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 diff --git a/Fortran/gfortran/regression/endfile_5.f90 b/Fortran/gfortran/regression/endfile_5.f90 new file mode 100644 index 000000000..90eaa6b2e --- /dev/null +++ b/Fortran/gfortran/regression/endfile_5.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR107031 Check that endfile truncates at end of record 5. +program test_truncate + integer :: num_rec, tmp, i, nr, j + open(10, file="in.dat", action='readwrite') + + do i=1,10 + write(10, *) i + end do + + rewind (10) + + num_rec = 5 + i = 1 + ioerr = 0 + do while (i <= num_rec .and. ioerr == 0) + read(10, *, iostat=ioerr) tmp + i = i + 1 + enddo + endfile(10) + rewind (10) + i = 0 + ioerr = 0 + do while (i <= num_rec + 1 .and. ioerr == 0) + read(10, *, iostat=ioerr) j + i = i + 1 + end do + close(10, status='delete') + if (i - 1 /= 5) stop 1 +end program test_truncate diff --git a/Fortran/gfortran/regression/finalize_38.f90 b/Fortran/gfortran/regression/finalize_38.f90 index f4b00a16a..853348900 100644 --- a/Fortran/gfortran/regression/finalize_38.f90 +++ b/Fortran/gfortran/regression/finalize_38.f90 @@ -4,6 +4,8 @@ ! With -std=gnu, no finalization of array or structure constructors should occur. ! See finalize_38a.f90 for the result with f2008. ! Tests fix for PR64290 as well. +! Extended to test that nonfinalizable types with allocatable finalizable components +! are finalized before deallocation (PR111674). ! module testmode implicit none @@ -20,6 +22,10 @@ module testmode final :: destructor3, destructor4 end type complicated + type :: notfinalizable + type(simple), allocatable :: aa + end type + integer :: check_scalar integer :: check_array(4) real :: check_real @@ -114,6 +120,7 @@ program test_final type(simple), allocatable :: MyType, MyType2 type(simple), allocatable :: MyTypeArray(:) type(simple) :: ThyType = simple(21), ThyType2 = simple(22) + type(notfinalizable) :: MyNf class(simple), allocatable :: MyClass class(simple), allocatable :: MyClassArray(:) @@ -214,6 +221,15 @@ program test_final deallocate (MyClassArray) call test(2, 0, [10, 20], 170, rarray = [10.0,20.0]) +!****************** +! Test for PR111674 +!****************** + final_count = 0 + MyNf = notfinalizable (simple (42)) ! Allocatable component not finalized + if (final_count .ne. 0) stop 171 + MyNf = notfinalizable (simple (84)) ! Component finalized before deallocation + call test(1, 42, [0,0], 180) + ! Clean up for valgrind testing if (allocated (MyType)) deallocate (MyType) if (allocated (MyType2)) deallocate (MyType2) diff --git a/Fortran/gfortran/regression/finalize_53.f90 b/Fortran/gfortran/regression/finalize_53.f90 new file mode 100644 index 000000000..eeacb9eef --- /dev/null +++ b/Fortran/gfortran/regression/finalize_53.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! Check that the data reference preliminary code is properly +! generated and accepted by the finalization handling code. + +module m + implicit none + type t + integer :: i + contains + final :: finalize_t + end type t + logical :: finalize_called = .false. +contains + subroutine finalize_t(a) + type(t) :: a + finalize_called = .true. + end subroutine finalize_t +end module m +program p + use m + type u + type(t), allocatable :: ta + end type u + class(u), allocatable :: c(:) + integer, allocatable :: a(:), b(:) + a = [1, 2, 3] + b = [3, 5, 1] + allocate(c, source = [u(t(1)), u(t(9))]) + deallocate(c(count(a + b == 4))%ta) + if (.not. allocated (c(1)%ta)) stop 11 + if (allocated (c(2)%ta)) stop 12 + if (.not. finalize_called) stop 13 +end program p diff --git a/Fortran/gfortran/regression/finalize_54.f90 b/Fortran/gfortran/regression/finalize_54.f90 new file mode 100644 index 000000000..73d32b1b3 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_54.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Test the fix for PR113885, where not only was there a gimplifier ICE +! for a derived type 't' with no components but, with a component, gfortran +! gave wrong results. +! Contributed by David Binderman +! +module types + type t + contains + final :: finalize + end type t +contains + pure subroutine finalize(x) + type(t), intent(inout) :: x + end subroutine finalize +end module types + +subroutine test1(x) + use types + interface + elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + end interface + type(t) :: x(:) + x = elem(x) +end subroutine test1 + +subroutine test2(x) + use types + interface + elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + end function elem2 + end interface + type(t) :: x(:) + x = elem2(elem(x), elem(x)) +end subroutine test2 diff --git a/Fortran/gfortran/regression/finalize_55.f90 b/Fortran/gfortran/regression/finalize_55.f90 new file mode 100644 index 000000000..fa7e552ee --- /dev/null +++ b/Fortran/gfortran/regression/finalize_55.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! Test the fix for PR113885, where not only was there a gimplifier ICE +! for a derived type 't' with no components but this version gave wrong +! results. +! Contributed by David Binderman +! +module types + type t + integer :: i + contains + final :: finalize + end type t + integer :: ctr = 0 +contains + impure elemental subroutine finalize(x) + type(t), intent(inout) :: x + ctr = ctr + 1 + end subroutine finalize +end module types + +impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + elem%i = x%i + 1 +end function elem + +impure elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + elem2%i = x%i + y%i +end function elem2 + +subroutine test1(x) + use types + interface + impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + end interface + type(t) :: x(:) + type(t), allocatable :: y(:) + y = x + x = elem(y) +end subroutine test1 + +subroutine test2(x) + use types + interface + impure elemental function elem(x) + use types + type(t), intent(in) :: x + type(t) :: elem + end function elem + impure elemental function elem2(x, y) + use types + type(t), intent(in) :: x, y + type(t) :: elem2 + end function elem2 + end interface + type(t) :: x(:) + type(t), allocatable :: y(:) + y = x + x = elem2(elem(y), elem(y)) +end subroutine test2 + +program test113885 + use types + interface + subroutine test1(x) + use types + type(t) :: x(:) + end subroutine + subroutine test2(x) + use types + type(t) :: x(:) + end subroutine + end interface + type(t) :: x(2) = [t(1),t(2)] + call test1 (x) + if (any (x%i .ne. [2,3])) stop 1 + if (ctr .ne. 6) stop 2 + call test2 (x) + if (any (x%i .ne. [6,8])) stop 3 + if (ctr .ne. 16) stop 4 +end diff --git a/Fortran/gfortran/regression/finalize_56.f90 b/Fortran/gfortran/regression/finalize_56.f90 new file mode 100644 index 000000000..bd350a3bc --- /dev/null +++ b/Fortran/gfortran/regression/finalize_56.f90 @@ -0,0 +1,168 @@ +! { dg-do run } +! Test the fix for PR110987 +! Segfaulted in runtime, as shown below. +! Contributed by Kirill Chankin +! and John Haiducek (comment 5) +! +MODULE original_mod + IMPLICIT NONE + + TYPE T1_POINTER + CLASS(T1), POINTER :: T1 + END TYPE + + TYPE T1 + INTEGER N_NEXT + CLASS(T1_POINTER), ALLOCATABLE :: NEXT(:) + CONTAINS + FINAL :: T1_DESTRUCTOR + PROCEDURE :: SET_N_NEXT => T1_SET_N_NEXT + PROCEDURE :: GET_NEXT => T1_GET_NEXT + END TYPE + + INTERFACE T1 + PROCEDURE T1_CONSTRUCTOR + END INTERFACE + + TYPE, EXTENDS(T1) :: T2 + REAL X + CONTAINS + END TYPE + + INTERFACE T2 + PROCEDURE T2_CONSTRUCTOR + END INTERFACE + + TYPE, EXTENDS(T1) :: T3 + CONTAINS + FINAL :: T3_DESTRUCTOR + END TYPE + + INTERFACE T3 + PROCEDURE T3_CONSTRUCTOR + END INTERFACE + + INTEGER :: COUNTS = 0 + +CONTAINS + + TYPE(T1) FUNCTION T1_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%N_NEXT = 0 + END FUNCTION + + SUBROUTINE T1_DESTRUCTOR(SELF) + IMPLICIT NONE + TYPE(T1), INTENT(INOUT) :: SELF + IF (ALLOCATED(SELF%NEXT)) THEN + DEALLOCATE(SELF%NEXT) + ENDIF + END SUBROUTINE + + SUBROUTINE T3_DESTRUCTOR(SELF) + IMPLICIT NONE + TYPE(T3), INTENT(IN) :: SELF + if (.NOT.ALLOCATED (SELF%NEXT)) COUNTS = COUNTS + 1 + END SUBROUTINE + + SUBROUTINE T1_SET_N_NEXT(SELF, N_NEXT) + IMPLICIT NONE + CLASS(T1), INTENT(INOUT) :: SELF + INTEGER, INTENT(IN) :: N_NEXT + INTEGER I + SELF%N_NEXT = N_NEXT + ALLOCATE(SELF%NEXT(N_NEXT)) + DO I = 1, N_NEXT + NULLIFY(SELF%NEXT(I)%T1) + ENDDO + END SUBROUTINE + + FUNCTION T1_GET_NEXT(SELF) RESULT(NEXT) + IMPLICIT NONE + CLASS(T1), TARGET, INTENT(IN) :: SELF + CLASS(T1), POINTER :: NEXT + CLASS(T1), POINTER :: L + INTEGER I + IF (SELF%N_NEXT .GE. 1) THEN + NEXT => SELF%NEXT(1)%T1 + RETURN + ENDIF + NULLIFY(NEXT) + END FUNCTION + + TYPE(T2) FUNCTION T2_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%T1 = T1() + CALL L%T1%SET_N_NEXT(1) + END FUNCTION + + TYPE(T3) FUNCTION T3_CONSTRUCTOR() RESULT(L) + IMPLICIT NONE + L%T1 = T1() + END FUNCTION + +END MODULE original_mod + +module comment5_mod + type::parent + character(:), allocatable::name + end type parent + type, extends(parent)::child + contains + final::child_finalize + end type child + interface child + module procedure new_child + end interface child + integer :: counts = 0 + +contains + + type(child) function new_child(name) + character(*)::name + new_child%name=name + end function new_child + + subroutine child_finalize(this) + type(child), intent(in)::this + counts = counts + 1 + end subroutine child_finalize +end module comment5_mod + +PROGRAM TEST_PROGRAM + call original + call comment5 +contains + subroutine original + USE original_mod + IMPLICIT NONE + TYPE(T1), TARGET :: X1 + TYPE(T2), TARGET :: X2 + TYPE(T3), TARGET :: X3 + CLASS(T1), POINTER :: L + X1 = T1() + X2 = T2() + X2%NEXT(1)%T1 => X1 + X3 = T3() + CALL X3%SET_N_NEXT(1) + X3%NEXT(1)%T1 => X2 + L => X3 + DO WHILE (.TRUE.) + L => L%GET_NEXT() ! Used to segfault here in runtime + IF (.NOT. ASSOCIATED(L)) EXIT + COUNTS = COUNTS + 1 + ENDDO +! Two for T3 finalization and two for associated 'L's + IF (COUNTS .NE. 4) STOP 1 + end subroutine original + + subroutine comment5 + use comment5_mod, only: child, counts + implicit none + type(child)::kid + kid = child("Name") + if (.not.allocated (kid%name)) stop 2 + if (kid%name .ne. "Name") stop 3 + if (counts .ne. 2) stop 4 + end subroutine comment5 +END PROGRAM diff --git a/Fortran/gfortran/regression/finalize_57.f90 b/Fortran/gfortran/regression/finalize_57.f90 new file mode 100644 index 000000000..b6257357c --- /dev/null +++ b/Fortran/gfortran/regression/finalize_57.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/90068 +! +! Contributed by Brad Richardson +! + +program array_memory_leak + implicit none + + type, abstract :: base + end type base + + type, extends(base) :: extended + end type extended + + type :: container + class(base), allocatable :: thing + end type + + type, extends(base) :: collection + type(container), allocatable :: stuff(:) + end type collection + + call run() + call bad() +contains + subroutine run() + type(collection) :: my_thing + type(container) :: a_container + + a_container = newContainer(newExtended()) ! This is fine + my_thing = newCollection([a_container]) + end subroutine run + + subroutine bad() + type(collection) :: my_thing + + my_thing = newCollection([newContainer(newExtended())]) ! This is a memory leak + end subroutine bad + + function newExtended() + type(extended) :: newExtended + end function newExtended + + function newContainer(thing) + class(base), intent(in) :: thing + type(container) :: newContainer + + allocate(newContainer%thing, source = thing) + end function newContainer + + function newCollection(things) + type(container), intent(in) :: things(:) + type(collection) :: newCollection + + newCollection%stuff = things + end function newCollection +end program array_memory_leak + +! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } + diff --git a/Fortran/gfortran/regression/finalize_8.f03 b/Fortran/gfortran/regression/finalize_8.f03 index b2027a0ba..b7fa10dda 100644 --- a/Fortran/gfortran/regression/finalize_8.f03 +++ b/Fortran/gfortran/regression/finalize_8.f03 @@ -1,35 +1,49 @@ -! { dg-do compile } - -! Parsing of finalizer procedure definitions. -! Check that FINAL-declarations are only allowed on types defined in the -! specification part of a module. - -MODULE final_type +! { dg-do run } +! +! PR97122: Declaration of a finalizable derived type in a submodule +! IS allowed. +! +! Contributed by Ian Harvey +! +MODULE m IMPLICIT NONE -CONTAINS + INTERFACE + MODULE SUBROUTINE other(i) + IMPLICIT NONE + integer, intent(inout) :: i + END SUBROUTINE other + END INTERFACE - SUBROUTINE bar - IMPLICIT NONE + integer :: mi - TYPE :: mytype - INTEGER, ALLOCATABLE :: fooarr(:) - REAL :: foobar - CONTAINS - FINAL :: myfinal ! { dg-error "in the specification part of a MODULE" } - END TYPE mytype - - CONTAINS +END MODULE m - SUBROUTINE myfinal (el) - TYPE(mytype) :: el - END SUBROUTINE myfinal +SUBMODULE (m) s + IMPLICIT NONE - END SUBROUTINE bar + TYPE :: t + integer :: i + CONTAINS + FINAL :: final_t ! Used to be an error here + END TYPE t -END MODULE final_type +CONTAINS -PROGRAM finalizer - IMPLICIT NONE - ! Do nothing here -END PROGRAM finalizer + SUBROUTINE final_t(arg) + TYPE(t), INTENT(INOUT) :: arg + mi = -arg%i + END SUBROUTINE final_t + + module subroutine other(i) ! 'ti' is finalized + integer, intent(inout) :: i + type(t) :: ti + ti%i = i + END subroutine other +END SUBMODULE s + + use m + integer :: i = 42 + call other(i) + if (mi .ne. -i) stop 1 +end diff --git a/Fortran/gfortran/regression/findloc_10.f90 b/Fortran/gfortran/regression/findloc_10.f90 new file mode 100644 index 000000000..4d5ecd230 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_10.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! PR fortran/110288 - FINDLOC and deferred-length character arguments + +program test + character(len=:), allocatable :: array(:) + character(len=:), allocatable :: value + array = ["bb", "aa"] + value = "aa" + if (findloc (array, value, dim=1) /= 2) stop 1 +end program test + +! { dg-final { scan-tree-dump "_gfortran_findloc2_s1 \\(.*, \\.array, \\.value\\)" "original" } } diff --git a/Fortran/gfortran/regression/findloc_9.f90 b/Fortran/gfortran/regression/findloc_9.f90 new file mode 100644 index 000000000..05974476c --- /dev/null +++ b/Fortran/gfortran/regression/findloc_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/110585 - simplification of FINDLOC for constant complex arguments + +program mvce + implicit none + integer, parameter :: a(*) = findloc([(1.,0.),(2.,1.)], (2.,0.)) + integer, parameter :: b(*) = findloc([(1.,0.),(2.,1.)], (2.,0.), back=.true.) + integer, parameter :: c(*) = findloc([(1.,0.),(2.,1.)], (2.,1.)) + integer, parameter :: d(*) = findloc([(1.,0.),(2.,1.)], (2.,1.), back=.true.) + integer, parameter :: e = findloc([(1.,0.),(2.,1.)], (2.,1.), dim=1) + if (a(1) /= 0) stop 1 + if (b(1) /= 0) stop 2 + if (c(1) /= 2) stop 3 + if (d(1) /= 2) stop 4 + if (e /= 2) stop 5 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } diff --git a/Fortran/gfortran/regression/fmt_en.f90 b/Fortran/gfortran/regression/fmt_en.f90 index d7e51b3fa..0b757e981 100644 --- a/Fortran/gfortran/regression/fmt_en.f90 +++ b/Fortran/gfortran/regression/fmt_en.f90 @@ -180,4 +180,4 @@ subroutine checkfmt(fmt, x, cmp) end subroutine end program -! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-output "All kinds rounded to nearest" { xfail hppa*-*-hpux* } } diff --git a/Fortran/gfortran/regression/fmt_en_rd.f90 b/Fortran/gfortran/regression/fmt_en_rd.f90 index ea914e090..e1228e671 100644 --- a/Fortran/gfortran/regression/fmt_en_rd.f90 +++ b/Fortran/gfortran/regression/fmt_en_rd.f90 @@ -181,5 +181,5 @@ subroutine checkfmt(fmt, x, cmp) end subroutine end program -! { dg-output "All kinds rounded down" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-output "All kinds rounded down" { xfail hppa*-*-hpux* } } ! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_rn.f90 b/Fortran/gfortran/regression/fmt_en_rn.f90 index b0ada5c67..71d3ef698 100644 --- a/Fortran/gfortran/regression/fmt_en_rn.f90 +++ b/Fortran/gfortran/regression/fmt_en_rn.f90 @@ -181,5 +181,5 @@ subroutine checkfmt(fmt, x, cmp) end subroutine end program -! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-output "All kinds rounded to nearest" { xfail hppa*-*-hpux* } } ! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_ru.f90 b/Fortran/gfortran/regression/fmt_en_ru.f90 index 7834e2880..e9e278571 100644 --- a/Fortran/gfortran/regression/fmt_en_ru.f90 +++ b/Fortran/gfortran/regression/fmt_en_ru.f90 @@ -181,5 +181,5 @@ subroutine checkfmt(fmt, x, cmp) end subroutine end program -! { dg-output "All kinds rounded up" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-output "All kinds rounded up" { xfail hppa*-*-hpux* } } ! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_rz.f90 b/Fortran/gfortran/regression/fmt_en_rz.f90 index c07847cad..7e4db5dfa 100644 --- a/Fortran/gfortran/regression/fmt_en_rz.f90 +++ b/Fortran/gfortran/regression/fmt_en_rz.f90 @@ -181,5 +181,5 @@ subroutine checkfmt(fmt, x, cmp) end subroutine end program -! { dg-output "All kinds rounded to zero" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-output "All kinds rounded to zero" { xfail hppa*-*-hpux* } } ! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_error_10.f b/Fortran/gfortran/regression/fmt_error_10.f index 6e1a5f60b..fc6620a60 100644 --- a/Fortran/gfortran/regression/fmt_error_10.f +++ b/Fortran/gfortran/regression/fmt_error_10.f @@ -18,7 +18,7 @@ str = '(1pd0.15)' write (line,str,iostat=istat, iomsg=msg) 1.0d0 - if (line.ne."1.000000000000000") STOP 5 + if (line.ne."1.000000000000000D+0") STOP 5 read (*,str,iostat=istat, iomsg=msg) x if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 6 if (x.ne.555.25) STOP 7 diff --git a/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 b/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 index 3e7d8f64d..46f271e0c 100644 --- a/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 +++ b/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 @@ -30,6 +30,6 @@ program test #ifdef __GFC_REAL_16__ real_16 = 4.18 - write(buffer, fmt) ':',real_16,':' ! { dg-error "Nonnegative width required" "" { target fortran_real_16 } } + write(buffer, fmt) ':',real_16,':' ! { dg-error "Nonnegative width required" "" { target { fortran_real_16 || { hppa*64*-*-hpux* } } } } #endif end diff --git a/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 b/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 index 95a059819..22fe1a35d 100644 --- a/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 +++ b/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 @@ -33,6 +33,6 @@ program test #ifdef __GFC_REAL_16__ real_16 = 4.18 - write(buffer, fmt) ':',real_16,':' ! { dg-error "Positive width required" "" { target fortran_real_16 } } + write(buffer, fmt) ':',real_16,':' ! { dg-error "Positive width required" "" { target { fortran_real_16 || { hppa*64*-*-hpux* } } } } #endif end diff --git a/Fortran/gfortran/regression/g77/README b/Fortran/gfortran/regression/g77/README index 394bb824d..42d36fe56 100644 --- a/Fortran/gfortran/regression/g77/README +++ b/Fortran/gfortran/regression/g77/README @@ -201,7 +201,7 @@ check0.f Y select_no_compile.f Y -Copyright (C) 2004-2023 Free Software Foundation, Inc. +Copyright (C) 2004-2024 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright diff --git a/Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp b/Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp index d9ec3fab7..ce9dcfd0b 100644 --- a/Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp +++ b/Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# Copyright (C) 2005-2024 Free Software Foundation, Inc. # # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/goacc/DisabledFiles.cmake b/Fortran/gfortran/regression/goacc/DisabledFiles.cmake index f45ef032c..b1d9fc9cb 100644 --- a/Fortran/gfortran/regression/goacc/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/goacc/DisabledFiles.cmake @@ -181,4 +181,8 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # fails with a module not found error. There is a DejaGNU directive # "dg-compile-aux-modules" which might have something to do with this. routine-module-1.f90 + + # The causes of failure of these tests need to be investigated + enter-exit-data-2.f90 + readonly-1.f90 ) diff --git a/Fortran/gfortran/regression/goacc/attach-descriptor.f90 b/Fortran/gfortran/regression/goacc/attach-descriptor.f90 index 8c2ee4a5c..734afbe6c 100644 --- a/Fortran/gfortran/regression/goacc/attach-descriptor.f90 +++ b/Fortran/gfortran/regression/goacc/attach-descriptor.f90 @@ -11,19 +11,19 @@ program att integer, pointer :: myptr(:) !$acc enter data attach(myvar%arr2, myptr) -! { dg-final { scan-tree-dump-times "(?n)#pragma acc enter data map\\(attach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } -! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_enter_data map\\(attach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc enter data map\\(attach:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_enter_data map\\(attach:myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } !$acc exit data detach(myvar%arr2, myptr) -! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } -! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(detach:myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } ! Test valid usage and processing of the finalize clause. !$acc exit data detach(myvar%arr2, myptr) finalize -! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\) finalize;$" 1 "original" } } ! For array-descriptor detaches, we no longer generate a "release" mapping ! for the pointed-to data for gimplify.c to turn into "delete". Make sure ! the mapping still isn't there. -! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(force_detach:myptr\\.data \\\[bias: 0\\\]\\) finalize$" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_detach:myvar\\.arr2\\.data \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(force_detach:myptr\\.data \\\[bias: 0\\\]\\) finalize$" 1 "gimple" } } end program att diff --git a/Fortran/gfortran/regression/goacc/default-3.f95 b/Fortran/gfortran/regression/goacc/default-3.f95 index 98ed34200..c1edf4c81 100644 --- a/Fortran/gfortran/regression/goacc/default-3.f95 +++ b/Fortran/gfortran/regression/goacc/default-3.f95 @@ -5,14 +5,87 @@ subroutine f1 integer :: f1_a = 2 real, dimension (2) :: f1_b - !$acc kernels default (none) ! { dg-message "enclosing OpenACC .kernels. construct" } + !$acc kernels default (none) ! { dg-note "enclosing OpenACC .kernels. construct with 'default\\\(none\\\)' clause" } f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } } = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .kernels. construct" } ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } .-1 } !$acc end kernels - !$acc parallel default (none) ! { dg-message "enclosing OpenACC .parallel. construct" } + !$acc parallel default (none) ! { dg-note "enclosing OpenACC .parallel. construct with 'default\\\(none\\\)' clause" } f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } !$acc end parallel + + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc kernels ! { dg-note "enclosing OpenACC 'kernels' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .kernels. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } .-1 } + !$acc end kernels + !$acc end data + + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc parallel ! { dg-note "enclosing OpenACC 'parallel' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + + !$acc data default (none) + !$acc parallel default (none) ! { dg-note "enclosing OpenACC .parallel. construct with 'default\\\(none\\\)' clause" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc data + !$acc data + !$acc parallel ! { dg-note "enclosing OpenACC 'parallel' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + !$acc end data + !$acc end data + + !$acc data + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc data + !$acc parallel ! { dg-note "enclosing OpenACC 'parallel' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + !$acc end data + !$acc end data + + !$acc data + !$acc data + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc parallel ! { dg-note "enclosing OpenACC 'parallel' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + !$acc end data + !$acc end data + + !$acc data + !$acc data default (none) + !$acc data default (none) ! { dg-note "enclosing OpenACC 'data' construct with 'default\\\(none\\\)' clause" } + !$acc parallel ! { dg-note "enclosing OpenACC 'parallel' construct and" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel + !$acc end data + !$acc end data + !$acc end data + end subroutine f1 diff --git a/Fortran/gfortran/regression/goacc/default-4.f b/Fortran/gfortran/regression/goacc/default-4.f index 30f411f70..4e89b6859 100644 --- a/Fortran/gfortran/regression/goacc/default-4.f +++ b/Fortran/gfortran/regression/goacc/default-4.f @@ -38,6 +38,24 @@ SUBROUTINE F2 !$ACC END DATA END SUBROUTINE F2 + SUBROUTINE F2_ + IMPLICIT NONE + INTEGER :: F2__A = 2 + REAL, DIMENSION (2) :: F2__B + +!$ACC DATA DEFAULT (NONE) COPYIN (F2__A) COPYOUT (F2__B) +! { dg-final { scan-tree-dump-times "omp target oacc_data map\\(to:f2__a \[^\\)\]+\\) map\\(from:f2__b \[^\\)\]+\\) default\\(none\\)" 1 "gimple" } } +!$ACC KERNELS +! { dg-final { scan-tree-dump-times "omp target oacc_kernels map\\(tofrom:f2__b \[^\\)\]+\\) map\\(tofrom:f2__a" 1 "gimple" } } + F2__B(1) = F2__A; +!$ACC END KERNELS +!$ACC PARALLEL +! { dg-final { scan-tree-dump-times "omp target oacc_parallel map\\(tofrom:f2__b \[^\\)\]+\\) map\\(tofrom:f2__a" 1 "gimple" } } + F2__B(1) = F2__A; +!$ACC END PARALLEL +!$ACC END DATA + END SUBROUTINE F2_ + SUBROUTINE F3 IMPLICIT NONE INTEGER :: F3_A = 2 @@ -55,3 +73,21 @@ SUBROUTINE F3 !$ACC END PARALLEL !$ACC END DATA END SUBROUTINE F3 + + SUBROUTINE F3_ + IMPLICIT NONE + INTEGER :: F3__A = 2 + REAL, DIMENSION (2) :: F3__B + +!$ACC DATA DEFAULT (PRESENT) COPYIN (F3__A) COPYOUT (F3__B) +! { dg-final { scan-tree-dump-times "omp target oacc_data map\\(to:f3__a \[^\\)\]+\\) map\\(from:f3__b \[^\\)\]+\\) default\\(present\\)" 1 "gimple" } } +!$ACC KERNELS +! { dg-final { scan-tree-dump-times "omp target oacc_kernels map\\(tofrom:f3__b \[^\\)\]+\\) map\\(tofrom:f3__a" 1 "gimple" } } + F3__B(1) = F3__A; +!$ACC END KERNELS +!$ACC PARALLEL +! { dg-final { scan-tree-dump-times "omp target oacc_parallel map\\(tofrom:f3__b \[^\\)\]+\\) map\\(tofrom:f3__a" 1 "gimple" } } + F3__B(1) = F3__A; +!$ACC END PARALLEL +!$ACC END DATA + END SUBROUTINE F3_ diff --git a/Fortran/gfortran/regression/goacc/default-5.f b/Fortran/gfortran/regression/goacc/default-5.f index 9dc83cbe6..2cb07a8cb 100644 --- a/Fortran/gfortran/regression/goacc/default-5.f +++ b/Fortran/gfortran/regression/goacc/default-5.f @@ -4,8 +4,8 @@ SUBROUTINE F1 IMPLICIT NONE - INTEGER :: F1_A = 2 - REAL, DIMENSION (2) :: F1_B + INTEGER :: F1_A = 2, F1_C = 3 + REAL, DIMENSION (2) :: F1_B, F1_D !$ACC KERNELS DEFAULT (PRESENT) ! { dg-final { scan-tree-dump-times "omp target oacc_kernels default\\(present\\) map\\(force_present:f1_b \[^\\)\]+\\) map\\(force_tofrom:f1_a" 1 "gimple" } } @@ -15,4 +15,19 @@ SUBROUTINE F1 ! { dg-final { scan-tree-dump-times "omp target oacc_parallel default\\(present\\) map\\(force_present:f1_b \[^\\)\]+\\) firstprivate\\(f1_a\\)" 1 "gimple" } } F1_B(1) = F1_A; !$ACC END PARALLEL + +!$ACC DATA DEFAULT (PRESENT) +!$ACC KERNELS +! { dg-final { scan-tree-dump-times "omp target oacc_kernels map\\(force_present:f1_d \[^\\)\]+\\) map\\(force_tofrom:f1_c" 1 "gimple" } } + F1_D(1) = F1_C; +!$ACC END KERNELS +!$ACC END DATA +!$ACC DATA DEFAULT (NONE) +!$ACC DATA DEFAULT (PRESENT) +!$ACC PARALLEL DEFAULT (PRESENT) +! { dg-final { scan-tree-dump-times "omp target oacc_parallel default\\(present\\) map\\(force_present:f1_d \[^\\)\]+\\) firstprivate\\(f1_c\\)" 1 "gimple" } } + F1_D(1) = F1_C; +!$ACC END PARALLEL +!$ACC END DATA +!$ACC END DATA END SUBROUTINE F1 diff --git a/Fortran/gfortran/regression/goacc/enter-exit-data-2.f90 b/Fortran/gfortran/regression/goacc/enter-exit-data-2.f90 new file mode 100644 index 000000000..6a16c8a89 --- /dev/null +++ b/Fortran/gfortran/regression/goacc/enter-exit-data-2.f90 @@ -0,0 +1,38 @@ +! { dg-additional-options "-fdump-tree-original" } + +type t +integer, pointer :: arr(:) +end type t + +type(t) :: var + +allocate (var%arr(1:100)) + +!$acc enter data copyin(var%arr(10:20)) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc enter data map\(to:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\);$} 1 "original" } } + +!$acc exit data delete(var%arr(10:20)) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\);$} 1 "original" } } + + +!$acc enter data create(var%arr(20:30)) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc enter data map\(alloc:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\);$} 1 "original" } } + +!$acc exit data finalize delete(var%arr(20:30)) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\) finalize;$} 1 "original" } } + + +!$acc enter data copyin(var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc enter data map\(to:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: 0\]\);$} 1 "original" } } + +!$acc exit data delete(var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: 0\]\);$} 1 "original" } } + + +!$acc enter data create(var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc enter data map\(alloc:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: 0\]\);$} 1 "original" } } + +!$acc exit data finalize delete(var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma acc exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:var\.arr\.data \[bias: 0\]\) finalize;$} 1 "original" } } + +end diff --git a/Fortran/gfortran/regression/goacc/finalize-1.f b/Fortran/gfortran/regression/goacc/finalize-1.f index 1e5bf0ba1..63beb4794 100644 --- a/Fortran/gfortran/regression/goacc/finalize-1.f +++ b/Fortran/gfortran/regression/goacc/finalize-1.f @@ -20,8 +20,8 @@ SUBROUTINE f ! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(delete:del_f \\\[len: \[0-9\]+\\\]\\) finalize$" 1 "gimple" } } !$ACC EXIT DATA FINALIZE DELETE (del_f_p(2:5)) -! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(release:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.0\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(to:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) del_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.0\\.data - \\(.*int.*\\) del_f_p\\.data\\\]\\) finalize;$" 1 "original" } } -! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(delete:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(to:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:del_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(release:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.0\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(release:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) del_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.0\\.data - \\(.*int.*\\) del_f_p\\.data\\\]\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(delete:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(delete:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:del_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } !$ACC EXIT DATA COPYOUT (cpo_r) ! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:cpo_r\\);$" 1 "original" } } @@ -32,6 +32,6 @@ SUBROUTINE f ! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_from:cpo_f \\\[len: \[0-9\]+\\\]\\) finalize$" 1 "gimple" } } !$ACC EXIT DATA COPYOUT (cpo_f_p(4:10)) FINALIZE -! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.1\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(to:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) cpo_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.1\\.data - \\(.*int.*\\) cpo_f_p\\.data\\\]\\) finalize;$" 1 "original" } } -! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_from:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(to:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:cpo_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.1\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(release:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) cpo_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.1\\.data - \\(.*int.*\\) cpo_f_p\\.data\\\]\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_from:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(delete:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:cpo_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } END SUBROUTINE f diff --git a/Fortran/gfortran/regression/goacc/goacc.exp b/Fortran/gfortran/regression/goacc/goacc.exp index 95d0fe9d5..45c67c203 100644 --- a/Fortran/gfortran/regression/goacc/goacc.exp +++ b/Fortran/gfortran/regression/goacc/goacc.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# Copyright (C) 2005-2024 Free Software Foundation, Inc. # # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/goacc/host_data-error.f90 b/Fortran/gfortran/regression/goacc/host_data-error.f90 new file mode 100644 index 000000000..bd2629894 --- /dev/null +++ b/Fortran/gfortran/regression/goacc/host_data-error.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +subroutine foo () +!$acc host_data ! { dg-error "'host_data' construct at .1. requires 'use_device' clause" } +!$acc end host_data +end diff --git a/Fortran/gfortran/regression/goacc/if.f95 b/Fortran/gfortran/regression/goacc/if.f95 index 56f3711f3..753ef8251 100644 --- a/Fortran/gfortran/regression/goacc/if.f95 +++ b/Fortran/gfortran/regression/goacc/if.f95 @@ -1,3 +1,5 @@ +! See also 'self.f95'. + ! { dg-do compile } program test @@ -12,12 +14,14 @@ program test !$acc end parallel !$acc parallel if (1) ! { dg-error "scalar LOGICAL expression" } !$acc end parallel - !$acc kernels if (i) ! { dg-error "scalar LOGICAL expression" } - !$acc end kernels + !$acc kernels if ! { dg-error "Expected '\\(' after 'if'" } !$acc kernels if () ! { dg-error "Invalid character" } + !$acc kernels if (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end kernels !$acc kernels if (1) ! { dg-error "scalar LOGICAL expression" } !$acc end kernels + !$acc data if ! { dg-error "Expected '\\(' after 'if'" } !$acc data if () ! { dg-error "Invalid character" } !$acc data if (i) ! { dg-error "scalar LOGICAL expression" } @@ -36,12 +40,14 @@ program test !$acc end parallel !$acc parallel if (i.gt.1) !$acc end parallel + !$acc kernels if (x) !$acc end kernels !$acc kernels if (.true.) !$acc end kernels !$acc kernels if (i.gt.1) !$acc end kernels + !$acc data if (x) !$acc end data !$acc data if (.true.) diff --git a/Fortran/gfortran/regression/goacc/kernels-tree.f95 b/Fortran/gfortran/regression/goacc/kernels-tree.f95 index ceb07fbb9..2ee578f7f 100644 --- a/Fortran/gfortran/regression/goacc/kernels-tree.f95 +++ b/Fortran/gfortran/regression/goacc/kernels-tree.f95 @@ -12,6 +12,7 @@ program test logical :: l = .true. !$acc kernels if(l) async num_gangs(i) num_workers(i) vector_length(i) & + !$acc self & !$acc copy(i), copyin(j), copyout(k), create(m) & !$acc no_create(n) & !$acc present(o), pcopy(p), pcopyin(r), pcopyout(s), pcreate(t) & @@ -27,7 +28,7 @@ end program test ! { dg-final { scan-tree-dump-times "num_gangs" 1 "original" } } ! { dg-final { scan-tree-dump-times "num_workers" 1 "original" } } ! { dg-final { scan-tree-dump-times "vector_length" 1 "original" } } - +! { dg-final { scan-tree-dump-times "self\\(1\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "map\\(tofrom:i\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "map\\(to:j\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "map\\(from:k\\)" 1 "original" } } @@ -41,5 +42,5 @@ end program test ! { dg-final { scan-tree-dump-times "map\\(force_deviceptr:u\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_data_kernels if\((?:D\.|_)[0-9]+\)$} 1 "omp_oacc_kernels_decompose" } } -! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_parallel_kernels_gang_single num_gangs\(1\) if\((?:D\.|_)[0-9]+\) async\(-1\)$} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_data_kernels if\((?:D\.|_)[0-9]+\) self\(1\)$} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_parallel_kernels_gang_single num_gangs\(1\) if\((?:D\.|_)[0-9]+\) self\(1\) async\(-1\)$} 1 "omp_oacc_kernels_decompose" } } diff --git a/Fortran/gfortran/regression/goacc/parallel-tree.f95 b/Fortran/gfortran/regression/goacc/parallel-tree.f95 index 6110d93b9..0d4ec1133 100644 --- a/Fortran/gfortran/regression/goacc/parallel-tree.f95 +++ b/Fortran/gfortran/regression/goacc/parallel-tree.f95 @@ -14,6 +14,7 @@ program test logical :: l = .true. !$acc parallel if(l) async num_gangs(i) num_workers(i) vector_length(i) & + !$acc self & !$acc reduction(max:q), copy(i), copyin(j), copyout(k), create(m) & !$acc no_create(n) & !$acc present(o), pcopy(p), pcopyin(r), pcopyout(s), pcreate(t) & @@ -33,7 +34,7 @@ end program test ! { dg-final { scan-tree-dump-times "num_gangs" 1 "original" } } ! { dg-final { scan-tree-dump-times "num_workers" 1 "original" } } ! { dg-final { scan-tree-dump-times "vector_length" 1 "original" } } - +! { dg-final { scan-tree-dump-times "self\\(1\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "reduction\\(max:q\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "map\\(tofrom:i\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "map\\(to:j\\)" 1 "original" } } diff --git a/Fortran/gfortran/regression/goacc/pr109622-5.f90 b/Fortran/gfortran/regression/goacc/pr109622-5.f90 new file mode 100644 index 000000000..59dbe9c8c --- /dev/null +++ b/Fortran/gfortran/regression/goacc/pr109622-5.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } + +implicit none + +type t +integer :: foo +character(len=8) :: bar +integer :: qux(5) +end type t + +type(t) :: var + +var%foo = 3 +var%bar = "HELLOOMP" +var%qux = (/ 1, 2, 3, 4, 5 /) + +!$acc enter data copyin(var) + +!$acc enter data attach(var%foo) +! { dg-error "'attach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } +!$acc enter data attach(var%bar) +! { dg-error "'attach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } +!$acc enter data attach(var%qux) +! { dg-error "'attach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } + +!$acc serial +var%foo = 5 +var%bar = "GOODBYE!" +var%qux = (/ 6, 7, 8, 9, 10 /) +!$acc end serial + +!$acc exit data detach(var%qux) +! { dg-error "'detach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } +!$acc exit data detach(var%bar) +! { dg-error "'detach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } +!$acc exit data detach(var%foo) +! { dg-error "'detach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } + +!$acc exit data copyout(var) + +if (var%foo.ne.5) stop 1 +if (var%bar.ne."GOODBYE!") stop 2 + +end diff --git a/Fortran/gfortran/regression/goacc/pr109622-6.f90 b/Fortran/gfortran/regression/goacc/pr109622-6.f90 new file mode 100644 index 000000000..256ab90f2 --- /dev/null +++ b/Fortran/gfortran/regression/goacc/pr109622-6.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } + +implicit none +integer :: x +!$acc enter data attach(x) +! { dg-error "'attach' clause argument must be ALLOCATABLE or a POINTER" "" { target *-*-* } .-1 } + +end diff --git a/Fortran/gfortran/regression/goacc/pr71704.f90 b/Fortran/gfortran/regression/goacc/pr71704.f90 index 0235e85d4..31724c8b0 100644 --- a/Fortran/gfortran/regression/goacc/pr71704.f90 +++ b/Fortran/gfortran/regression/goacc/pr71704.f90 @@ -47,8 +47,9 @@ real function f8 () f8 = 1 end -real function f9 () -!$acc host_data +real function f9 (a) + integer a(:) +!$acc host_data use_device(a) !$acc end host_data f8 = 1 end diff --git a/Fortran/gfortran/regression/goacc/readonly-1.f90 b/Fortran/gfortran/regression/goacc/readonly-1.f90 new file mode 100644 index 000000000..fc1e2719e --- /dev/null +++ b/Fortran/gfortran/regression/goacc/readonly-1.f90 @@ -0,0 +1,95 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine foo (a, n) + integer :: n, a(:) + integer :: i, b(n), c(n) + !!$acc declare copyin(readonly: a(:), b(:n)) copyin(c(:)) + !$acc declare copyin(readonly: b) copyin(c) + + !$acc parallel copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end parallel + + !$acc kernels copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end kernels + + !$acc serial copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end serial + + !$acc data copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end data + + !$acc enter data copyin(readonly: a(:), b(:n)) copyin(c(:)) + +end subroutine foo + +program main + integer :: g(32), h(32) + integer :: i, n = 32, a(32) + integer :: b(32), c(32) + + !$acc declare copyin(readonly: g), copyin(h) + + !$acc parallel copyin(readonly: a(:32), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end parallel + + !$acc kernels copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end kernels + + !$acc serial copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end serial + + !$acc data copyin(readonly: a(:), b(:n)) copyin(c(:)) + do i = 1,32 + !$acc cache (readonly: a(:), b(:n)) + !$acc cache (c(:)) + enddo + !$acc end data + + !$acc enter data copyin(readonly: a(:), b(:n)) copyin(c(:)) + +end program main + +! The front end turns OpenACC 'declare' into OpenACC 'data'. +! { dg-final { scan-tree-dump-times "(?n)#pragma acc data map\\(readonly,to:\\*b\\) map\\(alloc:b.+ map\\(to:\\*c\\) map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc data map\\(readonly,to:g\\) map\\(to:h\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel map\\(readonly,to:\\*.+ map\\(alloc:a.+ map\\(readonly,to:\\*.+ map\\(alloc:b.+ map\\(to:\\*.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel map\\(readonly,to:a.+ map\\(alloc:a.+ map\\(readonly,to:b.+ map\\(alloc:b.+ map\\(to:c.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc kernels map\\(readonly,to:\\*.+ map\\(alloc:a.+ map\\(readonly,to:\\*.+ map\\(alloc:b.+ map\\(to:\\*.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc kernels map\\(readonly,to:a.+ map\\(alloc:a.+ map\\(readonly,to:b.+ map\\(alloc:b.+ map\\(to:c.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc serial map\\(readonly,to:\\*.+ map\\(alloc:a.+ map\\(readonly,to:\\*.+ map\\(alloc:b.+ map\\(to:\\*.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc serial map\\(readonly,to:a.+ map\\(alloc:a.+ map\\(readonly,to:b.+ map\\(alloc:b.+ map\\(to:c.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc data map\\(readonly,to:\\*.+ map\\(alloc:a.+ map\\(readonly,to:\\*.+ map\\(alloc:b.+ map\\(to:\\*.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc data map\\(readonly,to:a.+ map\\(alloc:a.+ map\\(readonly,to:b.+ map\\(alloc:b.+ map\\(to:c.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc enter data map\\(readonly,to:\\*.+ map\\(alloc:a.+ map\\(readonly,to:\\*.+ map\\(alloc:b.+ map\\(to:\\*.+ map\\(alloc:c.+" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc enter data map\\(readonly,to:a.+ map\\(alloc:a.+ map\\(readonly,to:b.+ map\\(alloc:b.+ map\\(to:c.+ map\\(alloc:c.+" 1 "original" } } + +! { dg-final { scan-tree-dump-times "(?n)#pragma acc cache \\(readonly:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parm.*data \\\[len: .+\\\]\\) \\(readonly:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parm.*data \\\[len: .+\\\]\\);" 8 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma acc cache \\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parm.*data \\\[len: .+\\\]\\);" 8 "original" } } diff --git a/Fortran/gfortran/regression/goacc/self.f95 b/Fortran/gfortran/regression/goacc/self.f95 new file mode 100644 index 000000000..aa0f6fe88 --- /dev/null +++ b/Fortran/gfortran/regression/goacc/self.f95 @@ -0,0 +1,61 @@ +! See also 'if.f95'. + +! { dg-do compile } + +program test + implicit none + + logical :: x + integer :: i + + !$acc parallel self () ! { dg-error "Invalid character" } + !$acc parallel self (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end parallel + !$acc parallel self (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end parallel + + !$acc kernels self () ! { dg-error "Invalid character" } + !$acc kernels self (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end kernels + !$acc kernels self (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end kernels + + !$acc serial self () ! { dg-error "Invalid character" } + !$acc serial self (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end serial + !$acc serial self (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end serial + + ! at most one self clause may appear + !$acc parallel self (.false.) self (.false.) { dg-error "Duplicated 'self' clause" } + !$acc kernels self (.false.) self (.false.) { dg-error "Duplicated 'self' clause" } + !$acc serial self (.false.) self (.false.) { dg-error "Duplicated 'self' clause" } + + !$acc parallel self + !$acc end parallel + !$acc parallel self (x) + !$acc end parallel + !$acc parallel self (.true.) + !$acc end parallel + !$acc parallel self (i.gt.1) + !$acc end parallel + + !$acc kernels self + !$acc end kernels + !$acc kernels self (x) + !$acc end kernels + !$acc kernels self (.true.) + !$acc end kernels + !$acc kernels self (i.gt.1) + !$acc end kernels + + !$acc serial self + !$acc end serial + !$acc serial self (x) + !$acc end serial + !$acc serial self (.true.) + !$acc end serial + !$acc serial self (i.gt.1) + !$acc end serial + +end program test diff --git a/Fortran/gfortran/regression/goacc/tests.cmake b/Fortran/gfortran/regression/goacc/tests.cmake index 8bf968c08..4d584046a 100644 --- a/Fortran/gfortran/regression/goacc/tests.cmake +++ b/Fortran/gfortran/regression/goacc/tests.cmake @@ -95,6 +95,7 @@ compile;derived-classtypes-1.f95;;-Wuninitialized;; compile;derived-types-2.f90;;-Wuninitialized;; compile;derived-types-3.f90;xfail;;; compile;derived-types.f90;xfail;;; +compile;enter-exit-data-2.f90;;-fdump-tree-original;; compile;enter-exit-data.f95;xfail;-fmax-errors=100;; compile;finalize-1.f;;-fdump-tree-original -fdump-tree-gimple;; compile;firstprivate-1.f95;xfail;;; @@ -104,6 +105,7 @@ compile;fixed-3.f;;;; compile;fixed-4.f;;;; compile;fixed-5.f;;;; compile;gang-static.f95;;-fdump-tree-omplower;; +compile;host_data-error.f90;xfail;;; compile;host_data-tree.f95;;-fdump-tree-original -fdump-tree-gimple -Wuninitialized;; compile;if.f95;xfail;;; compile;kernels-alias-2.f95;;-O2 -fdump-tree-ealias-all;; @@ -167,6 +169,8 @@ compile;parallel-kernels-regions.f95;xfail;;; compile;parallel-tree.f95;;-fdump-tree-original -Wuninitialized -Wopenacc-parallelism;; compile;parameter.f95;xfail;;; compile;pr104717.f90;;-O1 -fstack-arrays -fipa-pta;; +compile;pr109622-5.f90;xfail;;; +compile;pr109622-6.f90;xfail;;; compile;pr71704.f90;;;; compile;pr72715.f90;xfail;;; compile;pr72743.f90;;-O2;; @@ -204,6 +208,7 @@ compile;privatization-1-routine_gang-loop.f90;;-fopt-info-omp-note --param=opena compile;privatization-1-routine_gang.f90;;-fopt-info-omp-note --param=openacc-privatization=noisy -Wuninitialized;; compile;pure-elemental-procedures-2.f90;xfail;;; compile;pure-elemental-procedures.f95;xfail;-std=f2008 -fcoarray=single;; +compile;readonly-1.f90;;-fdump-tree-original;; compile;reduction-2.f95;;-fdump-tree-gimple;; compile;reduction-3.f95;xfail;;; compile;reduction-promotions.f90;;-fdump-tree-gimple;; @@ -227,6 +232,7 @@ compile;routine-module-3.f90 routine-module-mod-1.f90;xfail;;; compile;routine-multiple-directives-1.f90;;-fdump-tree-oaccloops -Wopenacc-parallelism;; compile;routine-multiple-directives-2.f90;xfail;;; compile;routine-multiple-lop-clauses-1.f90;xfail;;; +compile;self.f95;xfail;;; compile;sentinel-free-form.f95;xfail;;; compile;several-directives.f95;xfail;;; compile;sie.f95;xfail;-fmax-errors=100;; @@ -250,4 +256,4 @@ compile;update-if_present-2.f90;xfail;;; compile;update.f95;xfail;;; compile;vector_length.f90;;;; compile;wait.f90;;-Wuninitialized;; -compile;warn_truncated.f90;xfail;;; \ No newline at end of file +compile;warn_truncated.f90;xfail;-std=f2018;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/goacc/warn_truncated.f90 b/Fortran/gfortran/regression/goacc/warn_truncated.f90 index 15ef3f513..101e02670 100644 --- a/Fortran/gfortran/regression/goacc/warn_truncated.f90 +++ b/Fortran/gfortran/regression/goacc/warn_truncated.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-additional-options "-std=f2018" } ! PR fortran/97390 ! integer :: tempRbuffer, array, compactHaloInfo, dimsizes, nHaloLayers, gpu_nList_send, gpu_idx_send, gpu_bufferOffset_send, counter diff --git a/Fortran/gfortran/regression/gomp/DisabledFiles.cmake b/Fortran/gfortran/regression/gomp/DisabledFiles.cmake index 65a8ad55d..a0a402cb0 100644 --- a/Fortran/gfortran/regression/gomp/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/gomp/DisabledFiles.cmake @@ -98,6 +98,9 @@ file(GLOB SKIPPED_FILES CONFIGURE_DEPENDS openmp-simd-2.f90 openmp-simd-3.f90 pr71704.f90 + + # error: A DO loop must follow the SIMD directive + unroll-simd-2.f90 ) file(GLOB FAILING_FILES CONFIGURE_DEPENDS @@ -335,7 +338,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # Must be a constant value target2.f90 - # bad character ('{') in Fortran token + # bad character ('{') in Fortran token declare-variant-10.f90 declare-variant-11.f90 declare-variant-12.f90 @@ -367,4 +370,53 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS pr78866-2.f90 reduction3.f90 sharing-3.f90 + + # These tests fail, but the cause of their failure needs to be investigated. + allocate-10.f90 + allocate-13.f90 + allocate-13a.f90 + allocate-5.f90 + allocate-8.f90 + c_ptr_tests_20.f90 + declare-target-indirect-2.f90 + defaultmap-8.f90 + defaultmap-9.f90 + depobj-3.f90 + inner-loops-1.f90 + map-10.f90 + map-11.f90 + map-12.f90 + requires-10.f90 + target-update-1.f90 + tile-10.f90 + tile-1.f90 + tile-2.f90 + tile-5.f90 + tile-imperfect-nest-1.f90 + tile-inner-loops-1.f90 + tile-inner-loops-2.f90 + tile-inner-loops-3.f90 + tile-inner-loops-4.f90 + tile-inner-loops-5.f90 + tile-inner-loops-6.f90 + tile-inner-loops-7.f90 + tile-non-rectangular-1.f90 + tile-unroll-1.f90 + unroll-13.f90 + unroll-1.f90 + unroll-2.f90 + unroll-3.f90 + unroll-4.f90 + unroll-5.f90 + unroll-7.f90 + unroll-8.f90 + unroll-9.f90 + unroll-inner-loop-1.f90 + unroll-no-clause-1.f90 + unroll-non-rect-1.f90 + unroll-non-rect-2.f90 + unroll-simd-1.f90 + unroll-tile-1.f90 + unroll-tile-2.f90 + unroll-tile-inner-1.f90 ) diff --git a/Fortran/gfortran/regression/gomp/allocate-10.f90 b/Fortran/gfortran/regression/gomp/allocate-10.f90 new file mode 100644 index 000000000..e50db53c1 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-10.f90 @@ -0,0 +1,75 @@ +! { dg-additional-options "-Wall -fdump-tree-gimple" } + +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end + + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free" 3 "gimple" } } + +subroutine f + use m + implicit none + integer :: n + block + integer :: A(n) ! { dg-warning "Unused variable 'a' declared" } + end block +end + +subroutine f2 + use m + implicit none + integer :: n ! { dg-note "'n' was declared here" } + block + integer :: A(n) ! { dg-warning "'n' is used uninitialized" } + !$omp allocate(A) + ! by matching 'A' above, TREE_USE is set. Hence: + ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(., D\.\[0-9\]+, 0B\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } } + end block +end + +subroutine h1() + use m + implicit none + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" } + integer :: B1(3) + !$omp allocate(B1) allocator(my_handle) ! { dg-warning "31:'my_handle' is used uninitialized" } + B1(1) = 5 + ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b1.\[0-9\]+, 0B\\);" 1 "gimple" } } +end + +subroutine h2() + use m + implicit none + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" } + block + integer :: B2(3) + !$omp allocate(B2) allocator(my_handle) ! { dg-warning "33:'my_handle' is used uninitialized" } + ! Similar above; B2 is unused - but in gfortran, the match in 'allocate(B2)' already + ! causes TREE_USED = 1 + ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } } + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b2.\[0-9\]+, 0B\\);" 1 "gimple" } } + end block +end diff --git a/Fortran/gfortran/regression/gomp/allocate-11.f90 b/Fortran/gfortran/regression/gomp/allocate-11.f90 new file mode 100644 index 000000000..8a8d93930 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-11.f90 @@ -0,0 +1,33 @@ +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end + +subroutine f () + use m + implicit none + integer :: i + !$omp parallel firstprivate(i) allocate(allocator(omp_low_latency_mem_alloc): i) + ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1 } + ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." "" { target *-*-* } .-2 } + i = 4 + !$omp end parallel +end diff --git a/Fortran/gfortran/regression/gomp/allocate-12.f90 b/Fortran/gfortran/regression/gomp/allocate-12.f90 new file mode 100644 index 000000000..183c29418 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-12.f90 @@ -0,0 +1,24 @@ +module m + implicit none +contains +subroutine f () + !$omp declare target + integer :: var ! { dg-error "'allocate' directive for 'var' inside a target region must specify an 'allocator' clause" } + !$omp allocate(var) + var = 5 +end + +subroutine h () + !$omp target + !$omp parallel + !$omp single + block + integer :: var2(5) ! { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } + !$omp allocate(var2) + var2(1) = 7 + end block + !$omp end single + !$omp end parallel + !$omp end target +end +end module diff --git a/Fortran/gfortran/regression/gomp/allocate-13.f90 b/Fortran/gfortran/regression/gomp/allocate-13.f90 new file mode 100644 index 000000000..bf8a5a2be --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-13.f90 @@ -0,0 +1,25 @@ +module m + implicit none + !$omp requires dynamic_allocators +contains +subroutine f () + !$omp declare target + integer :: var + !$omp allocate(var) + var = 5 +end + +subroutine h () + !$omp target + !$omp parallel + !$omp single + block + integer :: var2(5) + !$omp allocate(var2) + var2(1) = 7 + end block + !$omp end single + !$omp end parallel + !$omp end target +end +end module diff --git a/Fortran/gfortran/regression/gomp/allocate-13a.f90 b/Fortran/gfortran/regression/gomp/allocate-13a.f90 new file mode 100644 index 000000000..4b297cdb4 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-13a.f90 @@ -0,0 +1,34 @@ +! { dg-do compile { target lto } } +! { dg-additional-options "-flto" } + +! Same as allocate-13.f90 but compiled with -flto. + +! This was failing before as the statement list, +! used for placing the GOMP_alloc/GOMP_free leaked +! through to LTO. + +module m + implicit none + !$omp requires dynamic_allocators +contains +subroutine f () + !$omp declare target + integer :: var + !$omp allocate(var) + var = 5 +end + +subroutine h () + !$omp target + !$omp parallel + !$omp single + block + integer :: var2(5) + !$omp allocate(var2) + var2(1) = 7 + end block + !$omp end single + !$omp end parallel + !$omp end target +end +end module diff --git a/Fortran/gfortran/regression/gomp/allocate-14.f90 b/Fortran/gfortran/regression/gomp/allocate-14.f90 new file mode 100644 index 000000000..4fed19249 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-14.f90 @@ -0,0 +1,136 @@ +! { dg-additional-options "-fcoarray=single -fcray-pointer" } + +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end + +subroutine coarrays(x) + use m + implicit none + + integer :: x[*] + integer, allocatable :: y[:], z(:)[:] + + !$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" } + + !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." } + allocate(y[*]) + + !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." } + allocate(z(5)[*]) + x = 5 +end + + +integer function f() result(res) + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } + !$omp allocate(res) ! { dg-error "Unexpected function-result variable 'res' at .1. in declarative !.OMP ALLOCATE" } + res = 5 +end + +integer function g() result(res) + allocatable :: res + !$omp allocators allocate(g) ! { dg-error "Expected variable list at .1." } + + !$omp allocators allocate (res) + allocate(res, source=5) + deallocate(res) + + !$omp allocate (res) + allocate(res, source=5) +end + + +subroutine cray_ptr() + real pointee(10) + pointer (ipt, pointee) + !$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and pointees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." } + !$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and pointees such as 'ipt' are not supported with !.OMP ALLOCATE at .1." } +end + +subroutine equiv + integer :: A + real :: B(2) + equivalence(A,B) + !$omp allocate (A) ! { dg-error "Sorry, EQUIVALENCE object 'a' not supported with !.OMP ALLOCATE at .1." } + !$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not supported with !.OMP ALLOCATE at .1." } +end + +subroutine common + use m + integer :: a,b,c(5) + common /my/ a,b,c + !$omp allocate(b) allocator(omp_cgroup_mem_alloc) ! { dg-error "'b' at .1. is part of the common block '/my/' and may only be specificed implicitly via the named common block" } +end + +subroutine c_and_func_ptrs + use iso_c_binding + implicit none + procedure(), pointer :: p + type(c_ptr) :: cptr + type(c_ptr) :: cfunptr + + !$omp allocate(cptr) ! OK + !$omp allocate(cfunptr) ! OK? A normal derived-type var? + !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } +end + + +subroutine coarray_2 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocate(a,b) align(16) + !$omp allocate ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } +end + + +subroutine coarray_3 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocators allocate(align(16): a,b) allocate(align(32) : d) + allocate(a,b,c[*],d) ! OK - Fortran allocator used for 'C' +end + + +subroutine unclear + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + + ! OpenMP is unclear which allocator is used for 'C' - the fortran one or the OpenMP one. + ! GCC therefore rejects it. + + x = 5 ! executable stmt + + !$omp allocate(a,b) align(16) + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "'c' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" } +end diff --git a/Fortran/gfortran/regression/gomp/allocate-15.f90 b/Fortran/gfortran/regression/gomp/allocate-15.f90 new file mode 100644 index 000000000..a0690a563 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-15.f90 @@ -0,0 +1,38 @@ +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end + +subroutine common + use m + integer :: a,b,c(5) + common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" } + !$omp allocate(/my/) allocator(omp_cgroup_mem_alloc) +end + +integer function allocators() result(res) + use m + integer, save :: a(5) = [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allocate for variable 'a' at .1. with SAVE attribute not yet implemented" } + !$omp allocate(a) allocator(omp_high_bw_mem_alloc) + res = a(4) +end + + diff --git a/Fortran/gfortran/regression/gomp/allocate-16.f90 b/Fortran/gfortran/regression/gomp/allocate-16.f90 new file mode 100644 index 000000000..6c203e02d --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-16.f90 @@ -0,0 +1,10 @@ +integer, pointer :: ptr + +!$omp flush +!$omp allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATE' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/gomp/allocate-2.f90 b/Fortran/gfortran/regression/gomp/allocate-2.f90 index 657ff44d0..cc83b5edb 100644 --- a/Fortran/gfortran/regression/gomp/allocate-2.f90 +++ b/Fortran/gfortran/regression/gomp/allocate-2.f90 @@ -25,11 +25,11 @@ subroutine foo(x) x=3 !$omp end parallel - !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." } + !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." } x=4 !$omp end parallel - !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." } + !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." } x=5 !$omp end parallel diff --git a/Fortran/gfortran/regression/gomp/allocate-4.f90 b/Fortran/gfortran/regression/gomp/allocate-4.f90 new file mode 100644 index 000000000..b93a37c78 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-4.f90 @@ -0,0 +1,54 @@ +module my_omp_lib + use iso_c_binding, only: c_intptr_t + !use omp_lib + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end module my_omp_lib + +subroutine one(n, my_alloc) + use my_omp_lib + implicit none +integer :: n +integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc + +!stack variables: +integer :: a,b,c(n),d(5),e(2) +!$omp allocate(a) +!$omp allocate ( b , c ) align ( 32) allocator (my_alloc) +!$omp allocate (d) align( 128 ) +!$omp allocate( e ) allocator( omp_high_bw_mem_alloc ) + +!saved vars +integer, save :: k,l,m(5),r(2) ! { dg-error "Sorry, !.OMP allocate for variable 'k' at .1. with SAVE attribute not yet implemented" } +!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc) +!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32) +!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc ) +!$omp allocate( r ) allocator( omp_high_bw_mem_alloc ) + +!common /block/ +integer :: q,x,y(2),z(5) +common /com1/ q,x +common /com2/ y,z +!$omp allocate ( / com1/) align( 128 ) allocator( omp_high_bw_mem_alloc ) +!$omp allocate(/com2 / ) allocator( omp_high_bw_mem_alloc ) +end diff --git a/Fortran/gfortran/regression/gomp/allocate-5.f90 b/Fortran/gfortran/regression/gomp/allocate-5.f90 new file mode 100644 index 000000000..28369ae87 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-5.f90 @@ -0,0 +1,94 @@ +! { dg-additional-options "-fopenmp-allocators" } +module my_omp_lib + use iso_c_binding, only: c_intptr_t + !use omp_lib + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 + type t + integer :: a + end type t +end module my_omp_lib + +subroutine zero() + !$omp assumes absent (allocators) + + !$omp assume absent (allocators) + !$omp end assume +end + +subroutine two(c,x2,y2) + use my_omp_lib + implicit none + integer, allocatable :: a, b(:), c(:,:) + type(t), allocatable :: x1 + type(t), pointer :: x2(:) + class(t), allocatable :: y1 + class(t), pointer :: y2(:) + + !$omp flush ! some executable statement + !$omp allocate(a) + allocate(a) + deallocate(a) + + !$omp allocate(x1,y1,x2,y2) + allocate(x1,y1,x2(5),y2(5)) + deallocate(x1,y1,x2,y2) + + !$omp allocate(b,a) align ( 128 ) + !$omp allocate align ( 64 ) + allocate(a,b(4),c(3,4)) + deallocate(a,b,c) +end + +subroutine three(c) + use my_omp_lib + implicit none + integer :: q + integer, allocatable :: a, b(:), c(:,:) + + call foo() ! executable stmt + !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) + !$omp allocate(b) allocator( omp_high_bw_mem_alloc ) + !$omp allocate(c) allocator( omp_high_bw_mem_alloc ) + allocate(a,b(4),c(3,4)) + deallocate(a,b,c) + + block + q = 5 ! executable stmt + !$omp allocate(a) align(64) + !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) + !$omp allocate(c) allocator( omp_thread_mem_alloc ) + allocate(a,b(4),c(3,4)) + deallocate(a,b,c) + end block + call inner +contains + subroutine inner + call foo() ! executable stmt + !$omp allocate(a) align(64) + !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) + !$omp allocate(c) allocator( omp_thread_mem_alloc ) + allocate(a,b(4),c(3,4)) + deallocate(a,b,c) + end subroutine inner +end diff --git a/Fortran/gfortran/regression/gomp/allocate-6.f90 b/Fortran/gfortran/regression/gomp/allocate-6.f90 new file mode 100644 index 000000000..73e5bbcf7 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-6.f90 @@ -0,0 +1,103 @@ +module my_omp_lib + use iso_c_binding, only: c_intptr_t + !use omp_lib + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 + type t + integer,allocatable :: a + integer,pointer :: b(:,:) + end type t +end module my_omp_lib + +subroutine zero() + !$omp assumes absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" } + + !$omp assume absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" } + !!$omp end assume +end + +subroutine alloc(c,x2,y2) + use my_omp_lib + implicit none + integer, allocatable :: a, b(:), c(:,:) + type(t) :: x1,x2 + class(t) :: y1,y2 + allocatable :: x1, y1 + + !$omp flush ! some executable statement + + !$omp allocate(x2%a,x2%b,y2%a,y2%b) allocator(omp_pteam_mem_alloc) align(64) ! { dg-error "Sorry, structure-element list item at .1. in ALLOCATE directive is not yet supported" } + allocate(x2%a,x2%b(3,4),y2%a,y2%b(3,4)) + + !$omp allocate(b(3)) align ( 64 ) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" } + allocate(b(3)) +end + +subroutine one(n, my_alloc) + use my_omp_lib + implicit none +integer :: n +integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc + +integer :: a,b,c(n),d(5),e(2) +integer, save :: k,l,m(5),r(2) +integer :: q,x,y(2),z(5) +common /com1/ q,x +common /com2/ y,z +integer, allocatable :: alloc +integer, pointer :: ptr + +!$omp allocate(q) ! { dg-error "'q' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" } + +!$omp allocate(d(:)) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" } +!$omp allocate(a) align(4), align(4) ! { dg-error "Duplicated 'align' clause" } +!$omp allocate( e ) allocator( omp_high_bw_mem_alloc ), align(32),allocator( omp_high_bw_mem_alloc ) ! { dg-error "Duplicated 'allocator' clause" } + +!$omp allocate align(32) ! { dg-error "'!.OMP ALLOCATE' directive at .1. must either have a variable argument or, if associated with an ALLOCATE stmt, must be preceded by an executable statement or OpenMP construct" } + +!$omp allocate(alloc) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" } +!$omp allocate(ptr) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" } + +!$omp allocate(e) allocate(omp_thread_mem_alloc) ! { dg-error "Expected ALIGN or ALLOCATOR clause" } +end + +subroutine two() + integer, allocatable :: a,b,c + + call foo() + !$omp allocate(a) + a = 5 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" } + + !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" } + !$omp allocate(b) + !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" } + allocate(a,b,c) + + !$omp allocate + allocate(a,b,c) ! allocate is no block construct, hence: + !$omp end allocate ! { dg-error "Unclassifiable OpenMP directive" } + + !$omp allocators allocate(align(64) : a, b) + !$omp allocators allocate(align(128) : c) ! { dg-error "Unexpected !.OMP ALLOCATORS at .1.; expected ALLOCATE statement after !.OMP ALLOCATORS" } + allocate(a,b,c) +end diff --git a/Fortran/gfortran/regression/gomp/allocate-7.f90 b/Fortran/gfortran/regression/gomp/allocate-7.f90 new file mode 100644 index 000000000..ab85e3277 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-7.f90 @@ -0,0 +1,221 @@ +! { dg-additional-options "-fmax-errors=1000" } +module my_omp_lib + use iso_c_binding, only: c_intptr_t + !use omp_lib + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 + type t + integer,allocatable :: a + integer,pointer :: b(:,:) + end type t + integer :: used +end module my_omp_lib + +subroutine one(n, my_alloc) + use my_omp_lib + implicit none +integer :: n +integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc + +integer :: a,b,c(n),d(5),e(2) +integer, save :: k,l,m(5),r(2) +integer :: q,x,y(2),z(5) +common /com1/ q,x +common /com2/ y,z +integer, allocatable :: alloc +integer, pointer :: ptr +integer, parameter :: prm=5 + +!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } + +!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } +!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" } + +!$omp allocate (x) align(128) ! { dg-error "'x' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" } + +!$omp allocate (a, b, a) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'a' in !.OMP ALLOCATE" } +contains + + subroutine inner + !$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + end +end + +subroutine three(n) + use my_omp_lib + implicit none +integer,value :: n +integer :: a,b,c(n),d(5),e(2) +integer, save :: k,l,m(5) +integer :: q,x,y(2),z(5),r +common /com4/ y,z +allocatable :: q +pointer :: b +!$omp allocate (c, d) allocator (omp_pteam_mem_alloc) +!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) +!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" } +!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" } + +!$omp allocate(q,x) ! { dg-error "Unexpected allocatable variable 'q' at .1. in declarative !.OMP ALLOCATE directive" } +!$omp allocate(b,e) ! { dg-error "Unexpected pointer variable 'b' at .1. in declarative !.OMP ALLOCATE directive" } +end + +subroutine four(n) + integer :: qq, rr, ss, tt, uu, vv,n +!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +end + +subroutine five(n,my_alloc) + use my_omp_lib + implicit none + integer :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc +!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +!$omp allocate (tt) allocator(my_alloc) ! OK +end + + +subroutine five_SaveAll(n,my_alloc) + use my_omp_lib + implicit none + save + integer :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc +!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } +!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } +!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } +end + + +subroutine five_Save(n,my_alloc) + use my_omp_lib + implicit none + integer :: n + integer, save :: qq, rr, ss, tt, uu, vv + integer(omp_allocator_handle_kind) :: my_alloc +!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } +!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } +!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } +end + +module five_Module + use my_omp_lib + implicit none + integer, save :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc +!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } +!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } +!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } +end module + +program five_program + use my_omp_lib + implicit none + integer, save :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc +!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" } +!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" } +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" } +!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" } +end program + + + +subroutine six(n,my_alloc) + use my_omp_lib + implicit none + integer :: qq, rr, ss, tt, uu, vv,n + common /com6qq/ qq + common /com6rr/ rr + common /com6ss/ ss + common /com6tt/ tt + integer(omp_allocator_handle_kind) :: my_alloc + +!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" } +!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" } +!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" } +!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" } +end + + +subroutine two() + use my_omp_lib + implicit none + integer,allocatable :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc + + call foo() +!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +allocate(qq) +!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +allocate(rr) +!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" } +allocate(ss) +!$omp allocate (tt) allocator(my_alloc) ! OK +allocate(tt) +end + +subroutine two_ptr() + use my_omp_lib + implicit none + integer,pointer :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc + + call foo() +!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +allocate(qq) +!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +allocate(rr) +!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +allocate(ss) +!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +allocate(tt) +!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } +allocate(uu) +end + +subroutine next() + use my_omp_lib + implicit none + integer,allocatable :: qq, rr, ss, tt, uu, vv,n + integer(omp_allocator_handle_kind) :: my_alloc + + !$omp allocate(qq) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" } + allocate(qq,rr) + + !$omp allocate(uu,tt) + !$omp allocate(tt) ! { dg-warning "'tt' appears more than once in 'allocate" } + allocate(uu,tt) + + !$omp allocate(uu,vv) ! { dg-error "'uu' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" } + allocate(vv) +end diff --git a/Fortran/gfortran/regression/gomp/allocate-8.f90 b/Fortran/gfortran/regression/gomp/allocate-8.f90 new file mode 100644 index 000000000..bb4d07d0c --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-8.f90 @@ -0,0 +1,29 @@ +! { dg-additional-options "-fdump-tree-original" } + +module m + use iso_c_binding + !use omp_lib, only: omp_allocator_handle_kind + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer :: a = 0, b = 42, c = 0 + +contains + integer(omp_allocator_handle_kind) function get_alloc() + allocatable :: get_alloc + get_alloc = 2_omp_allocator_handle_kind + end + subroutine foo () + !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( get_alloc() : a , b , c) + if (b /= 42) & + error stop + a = 36 + b = 15 + c = c + 1 + !$omp end scope + end +end + +! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } } + +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = get_alloc \\(\\);\[\n\r\]+ *D\\.\[0-9\]+ = \\*D\\.\[0-9\]+;\[\n\r\]+ *__builtin_free \\(\\(void \\*\\) D\\.\[0-9\]+\\);" 1 "original" } } + diff --git a/Fortran/gfortran/regression/gomp/allocate-9.f90 b/Fortran/gfortran/regression/gomp/allocate-9.f90 new file mode 100644 index 000000000..4d9553686 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-9.f90 @@ -0,0 +1,112 @@ +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end + + +module m2 + use m + implicit none + integer :: A(5) = [1,2,3,4,5], A2, A3, A4, A5 + integer :: B, C, D + +! If the following fails because of added predefined allocators, please update +! - c/c-parser.c's c_parser_omp_allocate +! - fortran/openmp.cc's is_predefined_allocator +! - libgomp/env.c's parse_allocator +! - libgomp/libgomp.texi (document the new values - multiple locations) +! + ensure that the memory-spaces are also up to date. + +!$omp allocate(A) align(32) allocator(9_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a' at .2. has the SAVE attribute" } + +! typo in allocator name: +!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\?" } +! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a2' at .2. has the SAVE attribute" "" { target *-*-* } .-1 } + +! align be const multiple of 2 +!$omp allocate(A3) align(31) allocator(omp_default_mem_alloc) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" } + +! allocator missing (required as A is static) +!$omp allocate(A4) align(32) ! { dg-error "An ALLOCATOR clause is required as the list item 'a4' at .1. has the SAVE attribute" } + +! "expression in the clause must be a constant expression that evaluates to one of the +! predefined memory allocator values -> omp_low_lat_mem_alloc" +!$omp allocate(B) allocator(omp_high_bw_mem_alloc+1_omp_allocator_handle_kind) align(32) ! OK: omp_low_lat_mem_alloc + +!$omp allocate(C) allocator(2_omp_allocator_handle_kind) ! OK: omp_large_cap_mem_alloc + +!$omp allocate(A5) align(32) allocator(omp_null_allocator) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a5' at .2. has the SAVE attribute" } + +!$omp allocate(C) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE at .1." } + +contains + +integer function f() + !$omp allocate(D) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + f = A(1) +end + +integer function g() + integer :: a2, b2 + !$omp allocate(a2) + !$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP ALLOCATE at .1." } + a2=1; b2=2 + block + integer :: c2 + !$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + c2 = 3 + g = c2+a2+b2 + end block +end + +integer function h(q) + integer :: q + !$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argument at .1. to declarative !.OMP ALLOCATE" } + h = q +end + +integer function k () + integer, save :: var3 = 8 + !$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'var3' at .2. has the SAVE attribute" } + k = var3 +end +end module + + +subroutine foo + integer :: a, b + integer :: c, d,h + !$omp allocate(a,b) + b = 1; d = 5 +contains +subroutine internal + integer :: e,f + !$omp allocate(c,d) + ! { dg-error "Argument 'c' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-1 } + ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-2 } + !$omp allocate(e) + a = 1; c = 2; e = 4 + block + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + !$omp allocate(h) ! { dg-error "Argument 'h' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" } + end block +end +end diff --git a/Fortran/gfortran/regression/gomp/allocate-pinned-1.f90 b/Fortran/gfortran/regression/gomp/allocate-pinned-1.f90 new file mode 100644 index 000000000..0e6619b78 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocate-pinned-1.f90 @@ -0,0 +1,16 @@ +! Test that the ompx_gnu_pinned_mem_alloc is accepted by the parser + +module m +use iso_c_binding +integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer (kind=omp_allocator_handle_kind), & + parameter :: ompx_gnu_pinned_mem_alloc = 200 +end + +subroutine f () + use m + implicit none + ! The "Sorry" is here temporarily only to avoid excess error failures. + integer, save :: i ! { dg-error "Sorry, !.OMP allocate for variable 'i' at .1. with SAVE attribute not yet implemented" } + !$omp allocate(i) allocator(ompx_gnu_pinned_mem_alloc) +end diff --git a/Fortran/gfortran/regression/gomp/allocators-1.f90 b/Fortran/gfortran/regression/gomp/allocators-1.f90 new file mode 100644 index 000000000..b39f6d272 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocators-1.f90 @@ -0,0 +1,28 @@ +implicit none +integer, allocatable :: a, b +integer :: q +integer :: arr(2) + +!$omp allocators allocate(align(64): a) +block ! { dg-error "expected ALLOCATE statement after !.OMP ALLOCATORS" } +end block ! { dg-error "Expecting END PROGRAM statement" } + + +!$omp allocators allocate(align(64): a) + allocate(a, b) ! OK +!$omp end allocators + +!$omp allocators allocate(align(128): b) + allocate(a, b) ! OK (assuming not allocated) + + +!$omp allocators allocate(align(64): a) + allocate(a, b, stat=arr) ! { dg-error "Stat-variable at .1. must be a scalar INTEGER variable" } +!$omp end allocators + + +!$omp allocators allocate(align(64): a) + allocate(q) ! { dg-error "is neither a data pointer nor an allocatable variable" } +!$omp end allocators ! { dg-error "Unexpected !.OMP END ALLOCATORS" } + +end diff --git a/Fortran/gfortran/regression/gomp/allocators-2.f90 b/Fortran/gfortran/regression/gomp/allocators-2.f90 new file mode 100644 index 000000000..6fb80879e --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocators-2.f90 @@ -0,0 +1,22 @@ +implicit none +integer, allocatable :: a, b +integer :: q +integer :: arr(2) + +!$omp allocators allocate(align(64): a) + allocate(a, b) ! OK +!$omp end allocators + +!$omp allocators allocate(align(128): b) + allocate(a, b) ! OK (assuming not allocated) + + +!$omp allocators allocate(align(62.0): a) ! { dg-error "a scalar positive constant integer alignment expression" } + allocate(a) + + +!$omp allocators allocate(align(64): a, b) ! { dg-error "'b' specified in 'allocate' at \\(1\\) but not in the associated ALLOCATE statement" } + allocate(a) +!$omp end allocators + +end diff --git a/Fortran/gfortran/regression/gomp/allocators-3.f90 b/Fortran/gfortran/regression/gomp/allocators-3.f90 new file mode 100644 index 000000000..d0e31ee87 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocators-3.f90 @@ -0,0 +1,36 @@ +subroutine f + integer, allocatable :: A1, A2, B(:), C + !$omp declare target + + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) +end + +subroutine g + integer, allocatable :: A1, A2, B(:), C + + !$omp target + !$omp single + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) + !$omp end single + !$omp end target +end diff --git a/Fortran/gfortran/regression/gomp/allocators-4.f90 b/Fortran/gfortran/regression/gomp/allocators-4.f90 new file mode 100644 index 000000000..55ae48d61 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/allocators-4.f90 @@ -0,0 +1,9 @@ +integer, pointer :: ptr + +!$omp allocators allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATORS' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/gomp/atomic-21.f90 b/Fortran/gfortran/regression/gomp/atomic-21.f90 index febcdbbac..35099294d 100644 --- a/Fortran/gfortran/regression/gomp/atomic-21.f90 +++ b/Fortran/gfortran/regression/gomp/atomic-21.f90 @@ -56,7 +56,7 @@ subroutine foobar() endif ! TARGET_EXPR = #pragma omp atomic capture acq_rel -! TARGET_EXPR = NON_LVALUE_EXPR = *TARGET_EXPR == oo> ? pp : *TARGET_EXPR ;, if (TARGET_EXPR ) +! TARGET_EXPR = NON_LVALUE_EXPR = *TARGET_EXPR == oo> ? pp : *TARGET_EXPR , if (TARGET_EXPR ) ! { ! <<< Unknown tree: void_cst >>> ! } @@ -66,7 +66,7 @@ subroutine foobar() ! }; ! ! { dg-final { scan-tree-dump-times "TARGET_EXPR = #pragma omp atomic capture acq_rel" 1 "original" } } -! { dg-final { scan-tree-dump-times "TARGET_EXPR = NON_LVALUE_EXPR = \\*TARGET_EXPR == oo> \\? pp : \\*TARGET_EXPR ;, if \\(TARGET_EXPR \\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = NON_LVALUE_EXPR = \\*TARGET_EXPR == oo> \\? pp : \\*TARGET_EXPR , if \\(TARGET_EXPR \\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "<<< Unknown tree: void_cst >>>" 1 "original" } } ! { dg-final { scan-tree-dump-times "qq = TARGET_EXPR ;" 1 "original" } } diff --git a/Fortran/gfortran/regression/gomp/c_ptr_tests_20.f90 b/Fortran/gfortran/regression/gomp/c_ptr_tests_20.f90 new file mode 100644 index 000000000..777181cec --- /dev/null +++ b/Fortran/gfortran/regression/gomp/c_ptr_tests_20.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! This failed to compile the declare variant directive due to the C_PTR +! arguments to foo being recognised as INTEGER(8) + +program adjust_args + use iso_c_binding, only: c_loc + implicit none + + integer, parameter :: N = 1024 + real, allocatable, target :: av(:), bv(:), cv(:) + + call foo(c_loc(bv), c_loc(av), N) + + !$omp target data map(to: av(:N)) map(from: cv(:N)) + !$omp parallel + call foo(c_loc(cv), c_loc(av), N) + !$omp end parallel + !$omp end target data + +contains + subroutine foo_variant(c_d_bv, c_d_av, n) + use iso_c_binding, only: c_ptr, c_f_pointer + type(c_ptr), intent(in) :: c_d_bv, c_d_av + integer, intent(in) :: n + real, pointer :: f_d_bv(:) + real, pointer :: f_d_av(:) + integer :: i + + call c_f_pointer(c_d_bv, f_d_bv, [n]) + call c_f_pointer(c_d_av, f_d_av, [n]) + !$omp target teams loop is_device_ptr(f_d_bv, f_d_av) + do i = 1, n + f_d_bv(i) = f_d_av(i) * i + end do + end subroutine + + + subroutine foo(c_bv, c_av, n) + use iso_c_binding, only: c_ptr, c_f_pointer + type(c_ptr), intent(in) :: c_bv, c_av + integer, intent(in) :: n + real, pointer :: f_bv(:) + real, pointer :: f_av(:) + integer :: i + !$omp declare variant(foo_variant) & + !$omp match(construct={parallel}) + + call c_f_pointer(c_bv, f_bv, [n]) + call c_f_pointer(c_av, f_av, [n]) + !$omp parallel loop + do i = 1, n + f_bv(i) = f_av(i) * i + end do + end subroutine +end program diff --git a/Fortran/gfortran/regression/gomp/c_ptr_tests_21.f90 b/Fortran/gfortran/regression/gomp/c_ptr_tests_21.f90 new file mode 100644 index 000000000..b41073616 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/c_ptr_tests_21.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! Ensure that C_PTR and C_FUNPTR are reported as incompatible types in variant +! argument lists + +program adjust_args + use iso_c_binding, only: c_loc + implicit none + + integer, parameter :: N = 1024 + real, allocatable, target :: av(:), bv(:), cv(:) + + call foo(c_loc(bv), c_loc(av), N) + + !$omp target data map(to: av(:N)) map(from: cv(:N)) + !$omp parallel + call foo(c_loc(cv), c_loc(av), N) + !$omp end parallel + !$omp end target data + +contains + subroutine foo_variant(c_d_bv, c_d_av, n) + use iso_c_binding, only: c_funptr, c_f_pointer + type(c_funptr), intent(in) :: c_d_bv, c_d_av + integer, intent(in) :: n + real, pointer :: f_d_bv(:) + real, pointer :: f_d_av(:) + integer :: i + +! call c_f_pointer(c_d_bv, f_d_bv, [n]) +! call c_f_pointer(c_d_av, f_d_av, [n]) + !$omp target teams loop is_device_ptr(f_d_bv, f_d_av) + do i = 1, n + f_d_bv(i) = f_d_av(i) * i + end do + end subroutine + + + subroutine foo(c_bv, c_av, n) + use iso_c_binding, only: c_ptr, c_f_pointer + type(c_ptr), intent(in) :: c_bv, c_av + integer, intent(in) :: n + real, pointer :: f_bv(:) + real, pointer :: f_av(:) + integer :: i + !$omp declare variant(foo_variant) & ! { dg-error "variant 'foo_variant' and base 'foo' at .1. have incompatible types: Type mismatch in argument 'c_bv' .TYPE.c_ptr./TYPE.c_funptr.." } + !$omp match(construct={parallel}) + + call c_f_pointer(c_bv, f_bv, [n]) + call c_f_pointer(c_av, f_av, [n]) + !$omp parallel loop + do i = 1, n + f_bv(i) = f_av(i) * i + end do + end subroutine +end program diff --git a/Fortran/gfortran/regression/gomp/collapse1.f90 b/Fortran/gfortran/regression/gomp/collapse1.f90 index 77b2bdd7f..613f06f6e 100644 --- a/Fortran/gfortran/regression/gomp/collapse1.f90 +++ b/Fortran/gfortran/regression/gomp/collapse1.f90 @@ -31,11 +31,11 @@ subroutine collapse1 do i = 1, 3 do j = 4, 6 end do - k = 4 ! { dg-error "loops not perfectly nested" } + k = 4 end do - !$omp parallel do collapse(2) + !$omp parallel do collapse(2) ! { dg-error "not enough DO loops" } do i = 1, 3 - do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + do end do end do !$omp parallel do collapse(2) diff --git a/Fortran/gfortran/regression/gomp/collapse2.f90 b/Fortran/gfortran/regression/gomp/collapse2.f90 index 1ab934e3d..9af3b6568 100644 --- a/Fortran/gfortran/regression/gomp/collapse2.f90 +++ b/Fortran/gfortran/regression/gomp/collapse2.f90 @@ -6,24 +6,24 @@ program p do j = 1, 8 do k = 1, 8 end do - x = 5 ! { dg-error "loops not perfectly nested" } + x = 5 end do end do - !$omp parallel do ordered(3) + !$omp parallel do ordered(3) ! { dg-error "inner loops must be perfectly nested" } do i = 1, 8 do j = 1, 8 do k = 1, 8 end do end do - x = 5 ! { dg-error "loops not perfectly nested" } + x = 5 end do - !$omp parallel do collapse(2) ! { dg-error "not enough DO loops for collapsed" } + !$omp parallel do collapse(2) do i = 1, 8 x = 5 do j = 1, 8 end do end do - !$omp parallel do ordered(2) ! { dg-error "not enough DO loops for collapsed" } + !$omp parallel do ordered(2) ! { dg-error "inner loops must be perfectly nested" } do i = 1, 8 x = 5 do j = 1, 8 diff --git a/Fortran/gfortran/regression/gomp/declare-simd-2.f90 b/Fortran/gfortran/regression/gomp/declare-simd-2.f90 index bbf70d966..8f76774fd 100644 --- a/Fortran/gfortran/regression/gomp/declare-simd-2.f90 +++ b/Fortran/gfortran/regression/gomp/declare-simd-2.f90 @@ -1,6 +1,6 @@ ! { dg-do compile } -function f1 (a, b, c, d, e, f) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +function f1 (a, b, c, d, e, f) integer, value :: a, b, c integer :: d, e, f, f1 !$omp declare simd (f1) uniform(b) linear(c, d) linear(uval(e)) linear(ref(f)) @@ -12,7 +12,7 @@ function f1 (a, b, c, d, e, f) ! { dg-warning "GCC does not currently support mi f = f + 1 f1 = a + b + c + d + e + f end function f1 -integer function f2 (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +integer function f2 (a, b) integer :: a, b !$omp declare simd uniform(b) linear(ref(a):b) a = a + 1 diff --git a/Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 b/Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 index f0c4e39ef..1f74da76f 100644 --- a/Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 +++ b/Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 @@ -5,7 +5,7 @@ ! Failed as TREE_TYPE(fndecl) did not include the ! hidden caf_token/caf_offset arguments. ! -integer function f(x) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +integer function f(x) integer :: x[*] !$omp declare simd f = x[1] diff --git a/Fortran/gfortran/regression/gomp/declare-target-4.f90 b/Fortran/gfortran/regression/gomp/declare-target-4.f90 index 4f5de4bd8..55534d8fe 100644 --- a/Fortran/gfortran/regression/gomp/declare-target-4.f90 +++ b/Fortran/gfortran/regression/gomp/declare-target-4.f90 @@ -2,7 +2,7 @@ ! { dg-additional-options "-fdump-tree-original" } subroutine f1 - !$omp declare target device_type (any) ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE clause is ignored" } + !$omp declare target device_type (any) ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE or INDIRECT clauses is ignored" } end subroutine subroutine f2 diff --git a/Fortran/gfortran/regression/gomp/declare-target-indirect-1.f90 b/Fortran/gfortran/regression/gomp/declare-target-indirect-1.f90 new file mode 100644 index 000000000..504c1a298 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/declare-target-indirect-1.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m + integer :: a + integer, parameter :: X = 1 + integer, parameter :: Y = 2 + + ! Indirect on a variable should have no effect. + integer :: z + !$omp declare target to (z) indirect +contains + subroutine sub1 + !$omp declare target indirect to (sub1) + end subroutine + + subroutine sub2 + !$omp declare target enter (sub2) indirect (.true.) + end subroutine + + subroutine sub3 + !$omp declare target to (sub3) indirect (.false.) + end subroutine + + subroutine sub4 + !$omp declare target to (sub4) indirect (1) ! { dg-error "INDIRECT clause at .1. requires a constant logical expression" } + end subroutine + + ! Compile-time non-constant expressions are not allowed. + subroutine sub5 + !$omp declare target indirect (a > 0) to (sub5) ! { dg-error "INDIRECT clause at .1. requires a constant logical expression" } + end subroutine + + ! Compile-time constant expressions are permissible. + subroutine sub6 + !$omp declare target indirect (X .eq. Y) to (sub6) + end subroutine + + subroutine sub7 + !$omp declare target indirect ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE or INDIRECT clauses is ignored" } + end subroutine + + subroutine sub8 + !$omp declare target indirect (.true.) indirect (.false.) to (sub8) ! { dg-error "Duplicated .indirect. clause at .1." } + end subroutine + + subroutine sub9 + !$omp declare target to (sub9) indirect ("abs") ! { dg-error "INDIRECT clause at .1. requires a constant logical expression" } + end subroutine + + subroutine sub10 + !$omp declare target to (sub10) indirect (5.5) ! { dg-error "INDIRECT clause at .1. requires a constant logical expression" } + end subroutine + + subroutine sub11 + !$omp declare target indirect (.true.) device_type (host) enter (sub11) ! { dg-error "DEVICE_TYPE must be ANY when used with INDIRECT at .1." } + end subroutine + + subroutine sub12 + !$omp declare target indirect (.false.) device_type (nohost) enter (sub12) + end subroutine +end module diff --git a/Fortran/gfortran/regression/gomp/declare-target-indirect-2.f90 b/Fortran/gfortran/regression/gomp/declare-target-indirect-2.f90 new file mode 100644 index 000000000..f6b3ae178 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/declare-target-indirect-2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m +contains + subroutine sub1 + !$omp declare target indirect enter (sub1) + end subroutine + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target, omp declare target indirect\\\)\\\)\\\n.*\\\nvoid sub1" "gimple" } } + + subroutine sub2 + !$omp declare target indirect (.false.) to (sub2) + end subroutine + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub2" "gimple" } } + + subroutine sub3 + !$omp declare target indirect (.true.) to (sub3) + end subroutine + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target, omp declare target indirect\\\)\\\)\\\n.*\\\nvoid sub3" "gimple" } } + + subroutine sub4 + !$omp declare target indirect (.false.) enter (sub4) + end subroutine + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub4" "gimple" } } +end module diff --git a/Fortran/gfortran/regression/gomp/declare-variant-1.f90 b/Fortran/gfortran/regression/gomp/declare-variant-1.f90 index de09dbfe8..9b68397d1 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-1.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-1.f90 @@ -20,11 +20,12 @@ integer function baz (a, b, c) !$omp & match (construct={parallel,do}, & !$omp & device={isa(avx512f,avx512vl),kind(host,cpu)}, & !$omp & implementation={vendor(score(0):gnu),unified_shared_memory}, & - !$omp & user={condition(score(0):0)}) + !$omp & user={condition(score(0):.false.)}) !$omp declare variant (bar) & !$omp & match (device={arch(x86_64,powerpc64),isa(avx512f,popcntb)}, & !$omp & implementation={atomic_default_mem_order(seq_cst),made_up_selector("foo", 13, "bar")}, & - !$omp & user={condition(3-3)}) + !$omp & user={condition(.true. .AND. (.not. .true.))}) +! { dg-warning "unknown selector 'made_up_selector'" "" { target *-*-* } .-2 } end function subroutine quux diff --git a/Fortran/gfortran/regression/gomp/declare-variant-11.f90 b/Fortran/gfortran/regression/gomp/declare-variant-11.f90 index 3593c9a5b..15b6901a0 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-11.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-11.f90 @@ -49,8 +49,8 @@ subroutine f12 () subroutine f13 () !$omp declare variant (f10) match (device={isa("avx512f")}) - !$omp declare variant (f11) match (user={condition(1)},device={isa(avx512f)},implementation={vendor(gnu)}) - !$omp declare variant (f12) match (user={condition(2 + 1)},device={isa(avx512f)}) + !$omp declare variant (f11) match (user={condition(.true.)},device={isa(avx512f)},implementation={vendor(gnu)}) + !$omp declare variant (f12) match (user={condition(.true. .NEQV. .false.)},device={isa(avx512f)}) end subroutine subroutine f14 () diff --git a/Fortran/gfortran/regression/gomp/declare-variant-12.f90 b/Fortran/gfortran/regression/gomp/declare-variant-12.f90 index 2fd8abd0d..f1b4a2280 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-12.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-12.f90 @@ -17,7 +17,7 @@ subroutine f03 () subroutine f04 () !$omp declare variant (f01) match (device={isa("avx512f","avx512vl")}) ! 16 !$omp declare variant (f02) match (implementation={vendor(score(15):gnu)}) - !$omp declare variant (f03) match (user={condition(score(11):1)}) + !$omp declare variant (f03) match (user={condition(score(11):.true.)}) end subroutine subroutine f05 () @@ -32,7 +32,7 @@ subroutine f07 () subroutine f08 () !$omp declare variant (f05) match (device={isa(avx512f,avx512vl)}) ! 16 !$omp declare variant (f06) match (implementation={vendor(score(15):gnu)}) - !$omp declare variant (f07) match (user={condition(score(17):1)}) + !$omp declare variant (f07) match (user={condition(score(17):.true.)}) end subroutine subroutine f09 () @@ -48,7 +48,7 @@ subroutine f12 () end subroutine subroutine f13 () - !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):1)}) ! 64+65 + !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):.true.)}) ! 64+65 !$omp declare variant (f10) match (implementation={vendor(score(127):"gnu")}) !$omp declare variant (f11) match (device={isa(ssse3)}) ! 128 !$omp declare variant (f12) match (implementation={atomic_default_mem_order(score(126):seq_cst)}) @@ -65,7 +65,7 @@ subroutine f16 () subroutine f17 () !$omp declare variant (f14) match (construct={teams,parallel,do}) ! 16+8+4 - !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):1)}) ! 8+19 + !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):.true.)}) ! 8+19 !$omp declare variant (f16) match (implementation={atomic_default_mem_order(score(27):seq_cst)}) end subroutine @@ -80,7 +80,7 @@ subroutine f20 () subroutine f21 () !$omp declare variant (f18) match (construct={teams,parallel,do}) ! 16+8+4 - !$omp declare variant (f19) match (construct={do},user={condition(score(25):1)}) ! 4+25 + !$omp declare variant (f19) match (construct={do},user={condition(score(25):.true.)}) ! 4+25 !$omp declare variant (f20) match (implementation={atomic_default_mem_order(score(28):seq_cst)}) end subroutine @@ -110,7 +110,7 @@ subroutine f28 () subroutine f29 () !$omp declare variant (f26) match (construct={parallel,do}) ! 2+1 - !$omp declare variant (f27) match (construct={do},user={condition(1)}) ! 4 + !$omp declare variant (f27) match (construct={do},user={condition(.true.)}) ! 4 !$omp declare variant (f28) match (implementation={atomic_default_mem_order(score(3):seq_cst)}) end subroutine diff --git a/Fortran/gfortran/regression/gomp/declare-variant-13.f90 b/Fortran/gfortran/regression/gomp/declare-variant-13.f90 index 91648f9bc..97484a63d 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-13.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-13.f90 @@ -30,7 +30,7 @@ integer function f05 (x) !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8 !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3 - !$omp declare variant (f03) match (user={condition(score(9):1)}) + !$omp declare variant (f03) match (user={condition(score(9):.true.)}) !$omp declare variant (f04) match (implementation={vendor(score(6):gnu)},device={kind(host)}) ! (1 or 2) + 6 f05 = x end function diff --git a/Fortran/gfortran/regression/gomp/declare-variant-14.f90 b/Fortran/gfortran/regression/gomp/declare-variant-14.f90 index 06c9a5d1e..6319df055 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-14.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-14.f90 @@ -35,13 +35,15 @@ integer function test1 (x) integer :: a, b ! At gimplification time, we can't decide yet which function to call. - ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" } } + ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" { target { !aarch64*-*-* } } } } ! After simd clones are created, the original non-clone test1 shall ! call f03 (score 6), the sse2/avx/avx2 clones too, but avx512f clones ! shall call f01 with score 8. ! { dg-final { scan-tree-dump-not "f04 \\\(x" "optimized" } } - ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" } } - ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" } } + ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" { target { !aarch64*-*-* } } } } + ! { dg-final { scan-tree-dump-times "f03 \\\(x" 6 "optimized" { target { aarch64*-*-* } } } } + ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" { target { !aarch64*-*-* } } } } + ! { dg-final { scan-tree-dump-times "f01 \\\(x" 0 "optimized" { target { aarch64*-*-* } } } } a = f04 (x) b = f04 (x) test1 = a + b diff --git a/Fortran/gfortran/regression/gomp/declare-variant-2.f90 b/Fortran/gfortran/regression/gomp/declare-variant-2.f90 index 63d777801..7fc5071fe 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-2.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-2.f90 @@ -15,7 +15,7 @@ subroutine f4 () !$omp declare variant () ! { dg-error "" } end subroutine subroutine f5 () - !$omp declare variant match(user={condition(0)}) ! { dg-error "expected '\\(' at .1." } + !$omp declare variant match(user={condition(.false.)}) ! { dg-error "expected '\\(' at .1." } end subroutine subroutine f6 () !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." } @@ -27,16 +27,16 @@ subroutine f8 () !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." } end subroutine subroutine f9 () - !$omp declare variant (f1) match( ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + !$omp declare variant (f1) match( ! { dg-error "expected context selector set name at .1." } end subroutine subroutine f10 () - !$omp declare variant (f1) match() ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + !$omp declare variant (f1) match() ! { dg-error "expected context selector set name at .1." } end subroutine subroutine f11 () - !$omp declare variant (f1) match(foo) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + !$omp declare variant (f1) match(foo) ! { dg-error "expected context selector set name at .1." } end subroutine subroutine f12 () - !$omp declare variant (f1) match(something={something}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + !$omp declare variant (f1) match(something={something}) ! { dg-error "expected context selector set name at .1." } end subroutine subroutine f13 () !$omp declare variant (f1) match(user) ! { dg-error "expected '=' at .1." } @@ -66,13 +66,13 @@ subroutine f21 () !$omp declare variant (f1) match(user={condition(f1)}) ! { dg-error "expected expression at .1." } end subroutine subroutine f22 () - !$omp declare variant (f1) match(user={condition(1, 2, 3)}) ! { dg-error "expected '\\)' at .1." } + !$omp declare variant (f1) match(user={condition(.false., .true., .false.)}) ! { dg-error "expected '\\)' at .1." } end subroutine subroutine f23 () - !$omp declare variant (f1) match(construct={master}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={master}) ! { dg-warning "unknown selector 'master' for context selector set 'construct'" } end subroutine subroutine f24 () - !$omp declare variant (f1) match(construct={teams,parallel,master,do}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={teams,parallel,master,do}) ! { dg-warning "unknown selector 'master' for context selector set 'construct'" } end subroutine subroutine f25 () !$omp declare variant (f1) match(construct={parallel(1 ! { dg-error "selector 'parallel' does not accept any properties at .1." } @@ -105,10 +105,10 @@ subroutine f40 () !$omp declare variant (f1) match(device={arch(17)}) ! { dg-error "expected identifier or string literal at .1." } end subroutine subroutine f41 () - !$omp declare variant (f1) match(device={foobar(3)}) + !$omp declare variant (f1) match(device={foobar(3)}) ! { dg-warning "unknown selector 'foobar' for context selector set 'device' at .1." } end subroutine subroutine f43 () - !$omp declare variant (f1) match(implementation={foobar(3)}) + !$omp declare variant (f1) match(implementation={foobar(3)}) ! { dg-warning "unknown selector 'foobar' for context selector set 'implementation' at .1." } end subroutine subroutine f44 () !$omp declare variant (f1) match(implementation={vendor}) ! { dg-error "expected '\\(' at .1." } @@ -141,46 +141,46 @@ subroutine f56 () !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed,seq_cst)}) ! { dg-error "expected '\\)' at .1." } end subroutine subroutine f58 () - !$omp declare variant (f1) match(user={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'user' at .1." } + !$omp declare variant (f1) match(user={foobar(3)}) ! { dg-warning "unknown selector 'foobar' for context selector set 'user' at .1." } end subroutine subroutine f59 () - !$omp declare variant (f1) match(construct={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={foobar(3)}) ! { dg-warning "unknown selector 'foobar' for context selector set 'construct' at .1." } end subroutine subroutine f60 () - !$omp declare variant (f1) match(construct={parallel},foobar={bar}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + !$omp declare variant (f1) match(construct={parallel},foobar={bar}) ! { dg-error "expected context selector set name at .1." } end subroutine subroutine f64 () - !$omp declare variant (f1) match(construct={single}) ! { dg-error "selector 'single' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={single}) ! { dg-warning "unknown selector 'single' for context selector set 'construct' at .1." } end subroutine subroutine f65 () - !$omp declare variant (f1) match(construct={taskgroup}) ! { dg-error "selector 'taskgroup' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={taskgroup}) ! { dg-warning "unknown selector 'taskgroup' for context selector set 'construct' at .1." } end subroutine subroutine f66 () - !$omp declare variant (f1) match(construct={for}) ! { dg-error "selector 'for' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={for}) ! { dg-warning "unknown selector 'for' for context selector set 'construct' at .1." } end subroutine subroutine f67 () - !$omp declare variant (f1) match(construct={threadprivate}) ! { dg-error "selector 'threadprivate' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={threadprivate}) ! { dg-warning "unknown selector 'threadprivate' for context selector set 'construct' at .1." } end subroutine subroutine f68 () - !$omp declare variant (f1) match(construct={critical}) ! { dg-error "selector 'critical' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={critical}) ! { dg-warning "unknown selector 'critical' for context selector set 'construct' at .1." } end subroutine subroutine f69 () - !$omp declare variant (f1) match(construct={task}) ! { dg-error "selector 'task' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={task}) ! { dg-warning "unknown selector 'task' for context selector set 'construct' at .1." } end subroutine subroutine f70 () - !$omp declare variant (f1) match(construct={taskloop}) ! { dg-error "selector 'taskloop' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={taskloop}) ! { dg-warning "unknown selector 'taskloop' for context selector set 'construct' at .1." } end subroutine subroutine f71 () - !$omp declare variant (f1) match(construct={sections}) ! { dg-error "selector 'sections' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={sections}) ! { dg-warning "unknown selector 'sections' for context selector set 'construct' at .1." } end subroutine subroutine f72 () - !$omp declare variant (f1) match(construct={section}) ! { dg-error "selector 'section' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={section}) ! { dg-warning "unknown selector 'section' for context selector set 'construct' at .1." } end subroutine subroutine f73 () - !$omp declare variant (f1) match(construct={workshare}) ! { dg-error "selector 'workshare' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={workshare}) ! { dg-warning "unknown selector 'workshare' for context selector set 'construct' at .1." } end subroutine subroutine f74 () - !$omp declare variant (f1) match(construct={requires}) ! { dg-error "selector 'requires' not allowed for context selector set 'construct' at .1." } + !$omp declare variant (f1) match(construct={requires}) ! { dg-warning "unknown selector 'requires' for context selector set 'construct' at .1." } end subroutine subroutine f75 () !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." } @@ -189,9 +189,9 @@ subroutine f76 () !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." } end subroutine subroutine f77 () - !$omp declare variant (f1) match(user={condition(score(f76):1)}) ! { dg-error "score argument must be constant integer expression at .1." } + !$omp declare variant (f1) match(user={condition(score(f76):.true.)}) ! { dg-error ".score. argument must be constant integer expression at .1." } end subroutine subroutine f78 () - !$omp declare variant (f1) match(user={condition(score(-130):1)}) ! { dg-error "score argument must be non-negative" } + !$omp declare variant (f1) match(user={condition(score(-130):.true.)}) ! { dg-error ".score. argument must be non-negative" } end subroutine end module diff --git a/Fortran/gfortran/regression/gomp/declare-variant-20.f90 b/Fortran/gfortran/regression/gomp/declare-variant-20.f90 new file mode 100644 index 000000000..17fdcb7e8 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/declare-variant-20.f90 @@ -0,0 +1,51 @@ +! PR middle-end/113904 + +module m + implicit none (type, external) + logical, parameter :: parameter_true = .false. + logical :: false_flag = .false. + integer :: my_dev_num +contains + integer function variant1() result(res) + res = 1 + end function + + integer function variant2() result(res) + res = 2 + end function + + integer function variant3() result(res) + res = 3 + end function + + integer function variant4() result(res) + res = 4 + end function + + integer function variant5() result(res) + res = 4 + end function + + integer function variant6() result(res) + res = 4 + end function + + integer function foo() result(res) + ! 'condition' + !$omp declare variant(variant1) match(user={condition(parameter_true)},construct={teams}) ! OK + ! Below: OK since OpenMP 5.1 - but not yet supported: PR middle-end/113904 + !$omp declare variant(variant2) match(user={condition(false_flag)},construct={parallel}) ! { dg-error "property must be a constant logical expression" } + !$omp declare variant(variant3) match(user={condition(1)},construct={target}) ! { dg-error "property must be a constant logical expression" } + + ! 'device_num' + !$omp declare variant(variant4) match(target_device={device_num(0)}) ! OK + !$omp declare variant(variant4) match(target_device={device_num(2)}) ! OK - assuming there are two non-host devices. + !$omp declare variant(variant5) match(target_device={device_num(-1)}) ! OK - omp_initial_device + !$omp declare variant(variant5) match(target_device={device_num(-4)}) ! OK - omp_invalid_device (will never match) + ! OK - but not handled -> PR middle-end/113904 + !$omp declare variant(variant5) match(target_device={device_num(my_device)}) ! { dg-error "property must be a constant integer expression" } + !$omp declare variant(variant5) match(target_device={device_num(-2)}) ! { dg-error "property must be a conforming device number" } + + res = 99 + end +end module m diff --git a/Fortran/gfortran/regression/gomp/declare-variant-2a.f90 b/Fortran/gfortran/regression/gomp/declare-variant-2a.f90 index 56de11777..b44322ac0 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-2a.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-2a.f90 @@ -10,10 +10,10 @@ subroutine f29 () !$omp declare variant (f1) match(construct={parallel},construct={parallel}) ! { dg-error "selector set 'construct' specified more than once" } end subroutine subroutine f30 () - !$omp declare variant (f1) match(user={condition(0)},construct={target},user={condition(0)}) ! { dg-error "selector set 'user' specified more than once" } + !$omp declare variant (f1) match(user={condition(.false.)},construct={target},user={condition(.false.)}) ! { dg-error "selector set 'user' specified more than once" } end subroutine subroutine f31 () - !$omp declare variant (f1) match(user={condition(0)},user={condition(1)}) ! { dg-error "selector set 'user' specified more than once" } + !$omp declare variant (f1) match(user={condition(.false.)},user={condition(.true.)}) ! { dg-error "selector set 'user' specified more than once" } end subroutine subroutine f37 () !$omp declare variant (f1) match(device={kind(unknown)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" } @@ -29,10 +29,10 @@ subroutine f47 () !$omp declare variant (f1) match(implementation={vendor("foobar")}) ! { dg-warning "unknown property '.foobar.' of 'vendor' selector" } end subroutine subroutine f53 () - !$omp declare variant (f1) match(implementation={atomic_default_mem_order(acquire)}) ! { dg-error "incorrect property 'acquire' of 'atomic_default_mem_order' selector" } + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(acquire)}) end subroutine subroutine f54 () - !$omp declare variant (f1) match(implementation={atomic_default_mem_order(release)}) ! { dg-error "incorrect property 'release' of 'atomic_default_mem_order' selector" } + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(release)}) end subroutine subroutine f55 () !$omp declare variant (f1) match(implementation={atomic_default_mem_order(foobar)}) ! { dg-error "incorrect property 'foobar' of 'atomic_default_mem_order' selector" } diff --git a/Fortran/gfortran/regression/gomp/declare-variant-3.f90 b/Fortran/gfortran/regression/gomp/declare-variant-3.f90 index c62622b60..6b23d40e4 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-3.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-3.f90 @@ -210,13 +210,13 @@ subroutine f71 () !$omp& vendor(score(22):gnu),unified_address,extension(score(22):foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 } end subroutine subroutine f72 () - !$omp declare variant (f13) match (user={condition(0)}) + !$omp declare variant (f13) match (user={condition(.false.)}) end subroutine subroutine f73 () - !$omp declare variant (f13) match (user={condition(272-272*1)}) + !$omp declare variant (f13) match (user={condition(.true..and..not..true.)}) end subroutine subroutine f74 () - !$omp declare variant (f13) match (user={condition(score(25):1)}) + !$omp declare variant (f13) match (user={condition(score(25):.true.)}) end subroutine subroutine f75 () !$omp declare variant (f13) match (device={kind(any,"any")}) @@ -231,7 +231,7 @@ subroutine f78 () !$omp declare variant (f13) match (implementation={vendor(nvidia)}) end subroutine subroutine f79 () - !$omp declare variant (f13) match (user={condition(score(0):0)}) + !$omp declare variant (f13) match (user={condition(score(0):.false.)}) end subroutine end module diff --git a/Fortran/gfortran/regression/gomp/declare-variant-4.f90 b/Fortran/gfortran/regression/gomp/declare-variant-4.f90 index bc4f41647..5c7fee235 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-4.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-4.f90 @@ -44,10 +44,10 @@ function f5 (x, y, z) end function end interface - !$omp declare variant (f1) match (user={condition(1)}) - !$omp declare variant (f2) match (user={condition(score(1):1)}) - !$omp declare variant (f3) match (user={condition(score(3):1)}) - !$omp declare variant (f4) match (user={condition(score(2):1)}) + !$omp declare variant (f1) match (user={condition(.true.)}) + !$omp declare variant (f2) match (user={condition(score(1):.true.)}) + !$omp declare variant (f3) match (user={condition(score(3):.true.)}) + !$omp declare variant (f4) match (user={condition(score(2):.true.)}) !$omp declare variant (f5) match (implementation={vendor(gnu)}) f6 = z + x + y diff --git a/Fortran/gfortran/regression/gomp/declare-variant-6.f90 b/Fortran/gfortran/regression/gomp/declare-variant-6.f90 index 3f33f38b9..63a8bd874 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-6.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-6.f90 @@ -24,7 +24,7 @@ function f3 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f1) match (user={condition(0)},construct={parallel}) + !$omp declare variant (f1) match (user={condition(.false.)},construct={parallel}) f3 = 0.0 end function @@ -33,7 +33,7 @@ function f4 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f1) match (construct={parallel},user={condition(score(1):1)}) + !$omp declare variant (f1) match (construct={parallel},user={condition(score(1):.true.)}) f4 = 0.0 end function @@ -50,7 +50,7 @@ function f6 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f5) match (user={condition(0)}) ! { dg-error "'f5' used as a variant with incompatible 'construct' selector sets" } + !$omp declare variant (f5) match (user={condition(.false.)}) ! { dg-error "'f5' used as a variant with incompatible 'construct' selector sets" } f6 = 0.0 end function @@ -59,7 +59,7 @@ function f7 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f5) match (construct={parallel},user={condition(score(1):1)}) + !$omp declare variant (f5) match (construct={parallel},user={condition(score(1):.true.)}) f7 = 0.0 end function @@ -76,7 +76,7 @@ function f9 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f8) match (user={condition(0)},construct={do}) ! { dg-error "'f8' used as a variant with incompatible 'construct' selector sets" } + !$omp declare variant (f8) match (user={condition(.false.)},construct={do}) ! { dg-error "'f8' used as a variant with incompatible 'construct' selector sets" } f9 = 0.0 end function @@ -85,7 +85,7 @@ function f10 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f8) match (user={condition(1)}) + !$omp declare variant (f8) match (user={condition(.true.)}) f10 = 0.0 end function @@ -111,7 +111,7 @@ function f13 (x, y, z) integer, intent(in) :: x integer (kind = 8), intent(in) :: y real :: z - !$omp declare variant (f11) match (user={condition(score(1):1)},construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" } + !$omp declare variant (f11) match (user={condition(score(1):.true.)},construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" } f13 = 0.0 end function diff --git a/Fortran/gfortran/regression/gomp/declare-variant-8.f90 b/Fortran/gfortran/regression/gomp/declare-variant-8.f90 index c751489a5..d69e552ee 100644 --- a/Fortran/gfortran/regression/gomp/declare-variant-8.f90 +++ b/Fortran/gfortran/regression/gomp/declare-variant-8.f90 @@ -23,7 +23,7 @@ subroutine f05 () end subroutine subroutine f06 () - !$omp declare variant (f05) match (user={condition(1)},implementation={atomic_default_mem_order(relaxed)}) + !$omp declare variant (f05) match (user={condition(.true.)},implementation={atomic_default_mem_order(relaxed)}) end subroutine subroutine f07 () diff --git a/Fortran/gfortran/regression/gomp/declare-variant-no-score.f90 b/Fortran/gfortran/regression/gomp/declare-variant-no-score.f90 new file mode 100644 index 000000000..616a34bc8 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/declare-variant-no-score.f90 @@ -0,0 +1,30 @@ +! { dg-do compile { target x86_64-*-* } } +! { dg-additional-options "-foffload=disable" } + +program main +contains + subroutine f01 () + end subroutine + subroutine f02 () + !$omp declare variant (f01) & + !$omp& match (device={kind (score(5) : host)}) + ! { dg-error ".score. cannot be specified in traits in the .device. trait-selector-set" "" { target *-*-*} .-1 } + end subroutine + subroutine f03 () + end subroutine + subroutine f04 () + !$omp declare variant (f03) & + !$omp& match (device={kind (host), arch (score(6) : x86_64), isa (avx512f)}) + ! { dg-error ".score. cannot be specified in traits in the .device. trait-selector-set" "" { target *-*-*} .-1 } + end subroutine + subroutine f05 () + end subroutine + subroutine f06 () + !$omp declare variant (f05) & + !$omp& match (device={kind (host), arch (score(6) : x86_64), & + !$omp& isa (score(7): avx512f)}) + ! { dg-error ".score. cannot be specified in traits in the .device. trait-selector-set" "" { target *-*-*} .-2 } + end subroutine + +end program + diff --git a/Fortran/gfortran/regression/gomp/defaultmap-1.f90 b/Fortran/gfortran/regression/gomp/defaultmap-1.f90 index 299d971f2..5123e078e 100644 --- a/Fortran/gfortran/regression/gomp/defaultmap-1.f90 +++ b/Fortran/gfortran/regression/gomp/defaultmap-1.f90 @@ -2,9 +2,9 @@ implicit none -!$omp target defaultmap(bar) ! { dg-error "25: Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, NONE or DEFAULT" } +!$omp target defaultmap(bar) ! { dg-error "25: Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, PRESENT, NONE or DEFAULT" } -!$omp target defaultmap ( alloc: foo) ! { dg-error "34: Expected SCALAR, AGGREGATE, ALLOCATABLE or POINTER" } +!$omp target defaultmap ( alloc: foo) ! { dg-error "34: Expected SCALAR, AGGREGATE, ALLOCATABLE, POINTER or ALL" } !$omp target defaultmap(alloc:scalar) defaultmap(none:Scalar) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category SCALAR" } diff --git a/Fortran/gfortran/regression/gomp/defaultmap-10.f90 b/Fortran/gfortran/regression/gomp/defaultmap-10.f90 new file mode 100644 index 000000000..7e230d886 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/defaultmap-10.f90 @@ -0,0 +1,116 @@ +subroutine f + implicit none + type t + integer :: i + end type t + integer, target :: scalar + integer, target :: array(5) + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc1, alloc2(:) + type(t) :: agg1, agg2(2) + + scalar = 1 + array = [1,2,3,4,5] + ptr1 => scalar + ptr2 => array + alloc1 = 5 + alloc2 = [1,2] + agg1%i = 1 + agg2(:)%i = [1,2] + + !$omp target defaultmap(firstprivate ) defaultmap(firstprivate : aggregate) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP with unspecified category" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate : all ) defaultmap(alloc : pointer) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category ALL" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate : aggregate) defaultmap(firstprivate ) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category AGGREGATE" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(alloc : pointer) defaultmap(firstprivate : all ) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category POINTER" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate :all ) defaultmap(firstprivate : all) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category ALL" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate ) defaultmap(firstprivate) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP with unspecified category" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate ) defaultmap(firstprivate : all) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP with unspecified category" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + !$omp target defaultmap(firstprivate : all) defaultmap(firstprivate) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category ALL" } + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block +end diff --git a/Fortran/gfortran/regression/gomp/defaultmap-8.f90 b/Fortran/gfortran/regression/gomp/defaultmap-8.f90 new file mode 100644 index 000000000..e26d1e004 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/defaultmap-8.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + implicit none + integer, parameter :: N = 1000 + integer :: a(N), b(N), c(N), i + + ! Should generate implicit 'map(present, alloc)' clauses. + !$omp target defaultmap (present: aggregate) + do i = 1, N + c(i) = a(i) + b(i) + end do + !$omp end target + + ! Should generate implicit 'map(present, alloc)' clauses, + ! and they should go before other non-present clauses. + !$omp target map(from: c) defaultmap (present: aggregate) + do i = 1, N + c(i) = a(i) + b(i) + end do + !$omp end target +end program + +! { dg-final { scan-tree-dump "pragma omp target.*defaultmap\\(present:aggregate\\).*map\\(force_present:c \\\[len: \[0-9\]+\\\]\\\[implicit\\\]\\) map\\(force_present:b \\\[len: \[0-9\]+\\\]\\\[implicit\\\]\\) map\\(force_present:a \\\[len: \[0-9\]+\\\]\\\[implicit\\\]\\)" "gimple" } } +! { dg-final { scan-tree-dump "pragma omp target.*map\\(force_present:b \\\[len: \[0-9\]+\\\]\\\[implicit\\\]\\) map\\(force_present:a \\\[len: \[0-9\]+\\\]\\\[implicit\\\]\\) map\\(from:c \\\[len: \[0-9\]+\\\]\\) defaultmap\\(present:aggregate\\)" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/defaultmap-9.f90 b/Fortran/gfortran/regression/gomp/defaultmap-9.f90 new file mode 100644 index 000000000..b24fc95fc --- /dev/null +++ b/Fortran/gfortran/regression/gomp/defaultmap-9.f90 @@ -0,0 +1,71 @@ +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + +subroutine f + implicit none + type t + integer :: i + end type t + integer, target :: scalar + integer, target :: array(5) + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc1, alloc2(:) + type(t) :: agg1, agg2(2) + + scalar = 1 + array = [1,2,3,4,5] + ptr1 => scalar + ptr2 => array + alloc1 = 5 + alloc2 = [1,2] + agg1%i = 1 + agg2(:)%i = [1,2] + + ! firstprivate + unspecified modifer. + !$omp target defaultmap(firstprivate) + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + ! equivalent: firstprivate + ALL modifer. + !$omp target defaultmap(firstprivate : all) + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block + + ! tofrom + ALL modifer. + !$omp target defaultmap(tofrom : all) + block + scalar = 1; + array(1) = 2; + if (associated(ptr1)) & + agg1%i = 3; + if (associated(ptr2)) & + agg2(1)%i = 3; + if (allocated(alloc1)) & + alloc2(1) = 0 + end block +end subroutine + +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(firstprivate\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(firstprivate:all\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(tofrom:all\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target.* defaultmap\\(firstprivate\\) firstprivate\\(scalar\\) firstprivate\\(ptr2\\) firstprivate\\(ptr1\\) firstprivate\\(array\\) firstprivate\\(alloc2\\) firstprivate\\(alloc1\\) firstprivate\\(agg2\\) firstprivate\\(agg1\\)" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target.* defaultmap\\(firstprivate:all\\) firstprivate\\(scalar\\) firstprivate\\(ptr2\\) firstprivate\\(ptr1\\) firstprivate\\(array\\) firstprivate\\(alloc2\\) firstprivate\\(alloc1\\) firstprivate\\(agg2\\) firstprivate\\(agg1\\)" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target.* defaultmap\\(tofrom:all\\) map\\(tofrom:scalar \\\[len: .\\\]\\\[implicit\\\]\\) map\\(tofrom:.*ptr2.data \\\[len: .*\\\]\\\[implicit\\\]\\) map\\(to:ptr2 \\\[pointer set, len: ..\\\]\\) map\\(always_pointer:.*ptr2.data \\\[pointer assign, bias: 0\\\]\\) map\\(tofrom:\\*ptr1 \\\[len: .\\\]\\\[implicit\\\]\\) map\\(alloc:ptr1 \\\[pointer assign, bias: 0\\\]\\) map\\(tofrom:array \\\[len: ..\\\]\\\[implicit\\\]\\) map\\(tofrom:.*alloc2.data \\\[len: .*\\\]\\\[implicit\\\]\\) map\\(to:alloc2 \\\[pointer set, len: ..\\\]\\) map\\(alloc:.*alloc2.data \\\[pointer assign, bias: 0\\\]\\) map\\(tofrom:\\*alloc1 \\\[len: .\\\]\\\[implicit\\\]\\) map\\(alloc:alloc1 \\\[pointer assign, bias: 0\\\]\\) map\\(tofrom:agg2 \\\[len: .\\\]\\\[implicit\\\]\\) map\\(tofrom:agg1 \\\[len: .\\\]\\\[implicit\\\]\\)" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/depobj-3.f90 b/Fortran/gfortran/regression/gomp/depobj-3.f90 new file mode 100644 index 000000000..8a3625e88 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/depobj-3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile { target { fortran_integer_16 || ilp32 } } } +! omp_depend_kind = 2*intptr_t --> 16 (128 bit) on 64bit-pointer systems +! --> 8 (128 bit) on 32bit-pointer systems +subroutine f1 + !use omp_lib ! N/A in gcc/testsuite + use iso_c_binding, only: c_intptr_t + implicit none + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer :: a, b + integer(kind=omp_depend_kind) :: depobj, depobj1(5), depobj2 + + !$omp depobj(depobj) destroy + + !$omp depobj(depobj) destroy( depobj) + + !$omp depobj(depobj) destroy( depobj2) ! { dg-warning "The same depend object should be used as DEPOBJ argument at .1. and as DESTROY argument at .2." } + !$omp depobj(depobj) destroy( a) ! { dg-warning "The same depend object should be used as DEPOBJ argument at .1. and as DESTROY argument at .2." } +end diff --git a/Fortran/gfortran/regression/gomp/gomp.exp b/Fortran/gfortran/regression/gomp/gomp.exp index 43840b284..585ca94c6 100644 --- a/Fortran/gfortran/regression/gomp/gomp.exp +++ b/Fortran/gfortran/regression/gomp/gomp.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# Copyright (C) 2005-2024 Free Software Foundation, Inc. # # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/gomp/imperfect-gotos.f90 b/Fortran/gfortran/regression/gomp/imperfect-gotos.f90 new file mode 100644 index 000000000..e184ffe63 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect-gotos.f90 @@ -0,0 +1,69 @@ +! This test case is expected to fail due to errors. + +! These jumps are all OK since they are to/from the same structured block. +subroutine f1 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 10 +10 continue + do j = 1, 64 + go to 11 +11 continue + end do + go to 12 +12 continue + end do +end subroutine + +! Jump around loop body to/from different structured blocks of intervening +! code. +subroutine f2 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 20 +20 continue + if (i > 16) go to 22 ! { dg-error "invalid branch to/from OpenMP structured block" } + do j = 1, 64 + go to 21 +21 continue + end do + go to 22 +22 continue + end do +end subroutine + +! Jump into loop body from intervening code. +subroutine f3 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 30 +30 continue + if (i > 16) go to 31 ! { dg-error "invalid branch to/from OpenMP structured block" } + ! { dg-warning "Legacy Extension:" "" { target *-*-* } .-1 } + do j = 1, 64 + go to 31 +31 continue ! { dg-warning "Legacy Extension:" } + end do + go to 32 +32 continue + end do +end subroutine + +! Jump out of loop body to intervening code. +subroutine f4 () + integer :: i, j + !$omp do collapse(2) + do i = 1, 64 + go to 40 +40 continue + do j = 1, 64 + if (i > 16) go to 41 ! { dg-error "invalid branch to/from OpenMP structured block" } + end do +41 continue + go to 42 +42 continue + end do +end subroutine diff --git a/Fortran/gfortran/regression/gomp/imperfect-invalid-scope.f90 b/Fortran/gfortran/regression/gomp/imperfect-invalid-scope.f90 new file mode 100644 index 000000000..7cc609441 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect-invalid-scope.f90 @@ -0,0 +1,81 @@ +! Test that various errors involving references to variables bound +! in intervening code in the DO loop control expressions are diagnosed. + +subroutine foo (x, y) + integer :: x, y +end subroutine + +subroutine f1 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = v, 64 ! { dg-error "loop start expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f2 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = 1, v ! { dg-error "loop end expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f3 () + integer :: i, j + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: v + v = (i + 4) * 2 + do j = 1, 64, v ! { dg-error "loop increment expression at .1. uses variable bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f4 () + integer :: i + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: j + do j = 1, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine + +subroutine f5 () + integer :: i + + !$omp do collapse (2) + do i = 1, 64 + block + integer :: j + integer :: v + v = (i + 4) * 2 + do j = v, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" } + call foo (i, j) + end do + end block + end do +end subroutine diff --git a/Fortran/gfortran/regression/gomp/imperfect1.f90 b/Fortran/gfortran/regression/gomp/imperfect1.f90 new file mode 100644 index 000000000..4e750d9ad --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect1.f90 @@ -0,0 +1,39 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + if (i == 3) then + cycle ! { dg-error "CYCLE statement" } + else + exit ! { dg-error "EXIT statement" } + endif +!$omp barrier ! { dg-error "OpenMP directive in intervening code" } + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + do k = 1, a3 ! { dg-error "loop in intervening code" } + call f1 (3, k) + call f2 (3, k) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/Fortran/gfortran/regression/gomp/imperfect2.f90 b/Fortran/gfortran/regression/gomp/imperfect2.f90 new file mode 100644 index 000000000..d02191050 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect2.f90 @@ -0,0 +1,56 @@ +! This test case is expected to fail due to errors. + +! Note that the calls to these functions in the test case don't make +! any sense in terms of behavior, they're just there to test the error +! behavior. + +module omp_lib + use iso_c_binding + interface + integer function omp_get_thread_num () + end + subroutine omp_set_max_levels (i) + integer :: i + end + end interface +end module + +program junk + use omp_lib + implicit none + +contains + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + integer :: m + + !$omp do collapse(3) + do i = 1, a1 + call f1 (1, i) + m = omp_get_thread_num () ! { dg-error "OpenMP API call in intervening code" } + do j = 1, a2 + omp_get_thread_num () ! This is OK + call f1 (2, j) + do k = 1, a3 + call f1 (m, k) + call omp_set_max_active_levels (k) ! This is OK too + call f2 (m, k) + end do + call f2 (2, j) + call omp_set_max_active_levels (i) ! { dg-error "OpenMP API call in intervening code" } + end do + call f2 (1, i) + end do +end subroutine + +end program diff --git a/Fortran/gfortran/regression/gomp/imperfect3.f90 b/Fortran/gfortran/regression/gomp/imperfect3.f90 new file mode 100644 index 000000000..aa26a4909 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect3.f90 @@ -0,0 +1,45 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + ! This loop without intervening code ought to be OK. + !$omp do ordered(3) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + !$omp ordered doacross(source:omp_cur_iteration) + !$omp ordered doacross(sink: i - 2, j + 2, k - 1) + end do + end do + end do + + ! Adding intervening code should make it error. + !$omp do ordered(3) ! { dg-error "inner loops must be perfectly nested" } + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 + call f1 (3, k) + call f2 (3, k) + !$omp ordered doacross(source:omp_cur_iteration) + !$omp ordered doacross(sink: i - 2, j + 2, k - 1) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/Fortran/gfortran/regression/gomp/imperfect4.f90 b/Fortran/gfortran/regression/gomp/imperfect4.f90 new file mode 100644 index 000000000..b7ccd8b6c --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect4.f90 @@ -0,0 +1,36 @@ +! This test case is expected to fail due to errors. + +subroutine f1 (depth, iter) + integer :: depth, iter +end subroutine + +subroutine f2 (depth, iter) + integer :: depth, iter +end subroutine + +! Unlike the C/C++ front ends, the Fortran front end already has the whole +! parse tree for the OMP DO construct before doing error checking on it. +! It gives up immediately if there are not enough nested loops for the +! specified COLLAPSE depth, without error-checking intervening code. + +subroutine s1 (a1, a2, a3) + integer :: a1, a2, a3 + integer :: i, j, k + + !$omp do collapse(4) ! { dg-error "not enough DO loops" } + do i = 1, a1 + call f1 (1, i) + do j = 1, a2 + call f1 (2, j) + do k = 1, a3 +! This is not valid intervening code, but the above error takes precedence. +!$omp barrier + call f1 (3, k) + call f2 (3, k) + end do + call f2 (2, j) + end do + call f2 (1, i) + end do + +end subroutine diff --git a/Fortran/gfortran/regression/gomp/imperfect5.f90 b/Fortran/gfortran/regression/gomp/imperfect5.f90 new file mode 100644 index 000000000..d71073563 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/imperfect5.f90 @@ -0,0 +1,85 @@ +! This test case is expected to fail due to errors. + +module mm + +implicit none +integer, parameter :: N = 30 +integer, parameter :: M = 3 + +integer :: a(M,N), b(M,N), c(M,N) + +contains + +subroutine dostuff (index, flag) + integer :: index, flag +end subroutine + +! These functions should compile without error. +subroutine good1 () + integer :: i, j, x, shift + + x = 0 + !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) + do i = 1, N + do j = 1, M + x = x + a(j,i) + x = x + b(j,i) + !$omp scan inclusive(x) + shift = i + 29*j + c(j,i) = x + shift; + end do + end do +end subroutine + +subroutine good2 () + integer :: i, j, x, shift + + x = 0 + !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) + do i = 1, N + do j = 1, M + shift = i + 29*j + c(j,i) = x + shift; + !$omp scan exclusive(x) + x = x + a(j,i) + x = x + b(j,i) + end do + end do +end subroutine + +! Adding intervening code should trigger an error. +subroutine bad1 () + integer :: i, j, x, shift + + x = 0 + !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) ! { dg-error "inner loops must be perfectly nested" } + do i = 1, N + call dostuff (i, 0) + do j = 1, M + x = x + a(j,i) + x = x + b(j,i) + !$omp scan inclusive(x) + shift = i + 29*j + c(j,i) = x + shift; + end do + end do +end subroutine + +subroutine bad2 () + integer :: i, j, x, shift + + x = 0 + !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) ! { dg-error "inner loops must be perfectly nested" } + do i = 1, N + do j = 1, M + shift = i + 29*j + c(j,i) = x + shift; + !$omp scan exclusive(x) + x = x + a(j,i) + x = x + b(j,i) + end do + call dostuff (i, 1) + end do +end subroutine + +end module \ No newline at end of file diff --git a/Fortran/gfortran/regression/gomp/inner-loops-1.f90 b/Fortran/gfortran/regression/gomp/inner-loops-1.f90 new file mode 100644 index 000000000..00a2b8ac5 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/inner-loops-1.f90 @@ -0,0 +1,60 @@ +subroutine test1 + !$omp parallel do collapse(2) + do i=0,100 + !$omp unroll partial(2) + do j=-300,100 + call dummy (j) + end do + end do +end subroutine test1 + +subroutine test3 + !$omp parallel do collapse(3) + do i=0,100 + do j=-300,100 + !$omp unroll partial(2) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test3 + +subroutine test6 + !$omp parallel do collapse(3) + do i=0,100 + !$omp tile sizes(3,2) + do j=-300,100 + !$omp unroll partial(2) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test6 + +subroutine test7 + !$omp parallel do collapse(3) + do i=0,100 + !$omp tile sizes(3,3) + do j=-300,100 + !$omp tile sizes(5) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test7 + +subroutine test8 + !$omp parallel do collapse(1) + do i=0,100 + !$omp tile sizes(3,3) + do j=-300,100 + !$omp tile sizes(5) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test8 diff --git a/Fortran/gfortran/regression/gomp/inner-loops-2.f90 b/Fortran/gfortran/regression/gomp/inner-loops-2.f90 new file mode 100644 index 000000000..35f44db1c --- /dev/null +++ b/Fortran/gfortran/regression/gomp/inner-loops-2.f90 @@ -0,0 +1,62 @@ +subroutine test2 + !$omp parallel do collapse(3) + do i=0,100 + !$omp unroll partial(2) ! { dg-error "UNROLL construct at \\\(1\\\) with PARTIAL clause generates just one loop with canonical form but 2 loops are needed" } + do j=-300,100 + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test2 + +subroutine test4 + !$omp parallel do collapse(3) + do i=0,100 + !$omp tile sizes(3) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do j=-300,100 + !$omp unroll partial(2) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test4 + +subroutine test5 + !$omp parallel do collapse(3) + !$omp tile sizes(3,2) ! { dg-error "TILE construct at \\\(1\\\) generates 2 loops with canonical form but 3 loops are needed" } + do i=0,100 + do j=-300,100 + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test5 + +subroutine test9 + !$omp parallel do collapse(3) + do i=0,100 + !$omp tile sizes(3,3,3) + do j=-300,100 + !$omp tile sizes(5) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test9 + +subroutine test10 + !$omp parallel do + do i=0,100 + !$omp tile sizes(3,3,3) + do j=-300,100 + !$omp tile sizes(5) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test10 diff --git a/Fortran/gfortran/regression/gomp/linear-2.f90 b/Fortran/gfortran/regression/gomp/linear-2.f90 index 05f007fd5..88df96e9b 100644 --- a/Fortran/gfortran/regression/gomp/linear-2.f90 +++ b/Fortran/gfortran/regression/gomp/linear-2.f90 @@ -105,8 +105,8 @@ subroutine foo (x,y) ! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 6 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp for linear\\(x:D\\.\[0-9\]+\\) nowait" 1 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp for linear\\(x:val,step\\(D\\.\[0-9\]+\\)\\) nowait" 1 "original" } } -! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(count\\.\[0-9\]:1\\) linear\\(i:3\\)" 2 "original" } } -! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(count\\.\[0-9\]:1\\) linear\\(i:val,step\\(3\\)\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:3\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:val,step\\(3\\)\\)" 2 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) linear\\(x:D\\.\[0-9\]+\\)" 2 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) linear\\(x:val,step\\(D\\.\[0-9\]+\\)\\)" 2 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:D\\.\[0-9\]+\\)" 2 "original" } } diff --git a/Fortran/gfortran/regression/gomp/loop-2.f90 b/Fortran/gfortran/regression/gomp/loop-2.f90 index 2d83e3a75..92a17b247 100644 --- a/Fortran/gfortran/regression/gomp/loop-2.f90 +++ b/Fortran/gfortran/regression/gomp/loop-2.f90 @@ -18,23 +18,23 @@ subroutine foo() end do !$omp loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp teams loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp parallel loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp target teams loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp target parallel loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do diff --git a/Fortran/gfortran/regression/gomp/map-10.f90 b/Fortran/gfortran/regression/gomp/map-10.f90 new file mode 100644 index 000000000..c12bf25ad --- /dev/null +++ b/Fortran/gfortran/regression/gomp/map-10.f90 @@ -0,0 +1,69 @@ +! { dg-additional-options "-fdump-tree-omplower" } + +! If enter data adds a (GOMP_MAP_)POINTER attachment, exit data needs to remove +! it again. If not there can be all kind of issues, in particular when +! stack memory was mapped, reused later and mapped again. + +subroutine test_aa (aa2, aa3) + integer(kind=4), allocatable :: aa1, aa2, aa3 + optional :: aa3 + !$omp target enter data map(aa1) + !$omp target exit data map(aa1) + !$omp target enter data map(aa2) + !$omp target exit data map(aa2) + !$omp target enter data map(aa3) + !$omp target exit data map(aa3) +end + +subroutine test_pp (pp2, pp3) + integer(kind=4), allocatable :: pp1, pp2, pp3 + optional :: pp3 + !$omp target enter data map(pp1) + !$omp target exit data map(pp1) + !$omp target enter data map(pp2) + !$omp target exit data map(pp2) + !$omp target enter data map(pp3) + !$omp target exit data map(pp3) +end + +subroutine test_pprelease (rp2, rp3) + integer(kind=4), allocatable :: rp1, rp2, rp3 + optional :: rp3 + !$omp target enter data map(rp1) + !$omp target exit data map(release:rp1) + !$omp target enter data map(rp2) + !$omp target exit data map(release:rp2) + !$omp target enter data map(rp3) + !$omp target exit data map(release:rp3) +end + +subroutine test_ppdelete (dp2, dp3) + integer(kind=4), allocatable :: dp1, dp2, dp3 + optional :: dp3 + !$omp target enter data map(dp1) + !$omp target exit data map(delete:dp1) + !$omp target enter data map(dp2) + !$omp target exit data map(delete:dp2) + !$omp target enter data map(dp3) + !$omp target exit data map(delete:dp3) +end + + +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*aa1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:aa1 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*aa1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:aa1 \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*_\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:\\*aa2.\[0-9\]+_\[0-9\]+ \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:aa2 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*_\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:aa2 \\\[len: .\\\]\\) map\\(release:\\*aa2.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:\\*aa3.\[0-9\]+_\[0-9\]+ \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:aa3 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:aa3 \\\[len: .\\\]\\) map\\(release:\\*aa3.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*pp1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:pp1 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*pp1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:pp1 \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*_\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:\\*pp2.\[0-9\]+_\[0-9\]+ \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:pp2 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*_\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:pp2 \\\[len: .\\\]\\) map\\(release:\\*pp2.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(to:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(alloc:\\*pp3.\[0-9\]+_\[0-9\]+ \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:pp3 \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(from:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:pp3 \\\[len: .\\\]\\) map\\(release:\\*pp3.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(release:rp1 \\\[len: .\\\]\\) map\\(release:\\*rp1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(release:rp2 \\\[len: .\\\]\\) map\\(release:\\*rp2.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\) map\\(release:\\*_\[0-9\]+ \\\[len: 4\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(release:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(release:rp3 \\\[len: .\\\]\\) map\\(release:\\*rp3.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(delete:dp1 \\\[len: .\\\]\\) map\\(delete:\\*dp1.\[0-9\]+_\[0-9\]+ \\\[len: 4\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(delete:dp2 \\\[len: .\\\]\\) map\\(delete:\\*dp2.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\) map\\(delete:\\*_\[0-9\]+ \\\[len: 4\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(delete:\\*D.\[0-9\]+ \\\[len: 4\\\]\\) map\\(delete:dp3 \\\[len: .\\\]\\) map\\(delete:\\*dp3.\[0-9\]+_\[0-9\]+ \\\[len: .\\\]\\)" "omplower" } } diff --git a/Fortran/gfortran/regression/gomp/map-11.f90 b/Fortran/gfortran/regression/gomp/map-11.f90 new file mode 100644 index 000000000..7ef9d46f2 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/map-11.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + implicit none + integer, parameter :: N = 1000 + integer :: a(N), b(N), c(N), i + + ! Should be able to parse 'present' map modifier. + !$omp target enter data map (present, to: a, b) + + !$omp target data map (present, to: a, b) map (always, present, from: c) + !$omp target map (present, to: a, b) map (present, from: c) + do i = 1, N + c(i) = a(i) + b(i) + end do + !$omp end target + !$omp end target data + + !$omp target exit data map (always, present, from: c) + + ! Map clauses with 'present' modifier should go ahead of those without. + !$omp target map (to: a) map (present, to: b) map (from: c) + do i = 1, N + c(i) = a(i) + b(i) + end do + !$omp end target +end program + +! { dg-final { scan-tree-dump "pragma omp target enter data map\\(force_present:a \\\[len: \[0-9\]+\\\]\\) map\\(force_present:b \\\[len: \[0-9\]+\\\]\\)" "gimple" } } +! { dg-final { scan-tree-dump "pragma omp target data map\\(force_present:a \\\[len: \[0-9\]+\\\]\\) map\\(force_present:b \\\[len: \[0-9\]+\\\]\\) map\\(always,present,from:c \\\[len: \[0-9\]+\\\]\\)" "gimple" } } +! { dg-final { scan-tree-dump "pragma omp target.*map\\(force_present:a \\\[len: \[0-9\]+\\\]\\) map\\(force_present:b \\\[len: \[0-9\]+\\\]\\) map\\(force_present:c \\\[len: \[0-9\]+\\\]\\)" "gimple" } } +! { dg-final { scan-tree-dump "pragma omp target exit data map\\(always,present,from:c \\\[len: \[0-9\]+\\\]\\)" "gimple" } } +! { dg-final { scan-tree-dump "pragma omp target.*map\\(force_present:b \\\[len: \[0-9\]+\\\]\\) map\\(to:a \\\[len: \[0-9\]+\\\]\\) map\\(from:c \\\[len: \[0-9\]+\\\]\\)" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/map-12.f90 b/Fortran/gfortran/regression/gomp/map-12.f90 new file mode 100644 index 000000000..ac9a0f8aa --- /dev/null +++ b/Fortran/gfortran/regression/gomp/map-12.f90 @@ -0,0 +1,68 @@ +! { dg-additional-options "-fdump-tree-omplower -fdump-tree-original" } + +subroutine foo + implicit none + integer :: a, b, b1 + + !$omp target data map(tofrom:b1) + block; end block + !$omp target data map(close,tofrom:b1) + block; end block + !$omp target data map(close always,tofrom:b1) + block; end block + !$omp target data map(close always,tofrom:b1) + block; end block + !$omp target data map(close present,tofrom:b1) + block; end block + !$omp target data map(close present,tofrom:b1) + block; end block + !$omp target data map(always close present,tofrom:b1) + block; end block + !$omp target data map(always close present,tofrom:b1) + block; end block + + !$omp target enter data map(alloc: a) map(to:b) map(tofrom:b1) + !$omp target enter data map(close, alloc: a) map(close,to:b) map(close,tofrom:b1) + !$omp target enter data map(always,alloc: a) map(always,to:b) map(close always,tofrom:b1) + !$omp target enter data map(always,close,alloc: a) map(close,always,to:b) map(close always,tofrom:b1) + !$omp target enter data map(present,alloc: a) map(present,to:b) map(close present,tofrom:b1) + !$omp target enter data map(present,close,alloc: a) map(close,present,to:b) map(close present,tofrom:b1) + !$omp target enter data map(present,always,alloc: a) map(always,present,to:b) map(always close present,tofrom:b1) + !$omp target enter data map(present,always,close,alloc: a) map(close,present,always,to:b) map(always close present,tofrom:b1) + + !$omp target exit data map(delete: a) map(release:b) map(from:b1) + !$omp target exit data map(close,delete: a) map(close,release:b) map(close,from:b1) + !$omp target exit data map(always,delete: a) map(always,release:b) map(close always,from:b1) + !$omp target exit data map(always,close,delete: a) map(close,always,release:b) map(close always,from:b1) + !$omp target exit data map(present,delete: a) map(present,release:b) map(close present,from:b1) + !$omp target exit data map(present,close,delete: a) map(close,present,release:b) map(close present,from:b1) + !$omp target exit data map(present,always,delete: a) map(always,present,release:b) map(always close present,from:b1) + !$omp target exit data map(present,always,close,delete: a) map(close,present,always,release:b) map(always close present,from:b1) +end subroutine + +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(always,tofrom:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(present,tofrom:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(always,present,tofrom:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(alloc:a\\) map\\(to:b\\) map\\(to:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(alloc:a\\) map\\(always,to:b\\) map\\(always,to:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(present,alloc:a\\) map\\(present,to:b\\) map\\(present,to:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(present,alloc:a\\) map\\(always,present,to:b\\) map\\(always,present,to:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(delete:a\\) map\\(release:b\\) map\\(from:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(delete:a\\) map\\(release:b\\) map\\(always,from:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(delete:a\\) map\\(release:b\\) map\\(present,from:b1\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(delete:a\\) map\\(release:b\\) map\\(always,present,from:b1\\)\[\r\n\]" 2 "original" } } + + +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(always,tofrom:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(force_present:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(always,present,tofrom:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(to:b \\\[len: 4\\\]\\) map\\(to:b1 \\\[len: 4\\\]\\) map\\(alloc:a \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(always,to:b \\\[len: 4\\\]\\) map\\(always,to:b1 \\\[len: 4\\\]\\) map\\(alloc:a \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(force_present:a \\\[len: 4\\\]\\) map\\(force_present:b \\\[len: 4\\\]\\) map\\(force_present:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(force_present:a \\\[len: 4\\\]\\) map\\(always,present,to:b \\\[len: 4\\\]\\) map\\(always,present,to:b1 \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(from:b1 \\\[len: 4\\\]\\) map\\(delete:a \\\[len: 4\\\]\\) map\\(release:b \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(always,from:b1 \\\[len: 4\\\]\\) map\\(delete:a \\\[len: 4\\\]\\) map\\(release:b \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(force_present:b1 \\\[len: 4\\\]\\) map\\(delete:a \\\[len: 4\\\]\\) map\\(release:b \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(always,present,from:b1 \\\[len: 4\\\]\\) map\\(delete:a \\\[len: 4\\\]\\) map\\(release:b \\\[len: 4\\\]\\)\[\r\n\]" 2 "omplower" } } diff --git a/Fortran/gfortran/regression/gomp/map-7.f90 b/Fortran/gfortran/regression/gomp/map-7.f90 index 009c6d495..317090acb 100644 --- a/Fortran/gfortran/regression/gomp/map-7.f90 +++ b/Fortran/gfortran/regression/gomp/map-7.f90 @@ -2,7 +2,7 @@ implicit none -integer :: a, b, close, always, to +integer :: a, b, close, always, to, present !$omp target map(close) !$omp end target @@ -10,17 +10,43 @@ !$omp target map(always) !$omp end target +!$omp target map(present) +!$omp end target + !$omp target map(always, close) !$omp end target +!$omp target map(always, close, present) +!$omp end target + !$omp target map(always, close, to : always, close, a) !$omp end target +!$omp target map(always, close, present, to : always, close, present, a) +!$omp end target + + !$omp target map(to, always, close) !$omp end target +!$omp target map(present, to, always, close) +!$omp end target + +!$omp target map ( present , from : present) map(close , alloc : close) , map ( always, tofrom: always ) +!$omp end target + end ! { dg-final { scan-tree-dump-not "map\\(\[^\n\r)]*close\[^\n\r)]*to:" "original" } } -! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:always\\) map\\(always,to:close\\) map\\(always,to:a\\)" "original" } } ! { dg-final { scan-tree-dump-not "map\\(\[^\n\r)]*close\[^\n\r)]*to:" "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:close\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:always\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:present\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:always\\) map\\(tofrom:close\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:always\\) map\\(tofrom:close\\) map\\(tofrom:present\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(always,to:always\\) map\\(always,to:close\\) map\\(always,to:a\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(always,present,to:always\\) map\\(always,present,to:close\\) map\\(always,present,to:present\\) map\\(always,present,to:a\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:to\\) map\\(tofrom:always\\) map\\(tofrom:close\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:present\\) map\\(tofrom:to\\) map\\(tofrom:always\\) map\\(tofrom:close\\)\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(present,from:present\\) map\\(alloc:close\\) map\\(always,tofrom:always\\)\[\n\r]" 1 "original" } } diff --git a/Fortran/gfortran/regression/gomp/map-8.f90 b/Fortran/gfortran/regression/gomp/map-8.f90 index 92b802c67..15ebdd68b 100644 --- a/Fortran/gfortran/regression/gomp/map-8.f90 +++ b/Fortran/gfortran/regression/gomp/map-8.f90 @@ -28,7 +28,18 @@ !$omp target map(close close to : a) ! { dg-error "too many 'close' modifiers" } ! !$omp end target +!$omp target map(present present, to : a) ! { dg-error "too many 'present' modifiers" } +! !$omp end target +!$omp target map(present, present to : a) ! { dg-error "too many 'present' modifiers" } +! !$omp end target +!$omp target map(present present to : a) ! { dg-error "too many 'present' modifiers" } +! !$omp end target + + !$omp target map(close close always always to : a) ! { dg-error "too many 'always' modifiers" } ! !$omp end target +!$omp target map(present close always present to : a) ! { dg-error "too many 'present' modifiers" } +! !$omp end target + end diff --git a/Fortran/gfortran/regression/gomp/map-9.f90 b/Fortran/gfortran/regression/gomp/map-9.f90 index 9e7b811c8..8c8d4f7c5 100644 --- a/Fortran/gfortran/regression/gomp/map-9.f90 +++ b/Fortran/gfortran/regression/gomp/map-9.f90 @@ -2,7 +2,7 @@ ! PR fortran/108545 -! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(struct:x \\\[len: 1\\\]\\) map\\(to:x.a \\\[len: \[0-9\]+\\\]\\) map\\(to:MEM \\\[\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\)_\[0-9\]+] \\\[len: _\[0-9\]+\\\]\\) map\\(always_pointer:x.a.data \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(struct:x \\\[len: 1\\\]\\) map\\(to:x\.a \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(to:MEM \\\[\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\)_\[0-9\]+] \\\[len: _\[0-9\]+\\\]\\) map\\(attach:x\.a\.data \\\[bias: 0\\\]\\)" "omplower" } } program p type t diff --git a/Fortran/gfortran/regression/gomp/map-subarray-2.f90 b/Fortran/gfortran/regression/gomp/map-subarray-2.f90 new file mode 100644 index 000000000..26e113f4f --- /dev/null +++ b/Fortran/gfortran/regression/gomp/map-subarray-2.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +type T +integer, pointer :: arr1(:) +integer, pointer :: arr2(:) +integer, pointer :: arr3(:) +integer, pointer :: arr4(:) +end type T + +type(T) :: tv +integer, allocatable, target, dimension(:) :: arr + +allocate(arr(1:20)) + +tv%arr1 => arr +tv%arr2 => arr +tv%arr3 => arr +tv%arr4 => arr + +!$omp target enter data map(to: tv%arr1) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target enter data map\(struct:tv \[len: 1\]\) map\(to:tv\.arr1 \[pointer set, len: [0-9]+\]\) map\(to:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr1\.data \[bias: 0\]\)} "gimple" } } + +!$omp target exit data map(from: tv%arr1) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target exit data map\(release:tv\.arr1 \[pointer set, len: [0-9]+\]\) map\(from:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(detach:tv\.arr1\.data \[bias: 0\]\)} "gimple" } } + + +!$omp target enter data map(to: tv%arr2) map(to: tv%arr2(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target enter data map\(struct:tv \[len: 1\]\) map\(to:tv\.arr2 \[pointer set, len: [0-9]+\]\) map\(to:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr2\.data \[bias: [^\]]+\]\)} "gimple" } } + +!$omp target exit data map(from: tv%arr2) map(from: tv%arr2(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target exit data map\(release:tv\.arr2 \[pointer set, len: [0-9]+\]\) map\(from:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(detach:tv\.arr2\.data \[bias: [^\]]+\]\)} "gimple" } } + + +!$omp target enter data map(to: tv, tv%arr3(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target enter data map\(to:tv \[len: [0-9]+\]\) map\(to:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr3\.data \[bias: [^\]]+\]\)} "gimple" } } + +!$omp target exit data map(from: tv, tv%arr3(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target exit data map\(from:tv \[len: [0-9]+\]\) map\(from:MEM \[\(integer\(kind=4\)\[0:\] \*\)[_[0-9]+\] \[len: _[0-9]+\]\) map\(detach:tv\.arr3\.data \[bias: [^\]]+\]\)} "gimple" } } + + +!$omp target enter data map(to: tv%arr4(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target enter data map\(struct:tv \[len: 1\]\) map\(to:tv\.arr4 \[pointer set, len: [0-9]+\]\) map\(to:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr4\.data \[bias: [^\]]+\]\)} "gimple" } } + +!$omp target exit data map(from: tv%arr4(1:10)) + +! { dg-final { scan-tree-dump {(?n)#pragma omp target exit data map\(release:tv\.arr4 \[pointer set, len: [0-9]+\]\) map\(from:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(detach:tv\.arr4\.data \[bias: [^\]]+\]\)} "gimple" } } + +end + diff --git a/Fortran/gfortran/regression/gomp/map-subarray.f90 b/Fortran/gfortran/regression/gomp/map-subarray.f90 new file mode 100644 index 000000000..197888a43 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/map-subarray.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +type T +integer, pointer :: arr1(:) +integer, pointer :: arr2(:) +end type T + +type(T) :: tv +integer, allocatable, target, dimension(:) :: arr + +allocate(arr(1:20)) + +tv%arr1 => arr +tv%arr2 => arr + +!$omp target map(tv%arr1) +tv%arr1(1) = tv%arr1(1) + 1 +!$omp end target + +! { dg-final { scan-tree-dump {(?n)#pragma omp target.* map\(struct:tv \[len: 1\]\) map\(to:tv\.arr1 \[pointer set, len: [0-9]+\]\) map\(tofrom:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\[implicit\]\) map\(attach:tv\.arr1\.data \[bias: 0\]\)} "gimple" } } + +!$omp target map(tv%arr2) map(tv%arr2(1:10)) +tv%arr2(1) = tv%arr2(1) + 1 +!$omp end target + +!$omp target map(tv%arr2(1:10)) +tv%arr2(1) = tv%arr2(1) + 1 +!$omp end target + +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target.* map\(struct:tv \[len: 1\]\) map\(to:tv\.arr2 \[pointer set, len: [0-9]+\]\) map\(tofrom:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr2\.data \[bias: [^\]]+\]\)} 2 "gimple" } } + +!$omp target map(tv, tv%arr2(1:10)) +tv%arr2(1) = tv%arr2(1) + 1 +!$omp end target + +! { dg-final { scan-tree-dump {(?n)#pragma omp target.* map\(tofrom:tv \[len: [0-9]+\]\) map\(tofrom:MEM \[\(integer\(kind=4\)\[0:\] \*\)_[0-9]+\] \[len: _[0-9]+\]\) map\(attach:tv\.arr2\.data \[bias: [^\]]+\]\)} "gimple" } } + +end + diff --git a/Fortran/gfortran/regression/gomp/nothing-2.f90 b/Fortran/gfortran/regression/gomp/nothing-2.f90 index 554d4ef99..94fa3bba4 100644 --- a/Fortran/gfortran/regression/gomp/nothing-2.f90 +++ b/Fortran/gfortran/regression/gomp/nothing-2.f90 @@ -1,5 +1,5 @@ pure subroutine foo - !$omp nothing ! { dg-error "OpenMP directives other than SIMD or DECLARE TARGET at .1. may not appear in PURE procedures" } + !$omp nothing end subroutine subroutine bar diff --git a/Fortran/gfortran/regression/gomp/pr114825.f90 b/Fortran/gfortran/regression/gomp/pr114825.f90 new file mode 100644 index 000000000..b635476af --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pr114825.f90 @@ -0,0 +1,16 @@ +! PR fortran/114825 + +subroutine pr114825(b) + type t + real, allocatable :: m(:) + end type t + type(t), allocatable, target :: b(:) + type(t), pointer :: d + !$omp parallel private(d) + d => b(1) + !$omp end parallel +contains + subroutine sub + d => b(1) + end subroutine sub +end subroutine pr114825 diff --git a/Fortran/gfortran/regression/gomp/pr115103.f90 b/Fortran/gfortran/regression/gomp/pr115103.f90 new file mode 100644 index 000000000..9fb4979f6 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pr115103.f90 @@ -0,0 +1,14 @@ +subroutine nogroup_reduction + integer :: i, r + r = 0 +!$omp taskloop nogroup reduction(+:r) ! { dg-error "'REDUCTION' clause at .1. must not be used together with 'NOGROUP' clause" } + do i = 1, 32 + r = r + i + end do +end +subroutine grainsize_num_tasks + integer :: i +!$omp taskloop grainsize(2) num_tasks(2) ! { dg-error "'GRAINSIZE' clause at .1. must not be used together with 'NUM_TASKS' clause" } + do i = 1, 32 + end do +end diff --git a/Fortran/gfortran/regression/gomp/pr78260-2.f90 b/Fortran/gfortran/regression/gomp/pr78260-2.f90 index f5d888592..cd771b33a 100644 --- a/Fortran/gfortran/regression/gomp/pr78260-2.f90 +++ b/Fortran/gfortran/regression/gomp/pr78260-2.f90 @@ -48,9 +48,11 @@ subroutine sub() end subroutine sub end module m -! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[len: D.\[0-9\]+ \\* 4\\\]\\) map\\(to:arr \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } +! Check for multiplication: len = arrays_size * 4: +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = D\\.\[0-9\]+ \\* 4;" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[len: D.\[0-9\]+\\\]\\) map\\(to:arr \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[len: D.\[0-9\]+ \\* 4\\\]\\)" 1 "original" } } -! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[len: D.\[0-9\]+ \\* 4\\\]\\) map\\(to:\\*__result \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:__result \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[len: D.\[0-9\]+\\\]\\) map\\(to:\\*__result \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:__result \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[len: D.\[0-9\]+ \\* 4\\\]\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*__result.0\\) map\\(alloc:__result.0 \\\[pointer assign, bias: 0\\\]\\)" 2 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*__result.0\\)" 2 "original" } } diff --git a/Fortran/gfortran/regression/gomp/pr79154-1.f90 b/Fortran/gfortran/regression/gomp/pr79154-1.f90 index ea147bfa7..6376baa63 100644 --- a/Fortran/gfortran/regression/gomp/pr79154-1.f90 +++ b/Fortran/gfortran/regression/gomp/pr79154-1.f90 @@ -1,7 +1,7 @@ ! PR fortran/79154 ! { dg-do compile } -pure real function foo (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +pure real function foo (a, b) !$omp declare simd(foo) ! { dg-bogus "may not appear in PURE" } real, intent(in) :: a, b foo = a + b @@ -20,7 +20,7 @@ pure real function baz (a, b) real, intent(in) :: a, b baz = a + b end function baz -elemental real function fooe (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +elemental real function fooe (a, b) !$omp declare simd(fooe) ! { dg-bogus "may not appear in PURE" } real, intent(in) :: a, b fooe = a + b diff --git a/Fortran/gfortran/regression/gomp/pr79154-2.f90 b/Fortran/gfortran/regression/gomp/pr79154-2.f90 index 38d3fe5c3..6ceabc2b5 100644 --- a/Fortran/gfortran/regression/gomp/pr79154-2.f90 +++ b/Fortran/gfortran/regression/gomp/pr79154-2.f90 @@ -3,14 +3,14 @@ pure real function foo (a, b) real, intent(in) :: a, b -!$omp taskwait ! { dg-error "may not appear in PURE" } +!$omp taskwait ! { dg-error "may not appear in a PURE" } foo = a + b end function foo pure function bar (a, b) real, intent(in) :: a(8), b(8) real :: bar(8) integer :: i -!$omp do simd ! { dg-error "may not appear in PURE" } +!$omp do simd ! { dg-error "may not appear in a PURE" } do i = 1, 8 bar(i) = a(i) + b(i) end do @@ -19,38 +19,38 @@ pure function baz (a, b) real, intent(in) :: a(8), b(8) real :: baz(8) integer :: i -!$omp do ! { dg-error "may not appear in PURE" } +!$omp do ! { dg-error "may not appear in a PURE" } do i = 1, 8 baz(i) = a(i) + b(i) end do -!$omp end do ! { dg-error "may not appear in PURE" } +!$omp end do ! { dg-error "may not appear in a PURE" } end function baz pure real function baz2 (a, b) real, intent(in) :: a, b -!$omp target map(from:baz2) ! { dg-error "may not appear in PURE" } +!$omp target map(from:baz2) ! { dg-error "may not appear in a PURE" } baz2 = a + b -!$omp end target ! { dg-error "may not appear in PURE" } +!$omp end target ! { dg-error "may not appear in a PURE" } end function baz2 ! ELEMENTAL implies PURE elemental real function fooe (a, b) real, intent(in) :: a, b -!$omp taskyield ! { dg-error "may not appear in PURE" } +!$omp taskyield ! { dg-error "may not appear in a PURE" } fooe = a + b end function fooe elemental real function baze (a, b) real, intent(in) :: a, b -!$omp target map(from:baz) ! { dg-error "may not appear in PURE" } +!$omp target map(from:baz) ! { dg-error "may not appear in a PURE" } baze = a + b -!$omp end target ! { dg-error "may not appear in PURE" } +!$omp end target ! { dg-error "may not appear in a PURE" } end function baze elemental impure real function fooei (a, b) real, intent(in) :: a, b -!$omp taskyield ! { dg-bogus "may not appear in PURE" } +!$omp taskyield ! { dg-bogus "may not appear in a PURE" } fooe = a + b end function fooei elemental impure real function bazei (a, b) real, intent(in) :: a, b -!$omp target map(from:baz) ! { dg-bogus "may not appear in PURE" } +!$omp target map(from:baz) ! { dg-bogus "may not appear in a PURE" } baze = a + b -!$omp end target ! { dg-bogus "may not appear in PURE" } +!$omp end target ! { dg-bogus "may not appear in a PURE" } end function bazei diff --git a/Fortran/gfortran/regression/gomp/pr79154-simd.f90 b/Fortran/gfortran/regression/gomp/pr79154-simd.f90 index d6b72d6f3..a6626b03f 100644 --- a/Fortran/gfortran/regression/gomp/pr79154-simd.f90 +++ b/Fortran/gfortran/regression/gomp/pr79154-simd.f90 @@ -8,7 +8,7 @@ pure subroutine bar(a) pure subroutine foo(a,b) integer, intent(out) :: a(5) integer, intent(in) :: b(5) - !$omp target teams distribute simd ! { dg-error "may not appear in PURE procedures" } + !$omp target teams distribute simd ! { dg-error "may not appear in a PURE procedure" } do i=1, 5 a(i) = b(i) end do diff --git a/Fortran/gfortran/regression/gomp/pr83977.f90 b/Fortran/gfortran/regression/gomp/pr83977.f90 index ea8e229fe..b8ad1a7e3 100644 --- a/Fortran/gfortran/regression/gomp/pr83977.f90 +++ b/Fortran/gfortran/regression/gomp/pr83977.f90 @@ -1,7 +1,7 @@ ! PR middle-end/83977 ! { dg-do compile } -integer function foo (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +integer function foo (a, b) integer :: a, b !$omp declare simd uniform(b) linear(ref(a):b) a = a + 1 diff --git a/Fortran/gfortran/regression/gomp/pr99226.f90 b/Fortran/gfortran/regression/gomp/pr99226.f90 index 72dbdde2e..d1b35076d 100644 --- a/Fortran/gfortran/regression/gomp/pr99226.f90 +++ b/Fortran/gfortran/regression/gomp/pr99226.f90 @@ -2,8 +2,8 @@ subroutine sub (n) integer :: n, i - !$omp target ! { dg-error "construct with nested 'teams' construct contains directives outside of the 'teams' construct" } - !$omp teams distribute dist_schedule (static,n+4) + !$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp teams distribute dist_schedule (static,n+4) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } do i = 1, 8 end do !$omp teams distribute dist_schedule (static,n+4) diff --git a/Fortran/gfortran/regression/gomp/pure-1.f90 b/Fortran/gfortran/regression/gomp/pure-1.f90 new file mode 100644 index 000000000..cdbebe215 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pure-1.f90 @@ -0,0 +1,112 @@ +! The following directives are all 'pure' and should compile + +pure logical function func_assume(i) + implicit none + integer, value :: i + !$omp assume holds(i > 5) + func_assume = i < 3 + !$omp end assume +end + +pure logical function func_assumes() + implicit none + !$omp assumes absent(parallel) + func_assumes = .false. +end + +pure logical function func_reduction() + implicit none + !$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) + func_reduction = .false. +end + +pure logical function func_declare_simd() + implicit none + !$omp declare simd + func_declare_simd = .false. +end + +pure logical function func_declare_target() + implicit none + !$omp declare target + func_declare_target = .false. +end + +pure logical function func_error_1() + implicit none + !$omp error severity(warning) ! { dg-warning "OMP ERROR encountered" } + func_error_1 = .false. +end + +pure logical function func_error_2() + implicit none + !$omp error severity(warning) at(compilation) ! { dg-warning "OMP ERROR encountered" } + func_error_2 = .false. +end + +pure logical function func_error_3() + implicit none + !$omp error severity(warning) at(execution) ! { dg-error "OpenMP ERROR directive at .1. with 'at\\(execution\\)' clause in a PURE procedure" } + func_error_3 = .false. +end + +pure logical function func_nothing() + implicit none + !$omp nothing + func_nothing = .false. +end + +pure logical function func_scan(n) + implicit none + integer, value :: n + integer :: i, r + integer :: A(n) + integer :: B(n) + A = 0 + B = 0 + r = 0 + !$omp simd reduction (inscan, +:r) + do i = 1, 1024 + r = r + a(i) + !$omp scan inclusive(r) + b(i) = i + end do + + func_scan = b(1) == 3 +end + +pure integer function func_simd(n) + implicit none + integer, value :: n + integer :: j, r + r = 0 + !$omp simd reduction(+:r) + do j = 1, n + r = r + j + end do + func_simd = r +end + +pure integer function func_unroll(n) + implicit none + integer, value :: n + integer :: j, r + r = 0 + !$omp unroll partial(2) + do j = 1, n + r = r + j + end do + func_unroll = r +end + +pure integer function func_tile(n) + implicit none + integer, value :: n + integer :: j, r + r = 0 + !$omp tile sizes(2) + do j = 1, n + r = r + j + end do + func_tile = r +end diff --git a/Fortran/gfortran/regression/gomp/pure-2.f90 b/Fortran/gfortran/regression/gomp/pure-2.f90 new file mode 100644 index 000000000..35503c6a2 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pure-2.f90 @@ -0,0 +1,48 @@ +! The following directives are all 'pure' and should compile +! However, they are not yet implemented. Once done, move to pure-1.f90 + +!pure logical function func_declare_induction() +logical function func_declare_induction() + implicit none + ! Not quite right but should trigger an different error once implemented. + !$omp declare induction(next : (integer, integer)) & ! { dg-error "Unclassifiable OpenMP directive" } + !$omp& inductor (omp_var = omp_var(omp_step)) & + !$omp& collector(omp_step * omp_idx) + + func_declare_induction = .false. +end + +!pure logical function func_interchange(n) +logical function func_interchange(n) + implicit none + integer, value :: n + integer :: i, j + func_interchange = .false. + !$omp interchange permutation(2,1) ! { dg-error "Unclassifiable OpenMP directive" } + do i = 1, n + do j = 1, n + func_interchange = .not. func_interchange + end do + end do +end + + +!pure logical function func_metadirective() +logical function func_metadirective() + implicit none + !$omp metadirective ! { dg-error "Unclassifiable OpenMP directive" } + func_metadirective = .false. +end + +!pure logical function func_reverse(n) +logical function func_reverse(n) + implicit none + integer, value :: n + integer :: j + func_reverse = .false. + !$omp reverse ! { dg-error "Unclassifiable OpenMP directive" } + do j = 1, n + func_reverse = .not. func_reverse + end do +end + diff --git a/Fortran/gfortran/regression/gomp/pure-3.f90 b/Fortran/gfortran/regression/gomp/pure-3.f90 new file mode 100644 index 000000000..8c3c300df --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pure-3.f90 @@ -0,0 +1,31 @@ +! { dg-options "-fno-openmp -fopenmp-simd" } + +! Invalid combined directives with SIMD in PURE + +pure subroutine sub1 + implicit none + integer :: i + !$omp target do ! OK - not parsed by -fopenmp-simd + do i = 1, 5 + end do + !$omp end target +end + +subroutine sub2 + implicit none + integer :: i + !$omp target simd ! OK - not pure + do i = 1, 5 + end do + !$omp end target simd +end + +pure subroutine sub3 + implicit none + integer :: i + !$omp target simd ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } + do i = 1, 5 + end do + !$omp end target simd ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } +end + diff --git a/Fortran/gfortran/regression/gomp/pure-4.f90 b/Fortran/gfortran/regression/gomp/pure-4.f90 new file mode 100644 index 000000000..a03cdfb41 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/pure-4.f90 @@ -0,0 +1,35 @@ +pure subroutine sub1 + implicit none + integer :: i + !$omp target do ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } + do i = 1, 5 + end do + !$omp end target ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } +end + +subroutine sub2 + implicit none + integer :: i + !$omp target simd ! OK - not pure + do i = 1, 5 + end do + !$omp end target simd +end + +pure subroutine sub3 + implicit none + integer :: i + !$omp target simd ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } + do i = 1, 5 + end do + !$omp end target simd ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } +end + +pure subroutine sub4 + implicit none + integer :: i + !$omp do ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } + do i = 1, 5 + end do + !$omp end do ! { dg-error "OpenMP directive at .1. is not pure and thus may not appear in a PURE procedure" } +end diff --git a/Fortran/gfortran/regression/gomp/reduction5.f90 b/Fortran/gfortran/regression/gomp/reduction5.f90 index 44f89d84c..85491f0b6 100644 --- a/Fortran/gfortran/regression/gomp/reduction5.f90 +++ b/Fortran/gfortran/regression/gomp/reduction5.f90 @@ -21,7 +21,7 @@ !$omp end task ! { dg-error "Unexpected !.OMP END TASK statement" } !$omp taskloop reduction(inscan,+:a) in_reduction(+:b) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "34: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "34: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } ! { dg-error "'inscan' and non-'inscan' 'reduction' clauses on the same construct" "" { target *-*-* } .-2 } do i=1,10 a = a + 1 diff --git a/Fortran/gfortran/regression/gomp/reduction6.f90 b/Fortran/gfortran/regression/gomp/reduction6.f90 index 6bf685130..321f096e0 100644 --- a/Fortran/gfortran/regression/gomp/reduction6.f90 +++ b/Fortran/gfortran/regression/gomp/reduction6.f90 @@ -4,13 +4,13 @@ integer :: a, b, i a = 0 -!$omp simd reduction(inscan,+:a) ! { dg-error "30: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } +!$omp simd reduction(inscan,+:a) ! { dg-error "30: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" } do i=1,10 a = a + 1 end do !$omp parallel -!$omp do reduction(inscan,+:a) ! { dg-error "28: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } +!$omp do reduction(inscan,+:a) ! { dg-error "28: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" } do i=1,10 a = a + 1 end do diff --git a/Fortran/gfortran/regression/gomp/requires-1.f90 b/Fortran/gfortran/regression/gomp/requires-1.f90 index b115a654e..19007834c 100644 --- a/Fortran/gfortran/regression/gomp/requires-1.f90 +++ b/Fortran/gfortran/regression/gomp/requires-1.f90 @@ -9,5 +9,3 @@ subroutine bar !$omp requires unified_shared_memory unified_address !$omp requires atomic_default_mem_order(seq_cst) end - -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/requires-10.f90 b/Fortran/gfortran/regression/gomp/requires-10.f90 new file mode 100644 index 000000000..e912e3e86 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/requires-10.f90 @@ -0,0 +1,36 @@ +! { dg-additional-options "-fdump-tree-original" } + +function foo (x, y) result (z) + !$omp requires atomic_default_mem_order(release) + implicit none + real :: x, y, z + + !$omp atomic write + x = y + + !$omp atomic update + x = x + 1 + + !$omp atomic read acquire + z = x +end + +function bar (a, b) result (c) + !$omp requires atomic_default_mem_order(acquire) + implicit none + real :: a, b, c + + !$omp atomic write release + a = b + + !$omp atomic update + a = a + 1 + + !$omp atomic read + c = a +end + +! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 3 "original" } } */ +! { dg-final { scan-tree-dump-times "#pragma omp atomic acquire" 1 "original" } } */ +! { dg-final { scan-tree-dump-times "z = #pragma omp atomic read acquire" 1 "original" } } */ +! { dg-final { scan-tree-dump-times "c = #pragma omp atomic read acquire" 1 "original" } } */ diff --git a/Fortran/gfortran/regression/gomp/requires-11.f90 b/Fortran/gfortran/regression/gomp/requires-11.f90 new file mode 100644 index 000000000..c55009d5d --- /dev/null +++ b/Fortran/gfortran/regression/gomp/requires-11.f90 @@ -0,0 +1,31 @@ +function foo (x, y) result (z) + !$omp requires atomic_default_mem_order(release) + implicit none + real :: x, y, z + + !$omp atomic write + x = y + + !$omp atomic update + x = x + 1 + + !$omp atomic read ! { dg-error "!.OMP ATOMIC READ at .1. incompatible with RELEASE clause implicitly provided by a REQUIRES directive" } + z = x +end + +function bar (a, b) result (c) + !$omp requires atomic_default_mem_order(acquire) + implicit none + real :: a, b, c + + !$omp atomic write ! { dg-error "!.OMP ATOMIC WRITE at .1. incompatible with ACQUIRES clause implicitly provided by a REQUIRES directive" } + a = b + + !$omp atomic update + a = a + 1 + + !$omp atomic read + c = a +end + + diff --git a/Fortran/gfortran/regression/gomp/requires-2.f90 b/Fortran/gfortran/regression/gomp/requires-2.f90 index 7b63d4a8b..f144d3910 100644 --- a/Fortran/gfortran/regression/gomp/requires-2.f90 +++ b/Fortran/gfortran/regression/gomp/requires-2.f90 @@ -8,7 +8,5 @@ !$omp requires atomic_default_mem_order (seq_cst) !$omp requires atomic_default_mem_order (seq_cst) !$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "overrides a previous 'atomic_default_mem_order\\(seq_cst\\)'" } -!$omp requires atomic_default_mem_order (foo) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +!$omp requires atomic_default_mem_order (foo) ! { dg-error "Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause" } end - -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/requires-3.f90 b/Fortran/gfortran/regression/gomp/requires-3.f90 index 4429aab2e..8c9d6ed3b 100644 --- a/Fortran/gfortran/regression/gomp/requires-3.f90 +++ b/Fortran/gfortran/regression/gomp/requires-3.f90 @@ -1,4 +1,5 @@ -!$omp requires atomic_default_mem_order(acquire) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } -!$omp requires atomic_default_mem_order(release) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } -!$omp requires atomic_default_mem_order(foobar) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +!$omp requires atomic_default_mem_order(foobar) ! { dg-error "Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause" } + +!$omp requires atomic_default_mem_order(acquire) ! OK since OpenMP 5.2 +!$omp requires atomic_default_mem_order(release) ! { dg-error "!.OMP REQUIRES clause 'atomic_default_mem_order\\(release\\)' specified at .1. overrides a previous 'atomic_default_mem_order\\(acquire\\)' \\(which might be through using a module\\)" } end diff --git a/Fortran/gfortran/regression/gomp/requires-4.f90 b/Fortran/gfortran/regression/gomp/requires-4.f90 index c870a2840..9d936197f 100644 --- a/Fortran/gfortran/regression/gomp/requires-4.f90 +++ b/Fortran/gfortran/regression/gomp/requires-4.f90 @@ -33,4 +33,3 @@ subroutine bar !$omp requires unified_address ! { dg-error "must appear in the specification part of a program unit" } end subroutine bar end -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/requires-5.f90 b/Fortran/gfortran/regression/gomp/requires-5.f90 index ade2a3613..87be933ba 100644 --- a/Fortran/gfortran/regression/gomp/requires-5.f90 +++ b/Fortran/gfortran/regression/gomp/requires-5.f90 @@ -8,9 +8,7 @@ subroutine foo !$omp requires unified_shared_memory !$omp requires atomic_default_mem_order(relaxed) !$omp requires atomic_default_mem_order(relaxed) -!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "overrides a previous 'atomic_default_mem_order\\(seq_cst\\)'" } +!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "overrides a previous 'atomic_default_mem_order\\(relaxed\\)'" } !$omp target !$omp end target end - -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/requires-6.f90 b/Fortran/gfortran/regression/gomp/requires-6.f90 index cabd3d94a..b20c218dd 100644 --- a/Fortran/gfortran/regression/gomp/requires-6.f90 +++ b/Fortran/gfortran/regression/gomp/requires-6.f90 @@ -12,5 +12,3 @@ subroutine foobar i = i + 5 !$omp requires atomic_default_mem_order(acq_rel) ! { dg-error "Unexpected !.OMP REQUIRES statement" } end - -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/requires-7.f90 b/Fortran/gfortran/regression/gomp/requires-7.f90 index 3d75b89e0..231945714 100644 --- a/Fortran/gfortran/regression/gomp/requires-7.f90 +++ b/Fortran/gfortran/regression/gomp/requires-7.f90 @@ -38,4 +38,3 @@ subroutine foo !$omp requires unified_shared_memory ! { dg-error "must appear in the specification part of a program unit" } end end -! { dg-prune-output "not yet supported" } diff --git a/Fortran/gfortran/regression/gomp/scan-1.f90 b/Fortran/gfortran/regression/gomp/scan-1.f90 index f91c7fae0..a4f712f0d 100644 --- a/Fortran/gfortran/regression/gomp/scan-1.f90 +++ b/Fortran/gfortran/regression/gomp/scan-1.f90 @@ -176,7 +176,7 @@ subroutine f8 (c, d, e, f) use m implicit none integer i, c(64), d(64), e(64), f(64) - !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" } do i = 1, 64 block a = a + c(i) @@ -189,7 +189,7 @@ subroutine f8 (c, d, e, f) end block end do - !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" } do i = 1, 64 block a = a + c(i) @@ -207,12 +207,11 @@ subroutine f9 use m implicit none integer i -! The first error (exit) causes two follow-up errors: - !$omp simd reduction (inscan, +: a) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + !$omp simd reduction (inscan, +: a) do i = 1, 64 if (i == 23) & exit ! { dg-error "EXIT statement at .1. terminating ..OMP DO loop" } */ - !$omp scan exclusive (a) ! { dg-error "Unexpected ..OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + !$omp scan exclusive (a) ! { dg-warning "!.OMP SCAN at .1. with zero executable statements in preceding structured block sequence" } a = a + 1 end do end diff --git a/Fortran/gfortran/regression/gomp/scan-8.f90 b/Fortran/gfortran/regression/gomp/scan-8.f90 new file mode 100644 index 000000000..b706bbb6d --- /dev/null +++ b/Fortran/gfortran/regression/gomp/scan-8.f90 @@ -0,0 +1,96 @@ +integer function s1 (a1, a2, a3) result(r) + implicit none + integer :: a1, a2, a3 + integer :: i, j, k + procedure(integer) :: iii + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + !$omp scan exclusive (r) ! { dg-warning "!.OMP SCAN at .1. with zero executable statements in preceding structured block sequence" } + call f1 (2, k, r) + end do + end do + end do + + !$omp simd collapse(3) reduction (inscan, +:r) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + r = r + iii (i, j, k) + !$omp scan exclusive (r) ! { dg-warning "!.OMP SCAN at .1. with zero executable statements in succeeding structured block sequence" } + end do + end do + end do + + !$omp simd collapse(3) reduction (inscan, +:r) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + !$omp scan inclusive (r) + ! { dg-warning "!.OMP SCAN at .1. with zero executable statements in preceding structured block sequence" "" { target *-*-* } .-1 } + ! { dg-warning "!.OMP SCAN at .1. with zero executable statements in succeeding structured block sequence" "" { target *-*-* } .-2 } + end do + end do + end do +end function + +integer function s2 (a1, a2, a3) result(r) + implicit none + integer :: a1, a2, a3 + integer :: i, j, k + procedure(integer) :: iii + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) ! { dg-error "With INSCAN at .1., expected loop body with !.OMP SCAN between two structured block sequences" } + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + call f1 (2, k, r) + r = r + iii (i, j, k) + end do + end do + end do + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) ! { dg-error "With INSCAN at .1., expected loop body with !.OMP SCAN between two structured block sequences" } + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + end do + end do + end do + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + call f1 (2, k, r) + !$omp scan inclusive (r) + !$omp scan inclusive (r) ! { dg-error "Unexpected !.OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + r = r + iii (i, j, k) + end do + end do + end do + + !$omp scan inclusive (r) ! { dg-error "Unexpected !.OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + + r = 0 + !$omp simd collapse(3) reduction (inscan, +:r) ! { dg-error "With INSCAN at .1., expected loop body with !.OMP SCAN between two structured block sequences" } + do i = 1, a1 + do j = 1, a2 + do k = 1, a3 + call f1 (2, k, r) + block + !$omp scan inclusive (r) ! { dg-error "Unexpected !.OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + end block + r = r + iii (i, j, k) + end do + end do + end do + + +end function diff --git a/Fortran/gfortran/regression/gomp/scan-9.f90 b/Fortran/gfortran/regression/gomp/scan-9.f90 new file mode 100644 index 000000000..64d173602 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/scan-9.f90 @@ -0,0 +1,47 @@ +subroutine foo (c, d, a) + integer :: i, a, c(64), d(64) + !$omp do reduction (inscan, +: a) + !$omp tile sizes (2) + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) ! { dg-error "Unexpected !\\\$OMP SCAN at \\\(1\\\) outside loop construct with 'inscan' REDUCTION clause" } + d(i) = a + end do +end subroutine foo + +subroutine bar (c, d, a) + integer :: i, j, a, c(64, 64), d(64, 64) + !$omp do collapse (2) reduction (inscan, +: a) + do i = 1, 64 + !$omp tile sizes (2) + do j = 1, 64 + d(i, j) = a + !$omp scan exclusive (a) ! { dg-error "Unexpected !\\\$OMP SCAN at \\\(1\\\) outside loop construct with 'inscan' REDUCTION clause" } + a = a + c(i, j) + end do + end do +end subroutine bar + +subroutine baz (c, d, a) + integer :: i, a, c(64), d(64) + !$omp do reduction (inscan, +: a) + !$omp unroll partial (2) + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) ! { dg-error "Unexpected !\\\$OMP SCAN at \\\(1\\\) outside loop construct with 'inscan' REDUCTION clause" } + a = a + c(i) + end do +end subroutine baz + +subroutine qux (c, d, a) + integer :: i, j, a, c(64, 64), d(64, 64) + !$omp do collapse (2) reduction (inscan, +: a) + do i = 1, 64 + !$omp tile sizes (2) + do j = 1, 64 + a = a + c(i, j) + !$omp scan inclusive (a) ! { dg-error "Unexpected !\\\$OMP SCAN at \\\(1\\\) outside loop construct with 'inscan' REDUCTION clause" } + d(i, j) = a + end do + end do +end subroutine qux diff --git a/Fortran/gfortran/regression/gomp/strictly-structured-block-5.f90 b/Fortran/gfortran/regression/gomp/strictly-structured-block-5.f90 new file mode 100644 index 000000000..79cb92071 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/strictly-structured-block-5.f90 @@ -0,0 +1,77 @@ +subroutine f() + !$omp parallel + block + end block + + !$omp parallel + block + inner: block + block + end block + end block inner + end block +end + +subroutine f2() + !$omp parallel + my_name : block + end block my_name + + !$omp parallel + another_block : block + inner: block + block + end block + end block inner + end block another_block +end + +subroutine f3() + !$omp parallel + my_name : block + end block my_name2 ! { dg-error "Expected label 'my_name' for END BLOCK statement" } + end block my_name ! avoid follow up errors +end subroutine + +subroutine f4 + integer :: n + n = 5 + !$omp parallel + my: block + integer :: A(n) + A(1) = 1 + end block my +end + +subroutine f4a + intrinsic :: sin + !$omp parallel + block + procedure(), pointer :: proc + procedure(sin) :: my_sin + proc => sin + end block +end subroutine + +subroutine f5(x) + !$omp parallel + block + intent(in) :: x ! { dg-error "INTENT is not allowed inside of BLOCK" } + optional :: x ! { dg-error "OPTIONAL is not allowed inside of BLOCK" } + value :: x ! { dg-error "VALUE is not allowed inside of BLOCK" } + end block +end + +subroutine f6() + !$omp parallel + myblock: block + cycle myblock ! { dg-error "CYCLE statement at .1. is not applicable to non-loop construct 'myblock'" } + end block myblock + + !$omp parallel + myblock2: block + exit myblock2 ! OK. + ! jumps to the end of the block but stays in the structured block + end block myblock2 + !$omp end parallel +end diff --git a/Fortran/gfortran/regression/gomp/target-enter-exit-data.f90 b/Fortran/gfortran/regression/gomp/target-enter-exit-data.f90 new file mode 100644 index 000000000..c14a11dac --- /dev/null +++ b/Fortran/gfortran/regression/gomp/target-enter-exit-data.f90 @@ -0,0 +1,39 @@ +! { dg-additional-options "-fdump-tree-original" } + +type t +integer, pointer :: arr(:) +end type t + +type(t) :: var + +allocate (var%arr(1:100)) + +!$omp target enter data map(to: var%arr(10:20)) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target enter data map\(to:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\)$} 1 "original" } } + +!$omp target exit data map(release: var%arr(10:20)) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\)$} 1 "original" } } + + +!$omp target enter data map(alloc: var%arr(20:30)) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target enter data map\(alloc:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\)$} 1 "original" } } + +!$omp target exit data map(delete: var%arr(20:30)) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target exit data map\(delete:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) parm\.[0-9]+\.data \[len: D\.[0-9]+ \* [0-9]+\]\) map\(delete:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: \(integer\(kind=[0-9]+\)\) parm\.[0-9]+\.data - \(integer\(kind=[0-9]+\)\) var\.arr\.data\]\)$} 1 "original" } } + + +!$omp target enter data map(to: var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target enter data map\(to:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\[implicit\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: 0\]\)$} 1 "original" } } + +!$omp target exit data map(release: var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target exit data map\(release:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\[implicit\]\) map\(release:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: 0\]\)$} 1 "original" } } + + +!$omp target enter data map(alloc: var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target enter data map\(alloc:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\[implicit\]\) map\(to:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: 0\]\)$} 1 "original" } } + +!$omp target exit data map(delete: var%arr) +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target exit data map\(delete:\*\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[len: D\.[0-9]+ \* [0-9]+\]\[implicit\]\) map\(delete:var\.arr \[pointer set, len: [0-9]+\]\) map\(attach_detach:\(integer\(kind=[0-9]+\)\[0:\] \*\) var\.arr\.data \[bias: 0\]\)$} 1 "original" } } + + +end diff --git a/Fortran/gfortran/regression/gomp/target-exit-data.f90 b/Fortran/gfortran/regression/gomp/target-exit-data.f90 index ed57d0072..219dc467c 100644 --- a/Fortran/gfortran/regression/gomp/target-exit-data.f90 +++ b/Fortran/gfortran/regression/gomp/target-exit-data.f90 @@ -15,6 +15,6 @@ !$omp target exit data map(from:three) end -! { dg-final { scan-tree-dump "omp target exit data map\\(delete:.*\\) map\\(delete:one \\\[len: .*\\\]\\)" "omplower" } } -! { dg-final { scan-tree-dump "omp target exit data map\\(release:.*\\) map\\(release:two \\\[len: .*\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(delete:one \\\[len: \[0-9\]+\\\]\\) map\\(delete:MEM " "omplower" } } +! { dg-final { scan-tree-dump "#pragma omp target exit data map\\(release:two \\\[len: \[0-9\]+\\\]\\) map\\(release:MEM " "omplower" } } ! { dg-final { scan-tree-dump "omp target exit data map\\(from:.*\\) map\\(release:three \\\[len: .*\\\]\\)" "omplower" } } diff --git a/Fortran/gfortran/regression/gomp/target-update-1.f90 b/Fortran/gfortran/regression/gomp/target-update-1.f90 new file mode 100644 index 000000000..a9db2f1a3 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/target-update-1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + implicit none + integer, parameter :: N = 1000 + integer :: a(N), b(N), c, d, e + + ! Should be able to parse present in to/from clauses of 'target update'. + !$omp target update to(c) to(present: a) from(d) from(present: b) to(e) +end program + +! { dg-final { scan-tree-dump "#pragma omp target update to\\(c \\\[len: \[0-9\]+\\\]\\) to\\(present:a \\\[len: \[0-9\]+\\\]\\) to\\(e \\\[len: \[0-9\]+\\\]\\) from\\(d \\\[len: \[0-9\]+\\\]\\) from\\(present:b \\\[len: \[0-9\]+\\\]\\)" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/taskloop-2.f90 b/Fortran/gfortran/regression/gomp/taskloop-2.f90 index 41b4d6d21..d200a93bb 100644 --- a/Fortran/gfortran/regression/gomp/taskloop-2.f90 +++ b/Fortran/gfortran/regression/gomp/taskloop-2.f90 @@ -21,24 +21,24 @@ subroutine foo() end do !$omp taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } -do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } end do !$omp taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } -do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } end do !$omp master taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp master taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } - ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } do i = 1, 64 end do !$omp parallel master taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } -do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } end do !$omp parallel master taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } -do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 } end do end diff --git a/Fortran/gfortran/regression/gomp/teams-5.f90 b/Fortran/gfortran/regression/gomp/teams-5.f90 new file mode 100644 index 000000000..00377b69b --- /dev/null +++ b/Fortran/gfortran/regression/gomp/teams-5.f90 @@ -0,0 +1,150 @@ +! { dg-do compile } + +! PR fortran/110725 +! PR middle-end/71065 + +implicit none +integer :: x +!$omp target device(1) + block + !$omp teams num_teams(f()) + !$omp end teams + end block +!!$omp end target + +!$omp target device(1) + !$omp teams num_teams(f()) + !$omp end teams +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + x = 5 + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + x = 5 +!$omp end target + +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + block + !$omp teams num_teams(f()) + !$omp end teams + end block + end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + x = 5 + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + x = 5 + end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + x = 5 + end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + block; end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + block; end block; + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + end block +!$omp end target + +!$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + !$omp teams num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp end teams + block; end block; + end block +!!$omp end target + + +contains + +function f() + !$omp declare target + integer, allocatable :: f + f = 5 +end +end + +subroutine sub1 + implicit none + integer :: x,i + + !$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + !$omp teams distribute num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + x = 7 + end block + !$omp end target + + !$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + !$omp teams loop num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + x = 7 + end block + !$omp end target + + !$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp teams distribute simd num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + x = 7 + !$omp end target + + !$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + !$omp teams distribute parallel do num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + x = 7 + !$omp end target + + !$omp target device(1) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + block + x = 7 + !$omp teams distribute parallel do simd num_teams(f()) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + end block + !$omp end target + +contains + +function f() + !$omp declare target + integer, allocatable :: f + f = 5 +end + +end diff --git a/Fortran/gfortran/regression/gomp/teams-6.f90 b/Fortran/gfortran/regression/gomp/teams-6.f90 new file mode 100644 index 000000000..0bd7735e7 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/teams-6.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } + +! PR fortran/110725 +! PR middle-end/71065 + + +subroutine one +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } +block + integer :: i ! <<< invalid: variable declaration + !$omp teams ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + i = 5 + !$omp end teams +end block + +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } +block + type t ! <<< invalid: type declaration + end type t + !$omp teams ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + i = 5 + !$omp end teams +end block + +!$omp target + ! The following is invalid - but not detected as ST_NONE is returned: + !$omp error at(compilation) severity(warning) ! { dg-warning "OMP ERROR encountered" } + !$omp teams + i = 5 + !$omp end teams +!$omp end target + +!$omp target + ! The following is invalid - but not detected as ST_NONE is returned: + !$omp nothing ! <<< invalid: directive + !$omp teams + i = 5 + !$omp end teams +!$omp end target + + +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS may not contain any other statement, declaration or directive outside of the single TEAMS construct" } +block + do i = 5, 8 + !$omp teams + block; end block + end do +end block + +end + + +subroutine two +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } +block + integer :: i ! <<< invalid: variable declaration + !$omp teams distribute ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do + !$omp end teams distribute +end block + +!$omp target ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } +block + type t ! <<< invalid: type declaration + end type t + !$omp teams distribute parallel do ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" } + do i = 1, 5 + end do +end block + +!$omp target + ! The following is invalid - but not detected as ST_NONE is returned: + !$omp error at(compilation) severity(warning) ! { dg-warning "OMP ERROR encountered" } + !$omp teams loop + do i = 5, 10 + end do +!$omp end target + +!$omp target + ! The following is invalid - but not detected as ST_NONE is returned: + !$omp nothing ! <<< invalid: directive + !$omp teams distribute simd + do i = -3, 5 + end do + !$omp end teams distribute simd +!$omp end target +end diff --git a/Fortran/gfortran/regression/gomp/tests.cmake b/Fortran/gfortran/regression/gomp/tests.cmake index 0e3dfa223..018b54393 100644 --- a/Fortran/gfortran/regression/gomp/tests.cmake +++ b/Fortran/gfortran/regression/gomp/tests.cmake @@ -44,8 +44,27 @@ compile;all-memory-2.f90;;-fno-openmp;; compile;all-memory-3.f90;;;; compile;allocatable_components_1.f90;xfail;;; compile;allocate-1.f90;;;; +compile;allocate-10.f90;;-Wall -fdump-tree-gimple;; +compile;allocate-11.f90;xfail;;; +compile;allocate-12.f90;xfail;;; +compile;allocate-13.f90;;;; +compile;allocate-13a.f90;;-flto;; +compile;allocate-14.f90;xfail;-fcoarray=single -fcray-pointer;; +compile;allocate-15.f90;xfail;;; +compile;allocate-16.f90;xfail;;; compile;allocate-2.f90;xfail;;; compile;allocate-3.f90;xfail;;; +compile;allocate-4.f90;xfail;;; +compile;allocate-5.f90;;-fopenmp-allocators;; +compile;allocate-6.f90;xfail;;; +compile;allocate-7.f90;xfail;-fmax-errors=1000;; +compile;allocate-8.f90;;-fdump-tree-original;; +compile;allocate-9.f90;xfail;;; +compile;allocate-pinned-1.f90;xfail;;; +compile;allocators-1.f90;xfail;;; +compile;allocators-2.f90;xfail;;; +compile;allocators-3.f90;xfail;;; +compile;allocators-4.f90;xfail;;; compile;associate1.f90;xfail;;; compile;associate2.f90;xfail;;; compile;assume-1.f90;;;; @@ -73,6 +92,8 @@ compile;atomic-27.f90;xfail;;; compile;atomic-28.f90;xfail;;; compile;atomic.f90;;-fdump-tree-original;; compile;block-1.f90;xfail;;; +compile;c_ptr_tests_20.f90;;;; +compile;c_ptr_tests_21.f90;xfail;;; compile;cancel-1.f90;xfail;-cpp;; compile;cancel-2.f90;xfail;;; compile;cancel-3.f90;;-fdump-tree-original;; @@ -105,6 +126,8 @@ compile;declare-target-1.f90;;;; compile;declare-target-2.f90;xfail;;; compile;declare-target-4.f90;;-fdump-tree-original;; compile;declare-target-5.f90;xfail;;; +compile;declare-target-indirect-1.f90;xfail;-fopenmp;; +compile;declare-target-indirect-2.f90;;-fopenmp -fdump-tree-gimple;; compile;declare-variant-1.f90;;;; compile;declare-variant-10.f90;;-cpp -foffload=disable -fdump-tree-gimple;; compile;declare-variant-11.f90;;-foffload=disable -fdump-tree-gimple;; @@ -117,6 +140,7 @@ compile;declare-variant-17.f90;xfail;;; compile;declare-variant-18.f90;xfail;;; compile;declare-variant-19.f90;xfail;;; compile;declare-variant-2.f90;xfail;;; +compile;declare-variant-20.f90;xfail;;; compile;declare-variant-2a.f90;xfail;;; compile;declare-variant-3.f90;;;; compile;declare-variant-4.f90;;;; @@ -125,13 +149,17 @@ compile;declare-variant-6.f90;xfail;;; compile;declare-variant-7.f90;xfail;-mavx2;i.86-.+-.+ x86_64-.+-.+; compile;declare-variant-8.f90;;-fdump-tree-gimple;; compile;declare-variant-9.f90;;-cpp -fdump-tree-gimple;; +compile;declare-variant-no-score.f90;xfail;-foffload=disable;x86_64-.+-.+; compile;defaultmap-1.f90;xfail;;; +compile;defaultmap-10.f90;xfail;;; compile;defaultmap-2.f90;xfail;;; compile;defaultmap-3.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;defaultmap-4.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;defaultmap-5.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;defaultmap-6.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;defaultmap-7.f90;;-fdump-tree-original -fdump-tree-gimple;; +compile;defaultmap-8.f90;;-fdump-tree-gimple;; +compile;defaultmap-9.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;depend-1.f90;xfail;;; compile;depend-4.f90;;-fdump-tree-gimple -fdump-tree-original;; compile;depend-5.f90;;-fdump-tree-original;; @@ -141,6 +169,7 @@ compile;depend-iterator-2.f90;xfail;;; compile;depend-iterator-3.f90;xfail;;; compile;depobj-1.f90;;;; compile;depobj-2.f90;xfail;;; +compile;depobj-3.f90;;;; compile;do-1.f90;;-O -fopenmp -fdump-tree-omplower -std=legacy;; compile;doacross-5.f90;xfail;;; compile;doacross-6.f90;xfail;;; @@ -153,9 +182,18 @@ compile;flush-2.f90;xfail;;; compile;free-1.f90;;;; compile;free-2.f90;;;; compile;if-1.f90;;;; +compile;imperfect-gotos.f90;xfail;;; +compile;imperfect-invalid-scope.f90;xfail;;; +compile;imperfect1.f90;xfail;;; +compile;imperfect2.f90;xfail;;; +compile;imperfect3.f90;xfail;;; +compile;imperfect4.f90;xfail;;; +compile;imperfect5.f90;xfail;;; compile;implicit-save.f90;;;; compile;include_1.f;;-fopenmp -fdec;; compile;include_2.f90;;-fopenmp -fdec-include;; +compile;inner-loops-1.f90;;;; +compile;inner-loops-2.f90;xfail;;; compile;intentin1.f90;xfail;;; compile;is_device_ptr-1.f90;;;; compile;is_device_ptr-2.f90;;;; @@ -180,6 +218,9 @@ compile;loop-4.f90;xfail;;; compile;loop-5.f90;;-fdump-tree-original;; compile;loop-exit.f90;xfail;;; compile;map-1.f90;xfail;;; +compile;map-10.f90;;-fdump-tree-omplower;; +compile;map-11.f90;;-fdump-tree-gimple;; +compile;map-12.f90;;-fdump-tree-omplower -fdump-tree-original;; compile;map-2.f90;;;; compile;map-3.f90;;-fdump-tree-original;; compile;map-4.f90;xfail;;; @@ -189,6 +230,8 @@ compile;map-7.f90;;-fdump-tree-original;; compile;map-8.f90;xfail;;; compile;map-9.f90;;-fdump-tree-omplower;; compile;map-alloc-comp-1.f90;xfail;;; +compile;map-subarray-2.f90;;-fdump-tree-gimple;; +compile;map-subarray.f90;;-fdump-tree-gimple;; compile;masked-1.f90;;-ffree-line-length-none;; compile;masked-2.f90;xfail;;; compile;masked-3.f90;xfail;;; @@ -261,6 +304,8 @@ compile;pr107214-6.f90;xfail;;; compile;pr107214-7.f90;;-fdump-tree-original;; compile;pr107214-8.f90;xfail;;; compile;pr107214.f90;xfail;;; +compile;pr114825.f90;;;; +compile;pr115103.f90;xfail;;; compile;pr26224.f;;;; compile;pr27573.f90;;-O2 -fopenmp -fprofile-generate;; compile;pr29759.f90;xfail;;; @@ -357,6 +402,10 @@ compile;pr99928-6.f90;;-fopenmp -fdump-tree-gimple;; compile;pr99928-8.f90;;-fopenmp -fdump-tree-gimple;; compile;proc_ptr_1.f90;;;; compile;proc_ptr_2.f90;xfail;;; +compile;pure-1.f90;xfail;;; +compile;pure-2.f90;xfail;;; +compile;pure-3.f90;xfail;-fno-openmp -fopenmp-simd;; +compile;pure-4.f90;xfail;;; compile;reduction-task-1.f90;;;; compile;reduction-task-2.f90;xfail;;; compile;reduction-task-2a.f90;xfail;;; @@ -370,6 +419,8 @@ compile;reduction6.f90;xfail;;; compile;reduction7.f90;xfail;;; compile;ref_inquiry.f90;xfail;;; compile;requires-1.f90;;;; +compile;requires-10.f90;;-fdump-tree-original;; +compile;requires-11.f90;xfail;;; compile;requires-2.f90;xfail;;; compile;requires-3.f90;xfail;;; compile;requires-4.f90;xfail;;; @@ -385,6 +436,8 @@ compile;scan-4.f90;;-fdump-tree-original;; compile;scan-5.f90;;-fdump-tree-original;; compile;scan-6.f90;xfail;;; compile;scan-7.f90;xfail;;; +compile;scan-8.f90;xfail;;; +compile;scan-9.f90;xfail;;; compile;schedule-1.f90;;;; compile;schedule-modifiers-1.f90;;-fopenmp;; compile;schedule-modifiers-2.f90;xfail;-fopenmp;; @@ -400,6 +453,7 @@ compile;strictly-structured-block-1.f90;;-fopenmp;; compile;strictly-structured-block-2.f90;xfail;-fopenmp;; compile;strictly-structured-block-3.f90;;-fopenmp;; compile;strictly-structured-block-4.f90;xfail;;; +compile;strictly-structured-block-5.f90;xfail;;; compile;substring.f90;xfail;;; compile;target-data-1.f90;;-fdump-tree-original;; compile;target-data-2.f90;xfail;;; @@ -412,10 +466,12 @@ compile;target-device-ancestor-3.f90;xfail;;; compile;target-device-ancestor-4.f90;;-fdump-tree-original;; compile;target-device-ancestor-5.f90;;;; compile;target-device-ancestor-6.f90;;;; +compile;target-enter-exit-data.f90;;-fdump-tree-original;; compile;target-exit-data.f90;;-fdump-tree-omplower;; compile;target-has-device-addr-1.f90;xfail;;; compile;target-has-device-addr-2.f90;;-fdump-tree-gimple;; compile;target-parallel1.f90;;;; +compile;target-update-1.f90;;-fdump-tree-gimple;; compile;target1.f90;;;; compile;target2.f90;;-ffree-line-length-160;; compile;target3.f90;;;; @@ -426,8 +482,35 @@ compile;taskwait-depend-nowait-1.f90;xfail;;; compile;taskwait.f90;;-fdump-tree-original;; compile;teams-3.f90;xfail;;; compile;teams-4.f90;;;; +compile;teams-5.f90;xfail;;; +compile;teams-6.f90;xfail;;; compile;teams1.f90;;;; compile;threadprivate-1.f90;;;; +compile;tile-1.f90;;;; +compile;tile-10.f90;;;; +compile;tile-2.f90;;;; +compile;tile-3.f90;xfail;;; +compile;tile-4.f90;xfail;;; +compile;tile-5.f90;;;; +compile;tile-6.f90;xfail;;; +compile;tile-7.f90;xfail;;; +compile;tile-8.f90;xfail;;; +compile;tile-9.f90;xfail;;; +compile;tile-imperfect-nest-1.f90;;;; +compile;tile-imperfect-nest-2.f90;xfail;;; +compile;tile-inner-loops-1.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;tile-inner-loops-2.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;tile-inner-loops-3.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;tile-inner-loops-4.f90;;;; +compile;tile-inner-loops-5.f90;;;; +compile;tile-inner-loops-6.f90;;;; +compile;tile-inner-loops-7.f90;;;; +compile;tile-inner-loops-8.f90;xfail;;; +compile;tile-non-rectangular-1.f90;;;; +compile;tile-non-rectangular-2.f90;xfail;;; +compile;tile-non-rectangular-3.f90;xfail;;; +compile;tile-unroll-1.f90;;;; +compile;tile-unroll-2.f90;xfail;;; compile;udr1.f90;xfail;;; compile;udr2.f90;xfail;;; compile;udr3.f90;xfail;;; @@ -437,9 +520,32 @@ compile;udr6.f90;xfail;-fmax-errors=1000 -fopenmp -ffree-line-length-160;; compile;udr7.f90;xfail;;; compile;udr8.f90;xfail;-fmax-errors=1000 -fopenmp;; compile;unexpected-end.f90;xfail;;; +compile;unroll-1.f90;;;; +compile;unroll-10.f90;xfail;;; +compile;unroll-11.f90;xfail;;; +compile;unroll-12.f90;xfail;;; +compile;unroll-13.f90;;;; +compile;unroll-2.f90;;-fdump-tree-original;; +compile;unroll-3.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-4.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-5.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-6.f90;xfail;;; +compile;unroll-7.f90;;;; +compile;unroll-8.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-9.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-inner-loop-1.f90;;;; +compile;unroll-inner-loop-2.f90;xfail;;; +compile;unroll-no-clause-1.f90;;-O2 -fdump-tree-gimple;; +compile;unroll-non-rect-1.f90;;;; +compile;unroll-non-rect-2.f90;;;; +compile;unroll-simd-1.f90;;-fno-openmp -fopenmp-simd;; +compile;unroll-simd-3.f90;xfail;-fno-openmp -fopenmp-simd;; +compile;unroll-tile-1.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-tile-2.f90;;-O2 -fdump-tree-original -fdump-tree-gimple;; +compile;unroll-tile-inner-1.f90;;-fdump-tree-original -fdump-tree-gimple;; compile;use_device_ptr-1.f90;;-fdump-tree-original;; compile;warn_truncated.f;;-Wall;; -compile;warn_truncated.f90;xfail;;; +compile;warn_truncated.f90;xfail;-std=f2018;; compile;workshare-59.f90;xfail;;; compile;workshare-reduction-1.f90;;-O2 -fopenmp -fdump-tree-optimized;; compile;workshare-reduction-10.f90;;-O2 -fopenmp -fdump-tree-optimized;; @@ -501,4 +607,5 @@ compile;workshare-reduction-8.f90;;-O2 -fopenmp -fdump-tree-optimized;; compile;workshare-reduction-9.f90;;-O2 -fopenmp -fdump-tree-optimized;; compile;workshare1.f90;xfail;;; compile;workshare2.f90;;-fopenmp -ffrontend-optimize -fdump-tree-original;; -compile;workshare3.f90;;-ffrontend-optimize -fdump-tree-original -fopenmp;; \ No newline at end of file +compile;workshare3.f90;;-ffrontend-optimize -fdump-tree-original -fopenmp;; +run;unroll-simd-2.f90;;-O2 -fopenmp-simd -fdump-tree-original -fdump-tree-gimple;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/gomp/tile-1.f90 b/Fortran/gfortran/regression/gomp/tile-1.f90 new file mode 100644 index 000000000..a02d99a54 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-1.f90 @@ -0,0 +1,39 @@ +subroutine test + implicit none + integer :: i, j, k + + !$omp tile sizes ( 1 ) + do i = 1,100 + call dummy(i) + end do + + !$omp tile sizes(1) + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(2+3) + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + end do + end do + !$omp end tile + + !$omp tile sizes(1,2,1) + do i = 1,100 + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-10.f90 b/Fortran/gfortran/regression/gomp/tile-10.f90 new file mode 100644 index 000000000..43e1920b3 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-10.f90 @@ -0,0 +1,70 @@ +! It isn't really clear what is supposed to be valid and what isn't when mixing +! imperfectly nested loops with generated loops. Sorry for now until that is +! clarified. + +subroutine bar + integer :: i, j + !$omp do collapse(2) + do i = 0, 31 + call foo (i, -1) + !$omp tile sizes (2) ! { dg-message "Imperfectly nested loop using generated loops" } + do j = 0, 31 + call foo (i, j) + end do + call foo (i, -2) + end do +end subroutine bar + +subroutine baz + integer :: i, j, k, l + !$omp do collapse(2) + do i = 0, 31 + call foo (i, -1) + !$omp tile sizes (2, 2) ! { dg-message "Imperfectly nested loop using generated loops" } + do j = 0, 31 + !$omp tile sizes (2, 2) + do k = 0, 31 + do l = 0, 31 + call foo (i + k, j + l) + end do + end do + end do + call foo (i, -2) + end do +end subroutine baz + +subroutine qux + integer :: i, j, k, l, m + !$omp do collapse(2) + do i = 0, 31 + m = i + 6 + call foo (i, -1) + !$omp tile sizes (2) ! { dg-message "Imperfectly nested loop using generated loops" } + do j = m, 31 + call foo (i, j) + end do + call foo (i, -2) + end do +end subroutine qux + +subroutine freddy + integer :: i, j, k, l, m + !$omp do collapse(2) + do i = 0, 31 + block + integer :: m + m = i + 6 + call foo (i, -1) + !$omp tile sizes (2, 2) ! { dg-message "Imperfectly nested loop using generated loops" } + do j = 0, 31 + !$omp tile sizes (2, 2) + do k = 0, 31 + do l = m, 31 + call foo (i + k, j + l) + end do + end do + end do + call foo (i, -2) + end block + end do +end subroutine freddy diff --git a/Fortran/gfortran/regression/gomp/tile-2.f90 b/Fortran/gfortran/regression/gomp/tile-2.f90 new file mode 100644 index 000000000..56d7e1d1b --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-2.f90 @@ -0,0 +1,61 @@ +subroutine test1 + implicit none + integer :: i, j, k + + !$omp tile sizes (1,2) + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + + !$omp tile sizes (8) + !$omp tile sizes (1,2) + !$omp tile sizes (1,2,3) + do i = 1,100 + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test1 + +subroutine test2 + implicit none + integer :: i, j, k + + !$omp taskloop collapse(2) + !$omp tile sizes (3,4) + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + !$omp end taskloop + + !$omp taskloop simd + !$omp tile sizes (8) + !$omp tile sizes (1,2) + !$omp tile sizes (1,2,3) + do i = 1,100 + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + !$omp end taskloop simd +end subroutine test2 diff --git a/Fortran/gfortran/regression/gomp/tile-3.f90 b/Fortran/gfortran/regression/gomp/tile-3.f90 new file mode 100644 index 000000000..bd6b8b18c --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-3.f90 @@ -0,0 +1,17 @@ +subroutine test + implicit none + integer :: i, j, k + + !$omp parallel do collapse(2) ordered(2) ! { dg-error "'ordered' clause used with generated loops" } + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + !$omp end parallel do +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-4.f90 b/Fortran/gfortran/regression/gomp/tile-4.f90 new file mode 100644 index 000000000..51bf27e4f --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-4.f90 @@ -0,0 +1,89 @@ +subroutine test1 + implicit none + integer :: i, j, k + + !$omp tile sizes (1,2) + !$omp tile sizes (1) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test1 + +subroutine test2 + implicit none + integer :: i, j, k + + !$omp tile sizes (1,2) + !$omp tile sizes (1) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test2 + +subroutine test3 + implicit none + integer :: i, j, k + + !$omp target teams distribute + !$omp tile sizes (1,2) + !$omp tile sizes (1) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test3 + +subroutine test4 + implicit none + integer :: i, j, k + + !$omp target teams distribute collapse(2) + !$omp tile sizes (8) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test4 + +subroutine test5 + implicit none + integer :: i, j, k + + !$omp parallel do collapse(2) ordered(2) + !$omp tile sizes (8) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + !$omp end tile + !$omp end parallel do +end subroutine test5 diff --git a/Fortran/gfortran/regression/gomp/tile-5.f90 b/Fortran/gfortran/regression/gomp/tile-5.f90 new file mode 100644 index 000000000..ddeea0e37 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-5.f90 @@ -0,0 +1,73 @@ +subroutine test + implicit none + integer :: i, j, k, l, m, n, o + !$omp do private (i, j, k, l) + !$omp tile sizes(2, 3) + !$omp tile sizes(3, 4, 5) + !$omp tile sizes(6, 7, 8, 9) + do i = 1, 100 + do j = 1, 100 + do k = 1, 100 + do l = 1, 100 + call dummy(i) + end do + end do + end do + end do + + !$omp do private (i, j, k, l, m, n) + !$omp tile sizes(2, 3) + do i = 1, 100 + !$omp tile sizes(3, 4, 5) + do j = 1, 100 + !$omp tile sizes(6, 7, 8, 9) + do k = 1, 100 + do l = 1, 100 + do m = 1, 100 + !$omp unroll partial(2) + do n = 1, 100 + call dummy(i) + end do + end do + end do + end do + end do + end do + + !$omp do collapse(2) private (i, j, k, l, m) + do i = 1, 100 + !$omp tile sizes(2, 3) + !$omp tile sizes(3, 4, 5) + !$omp tile sizes(6, 7, 8, 9) + do j = 1, 100 + do k = 1, 100 + do l = 1, 100 + do m = 1, 100 + call dummy(i) + end do + end do + end do + end do + end do + + !$omp do private (i, j, k, l, m, n, o) collapse(2) + do i = 1, 100 + !$omp tile sizes(2, 3) + do j = 1, 100 + !$omp tile sizes(3, 4, 5) + do k = 1, 100 + !$omp tile sizes(6, 7, 8, 9) + do l = 1, 100 + do m = 1, 100 + do n = 1, 100 + !$omp unroll partial(2) + do o = 1, 100 + call dummy(i) + end do + end do + end do + end do + end do + end do + end do +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-6.f90 b/Fortran/gfortran/regression/gomp/tile-6.f90 new file mode 100644 index 000000000..8c5d94e8b --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-6.f90 @@ -0,0 +1,9 @@ +subroutine test + !$omp tile sizes(1,2,1) ! { dg-error "not enough DO loops for collapsed !\\\$OMP TILE" } + do i = 1,100 + do j = 1,100 + call dummy(i) + end do + end do + !$omp end tile +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-7.f90 b/Fortran/gfortran/regression/gomp/tile-7.f90 new file mode 100644 index 000000000..58559331c --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-7.f90 @@ -0,0 +1,128 @@ +subroutine test + implicit none + integer :: i, j, k + + !$omp tile sizes(-21) ! { dg-error "INTEGER expression of SIZES clause at \\\(1\\\) must be positive" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(0) ! { dg-error "INTEGER expression of SIZES clause at \\\(1\\\) must be positive" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(i) ! { dg-error "SIZES requires constant expression" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes ! { dg-error "Expected '\\\(' after 'sizes' at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes( ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(2 ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes() ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(2,) ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(,2) ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(,i) ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(i,) ! { dg-error "Syntax error in OpenMP expression list at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile ! { dg-error "Unexpected !\\\$OMP END TILE statement at \\\(1\\\)" } + + !$omp tile sizes(1,2) ! { dg-error "not enough DO loops for collapsed !\\\$OMP TILE" } + do i = 1,100 + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(1,2,1) ! { dg-error "not enough DO loops for collapsed !\\\$OMP TILE" } + do i = 1,100 + do j = 1,100 + call dummy(i) + end do + end do + !$omp end tile + + !$omp tile sizes(1,2,1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested at \\\(1\\\)" } + do i = 1,100 + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + end do + call dummy(i) + end do + !$omp end tile + + !$omp tile sizes(1,2,1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested at \\\(1\\\)" } + do i = 1,100 + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + call dummy(j) + end do + end do + !$omp end tile + + !$omp tile sizes(1,2,1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + do j = 1,100 + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + + !$omp tile sizes(1,2,1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested at \\\(1\\\)" } + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-8.f90 b/Fortran/gfortran/regression/gomp/tile-8.f90 new file mode 100644 index 000000000..3acfd9687 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-8.f90 @@ -0,0 +1,18 @@ +subroutine test3 + implicit none + integer :: i, j, k + + !$omp taskloop collapse(3) + !$omp tile sizes (1,2) ! { dg-error "TILE construct at \\\(1\\\) generates 2 loops with canonical form but 3 loops are needed" } + !$omp tile sizes (1,2) + do i = 1,100 + do j = 1,100 + call dummy(j) + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile + !$omp end taskloop +end subroutine test3 diff --git a/Fortran/gfortran/regression/gomp/tile-9.f90 b/Fortran/gfortran/regression/gomp/tile-9.f90 new file mode 100644 index 000000000..7bb6d732a --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-9.f90 @@ -0,0 +1,96 @@ +subroutine test1 + integer :: i, j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 ! { dg-error "cannot be redefined inside loop" } + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do i = 0, 1023 ! { dg-error "!\\\$OMP DO iteration variable used in more than one loop" } + end do ! { dg-error "cannot be redefined inside loop" "" { target *-*-* } .-1 } + end do + end do + end do +end subroutine test1 + +subroutine test2 + integer(kind=8) :: i + integer :: j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do l = i, 1023 ! { dg-error "!\\\$OMP DO loop start expression not in canonical form" } + end do + end do + end do + end do +end subroutine test2 + +subroutine test3 + integer :: i, j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do l = 0, 7 * i * i ! { dg-error "!\\\$OMP DO loop end expression not in canonical form" } + end do + end do + end do + end do +end subroutine test3 + +subroutine test4 + integer :: i, j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do l = i * i, 1023 ! { dg-error "!\\\$OMP DO loop start expression not in canonical form" } + end do + end do + end do + end do +end subroutine test4 + +subroutine test5 + integer :: i, j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do l = 0, 1023, j ! { dg-error "!\\\$OMP TILE loop increment not in canonical form" } + end do + end do + end do + end do +end subroutine test5 + +subroutine test6 + integer :: i, j, k, l + !$omp do collapse(4) private (i, j, k, l) + do i = 0, 1023 + !$omp tile sizes (2, 2, 2) + do j = 0, 1023 + !$omp tile sizes (3, 3) + do k = 0, 1023 + !$omp tile sizes (4) + do l = 0, i - 2 ! { dg-message "Non-rectangular loops from generated loops unsupported" } + end do + end do + end do + end do +end subroutine test6 diff --git a/Fortran/gfortran/regression/gomp/tile-imperfect-nest-1.f90 b/Fortran/gfortran/regression/gomp/tile-imperfect-nest-1.f90 new file mode 100644 index 000000000..f11cbbea5 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-imperfect-nest-1.f90 @@ -0,0 +1,17 @@ +subroutine test0 + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + !$omp parallel do collapse(2) private(inner) + !$omp tile sizes (8, 1) + do i = 1,m + !$omp tile sizes (8, 1) + do j = 1,n + !$omp unroll partial(10) + do k = 1, n + if (k == 1) then + inner = 0 + endif + end do + end do + end do +end subroutine test0 diff --git a/Fortran/gfortran/regression/gomp/tile-imperfect-nest-2.f90 b/Fortran/gfortran/regression/gomp/tile-imperfect-nest-2.f90 new file mode 100644 index 000000000..829eeb9ec --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-imperfect-nest-2.f90 @@ -0,0 +1,74 @@ +subroutine test0m + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + !$omp parallel do collapse(2) private(inner) + do i = 1,m + !$omp tile sizes (8, 1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested" } + do j = 1,n + do k = 1, n + if (k == 1) then + inner = 0 + endif + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end subroutine test0m + +subroutine test1 + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + !$omp parallel do collapse(2) private(inner) + !$omp tile sizes (8, 1) + do i = 1,m + !$omp tile sizes (8, 1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested" } + do j = 1,n + !$omp unroll partial(10) + do k = 1, n + if (k == 1) then + inner = 0 + endif + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end subroutine test1 + +subroutine test2 + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + !$omp parallel do collapse(2) private(inner) + !$omp tile sizes (8, 1) + do i = 1,m + !$omp tile sizes (8, 1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested" } + do j = 1,n + do k = 1, n + if (k == 1) then + inner = 0 + endif + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end subroutine test2 + +subroutine test3 + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + !$omp parallel do collapse(2) private(inner) + do i = 1,m + !$omp tile sizes (8, 1) ! { dg-error "!\\\$OMP TILE inner loops must be perfectly nested" } + do j = 1,n + do k = 1, n + if (k == 1) then + inner = 0 + endif + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end subroutine test3 diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-1.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-1.f90 new file mode 100644 index 000000000..6f6978c50 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-1.f90 @@ -0,0 +1,16 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test1 + !$omp parallel do collapse(2) + do i=0,100 + !$omp tile sizes(4) + do j=-300,100 + call dummy (j) + end do + end do +end subroutine test1 + +! Collapse of the gimple_omp_for should be unaffacted by the transformation +! { dg-final { scan-tree-dump-times "#pragma omp for nowait collapse\\\(2\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(4\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait collapse\\\(2\\\)\[\n\r\]+ +for \\\(i = 0; i <= 100; i = i \\\+ 1\\\)\[\n\r\]+ +for \\\(j.\\\d = -300; j.\\\d <= 100; j.\\\d = j.\\\d \\\+ 4\\\)" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-2.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-2.f90 new file mode 100644 index 000000000..23e804bfd --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-2.f90 @@ -0,0 +1,20 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test2 + !$omp parallel do + !$omp tile sizes(3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(3,3) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test2 + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(3, 3\\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait\[\n\r\]+ +for \\\(i.\\\d = 0; i.\\\d <= 100; i.\\\d = i.\\\d \\\+ 3\\\)" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-3.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-3.f90 new file mode 100644 index 000000000..2e27730db --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-3.f90 @@ -0,0 +1,22 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test3 + !$omp parallel do + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(3,3) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test3 + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(3, 3, 3\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(3, 3\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp tile" "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait\[\n\r\]+ +for \\\(i.\\\d = 0; i.\\\d <= 100; i.\\\d = i.\\\d \\\+ 3\\\)" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-4.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-4.f90 new file mode 100644 index 000000000..fb252ed56 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-4.f90 @@ -0,0 +1,14 @@ +subroutine test3 + !$omp parallel do + !$omp tile sizes(3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(3,3) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test3 diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-5.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-5.f90 new file mode 100644 index 000000000..cb4337ea0 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-5.f90 @@ -0,0 +1,59 @@ +subroutine test1a + !$omp parallel do + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test1a + +subroutine test2a + !$omp parallel do + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5,5) + do k=-300,100 + do l=-300,100 + do m=-300,100 + call dummy (m) + end do + end do + end do + end do + end do +end subroutine test2a + +subroutine test1b + !$omp parallel do + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5) + do k=-300,100 + call dummy (k) + end do + end do + end do +end subroutine test1b + +subroutine test2b + !$omp parallel do + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5,5) + do k=-300,100 + do l=-300,100 + do m=-300,100 + call dummy (m) + end do + end do + end do + end do + end do +end subroutine test2b diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-6.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-6.f90 new file mode 100644 index 000000000..da00a58a4 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-6.f90 @@ -0,0 +1,13 @@ +subroutine test + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(3,3) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-7.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-7.f90 new file mode 100644 index 000000000..966d2d84e --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-7.f90 @@ -0,0 +1,13 @@ +subroutine test3 + !$omp tile sizes(3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(3,3) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test3 diff --git a/Fortran/gfortran/regression/gomp/tile-inner-loops-8.f90 b/Fortran/gfortran/regression/gomp/tile-inner-loops-8.f90 new file mode 100644 index 000000000..3d38a0eab --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-inner-loops-8.f90 @@ -0,0 +1,63 @@ +subroutine test3a + !$omp parallel do + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do k=-300,100 + do l=-300,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test3a + +subroutine test4a + !$omp parallel do + !$omp tile sizes(3,3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5,5) ! { dg-error "TILE construct at \\\(1\\\) generates 2 loops with canonical form but 3 loops are needed" } + do k=-300,100 + do l=-300,100 + do m=-300,100 + call dummy (m) + end do + end do + end do + end do + end do +end subroutine test4a + +subroutine test3b + !$omp parallel do + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5) ! { dg-error "TILE construct at \\\(1\\\) generates 1 loops with canonical form but 2 loops are needed" } + do k=-300,100 + do l=-300,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test3b + +subroutine test4b + !$omp parallel do + !$omp tile sizes(3,3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp tile sizes(5,5) ! { dg-error "TILE construct at \\\(1\\\) generates 2 loops with canonical form but 3 loops are needed" } + do k=-300,100 + do l=-300,100 + do m=-300,100 + call dummy (m) + end do + end do + end do + end do + end do +end subroutine test4b diff --git a/Fortran/gfortran/regression/gomp/tile-non-rectangular-1.f90 b/Fortran/gfortran/regression/gomp/tile-non-rectangular-1.f90 new file mode 100644 index 000000000..4da9a2447 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-non-rectangular-1.f90 @@ -0,0 +1,23 @@ +subroutine test1 + !$omp tile sizes(1) + do i = 1,100 + do j = 1,i + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test1 + +subroutine test5 + !$omp tile sizes(1,2) + do i = 1,100 + do j = 1,100 + do k = 1,j + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test5 diff --git a/Fortran/gfortran/regression/gomp/tile-non-rectangular-2.f90 b/Fortran/gfortran/regression/gomp/tile-non-rectangular-2.f90 new file mode 100644 index 000000000..dd78e0268 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-non-rectangular-2.f90 @@ -0,0 +1,11 @@ +subroutine test + !$omp tile sizes(1,2,1) ! { dg-error "non-rectangular 'tile'" } + do i = 1,100 + do j = 1,100 + do k = 1,i + call dummy(i) + end do + end do + end do + !$end omp tile +end subroutine test diff --git a/Fortran/gfortran/regression/gomp/tile-non-rectangular-3.f90 b/Fortran/gfortran/regression/gomp/tile-non-rectangular-3.f90 new file mode 100644 index 000000000..940d2bb83 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-non-rectangular-3.f90 @@ -0,0 +1,47 @@ +subroutine test2 + !$omp tile sizes(1,2) ! { dg-error "non-rectangular 'tile'" } + do i = 1,100 + do j = 1,i + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test2 + +subroutine test3 + !$omp tile sizes(1,2,1) ! { dg-error "non-rectangular 'tile'" } + do i = 1,100 + do j = 1,i + do k = 1,100 + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test3 + +subroutine test4 + !$omp tile sizes(1,2,1) ! { dg-error "non-rectangular 'tile'" } + do i = 1,100 + do j = 1,100 + do k = 1,i + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test4 + +subroutine test6 + !$omp tile sizes(1,2,1) ! { dg-error "non-rectangular 'tile'" } + do i = 1,100 + do j = 1,100 + do k = 1,j + call dummy(i) + end do + end do + end do + !$omp end tile +end subroutine test6 diff --git a/Fortran/gfortran/regression/gomp/tile-unroll-1.f90 b/Fortran/gfortran/regression/gomp/tile-unroll-1.f90 new file mode 100644 index 000000000..fa6395b24 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-unroll-1.f90 @@ -0,0 +1,18 @@ +function mult (a, b) result (c) + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + + allocate(c( n, m )) + + !$omp tile sizes (8) + !$omp unroll partial(1) + do i = 1,m + do j = 1,n + inner = 0 + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end function mult diff --git a/Fortran/gfortran/regression/gomp/tile-unroll-2.f90 b/Fortran/gfortran/regression/gomp/tile-unroll-2.f90 new file mode 100644 index 000000000..8f7327f02 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/tile-unroll-2.f90 @@ -0,0 +1,44 @@ +function mult (a, b) result (c) + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + + allocate(c( n, m )) + + !$omp parallel do collapse(2) + !$omp tile sizes (8,8) + !$omp unroll partial(2) ! { dg-error "UNROLL construct at \\\(1\\\) with PARTIAL clause generates just one loop with canonical form but 2 loops are needed" } + do i = 1,m + do j = 1,n + inner = 0 + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do + + !$omp tile sizes (8,8) + !$omp unroll partial(2) ! { dg-error "UNROLL construct at \\\(1\\\) with PARTIAL clause generates just one loop with canonical form but 2 loops are needed" } + do i = 1,m + do j = 1,n + inner = 0 + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do + + !$omp parallel do collapse(2) + !$omp tile sizes (8,8) + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,m + do j = 1,n + inner = 0 + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end function mult diff --git a/Fortran/gfortran/regression/gomp/unroll-1.f90 b/Fortran/gfortran/regression/gomp/unroll-1.f90 new file mode 100644 index 000000000..3badf8700 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-1.f90 @@ -0,0 +1,35 @@ +subroutine test16 + implicit none + integer :: i + + !$omp do + !$omp unroll partial(1) + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test16 + +subroutine test17 + implicit none + integer :: i + + !$omp do + !$omp unroll partial(2) + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test17 + +subroutine test20 + implicit none + integer :: i + + !$omp do + !$omp unroll partial + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test20 diff --git a/Fortran/gfortran/regression/gomp/unroll-10.f90 b/Fortran/gfortran/regression/gomp/unroll-10.f90 new file mode 100644 index 000000000..d873b3dcf --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-10.f90 @@ -0,0 +1,6 @@ +subroutine test(i) + !$omp unroll full + call dummy0 ! { dg-error "Unexpected CALL statement at \\\(1\\\)" } +end subroutine test ! { dg-error "Unexpected END statement at \\\(1\\\)" } + +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/gomp/unroll-11.f90 b/Fortran/gfortran/regression/gomp/unroll-11.f90 new file mode 100644 index 000000000..93974b408 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-11.f90 @@ -0,0 +1,75 @@ +subroutine test1(i) + implicit none + integer :: i + !$omp unroll + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test1 + +subroutine test2(i) + implicit none + integer :: i + !$omp unroll full + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test2 + +subroutine test3(i) + implicit none + integer :: i + !$omp unroll full + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test3 + +subroutine test4(i) + implicit none + integer :: i + !$omp do + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test4 + +subroutine test5(i) + implicit none + integer :: i + !$omp do + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test5 + +subroutine test6(i) + implicit none + integer :: i + !$omp do + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test6 + +subroutine test7(i) + implicit none + integer :: i + !$omp loop + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,10 + call dummy(i) + end do +end subroutine test7 diff --git a/Fortran/gfortran/regression/gomp/unroll-12.f90 b/Fortran/gfortran/regression/gomp/unroll-12.f90 new file mode 100644 index 000000000..5ef640f84 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-12.f90 @@ -0,0 +1,29 @@ +subroutine test1 + implicit none + integer :: i + !$omp unroll + do while (i < 10) ! { dg-error "!\\\$OMP UNROLL cannot be a DO WHILE or DO without loop control at \\\(1\\\)" } + call dummy(i) + i = i + 1 + end do +end subroutine test1 + +subroutine test2 + implicit none + integer :: i + !$omp unroll + do ! { dg-error "!\\\$OMP UNROLL cannot be a DO WHILE or DO without loop control at \\\(1\\\)" } + call dummy(i) + i = i + 1 + if (i >= 10) exit + end do +end subroutine test2 + +subroutine test3 + implicit none + integer :: i + !$omp unroll + do concurrent (i=1:10) ! { dg-error "!\\\$OMP UNROLL cannot be a DO CONCURRENT loop at \\\(1\\\)" } + call dummy(i) ! { dg-error "Subroutine call to 'dummy' in DO CONCURRENT block at \\\(1\\\) is not PURE" } + end do +end subroutine test3 diff --git a/Fortran/gfortran/regression/gomp/unroll-13.f90 b/Fortran/gfortran/regression/gomp/unroll-13.f90 new file mode 100644 index 000000000..3d338d30a --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-13.f90 @@ -0,0 +1,43 @@ +subroutine foo + integer :: i, j + !$omp do collapse(2) + do i = 1, 512 + !$omp unroll partial (3) + do j = 1, 512 + end do + !$omp end unroll + end do + !$omp end do +end subroutine foo + +subroutine bar + integer :: i, j + !$omp do collapse(2) + do i = 1, 512 + !$omp unroll partial (3) + do j = 1, 512 + end do + end do + !$omp end do +end subroutine bar + +subroutine baz + integer :: i, j + !$omp do collapse(2) + do i = 1, 512 + !$omp unroll partial (3) + do j = 1, 512 + end do + !$omp end unroll + end do +end subroutine baz + +subroutine qux + integer :: i, j + !$omp do collapse(2) + do i = 1, 512 + !$omp unroll partial (3) + do j = 1, 512 + end do + end do +end subroutine qux diff --git a/Fortran/gfortran/regression/gomp/unroll-2.f90 b/Fortran/gfortran/regression/gomp/unroll-2.f90 new file mode 100644 index 000000000..fa9316d10 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-2.f90 @@ -0,0 +1,22 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine test1 + implicit none + integer :: i + !$omp unroll + do i = 1,10 + call dummy(i) + end do +end subroutine test1 + +subroutine test2 + implicit none + integer :: i + !$omp unroll full + do i = 1,10 + call dummy(i) + end do +end subroutine test2 + +! { dg-final { scan-tree-dump-times "#pragma omp unroll" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp unroll full" 1 "original" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-3.f90 b/Fortran/gfortran/regression/gomp/unroll-3.f90 new file mode 100644 index 000000000..a649bc5ed --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-3.f90 @@ -0,0 +1,15 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test1 + implicit none + integer :: i + !$omp unroll full + do i = 1,10 + call dummy(i) + end do +end subroutine test1 + +! Loop should be removed with 10 copies of the body remaining +! { dg-final { scan-tree-dump "#pragma omp unroll full" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp" "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r\]*, 1, 10\\\);" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-4.f90 b/Fortran/gfortran/regression/gomp/unroll-4.f90 new file mode 100644 index 000000000..96bc8da07 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-4.f90 @@ -0,0 +1,15 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test1 + implicit none + integer :: i + !$omp unroll + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +! { dg-final { scan-tree-dump "#pragma omp unroll" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp" "gimple" } } +! { dg-final { scan-tree-dump-times "dummy" 1 "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r\]*, 1, 8\\\);" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-5.f90 b/Fortran/gfortran/regression/gomp/unroll-5.f90 new file mode 100644 index 000000000..7894304f7 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-5.f90 @@ -0,0 +1,14 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test1 + implicit none + integer :: i + !$omp unroll partial + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +! { dg-final { scan-tree-dump "#pragma omp unroll partial" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp" "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r\]*, 1, 8\\\);" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-6.f90 b/Fortran/gfortran/regression/gomp/unroll-6.f90 new file mode 100644 index 000000000..fb507b516 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-6.f90 @@ -0,0 +1,241 @@ +subroutine test1 + implicit none + integer :: i + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +subroutine test2 + implicit none + integer :: i + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test2 + +subroutine test3 + implicit none + integer :: i + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end do +end subroutine test3 + +subroutine test4 + implicit none + integer :: i + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end do +end subroutine test4 + +subroutine test5 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test5 + +subroutine test6 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test6 + +subroutine test7 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test7 + +subroutine test8 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll +end subroutine test8 + +subroutine test9 + implicit none + integer :: i + + !$omp do + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test9 + +subroutine test10 + implicit none + integer :: i + + !$omp unroll full + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test10 + +subroutine test11 + implicit none + integer :: i,j + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + do j = 1,100 + call dummy2(i,j) + end do + end do +end subroutine test11 + +subroutine test12 + implicit none + integer :: i,j + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + call dummy(i) ! { dg-error "Unexpected CALL statement at \\\(1\\\)" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do j = 1,100 + call dummy2(i,j) + end do + end do +end subroutine test12 + +subroutine test13 + implicit none + integer :: i,j + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do j = 1,100 + call dummy2(i,j) + end do + call dummy(i) + end do +end subroutine test13 + +subroutine test14 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll + !$omp end unroll ! { dg-error "Unexpected !\\\$OMP END UNROLL statement at \\\(1\\\)" } +end subroutine test14 + +subroutine test15 + implicit none + integer :: i + + !$omp do + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll + !$omp end unroll ! { dg-error "Unexpected !\\\$OMP END UNROLL statement at \\\(1\\\)" } +end subroutine test15 + +subroutine test18 + implicit none + integer :: i + + !$omp do + !$omp unroll partial(0) ! { dg-error "PARTIAL clause argument not constant positive integer at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test18 + +subroutine test19 + implicit none + integer :: i + + !$omp do + !$omp unroll partial(-10) ! { dg-error "PARTIAL clause argument not constant positive integer at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test19 + +subroutine test21 + implicit none + integer :: i + + !$omp unroll partial + do concurrent (i = 1:100) ! { dg-error "!\\\$OMP UNROLL cannot be a DO CONCURRENT loop at \\\(1\\\)" } + call dummy(i) ! { dg-error "Subroutine call to 'dummy' in DO CONCURRENT block at \\\(1\\\) is not PURE" } + end do + !$omp end unroll +end subroutine test21 + +subroutine test22 + implicit none + integer :: i + + !$omp do + !$omp unroll partial + do concurrent (i = 1:100) ! { dg-error "!\\\$OMP UNROLL cannot be a DO CONCURRENT loop at \\\(1\\\)" } + call dummy(i) ! { dg-error "Subroutine call to 'dummy' in DO CONCURRENT block at \\\(1\\\) is not PURE" } + end do + !$omp end unroll +end subroutine test22 diff --git a/Fortran/gfortran/regression/gomp/unroll-7.f90 b/Fortran/gfortran/regression/gomp/unroll-7.f90 new file mode 100644 index 000000000..0a06dd277 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-7.f90 @@ -0,0 +1,35 @@ +subroutine foo + integer :: i + !$omp do + !$omp unroll partial ( 3 ) + do i = 1, 512 + end do + !$omp end unroll + !$omp end do +end subroutine foo + +subroutine bar + integer :: i + !$omp do + !$omp unroll partial(3) + do i = 1, 512 + end do + !$omp end do +end subroutine bar + +subroutine baz + integer :: i + !$omp do + !$omp unroll partial (3) + do i = 1, 512 + end do +end subroutine baz + +subroutine qux + integer :: i + !$omp do + !$omp unroll partial (3) + do i = 1, 512 + end do + !$omp end unroll +end subroutine qux diff --git a/Fortran/gfortran/regression/gomp/unroll-8.f90 b/Fortran/gfortran/regression/gomp/unroll-8.f90 new file mode 100644 index 000000000..c8fcfa17b --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-8.f90 @@ -0,0 +1,26 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } */ + +subroutine test1 + implicit none + integer :: i + !$omp parallel do collapse(1) + !$omp unroll partial(4) + !$omp unroll partial(3) + !$omp unroll partial(2) + !$omp unroll partial(1) + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +! Loop should be unrolled 1 * 2 * 3 * 4 = 24 times +! { dg-final { scan-tree-dump "#pragma omp for nowait collapse\\\(1\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(1\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(2\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(3\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(4\\\)" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp unroll" "gimple" } } +! { dg-final { scan-tree-dump-times "\.ANNOTATE \\\(\[^\n\r\]*, 1, 2\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "\.ANNOTATE \\\(\[^\n\r\]*, 1, 3\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "\.ANNOTATE \\\(\[^\n\r\]*, 1, 4\\\);" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp for" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-9.f90 b/Fortran/gfortran/regression/gomp/unroll-9.f90 new file mode 100644 index 000000000..2223387a3 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-9.f90 @@ -0,0 +1,22 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +subroutine test1 + implicit none + integer :: i + !$omp unroll full + !$omp unroll partial(3) + !$omp unroll partial(2) + !$omp unroll partial(1) + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +! { dg-final { scan-tree-dump "#pragma omp unroll full" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(1\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(2\\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp unroll partial\\\(3\\\)" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp unroll" "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r]*, 1, 2\\\);" "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r]*, 1, 3\\\);" "gimple" } } +! { dg-final { scan-tree-dump "\.ANNOTATE \\\(\[^\n\r]*, 1, 17\\\);" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-inner-loop-1.f90 b/Fortran/gfortran/regression/gomp/unroll-inner-loop-1.f90 new file mode 100644 index 000000000..c43314412 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-inner-loop-1.f90 @@ -0,0 +1,28 @@ +subroutine test1a + !$omp parallel do + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp unroll partial(5) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test1a + +subroutine test1b + !$omp tile sizes(3,3,3) + do i=0,100 + do j=-300,100 + !$omp unroll partial(5) + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test1b diff --git a/Fortran/gfortran/regression/gomp/unroll-inner-loop-2.f90 b/Fortran/gfortran/regression/gomp/unroll-inner-loop-2.f90 new file mode 100644 index 000000000..89dc74d4e --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-inner-loop-2.f90 @@ -0,0 +1,28 @@ +subroutine test2a + !$omp parallel do + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp unroll partial(5) ! { dg-error "UNROLL construct at \\\(1\\\) with PARTIAL clause generates just one loop with canonical form but 2 loops are needed" } + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test2a + +subroutine test2b + !$omp tile sizes(3,3,3,3) + do i=0,100 + do j=-300,100 + !$omp unroll partial(5) ! { dg-error "UNROLL construct at \\\(1\\\) with PARTIAL clause generates just one loop with canonical form but 2 loops are needed" } + do k=-300,100 + do l=0,100 + call dummy (l) + end do + end do + end do + end do +end subroutine test2b diff --git a/Fortran/gfortran/regression/gomp/unroll-no-clause-1.f90 b/Fortran/gfortran/regression/gomp/unroll-no-clause-1.f90 new file mode 100644 index 000000000..7c5e1947a --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-no-clause-1.f90 @@ -0,0 +1,21 @@ +! { dg-additional-options "-O2 -fdump-tree-gimple" } + +subroutine test + !$omp unroll + do i = 1,5 + do j = 1,10 + call dummy3(i,j) + end do + end do + !$omp end unroll + + !$omp unroll + do i = 1,6 + do j = 1,6 + call dummy3(i,j) + end do + end do + !$omp end unroll +end subroutine test + +! { dg-final { scan-tree-dump-times "\.ANNOTATE \\\(\[^\n\r\]*, 1, 8\\\);" 2 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-non-rect-1.f90 b/Fortran/gfortran/regression/gomp/unroll-non-rect-1.f90 new file mode 100644 index 000000000..11e26a819 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-non-rect-1.f90 @@ -0,0 +1,13 @@ +subroutine test + implicit none + + integer :: i, j, k + !$omp unroll full + do i = -3, 5 + do j = 1,10 + do k = j,j*2 + 1 + call dummy (i) + end do + end do + end do +end subroutine diff --git a/Fortran/gfortran/regression/gomp/unroll-non-rect-2.f90 b/Fortran/gfortran/regression/gomp/unroll-non-rect-2.f90 new file mode 100644 index 000000000..d81256e28 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-non-rect-2.f90 @@ -0,0 +1,22 @@ +subroutine test + implicit none + + integer :: i, j, k + !$omp target parallel do collapse(2) + do i = -300, 100 + !$omp unroll partial + do j = i,i*2 ! { dg-message "Non-rectangular loops from generated loops unsupported" } + call dummy (i) + end do + end do + + !$omp target parallel do collapse(3) + do i = -300, 100 + do j = 1,10 + !$omp unroll partial + do k = j,j*2 + 1 ! { dg-message "Non-rectangular loops from generated loops unsupported" } + call dummy (i) + end do + end do + end do +end subroutine diff --git a/Fortran/gfortran/regression/gomp/unroll-simd-1.f90 b/Fortran/gfortran/regression/gomp/unroll-simd-1.f90 new file mode 100644 index 000000000..a6e7496fa --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-simd-1.f90 @@ -0,0 +1,37 @@ +! { dg-options "-fno-openmp -fopenmp-simd" } + +subroutine test15 + implicit none + integer :: i + + !$omp simd + !$omp unroll partial(1) + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test15 + +subroutine test16 + implicit none + integer :: i + + !$omp simd + !$omp unroll partial(2) + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test16 + +subroutine test19 + implicit none + integer :: i + + !$omp simd + !$omp unroll partial + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test19 diff --git a/Fortran/gfortran/regression/gomp/unroll-simd-2.f90 b/Fortran/gfortran/regression/gomp/unroll-simd-2.f90 new file mode 100644 index 000000000..06e712e16 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-simd-2.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! { dg-options "-O2 -fopenmp-simd -fdump-tree-original -fdump-tree-gimple" } + +module test_functions + contains + integer function compute_sum() result(sum) + implicit none + + integer :: i,j + + !$omp simd + do i = 1,10,3 + !$omp unroll full + do j = 1,10,3 + sum = sum + 1 + end do + end do + end function + + integer function compute_sum2() result(sum) + implicit none + + integer :: i,j + + !$omp simd + !$omp unroll partial(2) + do i = 1,10,3 + do j = 1,10,3 + sum = sum + 1 + end do + end do + end function +end module test_functions + +program test + use test_functions + implicit none + + integer :: result + + result = compute_sum () + write (*,*) result + if (result .ne. 16) then + call abort + end if + + result = compute_sum2 () + write (*,*) result + if (result .ne. 16) then + call abort + end if +end program + +! { dg-final { scan-tree-dump "omp unroll full" "original" } } +! { dg-final { scan-tree-dump "omp unroll partial\\\(2\\\)" "original" } } +! { dg-final { scan-tree-dump-not "omp unroll" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-simd-3.f90 b/Fortran/gfortran/regression/gomp/unroll-simd-3.f90 new file mode 100644 index 000000000..1c73c149f --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-simd-3.f90 @@ -0,0 +1,208 @@ +! { dg-options "-fno-openmp -fopenmp-simd" } + +subroutine test1 + implicit none + integer :: i + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test1 + +subroutine test2 + implicit none + integer :: i + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test2 + +subroutine test3 + implicit none + integer :: i + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end do +end subroutine test3 + +subroutine test4 + implicit none + integer :: i + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end do +end subroutine test4 + +subroutine test5 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test5 + +subroutine test6 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test6 + +subroutine test7 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll +end subroutine test7 + +subroutine test8 + implicit none + integer :: i + + !$omp simd + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test8 + +subroutine test9 + implicit none + integer :: i + + !$omp unroll full + !$omp unroll full ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do +end subroutine test9 + +subroutine test10 + implicit none + integer :: i,j + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + do j = 1,100 + call dummy2(i,j) + end do + end do +end subroutine test10 + +subroutine test11 + implicit none + integer :: i,j + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + call dummy(i) ! { dg-error "Unexpected CALL statement at \\\(1\\\)" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do j = 1,100 + call dummy2(i,j) + end do + end do +end subroutine test11 + +subroutine test12 + implicit none + integer :: i,j + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do j = 1,100 + call dummy2(i,j) + end do + call dummy(i) + end do +end subroutine test12 + +subroutine test13 + implicit none + integer :: i + + !$omp unroll + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll + !$omp end unroll ! { dg-error "Unexpected !\\\$OMP END UNROLL statement at \\\(1\\\)" } +end subroutine test13 + +subroutine test14 + implicit none + integer :: i + + !$omp simd + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + !$omp unroll ! { dg-error "Generated loop of UNROLL construct at \\\(1\\\) without PARTIAL clause does not have canonical form" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll + !$omp end unroll + !$omp end unroll ! { dg-error "Unexpected !\\\$OMP END UNROLL statement at \\\(1\\\)" } +end subroutine test14 + +subroutine test17 + implicit none + integer :: i + + !$omp simd + !$omp unroll partial(0) ! { dg-error "PARTIAL clause argument not constant positive integer at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test17 + +subroutine test18 + implicit none + integer :: i + + !$omp simd + !$omp unroll partial(-10) ! { dg-error "PARTIAL clause argument not constant positive integer at \\\(1\\\)" } + do i = 1,100 + call dummy(i) + end do + !$omp end unroll +end subroutine test18 diff --git a/Fortran/gfortran/regression/gomp/unroll-tile-1.f90 b/Fortran/gfortran/regression/gomp/unroll-tile-1.f90 new file mode 100644 index 000000000..ed7691be1 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-tile-1.f90 @@ -0,0 +1,35 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +function mult (a, b) result (c) + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + + allocate(c( n, m )) + + !$omp parallel do + !$omp unroll partial(1) + !$omp tile sizes (8,8) + do i = 1,m + do j = 1,n + inner = 0 + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end function mult + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp unroll partial\\\(1\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(8, 8\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp unroll" "gimple" } } +! { dg-final { scan-tree-dump-not "#pragma omp tile" "gimple" } } + +! Tiling adds two floor and two tile loops. +! Unroll with partial(1) is effectively ignored and the innermost +! loop isn't associated with anything. So that means 5 loops, +! with the outermost associated with !$omp parallel do, where +! the innermost loop gimplifies condition into a boolean temporary. + +! { dg-final { scan-tree-dump-times "if \\\(\[A-Za-z0-9_.\]+ <" 3 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-tile-2.f90 b/Fortran/gfortran/regression/gomp/unroll-tile-2.f90 new file mode 100644 index 000000000..d49e5ea08 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-tile-2.f90 @@ -0,0 +1,40 @@ +! { dg-additional-options "-O2 -fdump-tree-original -fdump-tree-gimple" } + +function mult (a, b) result (c) + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + + allocate(c( n, m )) + c = 0 + + !$omp target + !$omp parallel do + !$omp unroll partial(2) + !$omp tile sizes (8,8,4) + do i = 1,m + do j = 1,n + do k = 1, n + c(j,i) = c(j,i) + a(k, i) * b(j, k) + end do + end do + end do + !$omp end target +end function mult + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp unroll partial\\\(2\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp tile sizes\\\(8, 8, 4\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp unroll" "gimple" } } +! { dg-final { scan-tree-dump-not "#pragma omp tile" "gimple" } } + +! Check the number of loops + +! Tiling adds three tile and three floor loops. +! The outermost tile loop is then partially unrolled, turning it +! into one tile and one floor loop, so now 7 loops in total, one +! of them being fully unrolled. And finally the outermost loop is +! associated with the !$omp parallel do and so not lowered during +! gimplification. + +! { dg-final { scan-tree-dump-times "if \\\(\[A-Za-z0-9_.\]+ <" 5 "gimple" } } +! { dg-final { scan-tree-dump-times "\.ANNOTATE \\\(\[^\n\r\]*, 1, 2\\\);" 1 "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/unroll-tile-inner-1.f90 b/Fortran/gfortran/regression/gomp/unroll-tile-inner-1.f90 new file mode 100644 index 000000000..22e51cd60 --- /dev/null +++ b/Fortran/gfortran/regression/gomp/unroll-tile-inner-1.f90 @@ -0,0 +1,24 @@ +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + +function mult (a, b) result (c) + integer, allocatable, dimension (:,:) :: a,b,c + integer :: i, j, k, inner + + allocate(c( n, m )) + + !$omp parallel do collapse(2) + !$omp tile sizes (8,8) + do i = 1,m + do j = 1,n + inner = 0 + !$omp unroll partial(10) + do k = 1, n + inner = inner + a(k, i) * b(j, k) + end do + c(j, i) = inner + end do + end do +end function mult + +! { dg-final { scan-tree-dump-times "#pragma omp unroll partial" 1 "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp unroll partial" "gimple" } } diff --git a/Fortran/gfortran/regression/gomp/warn_truncated.f90 b/Fortran/gfortran/regression/gomp/warn_truncated.f90 index 86d7eb27b..20cd0449b 100644 --- a/Fortran/gfortran/regression/gomp/warn_truncated.f90 +++ b/Fortran/gfortran/regression/gomp/warn_truncated.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-additional-options "-std=f2018" } ! ! PR fortran/94709 ! diff --git a/Fortran/gfortran/regression/graphite/graphite.exp b/Fortran/gfortran/regression/graphite/graphite.exp index 3dcf7bc73..62e35a40d 100644 --- a/Fortran/gfortran/regression/graphite/graphite.exp +++ b/Fortran/gfortran/regression/graphite/graphite.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2008-2023 Free Software Foundation, Inc. +# Copyright (C) 2008-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/regression/graphite/pr107865.f90 b/Fortran/gfortran/regression/graphite/pr107865.f90 index 6bddb17a1..323d8092a 100644 --- a/Fortran/gfortran/regression/graphite/pr107865.f90 +++ b/Fortran/gfortran/regression/graphite/pr107865.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-options "-O1 -floop-parallelize-all -ftree-parallelize-loops=2" } - SUBROUTINE FNC (F) + SUBROUTINE FNC (F,N) IMPLICIT REAL (A-H) DIMENSION F(N) diff --git a/Fortran/gfortran/regression/graphite/vect-pr40979.f90 b/Fortran/gfortran/regression/graphite/vect-pr40979.f90 index a42290948..6f2ad1166 100644 --- a/Fortran/gfortran/regression/graphite/vect-pr40979.f90 +++ b/Fortran/gfortran/regression/graphite/vect-pr40979.f90 @@ -1,6 +1,7 @@ ! { dg-do compile } ! { dg-require-effective-target vect_double } ! { dg-additional-options "-msse2" { target { { i?86-*-* x86_64-*-* } && ilp32 } } } +! { dg-additional-options "-mlsx" { target { loongarch*-*-* } } } module mqc_m integer, parameter, private :: longreal = selected_real_kind(15,90) diff --git a/Fortran/gfortran/regression/guality/guality.exp b/Fortran/gfortran/regression/guality/guality.exp index 86a966a91..610449523 100644 --- a/Fortran/gfortran/regression/guality/guality.exp +++ b/Fortran/gfortran/regression/guality/guality.exp @@ -18,6 +18,7 @@ if { [istarget "powerpc-ibm-aix*"] } { } dg-init +torture-init global GDB if ![info exists ::env(GUALITY_GDB_NAME)] { @@ -35,7 +36,6 @@ report_gdb $::env(GUALITY_GDB_NAME) [info script] global DG_TORTURE_OPTIONS set guality_dg_torture_options [guality_minimal_options $DG_TORTURE_OPTIONS] -torture-init set-torture-options \ $guality_dg_torture_options \ diff --git a/Fortran/gfortran/regression/ieee/DisabledFiles.cmake b/Fortran/gfortran/regression/ieee/DisabledFiles.cmake index 11454c3db..2f9ffe4c0 100644 --- a/Fortran/gfortran/regression/ieee/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/ieee/DisabledFiles.cmake @@ -60,6 +60,19 @@ file(GLOB SKIPPED_FILES CONFIGURE_DEPENDS # conditionally enabling them if libquadmath is available. ieee_9.f90 + + # -------------------------------------------------------------------------- + # + # These tests cause linker errors with undefined references to ieee_* + # functions. This may be a configuration issue, but disable it for now until + # that can be determined. + comparisons_1.f90 + comparisons_2.f90 + comparisons_3.F90 + minmax_1.f90 + minmax_2.f90 + minmax_3.f90 + minmax_4.f90 ) # There are currently no failing files. diff --git a/Fortran/gfortran/regression/ieee/comparisons_1.f90 b/Fortran/gfortran/regression/ieee/comparisons_1.f90 new file mode 100644 index 000000000..39a8abdef --- /dev/null +++ b/Fortran/gfortran/regression/ieee/comparisons_1.f90 @@ -0,0 +1,282 @@ +! { dg-do run } +program foo + use ieee_arithmetic + use iso_fortran_env + implicit none + + ! This allows us to test REAL128 if it exists, and still compile + ! on platforms were it is not present + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639 + integer, parameter :: large = merge(real128, real64, real128 > 0) + + real, volatile :: rnan, rinf + double precision, volatile :: dnan, dinf + real(kind=large), volatile :: lnan, linf + + rinf = ieee_value(0., ieee_positive_inf) + rnan = ieee_value(0., ieee_quiet_nan) + + dinf = ieee_value(0.d0, ieee_positive_inf) + dnan = ieee_value(0.d0, ieee_quiet_nan) + + linf = ieee_value(0._large, ieee_positive_inf) + lnan = ieee_value(0._large, ieee_quiet_nan) + + if (.not. ieee_quiet_eq (0., 0.)) stop 1 + if (.not. ieee_quiet_eq (0., -0.)) stop 2 + if (.not. ieee_quiet_eq (1., 1.)) stop 3 + if (.not. ieee_quiet_eq (rinf, rinf)) stop 4 + if (.not. ieee_quiet_eq (-rinf, -rinf)) stop 5 + if (ieee_quiet_eq (rnan, rnan)) stop 6 + if (ieee_quiet_eq (0., 1.)) stop 7 + if (ieee_quiet_eq (0., -1.)) stop 8 + if (ieee_quiet_eq (0., rnan)) stop 9 + if (ieee_quiet_eq (1., rnan)) stop 10 + if (ieee_quiet_eq (0., rinf)) stop 11 + if (ieee_quiet_eq (1., rinf)) stop 12 + if (ieee_quiet_eq (rinf, rnan)) stop 13 + + if (.not. ieee_quiet_eq (0.d0, 0.d0)) stop 14 + if (.not. ieee_quiet_eq (0.d0, -0.d0)) stop 15 + if (.not. ieee_quiet_eq (1.d0, 1.d0)) stop 16 + if (.not. ieee_quiet_eq (dinf, dinf)) stop 17 + if (.not. ieee_quiet_eq (-dinf, -dinf)) stop 18 + if (ieee_quiet_eq (dnan, dnan)) stop 19 + if (ieee_quiet_eq (0.d0, 1.d0)) stop 20 + if (ieee_quiet_eq (0.d0, -1.d0)) stop 21 + if (ieee_quiet_eq (0.d0, dnan)) stop 22 + if (ieee_quiet_eq (1.d0, dnan)) stop 23 + if (ieee_quiet_eq (0.d0, dinf)) stop 24 + if (ieee_quiet_eq (1.d0, dinf)) stop 25 + if (ieee_quiet_eq (dinf, dnan)) stop 26 + + if (.not. ieee_quiet_eq (0._large, 0._large)) stop 27 + if (.not. ieee_quiet_eq (0._large, -0._large)) stop 28 + if (.not. ieee_quiet_eq (1._large, 1._large)) stop 29 + if (.not. ieee_quiet_eq (linf, linf)) stop 30 + if (.not. ieee_quiet_eq (-linf, -linf)) stop 31 + if (ieee_quiet_eq (lnan, lnan)) stop 32 + if (ieee_quiet_eq (0._large, 1._large)) stop 33 + if (ieee_quiet_eq (0._large, -1._large)) stop 34 + if (ieee_quiet_eq (0._large, lnan)) stop 35 + if (ieee_quiet_eq (1._large, lnan)) stop 36 + if (ieee_quiet_eq (0._large, linf)) stop 37 + if (ieee_quiet_eq (1._large, linf)) stop 38 + if (ieee_quiet_eq (linf, lnan)) stop 39 + + + if (ieee_quiet_ne (0., 0.)) stop 40 + if (ieee_quiet_ne (0., -0.)) stop 41 + if (ieee_quiet_ne (1., 1.)) stop 42 + if (ieee_quiet_ne (rinf, rinf)) stop 43 + if (ieee_quiet_ne (-rinf, -rinf)) stop 44 + if (.not. ieee_quiet_ne (rnan, rnan)) stop 45 + if (.not. ieee_quiet_ne (0., 1.)) stop 46 + if (.not. ieee_quiet_ne (0., -1.)) stop 47 + if (.not. ieee_quiet_ne (0., rnan)) stop 48 + if (.not. ieee_quiet_ne (1., rnan)) stop 49 + if (.not. ieee_quiet_ne (0., rinf)) stop 50 + if (.not. ieee_quiet_ne (1., rinf)) stop 51 + if (.not. ieee_quiet_ne (rinf, rnan)) stop 52 + + if (ieee_quiet_ne (0.d0, 0.d0)) stop 53 + if (ieee_quiet_ne (0.d0, -0.d0)) stop 54 + if (ieee_quiet_ne (1.d0, 1.d0)) stop 55 + if (ieee_quiet_ne (dinf, dinf)) stop 56 + if (ieee_quiet_ne (-dinf, -dinf)) stop 57 + if (.not. ieee_quiet_ne (dnan, dnan)) stop 58 + if (.not. ieee_quiet_ne (0.d0, 1.d0)) stop 59 + if (.not. ieee_quiet_ne (0.d0, -1.d0)) stop 60 + if (.not. ieee_quiet_ne (0.d0, dnan)) stop 61 + if (.not. ieee_quiet_ne (1.d0, dnan)) stop 62 + if (.not. ieee_quiet_ne (0.d0, dinf)) stop 63 + if (.not. ieee_quiet_ne (1.d0, dinf)) stop 64 + if (.not. ieee_quiet_ne (dinf, dnan)) stop 65 + + if (ieee_quiet_ne (0._large, 0._large)) stop 66 + if (ieee_quiet_ne (0._large, -0._large)) stop 67 + if (ieee_quiet_ne (1._large, 1._large)) stop 68 + if (ieee_quiet_ne (linf, linf)) stop 69 + if (ieee_quiet_ne (-linf, -linf)) stop 70 + if (.not. ieee_quiet_ne (lnan, lnan)) stop 71 + if (.not. ieee_quiet_ne (0._large, 1._large)) stop 72 + if (.not. ieee_quiet_ne (0._large, -1._large)) stop 73 + if (.not. ieee_quiet_ne (0._large, lnan)) stop 74 + if (.not. ieee_quiet_ne (1._large, lnan)) stop 75 + if (.not. ieee_quiet_ne (0._large, linf)) stop 76 + if (.not. ieee_quiet_ne (1._large, linf)) stop 77 + if (.not. ieee_quiet_ne (linf, lnan)) stop 78 + + + if (.not. ieee_quiet_le (0., 0.)) stop 79 + if (.not. ieee_quiet_le (0., -0.)) stop 80 + if (.not. ieee_quiet_le (1., 1.)) stop 81 + if (.not. ieee_quiet_le (rinf, rinf)) stop 82 + if (.not. ieee_quiet_le (-rinf, -rinf)) stop 83 + if (ieee_quiet_le (rnan, rnan)) stop 84 + if (.not. ieee_quiet_le (0., 1.)) stop 85 + if (ieee_quiet_le (0., -1.)) stop 86 + if (ieee_quiet_le (0., rnan)) stop 87 + if (ieee_quiet_le (1., rnan)) stop 88 + if (.not. ieee_quiet_le (0., rinf)) stop 89 + if (.not. ieee_quiet_le (1., rinf)) stop 90 + if (ieee_quiet_le (rinf, rnan)) stop 91 + + if (.not. ieee_quiet_le (0.d0, 0.d0)) stop 92 + if (.not. ieee_quiet_le (0.d0, -0.d0)) stop 93 + if (.not. ieee_quiet_le (1.d0, 1.d0)) stop 94 + if (.not. ieee_quiet_le (dinf, dinf)) stop 95 + if (.not. ieee_quiet_le (-dinf, -dinf)) stop 96 + if (ieee_quiet_le (dnan, dnan)) stop 97 + if (.not. ieee_quiet_le (0.d0, 1.d0)) stop 98 + if (ieee_quiet_le (0.d0, -1.d0)) stop 99 + if (ieee_quiet_le (0.d0, dnan)) stop 100 + if (ieee_quiet_le (1.d0, dnan)) stop 101 + if (.not. ieee_quiet_le (0.d0, dinf)) stop 102 + if (.not. ieee_quiet_le (1.d0, dinf)) stop 103 + if (ieee_quiet_le (dinf, dnan)) stop 104 + + if (.not. ieee_quiet_le (0._large, 0._large)) stop 105 + if (.not. ieee_quiet_le (0._large, -0._large)) stop 106 + if (.not. ieee_quiet_le (1._large, 1._large)) stop 107 + if (.not. ieee_quiet_le (linf, linf)) stop 108 + if (.not. ieee_quiet_le (-linf, -linf)) stop 109 + if (ieee_quiet_le (lnan, lnan)) stop 110 + if (.not. ieee_quiet_le (0._large, 1._large)) stop 111 + if (ieee_quiet_le (0._large, -1._large)) stop 112 + if (ieee_quiet_le (0._large, lnan)) stop 113 + if (ieee_quiet_le (1._large, lnan)) stop 114 + if (.not. ieee_quiet_le (0._large, linf)) stop 115 + if (.not. ieee_quiet_le (1._large, linf)) stop 116 + if (ieee_quiet_le (linf, lnan)) stop 117 + + + if (.not. ieee_quiet_ge (0., 0.)) stop 118 + if (.not. ieee_quiet_ge (0., -0.)) stop 119 + if (.not. ieee_quiet_ge (1., 1.)) stop 120 + if (.not. ieee_quiet_ge (rinf, rinf)) stop 121 + if (.not. ieee_quiet_ge (-rinf, -rinf)) stop 122 + if (ieee_quiet_ge (rnan, rnan)) stop 123 + if (ieee_quiet_ge (0., 1.)) stop 124 + if (.not. ieee_quiet_ge (0., -1.)) stop 125 + if (ieee_quiet_ge (0., rnan)) stop 126 + if (ieee_quiet_ge (1., rnan)) stop 127 + if (ieee_quiet_ge (0., rinf)) stop 128 + if (ieee_quiet_ge (1., rinf)) stop 129 + if (ieee_quiet_ge (rinf, rnan)) stop 130 + + if (.not. ieee_quiet_ge (0.d0, 0.d0)) stop 131 + if (.not. ieee_quiet_ge (0.d0, -0.d0)) stop 132 + if (.not. ieee_quiet_ge (1.d0, 1.d0)) stop 133 + if (.not. ieee_quiet_ge (dinf, dinf)) stop 134 + if (.not. ieee_quiet_ge (-dinf, -dinf)) stop 135 + if (ieee_quiet_ge (dnan, dnan)) stop 136 + if (ieee_quiet_ge (0.d0, 1.d0)) stop 137 + if (.not. ieee_quiet_ge (0.d0, -1.d0)) stop 138 + if (ieee_quiet_ge (0.d0, dnan)) stop 139 + if (ieee_quiet_ge (1.d0, dnan)) stop 140 + if (ieee_quiet_ge (0.d0, dinf)) stop 141 + if (ieee_quiet_ge (1.d0, dinf)) stop 142 + if (ieee_quiet_ge (dinf, dnan)) stop 143 + + if (.not. ieee_quiet_ge (0._large, 0._large)) stop 144 + if (.not. ieee_quiet_ge (0._large, -0._large)) stop 145 + if (.not. ieee_quiet_ge (1._large, 1._large)) stop 146 + if (.not. ieee_quiet_ge (linf, linf)) stop 147 + if (.not. ieee_quiet_ge (-linf, -linf)) stop 148 + if (ieee_quiet_ge (lnan, lnan)) stop 149 + if (ieee_quiet_ge (0._large, 1._large)) stop 150 + if (.not. ieee_quiet_ge (0._large, -1._large)) stop 151 + if (ieee_quiet_ge (0._large, lnan)) stop 152 + if (ieee_quiet_ge (1._large, lnan)) stop 153 + if (ieee_quiet_ge (0._large, linf)) stop 154 + if (ieee_quiet_ge (1._large, linf)) stop 155 + if (ieee_quiet_ge (linf, lnan)) stop 156 + + + if (ieee_quiet_lt (0., 0.)) stop 157 + if (ieee_quiet_lt (0., -0.)) stop 158 + if (ieee_quiet_lt (1., 1.)) stop 159 + if (ieee_quiet_lt (rinf, rinf)) stop 160 + if (ieee_quiet_lt (-rinf, -rinf)) stop 161 + if (ieee_quiet_lt (rnan, rnan)) stop 162 + if (.not. ieee_quiet_lt (0., 1.)) stop 163 + if (ieee_quiet_lt (0., -1.)) stop 164 + if (ieee_quiet_lt (0., rnan)) stop 165 + if (ieee_quiet_lt (1., rnan)) stop 166 + if (.not. ieee_quiet_lt (0., rinf)) stop 167 + if (.not. ieee_quiet_lt (1., rinf)) stop 168 + if (ieee_quiet_lt (rinf, rnan)) stop 169 + + if (ieee_quiet_lt (0.d0, 0.d0)) stop 170 + if (ieee_quiet_lt (0.d0, -0.d0)) stop 171 + if (ieee_quiet_lt (1.d0, 1.d0)) stop 172 + if (ieee_quiet_lt (dinf, dinf)) stop 173 + if (ieee_quiet_lt (-dinf, -dinf)) stop 174 + if (ieee_quiet_lt (dnan, dnan)) stop 175 + if (.not. ieee_quiet_lt (0.d0, 1.d0)) stop 176 + if (ieee_quiet_lt (0.d0, -1.d0)) stop 177 + if (ieee_quiet_lt (0.d0, dnan)) stop 178 + if (ieee_quiet_lt (1.d0, dnan)) stop 179 + if (.not. ieee_quiet_lt (0.d0, dinf)) stop 180 + if (.not. ieee_quiet_lt (1.d0, dinf)) stop 181 + if (ieee_quiet_lt (dinf, dnan)) stop 182 + + if (ieee_quiet_lt (0._large, 0._large)) stop 183 + if (ieee_quiet_lt (0._large, -0._large)) stop 184 + if (ieee_quiet_lt (1._large, 1._large)) stop 185 + if (ieee_quiet_lt (linf, linf)) stop 186 + if (ieee_quiet_lt (-linf, -linf)) stop 187 + if (ieee_quiet_lt (lnan, lnan)) stop 188 + if (.not. ieee_quiet_lt (0._large, 1._large)) stop 189 + if (ieee_quiet_lt (0._large, -1._large)) stop 190 + if (ieee_quiet_lt (0._large, lnan)) stop 191 + if (ieee_quiet_lt (1._large, lnan)) stop 192 + if (.not. ieee_quiet_lt (0._large, linf)) stop 193 + if (.not. ieee_quiet_lt (1._large, linf)) stop 194 + if (ieee_quiet_lt (linf, lnan)) stop 195 + + + if (ieee_quiet_gt (0., 0.)) stop 196 + if (ieee_quiet_gt (0., -0.)) stop 197 + if (ieee_quiet_gt (1., 1.)) stop 198 + if (ieee_quiet_gt (rinf, rinf)) stop 199 + if (ieee_quiet_gt (-rinf, -rinf)) stop 200 + if (ieee_quiet_gt (rnan, rnan)) stop 201 + if (ieee_quiet_gt (0., 1.)) stop 202 + if (.not. ieee_quiet_gt (0., -1.)) stop 203 + if (ieee_quiet_gt (0., rnan)) stop 204 + if (ieee_quiet_gt (1., rnan)) stop 205 + if (ieee_quiet_gt (0., rinf)) stop 206 + if (ieee_quiet_gt (1., rinf)) stop 207 + if (ieee_quiet_gt (rinf, rnan)) stop 208 + + if (ieee_quiet_gt (0.d0, 0.d0)) stop 209 + if (ieee_quiet_gt (0.d0, -0.d0)) stop 210 + if (ieee_quiet_gt (1.d0, 1.d0)) stop 211 + if (ieee_quiet_gt (dinf, dinf)) stop 212 + if (ieee_quiet_gt (-dinf, -dinf)) stop 213 + if (ieee_quiet_gt (dnan, dnan)) stop 214 + if (ieee_quiet_gt (0.d0, 1.d0)) stop 215 + if (.not. ieee_quiet_gt (0.d0, -1.d0)) stop 216 + if (ieee_quiet_gt (0.d0, dnan)) stop 217 + if (ieee_quiet_gt (1.d0, dnan)) stop 218 + if (ieee_quiet_gt (0.d0, dinf)) stop 219 + if (ieee_quiet_gt (1.d0, dinf)) stop 220 + if (ieee_quiet_gt (dinf, dnan)) stop 221 + + if (ieee_quiet_gt (0._large, 0._large)) stop 222 + if (ieee_quiet_gt (0._large, -0._large)) stop 223 + if (ieee_quiet_gt (1._large, 1._large)) stop 224 + if (ieee_quiet_gt (linf, linf)) stop 225 + if (ieee_quiet_gt (-linf, -linf)) stop 226 + if (ieee_quiet_gt (lnan, lnan)) stop 227 + if (ieee_quiet_gt (0._large, 1._large)) stop 228 + if (.not. ieee_quiet_gt (0._large, -1._large)) stop 229 + if (ieee_quiet_gt (0._large, lnan)) stop 230 + if (ieee_quiet_gt (1._large, lnan)) stop 231 + if (ieee_quiet_gt (0._large, linf)) stop 232 + if (ieee_quiet_gt (1._large, linf)) stop 233 + if (ieee_quiet_gt (linf, lnan)) stop 234 + +end program foo diff --git a/Fortran/gfortran/regression/ieee/comparisons_2.f90 b/Fortran/gfortran/regression/ieee/comparisons_2.f90 new file mode 100644 index 000000000..35aa1fcba --- /dev/null +++ b/Fortran/gfortran/regression/ieee/comparisons_2.f90 @@ -0,0 +1,282 @@ +! { dg-do run } +program foo + use ieee_arithmetic + use iso_fortran_env + implicit none + + ! This allows us to test REAL128 if it exists, and still compile + ! on platforms were it is not present + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639 + integer, parameter :: large = merge(real128, real64, real128 > 0) + + real, volatile :: rnan, rinf + double precision, volatile :: dnan, dinf + real(kind=large), volatile :: lnan, linf + + rinf = ieee_value(0., ieee_positive_inf) + rnan = ieee_value(0., ieee_quiet_nan) + + dinf = ieee_value(0.d0, ieee_positive_inf) + dnan = ieee_value(0.d0, ieee_quiet_nan) + + linf = ieee_value(0._large, ieee_positive_inf) + lnan = ieee_value(0._large, ieee_quiet_nan) + + if (.not. ieee_signaling_eq (0., 0.)) stop 1 + if (.not. ieee_signaling_eq (0., -0.)) stop 2 + if (.not. ieee_signaling_eq (1., 1.)) stop 3 + if (.not. ieee_signaling_eq (rinf, rinf)) stop 4 + if (.not. ieee_signaling_eq (-rinf, -rinf)) stop 5 + if (ieee_signaling_eq (rnan, rnan)) stop 6 + if (ieee_signaling_eq (0., 1.)) stop 7 + if (ieee_signaling_eq (0., -1.)) stop 8 + if (ieee_signaling_eq (0., rnan)) stop 9 + if (ieee_signaling_eq (1., rnan)) stop 10 + if (ieee_signaling_eq (0., rinf)) stop 11 + if (ieee_signaling_eq (1., rinf)) stop 12 + if (ieee_signaling_eq (rinf, rnan)) stop 13 + + if (.not. ieee_signaling_eq (0.d0, 0.d0)) stop 14 + if (.not. ieee_signaling_eq (0.d0, -0.d0)) stop 15 + if (.not. ieee_signaling_eq (1.d0, 1.d0)) stop 16 + if (.not. ieee_signaling_eq (dinf, dinf)) stop 17 + if (.not. ieee_signaling_eq (-dinf, -dinf)) stop 18 + if (ieee_signaling_eq (dnan, dnan)) stop 19 + if (ieee_signaling_eq (0.d0, 1.d0)) stop 20 + if (ieee_signaling_eq (0.d0, -1.d0)) stop 21 + if (ieee_signaling_eq (0.d0, dnan)) stop 22 + if (ieee_signaling_eq (1.d0, dnan)) stop 23 + if (ieee_signaling_eq (0.d0, dinf)) stop 24 + if (ieee_signaling_eq (1.d0, dinf)) stop 25 + if (ieee_signaling_eq (dinf, dnan)) stop 26 + + if (.not. ieee_signaling_eq (0._large, 0._large)) stop 27 + if (.not. ieee_signaling_eq (0._large, -0._large)) stop 28 + if (.not. ieee_signaling_eq (1._large, 1._large)) stop 29 + if (.not. ieee_signaling_eq (linf, linf)) stop 30 + if (.not. ieee_signaling_eq (-linf, -linf)) stop 31 + if (ieee_signaling_eq (lnan, lnan)) stop 32 + if (ieee_signaling_eq (0._large, 1._large)) stop 33 + if (ieee_signaling_eq (0._large, -1._large)) stop 34 + if (ieee_signaling_eq (0._large, lnan)) stop 35 + if (ieee_signaling_eq (1._large, lnan)) stop 36 + if (ieee_signaling_eq (0._large, linf)) stop 37 + if (ieee_signaling_eq (1._large, linf)) stop 38 + if (ieee_signaling_eq (linf, lnan)) stop 39 + + + if (ieee_signaling_ne (0., 0.)) stop 40 + if (ieee_signaling_ne (0., -0.)) stop 41 + if (ieee_signaling_ne (1., 1.)) stop 42 + if (ieee_signaling_ne (rinf, rinf)) stop 43 + if (ieee_signaling_ne (-rinf, -rinf)) stop 44 + if (.not. ieee_signaling_ne (rnan, rnan)) stop 45 + if (.not. ieee_signaling_ne (0., 1.)) stop 46 + if (.not. ieee_signaling_ne (0., -1.)) stop 47 + if (.not. ieee_signaling_ne (0., rnan)) stop 48 + if (.not. ieee_signaling_ne (1., rnan)) stop 49 + if (.not. ieee_signaling_ne (0., rinf)) stop 50 + if (.not. ieee_signaling_ne (1., rinf)) stop 51 + if (.not. ieee_signaling_ne (rinf, rnan)) stop 52 + + if (ieee_signaling_ne (0.d0, 0.d0)) stop 53 + if (ieee_signaling_ne (0.d0, -0.d0)) stop 54 + if (ieee_signaling_ne (1.d0, 1.d0)) stop 55 + if (ieee_signaling_ne (dinf, dinf)) stop 56 + if (ieee_signaling_ne (-dinf, -dinf)) stop 57 + if (.not. ieee_signaling_ne (dnan, dnan)) stop 58 + if (.not. ieee_signaling_ne (0.d0, 1.d0)) stop 59 + if (.not. ieee_signaling_ne (0.d0, -1.d0)) stop 60 + if (.not. ieee_signaling_ne (0.d0, dnan)) stop 61 + if (.not. ieee_signaling_ne (1.d0, dnan)) stop 62 + if (.not. ieee_signaling_ne (0.d0, dinf)) stop 63 + if (.not. ieee_signaling_ne (1.d0, dinf)) stop 64 + if (.not. ieee_signaling_ne (dinf, dnan)) stop 65 + + if (ieee_signaling_ne (0._large, 0._large)) stop 66 + if (ieee_signaling_ne (0._large, -0._large)) stop 67 + if (ieee_signaling_ne (1._large, 1._large)) stop 68 + if (ieee_signaling_ne (linf, linf)) stop 69 + if (ieee_signaling_ne (-linf, -linf)) stop 70 + if (.not. ieee_signaling_ne (lnan, lnan)) stop 71 + if (.not. ieee_signaling_ne (0._large, 1._large)) stop 72 + if (.not. ieee_signaling_ne (0._large, -1._large)) stop 73 + if (.not. ieee_signaling_ne (0._large, lnan)) stop 74 + if (.not. ieee_signaling_ne (1._large, lnan)) stop 75 + if (.not. ieee_signaling_ne (0._large, linf)) stop 76 + if (.not. ieee_signaling_ne (1._large, linf)) stop 77 + if (.not. ieee_signaling_ne (linf, lnan)) stop 78 + + + if (.not. ieee_signaling_le (0., 0.)) stop 79 + if (.not. ieee_signaling_le (0., -0.)) stop 80 + if (.not. ieee_signaling_le (1., 1.)) stop 81 + if (.not. ieee_signaling_le (rinf, rinf)) stop 82 + if (.not. ieee_signaling_le (-rinf, -rinf)) stop 83 + if (ieee_signaling_le (rnan, rnan)) stop 84 + if (.not. ieee_signaling_le (0., 1.)) stop 85 + if (ieee_signaling_le (0., -1.)) stop 86 + if (ieee_signaling_le (0., rnan)) stop 87 + if (ieee_signaling_le (1., rnan)) stop 88 + if (.not. ieee_signaling_le (0., rinf)) stop 89 + if (.not. ieee_signaling_le (1., rinf)) stop 90 + if (ieee_signaling_le (rinf, rnan)) stop 91 + + if (.not. ieee_signaling_le (0.d0, 0.d0)) stop 92 + if (.not. ieee_signaling_le (0.d0, -0.d0)) stop 93 + if (.not. ieee_signaling_le (1.d0, 1.d0)) stop 94 + if (.not. ieee_signaling_le (dinf, dinf)) stop 95 + if (.not. ieee_signaling_le (-dinf, -dinf)) stop 96 + if (ieee_signaling_le (dnan, dnan)) stop 97 + if (.not. ieee_signaling_le (0.d0, 1.d0)) stop 98 + if (ieee_signaling_le (0.d0, -1.d0)) stop 99 + if (ieee_signaling_le (0.d0, dnan)) stop 100 + if (ieee_signaling_le (1.d0, dnan)) stop 101 + if (.not. ieee_signaling_le (0.d0, dinf)) stop 102 + if (.not. ieee_signaling_le (1.d0, dinf)) stop 103 + if (ieee_signaling_le (dinf, dnan)) stop 104 + + if (.not. ieee_signaling_le (0._large, 0._large)) stop 105 + if (.not. ieee_signaling_le (0._large, -0._large)) stop 106 + if (.not. ieee_signaling_le (1._large, 1._large)) stop 107 + if (.not. ieee_signaling_le (linf, linf)) stop 108 + if (.not. ieee_signaling_le (-linf, -linf)) stop 109 + if (ieee_signaling_le (lnan, lnan)) stop 110 + if (.not. ieee_signaling_le (0._large, 1._large)) stop 111 + if (ieee_signaling_le (0._large, -1._large)) stop 112 + if (ieee_signaling_le (0._large, lnan)) stop 113 + if (ieee_signaling_le (1._large, lnan)) stop 114 + if (.not. ieee_signaling_le (0._large, linf)) stop 115 + if (.not. ieee_signaling_le (1._large, linf)) stop 116 + if (ieee_signaling_le (linf, lnan)) stop 117 + + + if (.not. ieee_signaling_ge (0., 0.)) stop 118 + if (.not. ieee_signaling_ge (0., -0.)) stop 119 + if (.not. ieee_signaling_ge (1., 1.)) stop 120 + if (.not. ieee_signaling_ge (rinf, rinf)) stop 121 + if (.not. ieee_signaling_ge (-rinf, -rinf)) stop 122 + if (ieee_signaling_ge (rnan, rnan)) stop 123 + if (ieee_signaling_ge (0., 1.)) stop 124 + if (.not. ieee_signaling_ge (0., -1.)) stop 125 + if (ieee_signaling_ge (0., rnan)) stop 126 + if (ieee_signaling_ge (1., rnan)) stop 127 + if (ieee_signaling_ge (0., rinf)) stop 128 + if (ieee_signaling_ge (1., rinf)) stop 129 + if (ieee_signaling_ge (rinf, rnan)) stop 130 + + if (.not. ieee_signaling_ge (0.d0, 0.d0)) stop 131 + if (.not. ieee_signaling_ge (0.d0, -0.d0)) stop 132 + if (.not. ieee_signaling_ge (1.d0, 1.d0)) stop 133 + if (.not. ieee_signaling_ge (dinf, dinf)) stop 134 + if (.not. ieee_signaling_ge (-dinf, -dinf)) stop 135 + if (ieee_signaling_ge (dnan, dnan)) stop 136 + if (ieee_signaling_ge (0.d0, 1.d0)) stop 137 + if (.not. ieee_signaling_ge (0.d0, -1.d0)) stop 138 + if (ieee_signaling_ge (0.d0, dnan)) stop 139 + if (ieee_signaling_ge (1.d0, dnan)) stop 140 + if (ieee_signaling_ge (0.d0, dinf)) stop 141 + if (ieee_signaling_ge (1.d0, dinf)) stop 142 + if (ieee_signaling_ge (dinf, dnan)) stop 143 + + if (.not. ieee_signaling_ge (0._large, 0._large)) stop 144 + if (.not. ieee_signaling_ge (0._large, -0._large)) stop 145 + if (.not. ieee_signaling_ge (1._large, 1._large)) stop 146 + if (.not. ieee_signaling_ge (linf, linf)) stop 147 + if (.not. ieee_signaling_ge (-linf, -linf)) stop 148 + if (ieee_signaling_ge (lnan, lnan)) stop 149 + if (ieee_signaling_ge (0._large, 1._large)) stop 150 + if (.not. ieee_signaling_ge (0._large, -1._large)) stop 151 + if (ieee_signaling_ge (0._large, lnan)) stop 152 + if (ieee_signaling_ge (1._large, lnan)) stop 153 + if (ieee_signaling_ge (0._large, linf)) stop 154 + if (ieee_signaling_ge (1._large, linf)) stop 155 + if (ieee_signaling_ge (linf, lnan)) stop 156 + + + if (ieee_signaling_lt (0., 0.)) stop 157 + if (ieee_signaling_lt (0., -0.)) stop 158 + if (ieee_signaling_lt (1., 1.)) stop 159 + if (ieee_signaling_lt (rinf, rinf)) stop 160 + if (ieee_signaling_lt (-rinf, -rinf)) stop 161 + if (ieee_signaling_lt (rnan, rnan)) stop 162 + if (.not. ieee_signaling_lt (0., 1.)) stop 163 + if (ieee_signaling_lt (0., -1.)) stop 164 + if (ieee_signaling_lt (0., rnan)) stop 165 + if (ieee_signaling_lt (1., rnan)) stop 166 + if (.not. ieee_signaling_lt (0., rinf)) stop 167 + if (.not. ieee_signaling_lt (1., rinf)) stop 168 + if (ieee_signaling_lt (rinf, rnan)) stop 169 + + if (ieee_signaling_lt (0.d0, 0.d0)) stop 170 + if (ieee_signaling_lt (0.d0, -0.d0)) stop 171 + if (ieee_signaling_lt (1.d0, 1.d0)) stop 172 + if (ieee_signaling_lt (dinf, dinf)) stop 173 + if (ieee_signaling_lt (-dinf, -dinf)) stop 174 + if (ieee_signaling_lt (dnan, dnan)) stop 175 + if (.not. ieee_signaling_lt (0.d0, 1.d0)) stop 176 + if (ieee_signaling_lt (0.d0, -1.d0)) stop 177 + if (ieee_signaling_lt (0.d0, dnan)) stop 178 + if (ieee_signaling_lt (1.d0, dnan)) stop 179 + if (.not. ieee_signaling_lt (0.d0, dinf)) stop 180 + if (.not. ieee_signaling_lt (1.d0, dinf)) stop 181 + if (ieee_signaling_lt (dinf, dnan)) stop 182 + + if (ieee_signaling_lt (0._large, 0._large)) stop 183 + if (ieee_signaling_lt (0._large, -0._large)) stop 184 + if (ieee_signaling_lt (1._large, 1._large)) stop 185 + if (ieee_signaling_lt (linf, linf)) stop 186 + if (ieee_signaling_lt (-linf, -linf)) stop 187 + if (ieee_signaling_lt (lnan, lnan)) stop 188 + if (.not. ieee_signaling_lt (0._large, 1._large)) stop 189 + if (ieee_signaling_lt (0._large, -1._large)) stop 190 + if (ieee_signaling_lt (0._large, lnan)) stop 191 + if (ieee_signaling_lt (1._large, lnan)) stop 192 + if (.not. ieee_signaling_lt (0._large, linf)) stop 193 + if (.not. ieee_signaling_lt (1._large, linf)) stop 194 + if (ieee_signaling_lt (linf, lnan)) stop 195 + + + if (ieee_signaling_gt (0., 0.)) stop 196 + if (ieee_signaling_gt (0., -0.)) stop 197 + if (ieee_signaling_gt (1., 1.)) stop 198 + if (ieee_signaling_gt (rinf, rinf)) stop 199 + if (ieee_signaling_gt (-rinf, -rinf)) stop 200 + if (ieee_signaling_gt (rnan, rnan)) stop 201 + if (ieee_signaling_gt (0., 1.)) stop 202 + if (.not. ieee_signaling_gt (0., -1.)) stop 203 + if (ieee_signaling_gt (0., rnan)) stop 204 + if (ieee_signaling_gt (1., rnan)) stop 205 + if (ieee_signaling_gt (0., rinf)) stop 206 + if (ieee_signaling_gt (1., rinf)) stop 207 + if (ieee_signaling_gt (rinf, rnan)) stop 208 + + if (ieee_signaling_gt (0.d0, 0.d0)) stop 209 + if (ieee_signaling_gt (0.d0, -0.d0)) stop 210 + if (ieee_signaling_gt (1.d0, 1.d0)) stop 211 + if (ieee_signaling_gt (dinf, dinf)) stop 212 + if (ieee_signaling_gt (-dinf, -dinf)) stop 213 + if (ieee_signaling_gt (dnan, dnan)) stop 214 + if (ieee_signaling_gt (0.d0, 1.d0)) stop 215 + if (.not. ieee_signaling_gt (0.d0, -1.d0)) stop 216 + if (ieee_signaling_gt (0.d0, dnan)) stop 217 + if (ieee_signaling_gt (1.d0, dnan)) stop 218 + if (ieee_signaling_gt (0.d0, dinf)) stop 219 + if (ieee_signaling_gt (1.d0, dinf)) stop 220 + if (ieee_signaling_gt (dinf, dnan)) stop 221 + + if (ieee_signaling_gt (0._large, 0._large)) stop 222 + if (ieee_signaling_gt (0._large, -0._large)) stop 223 + if (ieee_signaling_gt (1._large, 1._large)) stop 224 + if (ieee_signaling_gt (linf, linf)) stop 225 + if (ieee_signaling_gt (-linf, -linf)) stop 226 + if (ieee_signaling_gt (lnan, lnan)) stop 227 + if (ieee_signaling_gt (0._large, 1._large)) stop 228 + if (.not. ieee_signaling_gt (0._large, -1._large)) stop 229 + if (ieee_signaling_gt (0._large, lnan)) stop 230 + if (ieee_signaling_gt (1._large, lnan)) stop 231 + if (ieee_signaling_gt (0._large, linf)) stop 232 + if (ieee_signaling_gt (1._large, linf)) stop 233 + if (ieee_signaling_gt (linf, lnan)) stop 234 + +end program foo diff --git a/Fortran/gfortran/regression/ieee/comparisons_3.F90 b/Fortran/gfortran/regression/ieee/comparisons_3.F90 new file mode 100644 index 000000000..40e8466c1 --- /dev/null +++ b/Fortran/gfortran/regression/ieee/comparisons_3.F90 @@ -0,0 +1,487 @@ +! { dg-do run } +! { dg-additional-options "-ffree-line-length-none" } +program foo + use ieee_arithmetic + use iso_fortran_env + implicit none + + ! This allows us to test REAL128 if it exists, and still compile + ! on platforms were it is not present + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639 + integer, parameter :: large = merge(real128, real64, real128 > 0) + + real, volatile :: rnan, rinf + double precision, volatile :: dnan, dinf + real(kind=large), volatile :: lnan, linf + + logical :: flag + + rinf = ieee_value(0., ieee_positive_inf) + rnan = ieee_value(0., ieee_quiet_nan) + + dinf = ieee_value(0.d0, ieee_positive_inf) + dnan = ieee_value(0.d0, ieee_quiet_nan) + + linf = ieee_value(0._large, ieee_positive_inf) + lnan = ieee_value(0._large, ieee_quiet_nan) + +#define CHECK_INVALID(expected) \ + call ieee_get_flag(ieee_invalid, flag) ; \ + if (flag .neqv. expected) then ; \ + write (*,*) "Check failed at ", __LINE__ ; \ + stop 1; \ + end if ; \ + call ieee_set_flag(ieee_invalid, .false.) + + !! REAL + + ! Signaling versions + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_eq (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_ne (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_le (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_le (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_le (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_lt (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_ge (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0., rnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_gt (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (rnan, rnan)) stop 15 + CHECK_INVALID(.true.) + + ! Quiet versions + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_le (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_le (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_lt (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0., 0.)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0., -0.)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0., rnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0., rinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (rnan, rnan)) stop 15 + CHECK_INVALID(.false.) + + !! DOUBLE PRECISION + + ! Signaling versions + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_eq (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_ne (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_le (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_le (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_le (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_lt (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_ge (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0.d0, dnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_gt (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (dnan, dnan)) stop 15 + CHECK_INVALID(.true.) + + ! Quiet versions + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_le (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_le (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_lt (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0.d0, 0.d0)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0.d0, -0.d0)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0.d0, dnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0.d0, dinf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (dnan, dnan)) stop 15 + CHECK_INVALID(.false.) + + !! LARGE KIND + + ! Signaling versions + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_eq (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_eq (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_eq (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_ne (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_ne (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ne (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_le (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_le (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_le (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_le (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (.not. ieee_signaling_lt (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_lt (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_signaling_ge (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_ge (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_ge (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (0._large, lnan)) stop 13 + CHECK_INVALID(.true.) + if (ieee_signaling_gt (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_signaling_gt (lnan, lnan)) stop 15 + CHECK_INVALID(.true.) + + ! Quiet versions + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_eq (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_eq (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_ne (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ne (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_le (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_le (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_le (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_lt (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_lt (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (.not. ieee_quiet_ge (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_ge (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0._large, 0._large)) stop 11 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0._large, -0._large)) stop 12 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0._large, lnan)) stop 13 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (0._large, linf)) stop 14 + CHECK_INVALID(.false.) + if (ieee_quiet_gt (lnan, lnan)) stop 15 + CHECK_INVALID(.false.) + + +end program foo diff --git a/Fortran/gfortran/regression/ieee/ieee.exp b/Fortran/gfortran/regression/ieee/ieee.exp index c53d2a881..b1099746d 100644 --- a/Fortran/gfortran/regression/ieee/ieee.exp +++ b/Fortran/gfortran/regression/ieee/ieee.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2013-2023 Free Software Foundation, Inc. +# Copyright (C) 2013-2024 Free Software Foundation, Inc. # # This file is part of GCC. # diff --git a/Fortran/gfortran/regression/ieee/ieee_6.f90 b/Fortran/gfortran/regression/ieee/ieee_6.f90 index 1af7ed395..fd637ebbe 100644 --- a/Fortran/gfortran/regression/ieee/ieee_6.f90 +++ b/Fortran/gfortran/regression/ieee/ieee_6.f90 @@ -12,7 +12,7 @@ type(ieee_status_type) :: s1, s2 logical :: flags(5), halt(5), haltworks type(ieee_round_type) :: mode - real :: x + real, volatile :: x ! Test IEEE_GET_STATUS and IEEE_SET_STATUS diff --git a/Fortran/gfortran/regression/ieee/minmax_1.f90 b/Fortran/gfortran/regression/ieee/minmax_1.f90 new file mode 100644 index 000000000..c820b1349 --- /dev/null +++ b/Fortran/gfortran/regression/ieee/minmax_1.f90 @@ -0,0 +1,235 @@ +! { dg-do run } +! +program test + call real() + call double() + call large1() + call large2() +end program test + + +subroutine real + use ieee_arithmetic + implicit none + + real :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num_mag (0., 0.) /= 0.) stop 1 + if (ieee_max_num_mag (-0., -0.) /= -0.) stop 2 + if (.not. ieee_signbit (ieee_max_num_mag (-0., -0.))) stop 3 + if (ieee_max_num_mag (0., -0.) /= 0.) stop 4 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (0., -0.))) stop 5 + if (ieee_max_num_mag (-0., 0.) /= 0.) stop 6 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (-0., 0.))) stop 7 + + if (ieee_max_num_mag (9., 0.) /= 9.) stop 8 + if (ieee_max_num_mag (0., 9.) /= 9.) stop 9 + if (ieee_max_num_mag (-9., 0.) /= -9.) stop 10 + if (ieee_max_num_mag (0., -9.) /= -9.) stop 11 + + if (ieee_max_num_mag (inf, 9.) /= inf) stop 12 + if (ieee_max_num_mag (0., inf) /= inf) stop 13 + if (ieee_max_num_mag (-9., inf) /= inf) stop 14 + if (ieee_max_num_mag (inf, -9.) /= inf) stop 15 + if (ieee_max_num_mag (-inf, 9.) /= -inf) stop 16 + if (ieee_max_num_mag (0., -inf) /= -inf) stop 17 + if (ieee_max_num_mag (-9., -inf) /= -inf) stop 18 + if (ieee_max_num_mag (-inf, -9.) /= -inf) stop 19 + + if (ieee_max_num_mag (0., nan) /= 0.) stop 20 + if (ieee_max_num_mag (nan, 0.) /= 0.) stop 21 + if (ieee_max_num_mag (-0., nan) /= -0.) stop 22 + if (.not. ieee_signbit (ieee_max_num_mag (-0., nan))) stop 23 + if (ieee_max_num_mag (nan, -0.) /= -0.) stop 24 + if (.not. ieee_signbit (ieee_max_num_mag (nan, -0.))) stop 25 + if (ieee_max_num_mag (9., nan) /= 9.) stop 26 + if (ieee_max_num_mag (nan, 9.) /= 9.) stop 27 + if (ieee_max_num_mag (-9., nan) /= -9.) stop 28 + if (ieee_max_num_mag (nan, -9.) /= -9.) stop 29 + + if (ieee_max_num_mag (nan, inf) /= inf) stop 30 + if (ieee_max_num_mag (inf, nan) /= inf) stop 31 + if (ieee_max_num_mag (nan, -inf) /= -inf) stop 32 + if (ieee_max_num_mag (-inf, nan) /= -inf) stop 33 + + if (.not. ieee_is_nan (ieee_max_num_mag (nan, nan))) stop 34 +end subroutine real + + +subroutine double + use ieee_arithmetic + implicit none + + double precision :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num_mag (0.d0, 0.d0) /= 0.d0) stop 35 + if (ieee_max_num_mag (-0.d0, -0.d0) /= -0.d0) stop 36 + if (.not. ieee_signbit (ieee_max_num_mag (-0.d0, -0.d0))) stop 37 + if (ieee_max_num_mag (0.d0, -0.d0) /= 0.d0) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (0.d0, -0.d0))) stop 39 + if (ieee_max_num_mag (-0.d0, 0.d0) /= 0.d0) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (-0.d0, 0.d0))) stop 41 + + if (ieee_max_num_mag (9.d0, 0.d0) /= 9.d0) stop 42 + if (ieee_max_num_mag (0.d0, 9.d0) /= 9.d0) stop 43 + if (ieee_max_num_mag (-9.d0, 0.d0) /= -9.d0) stop 44 + if (ieee_max_num_mag (0.d0, -9.d0) /= -9.d0) stop 45 + + if (ieee_max_num_mag (inf, 9.d0) /= inf) stop 46 + if (ieee_max_num_mag (0.d0, inf) /= inf) stop 47 + if (ieee_max_num_mag (-9.d0, inf) /= inf) stop 48 + if (ieee_max_num_mag (inf, -9.d0) /= inf) stop 49 + if (ieee_max_num_mag (-inf, 9.d0) /= -inf) stop 50 + if (ieee_max_num_mag (0.d0, -inf) /= -inf) stop 51 + if (ieee_max_num_mag (-9.d0, -inf) /= -inf) stop 52 + if (ieee_max_num_mag (-inf, -9.d0) /= -inf) stop 53 + + if (ieee_max_num_mag (0.d0, nan) /= 0.d0) stop 54 + if (ieee_max_num_mag (nan, 0.d0) /= 0.d0) stop 55 + if (ieee_max_num_mag (-0.d0, nan) /= -0.d0) stop 56 + if (.not. ieee_signbit (ieee_max_num_mag (-0.d0, nan))) stop 57 + if (ieee_max_num_mag (nan, -0.d0) /= -0.d0) stop 58 + if (.not. ieee_signbit (ieee_max_num_mag (nan, -0.d0))) stop 59 + if (ieee_max_num_mag (9.d0, nan) /= 9.d0) stop 60 + if (ieee_max_num_mag (nan, 9.d0) /= 9.d0) stop 61 + if (ieee_max_num_mag (-9.d0, nan) /= -9.d0) stop 62 + if (ieee_max_num_mag (nan, -9.d0) /= -9.d0) stop 63 + + if (ieee_max_num_mag (nan, inf) /= inf) stop 64 + if (ieee_max_num_mag (inf, nan) /= inf) stop 65 + if (ieee_max_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_max_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num_mag (nan, nan))) stop 68 +end subroutine double + + +subroutine large1 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num_mag (0._k1, 0._k1) /= 0._k1) stop 35 + if (ieee_max_num_mag (-0._k1, -0._k1) /= -0._k1) stop 36 + if (.not. ieee_signbit (ieee_max_num_mag (-0._k1, -0._k1))) stop 37 + if (ieee_max_num_mag (0._k1, -0._k1) /= 0._k1) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (0._k1, -0._k1))) stop 39 + if (ieee_max_num_mag (-0._k1, 0._k1) /= 0._k1) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (-0._k1, 0._k1))) stop 41 + + if (ieee_max_num_mag (9._k1, 0._k1) /= 9._k1) stop 42 + if (ieee_max_num_mag (0._k1, 9._k1) /= 9._k1) stop 43 + if (ieee_max_num_mag (-9._k1, 0._k1) /= -9._k1) stop 44 + if (ieee_max_num_mag (0._k1, -9._k1) /= -9._k1) stop 45 + + if (ieee_max_num_mag (inf, 9._k1) /= inf) stop 46 + if (ieee_max_num_mag (0._k1, inf) /= inf) stop 47 + if (ieee_max_num_mag (-9._k1, inf) /= inf) stop 48 + if (ieee_max_num_mag (inf, -9._k1) /= inf) stop 49 + if (ieee_max_num_mag (-inf, 9._k1) /= -inf) stop 50 + if (ieee_max_num_mag (0._k1, -inf) /= -inf) stop 51 + if (ieee_max_num_mag (-9._k1, -inf) /= -inf) stop 52 + if (ieee_max_num_mag (-inf, -9._k1) /= -inf) stop 53 + + if (ieee_max_num_mag (0._k1, nan) /= 0._k1) stop 54 + if (ieee_max_num_mag (nan, 0._k1) /= 0._k1) stop 55 + if (ieee_max_num_mag (-0._k1, nan) /= -0._k1) stop 56 + if (.not. ieee_signbit (ieee_max_num_mag (-0._k1, nan))) stop 57 + if (ieee_max_num_mag (nan, -0._k1) /= -0._k1) stop 58 + if (.not. ieee_signbit (ieee_max_num_mag (nan, -0._k1))) stop 59 + if (ieee_max_num_mag (9._k1, nan) /= 9._k1) stop 60 + if (ieee_max_num_mag (nan, 9._k1) /= 9._k1) stop 61 + if (ieee_max_num_mag (-9._k1, nan) /= -9._k1) stop 62 + if (ieee_max_num_mag (nan, -9._k1) /= -9._k1) stop 63 + + if (ieee_max_num_mag (nan, inf) /= inf) stop 64 + if (ieee_max_num_mag (inf, nan) /= inf) stop 65 + if (ieee_max_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_max_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num_mag (nan, nan))) stop 68 +end subroutine large1 + + +subroutine large2 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k2) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num_mag (0._k2, 0._k2) /= 0._k2) stop 35 + if (ieee_max_num_mag (-0._k2, -0._k2) /= -0._k2) stop 36 + if (.not. ieee_signbit (ieee_max_num_mag (-0._k2, -0._k2))) stop 37 + if (ieee_max_num_mag (0._k2, -0._k2) /= 0._k2) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (0._k2, -0._k2))) stop 39 + if (ieee_max_num_mag (-0._k2, 0._k2) /= 0._k2) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num_mag (-0._k2, 0._k2))) stop 41 + + if (ieee_max_num_mag (9._k2, 0._k2) /= 9._k2) stop 42 + if (ieee_max_num_mag (0._k2, 9._k2) /= 9._k2) stop 43 + if (ieee_max_num_mag (-9._k2, 0._k2) /= -9._k2) stop 44 + if (ieee_max_num_mag (0._k2, -9._k2) /= -9._k2) stop 45 + + if (ieee_max_num_mag (inf, 9._k2) /= inf) stop 46 + if (ieee_max_num_mag (0._k2, inf) /= inf) stop 47 + if (ieee_max_num_mag (-9._k2, inf) /= inf) stop 48 + if (ieee_max_num_mag (inf, -9._k2) /= inf) stop 49 + if (ieee_max_num_mag (-inf, 9._k2) /= -inf) stop 50 + if (ieee_max_num_mag (0._k2, -inf) /= -inf) stop 51 + if (ieee_max_num_mag (-9._k2, -inf) /= -inf) stop 52 + if (ieee_max_num_mag (-inf, -9._k2) /= -inf) stop 53 + + if (ieee_max_num_mag (0._k2, nan) /= 0._k2) stop 54 + if (ieee_max_num_mag (nan, 0._k2) /= 0._k2) stop 55 + if (ieee_max_num_mag (-0._k2, nan) /= -0._k2) stop 56 + if (.not. ieee_signbit (ieee_max_num_mag (-0._k2, nan))) stop 57 + if (ieee_max_num_mag (nan, -0._k2) /= -0._k2) stop 58 + if (.not. ieee_signbit (ieee_max_num_mag (nan, -0._k2))) stop 59 + if (ieee_max_num_mag (9._k2, nan) /= 9._k2) stop 60 + if (ieee_max_num_mag (nan, 9._k2) /= 9._k2) stop 61 + if (ieee_max_num_mag (-9._k2, nan) /= -9._k2) stop 62 + if (ieee_max_num_mag (nan, -9._k2) /= -9._k2) stop 63 + + if (ieee_max_num_mag (nan, inf) /= inf) stop 64 + if (ieee_max_num_mag (inf, nan) /= inf) stop 65 + if (ieee_max_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_max_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num_mag (nan, nan))) stop 68 +end subroutine large2 + diff --git a/Fortran/gfortran/regression/ieee/minmax_2.f90 b/Fortran/gfortran/regression/ieee/minmax_2.f90 new file mode 100644 index 000000000..52c3fa015 --- /dev/null +++ b/Fortran/gfortran/regression/ieee/minmax_2.f90 @@ -0,0 +1,235 @@ +! { dg-do run } +! +program test + call real() + call double() + call large1() + call large2() +end program test + + +subroutine real + use ieee_arithmetic + implicit none + + real :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num_mag (0., 0.) /= 0.) stop 1 + if (ieee_min_num_mag (-0., -0.) /= -0.) stop 2 + if (.not. ieee_signbit (ieee_min_num_mag (-0., -0.))) stop 3 + if (ieee_min_num_mag (0., -0.) /= -0.) stop 4 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (0., -0.))) stop 5 + if (ieee_min_num_mag (-0., 0.) /= 0.) stop 6 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (-0., 0.))) stop 7 + + if (ieee_min_num_mag (9., 0.) /= 0.) stop 8 + if (ieee_min_num_mag (0., 9.) /= 0.) stop 9 + if (ieee_min_num_mag (-9., 0.) /= 0.) stop 10 + if (ieee_min_num_mag (0., -9.) /= 0.) stop 11 + + if (ieee_min_num_mag (inf, 9.) /= 9.) stop 12 + if (ieee_min_num_mag (0., inf) /= 0.) stop 13 + if (ieee_min_num_mag (-9., inf) /= -9.) stop 14 + if (ieee_min_num_mag (inf, -9.) /= -9.) stop 15 + if (ieee_min_num_mag (-inf, 9.) /= 9.) stop 16 + if (ieee_min_num_mag (0., -inf) /= 0.) stop 17 + if (ieee_min_num_mag (-9., -inf) /= -9.) stop 18 + if (ieee_min_num_mag (-inf, -9.) /= -9.) stop 19 + + if (ieee_min_num_mag (0., nan) /= 0.) stop 20 + if (ieee_min_num_mag (nan, 0.) /= 0.) stop 21 + if (ieee_min_num_mag (-0., nan) /= -0.) stop 22 + if (.not. ieee_signbit (ieee_min_num_mag (-0., nan))) stop 23 + if (ieee_min_num_mag (nan, -0.) /= -0.) stop 24 + if (.not. ieee_signbit (ieee_min_num_mag (nan, -0.))) stop 25 + if (ieee_min_num_mag (9., nan) /= 9.) stop 26 + if (ieee_min_num_mag (nan, 9.) /= 9.) stop 27 + if (ieee_min_num_mag (-9., nan) /= -9.) stop 28 + if (ieee_min_num_mag (nan, -9.) /= -9.) stop 29 + + if (ieee_min_num_mag (nan, inf) /= inf) stop 30 + if (ieee_min_num_mag (inf, nan) /= inf) stop 31 + if (ieee_min_num_mag (nan, -inf) /= -inf) stop 32 + if (ieee_min_num_mag (-inf, nan) /= -inf) stop 33 + + if (.not. ieee_is_nan (ieee_min_num_mag (nan, nan))) stop 34 +end subroutine real + + +subroutine double + use ieee_arithmetic + implicit none + + double precision :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num_mag (0.d0, 0.d0) /= 0.d0) stop 35 + if (ieee_min_num_mag (-0.d0, -0.d0) /= -0.d0) stop 36 + if (.not. ieee_signbit (ieee_min_num_mag (-0.d0, -0.d0))) stop 37 + if (ieee_min_num_mag (0.d0, -0.d0) /= 0.d0) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (0.d0, -0.d0))) stop 39 + if (ieee_min_num_mag (-0.d0, 0.d0) /= 0.d0) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (-0.d0, 0.d0))) stop 41 + + if (ieee_min_num_mag (9.d0, 0.d0) /= 0.d0) stop 42 + if (ieee_min_num_mag (0.d0, 9.d0) /= 0.d0) stop 43 + if (ieee_min_num_mag (-9.d0, 0.d0) /= 0.d0) stop 44 + if (ieee_min_num_mag (0.d0, -9.d0) /= 0.d0) stop 45 + + if (ieee_min_num_mag (inf, 9.d0) /= 9.d0) stop 46 + if (ieee_min_num_mag (0.d0, inf) /= 0.d0) stop 47 + if (ieee_min_num_mag (-9.d0, inf) /= -9.d0) stop 48 + if (ieee_min_num_mag (inf, -9.d0) /= -9.d0) stop 49 + if (ieee_min_num_mag (-inf, 9.d0) /= 9.d0) stop 50 + if (ieee_min_num_mag (0.d0, -inf) /= 0.d0) stop 51 + if (ieee_min_num_mag (-9.d0, -inf) /= -9.d0) stop 52 + if (ieee_min_num_mag (-inf, -9.d0) /= -9.d0) stop 53 + + if (ieee_min_num_mag (0.d0, nan) /= 0.d0) stop 54 + if (ieee_min_num_mag (nan, 0.d0) /= 0.d0) stop 55 + if (ieee_min_num_mag (-0.d0, nan) /= -0.d0) stop 56 + if (.not. ieee_signbit (ieee_min_num_mag (-0.d0, nan))) stop 57 + if (ieee_min_num_mag (nan, -0.d0) /= -0.d0) stop 58 + if (.not. ieee_signbit (ieee_min_num_mag (nan, -0.d0))) stop 59 + if (ieee_min_num_mag (9.d0, nan) /= 9.d0) stop 60 + if (ieee_min_num_mag (nan, 9.d0) /= 9.d0) stop 61 + if (ieee_min_num_mag (-9.d0, nan) /= -9.d0) stop 62 + if (ieee_min_num_mag (nan, -9.d0) /= -9.d0) stop 63 + + if (ieee_min_num_mag (nan, inf) /= inf) stop 64 + if (ieee_min_num_mag (inf, nan) /= inf) stop 65 + if (ieee_min_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_min_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num_mag (nan, nan))) stop 68 +end subroutine double + + +subroutine large1 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num_mag (0._k1, 0._k1) /= 0._k1) stop 35 + if (ieee_min_num_mag (-0._k1, -0._k1) /= -0._k1) stop 36 + if (.not. ieee_signbit (ieee_min_num_mag (-0._k1, -0._k1))) stop 37 + if (ieee_min_num_mag (0._k1, -0._k1) /= 0._k1) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (0._k1, -0._k1))) stop 39 + if (ieee_min_num_mag (-0._k1, 0._k1) /= 0._k1) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (-0._k1, 0._k1))) stop 41 + + if (ieee_min_num_mag (9._k1, 0._k1) /= 0._k1) stop 42 + if (ieee_min_num_mag (0._k1, 9._k1) /= 0._k1) stop 43 + if (ieee_min_num_mag (-9._k1, 0._k1) /= 0._k1) stop 44 + if (ieee_min_num_mag (0._k1, -9._k1) /= 0._k1) stop 45 + + if (ieee_min_num_mag (inf, 9._k1) /= 9._k1) stop 46 + if (ieee_min_num_mag (0._k1, inf) /= 0._k1) stop 47 + if (ieee_min_num_mag (-9._k1, inf) /= -9._k1) stop 48 + if (ieee_min_num_mag (inf, -9._k1) /= -9._k1) stop 49 + if (ieee_min_num_mag (-inf, 9._k1) /= 9._k1) stop 50 + if (ieee_min_num_mag (0._k1, -inf) /= 0._k1) stop 51 + if (ieee_min_num_mag (-9._k1, -inf) /= -9._k1) stop 52 + if (ieee_min_num_mag (-inf, -9._k1) /= -9._k1) stop 53 + + if (ieee_min_num_mag (0._k1, nan) /= 0._k1) stop 54 + if (ieee_min_num_mag (nan, 0._k1) /= 0._k1) stop 55 + if (ieee_min_num_mag (-0._k1, nan) /= -0._k1) stop 56 + if (.not. ieee_signbit (ieee_min_num_mag (-0._k1, nan))) stop 57 + if (ieee_min_num_mag (nan, -0._k1) /= -0._k1) stop 58 + if (.not. ieee_signbit (ieee_min_num_mag (nan, -0._k1))) stop 59 + if (ieee_min_num_mag (9._k1, nan) /= 9._k1) stop 60 + if (ieee_min_num_mag (nan, 9._k1) /= 9._k1) stop 61 + if (ieee_min_num_mag (-9._k1, nan) /= -9._k1) stop 62 + if (ieee_min_num_mag (nan, -9._k1) /= -9._k1) stop 63 + + if (ieee_min_num_mag (nan, inf) /= inf) stop 64 + if (ieee_min_num_mag (inf, nan) /= inf) stop 65 + if (ieee_min_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_min_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num_mag (nan, nan))) stop 68 +end subroutine large1 + + +subroutine large2 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k2) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num_mag (0._k2, 0._k2) /= 0._k2) stop 35 + if (ieee_min_num_mag (-0._k2, -0._k2) /= -0._k2) stop 36 + if (.not. ieee_signbit (ieee_min_num_mag (-0._k2, -0._k2))) stop 37 + if (ieee_min_num_mag (0._k2, -0._k2) /= 0._k2) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (0._k2, -0._k2))) stop 39 + if (ieee_min_num_mag (-0._k2, 0._k2) /= 0._k2) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num_mag (-0._k2, 0._k2))) stop 41 + + if (ieee_min_num_mag (9._k2, 0._k2) /= 0._k2) stop 42 + if (ieee_min_num_mag (0._k2, 9._k2) /= 0._k2) stop 43 + if (ieee_min_num_mag (-9._k2, 0._k2) /= 0._k2) stop 44 + if (ieee_min_num_mag (0._k2, -9._k2) /= 0._k2) stop 45 + + if (ieee_min_num_mag (inf, 9._k2) /= 9._k2) stop 46 + if (ieee_min_num_mag (0._k2, inf) /= 0._k2) stop 47 + if (ieee_min_num_mag (-9._k2, inf) /= -9._k2) stop 48 + if (ieee_min_num_mag (inf, -9._k2) /= -9._k2) stop 49 + if (ieee_min_num_mag (-inf, 9._k2) /= 9._k2) stop 50 + if (ieee_min_num_mag (0._k2, -inf) /= 0._k2) stop 51 + if (ieee_min_num_mag (-9._k2, -inf) /= -9._k2) stop 52 + if (ieee_min_num_mag (-inf, -9._k2) /= -9._k2) stop 53 + + if (ieee_min_num_mag (0._k2, nan) /= 0._k2) stop 54 + if (ieee_min_num_mag (nan, 0._k2) /= 0._k2) stop 55 + if (ieee_min_num_mag (-0._k2, nan) /= -0._k2) stop 56 + if (.not. ieee_signbit (ieee_min_num_mag (-0._k2, nan))) stop 57 + if (ieee_min_num_mag (nan, -0._k2) /= -0._k2) stop 58 + if (.not. ieee_signbit (ieee_min_num_mag (nan, -0._k2))) stop 59 + if (ieee_min_num_mag (9._k2, nan) /= 9._k2) stop 60 + if (ieee_min_num_mag (nan, 9._k2) /= 9._k2) stop 61 + if (ieee_min_num_mag (-9._k2, nan) /= -9._k2) stop 62 + if (ieee_min_num_mag (nan, -9._k2) /= -9._k2) stop 63 + + if (ieee_min_num_mag (nan, inf) /= inf) stop 64 + if (ieee_min_num_mag (inf, nan) /= inf) stop 65 + if (ieee_min_num_mag (nan, -inf) /= -inf) stop 66 + if (ieee_min_num_mag (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num_mag (nan, nan))) stop 68 +end subroutine large2 + diff --git a/Fortran/gfortran/regression/ieee/minmax_3.f90 b/Fortran/gfortran/regression/ieee/minmax_3.f90 new file mode 100644 index 000000000..337bb368d --- /dev/null +++ b/Fortran/gfortran/regression/ieee/minmax_3.f90 @@ -0,0 +1,235 @@ +! { dg-do run } +! +program test + call real() + call double() + call large1() + call large2() +end program test + + +subroutine real + use ieee_arithmetic + implicit none + + real :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num (0., 0.) /= 0.) stop 1 + if (ieee_max_num (-0., -0.) /= -0.) stop 2 + if (.not. ieee_signbit (ieee_max_num (-0., -0.))) stop 3 + if (ieee_max_num (0., -0.) /= 0.) stop 4 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (0., -0.))) stop 5 + if (ieee_max_num (-0., 0.) /= 0.) stop 6 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (-0., 0.))) stop 7 + + if (ieee_max_num (9., 0.) /= 9.) stop 8 + if (ieee_max_num (0., 9.) /= 9.) stop 9 + if (ieee_max_num (-9., 0.) /= 0.) stop 10 + if (ieee_max_num (0., -9.) /= 0.) stop 11 + + if (ieee_max_num (inf, 9.) /= inf) stop 12 + if (ieee_max_num (0., inf) /= inf) stop 13 + if (ieee_max_num (-9., inf) /= inf) stop 14 + if (ieee_max_num (inf, -9.) /= inf) stop 15 + if (ieee_max_num (-inf, 9.) /= 9.) stop 16 + if (ieee_max_num (0., -inf) /= 0.) stop 17 + if (ieee_max_num (-9., -inf) /= -9.) stop 18 + if (ieee_max_num (-inf, -9.) /= -9.) stop 19 + + if (ieee_max_num (0., nan) /= 0.) stop 20 + if (ieee_max_num (nan, 0.) /= 0.) stop 21 + if (ieee_max_num (-0., nan) /= -0.) stop 22 + if (.not. ieee_signbit (ieee_max_num (-0., nan))) stop 23 + if (ieee_max_num (nan, -0.) /= -0.) stop 24 + if (.not. ieee_signbit (ieee_max_num (nan, -0.))) stop 25 + if (ieee_max_num (9., nan) /= 9.) stop 26 + if (ieee_max_num (nan, 9.) /= 9.) stop 27 + if (ieee_max_num (-9., nan) /= -9.) stop 28 + if (ieee_max_num (nan, -9.) /= -9.) stop 29 + + if (ieee_max_num (nan, inf) /= inf) stop 30 + if (ieee_max_num (inf, nan) /= inf) stop 31 + if (ieee_max_num (nan, -inf) /= -inf) stop 32 + if (ieee_max_num (-inf, nan) /= -inf) stop 33 + + if (.not. ieee_is_nan (ieee_max_num (nan, nan))) stop 34 +end subroutine real + + +subroutine double + use ieee_arithmetic + implicit none + + double precision :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num (0.d0, 0.d0) /= 0.d0) stop 35 + if (ieee_max_num (-0.d0, -0.d0) /= -0.d0) stop 36 + if (.not. ieee_signbit (ieee_max_num (-0.d0, -0.d0))) stop 37 + if (ieee_max_num (0.d0, -0.d0) /= 0.d0) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (0.d0, -0.d0))) stop 39 + if (ieee_max_num (-0.d0, 0.d0) /= 0.d0) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (-0.d0, 0.d0))) stop 41 + + if (ieee_max_num (9.d0, 0.d0) /= 9.d0) stop 42 + if (ieee_max_num (0.d0, 9.d0) /= 9.d0) stop 43 + if (ieee_max_num (-9.d0, 0.d0) /= 0.d0) stop 44 + if (ieee_max_num (0.d0, -9.d0) /= 0.d0) stop 45 + + if (ieee_max_num (inf, 9.d0) /= inf) stop 46 + if (ieee_max_num (0.d0, inf) /= inf) stop 47 + if (ieee_max_num (-9.d0, inf) /= inf) stop 48 + if (ieee_max_num (inf, -9.d0) /= inf) stop 49 + if (ieee_max_num (-inf, 9.d0) /= 9.d0) stop 50 + if (ieee_max_num (0.d0, -inf) /= 0.d0) stop 51 + if (ieee_max_num (-9.d0, -inf) /= -9.d0) stop 52 + if (ieee_max_num (-inf, -9.d0) /= -9.d0) stop 53 + + if (ieee_max_num (0.d0, nan) /= 0.d0) stop 54 + if (ieee_max_num (nan, 0.d0) /= 0.d0) stop 55 + if (ieee_max_num (-0.d0, nan) /= -0.d0) stop 56 + if (.not. ieee_signbit (ieee_max_num (-0.d0, nan))) stop 57 + if (ieee_max_num (nan, -0.d0) /= -0.d0) stop 58 + if (.not. ieee_signbit (ieee_max_num (nan, -0.d0))) stop 59 + if (ieee_max_num (9.d0, nan) /= 9.d0) stop 60 + if (ieee_max_num (nan, 9.d0) /= 9.d0) stop 61 + if (ieee_max_num (-9.d0, nan) /= -9.d0) stop 62 + if (ieee_max_num (nan, -9.d0) /= -9.d0) stop 63 + + if (ieee_max_num (nan, inf) /= inf) stop 64 + if (ieee_max_num (inf, nan) /= inf) stop 65 + if (ieee_max_num (nan, -inf) /= -inf) stop 66 + if (ieee_max_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num (nan, nan))) stop 68 +end subroutine double + + +subroutine large1 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num (0._k1, 0._k1) /= 0._k1) stop 35 + if (ieee_max_num (-0._k1, -0._k1) /= -0._k1) stop 36 + if (.not. ieee_signbit (ieee_max_num (-0._k1, -0._k1))) stop 37 + if (ieee_max_num (0._k1, -0._k1) /= 0._k1) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (0._k1, -0._k1))) stop 39 + if (ieee_max_num (-0._k1, 0._k1) /= 0._k1) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (-0._k1, 0._k1))) stop 41 + + if (ieee_max_num (9._k1, 0._k1) /= 9._k1) stop 42 + if (ieee_max_num (0._k1, 9._k1) /= 9._k1) stop 43 + if (ieee_max_num (-9._k1, 0._k1) /= 0._k1) stop 44 + if (ieee_max_num (0._k1, -9._k1) /= 0._k1) stop 45 + + if (ieee_max_num (inf, 9._k1) /= inf) stop 46 + if (ieee_max_num (0._k1, inf) /= inf) stop 47 + if (ieee_max_num (-9._k1, inf) /= inf) stop 48 + if (ieee_max_num (inf, -9._k1) /= inf) stop 49 + if (ieee_max_num (-inf, 9._k1) /= 9._k1) stop 50 + if (ieee_max_num (0._k1, -inf) /= 0._k1) stop 51 + if (ieee_max_num (-9._k1, -inf) /= -9._k1) stop 52 + if (ieee_max_num (-inf, -9._k1) /= -9._k1) stop 53 + + if (ieee_max_num (0._k1, nan) /= 0._k1) stop 54 + if (ieee_max_num (nan, 0._k1) /= 0._k1) stop 55 + if (ieee_max_num (-0._k1, nan) /= -0._k1) stop 56 + if (.not. ieee_signbit (ieee_max_num (-0._k1, nan))) stop 57 + if (ieee_max_num (nan, -0._k1) /= -0._k1) stop 58 + if (.not. ieee_signbit (ieee_max_num (nan, -0._k1))) stop 59 + if (ieee_max_num (9._k1, nan) /= 9._k1) stop 60 + if (ieee_max_num (nan, 9._k1) /= 9._k1) stop 61 + if (ieee_max_num (-9._k1, nan) /= -9._k1) stop 62 + if (ieee_max_num (nan, -9._k1) /= -9._k1) stop 63 + + if (ieee_max_num (nan, inf) /= inf) stop 64 + if (ieee_max_num (inf, nan) /= inf) stop 65 + if (ieee_max_num (nan, -inf) /= -inf) stop 66 + if (ieee_max_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num (nan, nan))) stop 68 +end subroutine large1 + + +subroutine large2 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k2) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_max_num (0._k2, 0._k2) /= 0._k2) stop 35 + if (ieee_max_num (-0._k2, -0._k2) /= -0._k2) stop 36 + if (.not. ieee_signbit (ieee_max_num (-0._k2, -0._k2))) stop 37 + if (ieee_max_num (0._k2, -0._k2) /= 0._k2) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (0._k2, -0._k2))) stop 39 + if (ieee_max_num (-0._k2, 0._k2) /= 0._k2) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_max_num (-0._k2, 0._k2))) stop 41 + + if (ieee_max_num (9._k2, 0._k2) /= 9._k2) stop 42 + if (ieee_max_num (0._k2, 9._k2) /= 9._k2) stop 43 + if (ieee_max_num (-9._k2, 0._k2) /= 0._k2) stop 44 + if (ieee_max_num (0._k2, -9._k2) /= 0._k2) stop 45 + + if (ieee_max_num (inf, 9._k2) /= inf) stop 46 + if (ieee_max_num (0._k2, inf) /= inf) stop 47 + if (ieee_max_num (-9._k2, inf) /= inf) stop 48 + if (ieee_max_num (inf, -9._k2) /= inf) stop 49 + if (ieee_max_num (-inf, 9._k2) /= 9._k2) stop 50 + if (ieee_max_num (0._k2, -inf) /= 0._k2) stop 51 + if (ieee_max_num (-9._k2, -inf) /= -9._k2) stop 52 + if (ieee_max_num (-inf, -9._k2) /= -9._k2) stop 53 + + if (ieee_max_num (0._k2, nan) /= 0._k2) stop 54 + if (ieee_max_num (nan, 0._k2) /= 0._k2) stop 55 + if (ieee_max_num (-0._k2, nan) /= -0._k2) stop 56 + if (.not. ieee_signbit (ieee_max_num (-0._k2, nan))) stop 57 + if (ieee_max_num (nan, -0._k2) /= -0._k2) stop 58 + if (.not. ieee_signbit (ieee_max_num (nan, -0._k2))) stop 59 + if (ieee_max_num (9._k2, nan) /= 9._k2) stop 60 + if (ieee_max_num (nan, 9._k2) /= 9._k2) stop 61 + if (ieee_max_num (-9._k2, nan) /= -9._k2) stop 62 + if (ieee_max_num (nan, -9._k2) /= -9._k2) stop 63 + + if (ieee_max_num (nan, inf) /= inf) stop 64 + if (ieee_max_num (inf, nan) /= inf) stop 65 + if (ieee_max_num (nan, -inf) /= -inf) stop 66 + if (ieee_max_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_max_num (nan, nan))) stop 68 +end subroutine large2 + diff --git a/Fortran/gfortran/regression/ieee/minmax_4.f90 b/Fortran/gfortran/regression/ieee/minmax_4.f90 new file mode 100644 index 000000000..f55a96ba6 --- /dev/null +++ b/Fortran/gfortran/regression/ieee/minmax_4.f90 @@ -0,0 +1,235 @@ +! { dg-do run } +! +program test + call real() + call double() + call large1() + call large2() +end program test + + +subroutine real + use ieee_arithmetic + implicit none + + real :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num (0., 0.) /= 0.) stop 1 + if (ieee_min_num (-0., -0.) /= -0.) stop 2 + if (.not. ieee_signbit (ieee_min_num (-0., -0.))) stop 3 + if (ieee_min_num (0., -0.) /= -0.) stop 4 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (0., -0.))) stop 5 + if (ieee_min_num (-0., 0.) /= 0.) stop 6 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (-0., 0.))) stop 7 + + if (ieee_min_num (9., 0.) /= 0.) stop 8 + if (ieee_min_num (0., 9.) /= 0.) stop 9 + if (ieee_min_num (-9., 0.) /= -9.) stop 10 + if (ieee_min_num (0., -9.) /= -9.) stop 11 + + if (ieee_min_num (inf, 9.) /= 9.) stop 12 + if (ieee_min_num (0., inf) /= 0.) stop 13 + if (ieee_min_num (-9., inf) /= -9.) stop 14 + if (ieee_min_num (inf, -9.) /= -9.) stop 15 + if (ieee_min_num (-inf, 9.) /= -inf) stop 16 + if (ieee_min_num (0., -inf) /= -inf) stop 17 + if (ieee_min_num (-9., -inf) /= -inf) stop 18 + if (ieee_min_num (-inf, -9.) /= -inf) stop 19 + + if (ieee_min_num (0., nan) /= 0.) stop 20 + if (ieee_min_num (nan, 0.) /= 0.) stop 21 + if (ieee_min_num (-0., nan) /= -0.) stop 22 + if (.not. ieee_signbit (ieee_min_num (-0., nan))) stop 23 + if (ieee_min_num (nan, -0.) /= -0.) stop 24 + if (.not. ieee_signbit (ieee_min_num (nan, -0.))) stop 25 + if (ieee_min_num (9., nan) /= 9.) stop 26 + if (ieee_min_num (nan, 9.) /= 9.) stop 27 + if (ieee_min_num (-9., nan) /= -9.) stop 28 + if (ieee_min_num (nan, -9.) /= -9.) stop 29 + + if (ieee_min_num (nan, inf) /= inf) stop 30 + if (ieee_min_num (inf, nan) /= inf) stop 31 + if (ieee_min_num (nan, -inf) /= -inf) stop 32 + if (ieee_min_num (-inf, nan) /= -inf) stop 33 + + if (.not. ieee_is_nan (ieee_min_num (nan, nan))) stop 34 +end subroutine real + + +subroutine double + use ieee_arithmetic + implicit none + + double precision :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num (0.d0, 0.d0) /= 0.d0) stop 35 + if (ieee_min_num (-0.d0, -0.d0) /= -0.d0) stop 36 + if (.not. ieee_signbit (ieee_min_num (-0.d0, -0.d0))) stop 37 + if (ieee_min_num (0.d0, -0.d0) /= 0.d0) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (0.d0, -0.d0))) stop 39 + if (ieee_min_num (-0.d0, 0.d0) /= 0.d0) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (-0.d0, 0.d0))) stop 41 + + if (ieee_min_num (9.d0, 0.d0) /= 0.d0) stop 42 + if (ieee_min_num (0.d0, 9.d0) /= 0.d0) stop 43 + if (ieee_min_num (-9.d0, 0.d0) /= -9.d0) stop 44 + if (ieee_min_num (0.d0, -9.d0) /= -9.d0) stop 45 + + if (ieee_min_num (inf, 9.d0) /= 9.d0) stop 46 + if (ieee_min_num (0.d0, inf) /= 0.d0) stop 47 + if (ieee_min_num (-9.d0, inf) /= -9.d0) stop 48 + if (ieee_min_num (inf, -9.d0) /= -9.d0) stop 49 + if (ieee_min_num (-inf, 9.d0) /= -inf) stop 50 + if (ieee_min_num (0.d0, -inf) /= -inf) stop 51 + if (ieee_min_num (-9.d0, -inf) /= -inf) stop 52 + if (ieee_min_num (-inf, -9.d0) /= -inf) stop 53 + + if (ieee_min_num (0.d0, nan) /= 0.d0) stop 54 + if (ieee_min_num (nan, 0.d0) /= 0.d0) stop 55 + if (ieee_min_num (-0.d0, nan) /= -0.d0) stop 56 + if (.not. ieee_signbit (ieee_min_num (-0.d0, nan))) stop 57 + if (ieee_min_num (nan, -0.d0) /= -0.d0) stop 58 + if (.not. ieee_signbit (ieee_min_num (nan, -0.d0))) stop 59 + if (ieee_min_num (9.d0, nan) /= 9.d0) stop 60 + if (ieee_min_num (nan, 9.d0) /= 9.d0) stop 61 + if (ieee_min_num (-9.d0, nan) /= -9.d0) stop 62 + if (ieee_min_num (nan, -9.d0) /= -9.d0) stop 63 + + if (ieee_min_num (nan, inf) /= inf) stop 64 + if (ieee_min_num (inf, nan) /= inf) stop 65 + if (ieee_min_num (nan, -inf) /= -inf) stop 66 + if (ieee_min_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num (nan, nan))) stop 68 +end subroutine double + + +subroutine large1 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num (0._k1, 0._k1) /= 0._k1) stop 35 + if (ieee_min_num (-0._k1, -0._k1) /= -0._k1) stop 36 + if (.not. ieee_signbit (ieee_min_num (-0._k1, -0._k1))) stop 37 + if (ieee_min_num (0._k1, -0._k1) /= 0._k1) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (0._k1, -0._k1))) stop 39 + if (ieee_min_num (-0._k1, 0._k1) /= 0._k1) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (-0._k1, 0._k1))) stop 41 + + if (ieee_min_num (9._k1, 0._k1) /= 0._k1) stop 42 + if (ieee_min_num (0._k1, 9._k1) /= 0._k1) stop 43 + if (ieee_min_num (-9._k1, 0._k1) /= -9._k1) stop 44 + if (ieee_min_num (0._k1, -9._k1) /= -9._k1) stop 45 + + if (ieee_min_num (inf, 9._k1) /= 9._k1) stop 46 + if (ieee_min_num (0._k1, inf) /= 0._k1) stop 47 + if (ieee_min_num (-9._k1, inf) /= -9._k1) stop 48 + if (ieee_min_num (inf, -9._k1) /= -9._k1) stop 49 + if (ieee_min_num (-inf, 9._k1) /= -inf) stop 50 + if (ieee_min_num (0._k1, -inf) /= -inf) stop 51 + if (ieee_min_num (-9._k1, -inf) /= -inf) stop 52 + if (ieee_min_num (-inf, -9._k1) /= -inf) stop 53 + + if (ieee_min_num (0._k1, nan) /= 0._k1) stop 54 + if (ieee_min_num (nan, 0._k1) /= 0._k1) stop 55 + if (ieee_min_num (-0._k1, nan) /= -0._k1) stop 56 + if (.not. ieee_signbit (ieee_min_num (-0._k1, nan))) stop 57 + if (ieee_min_num (nan, -0._k1) /= -0._k1) stop 58 + if (.not. ieee_signbit (ieee_min_num (nan, -0._k1))) stop 59 + if (ieee_min_num (9._k1, nan) /= 9._k1) stop 60 + if (ieee_min_num (nan, 9._k1) /= 9._k1) stop 61 + if (ieee_min_num (-9._k1, nan) /= -9._k1) stop 62 + if (ieee_min_num (nan, -9._k1) /= -9._k1) stop 63 + + if (ieee_min_num (nan, inf) /= inf) stop 64 + if (ieee_min_num (inf, nan) /= inf) stop 65 + if (ieee_min_num (nan, -inf) /= -inf) stop 66 + if (ieee_min_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num (nan, nan))) stop 68 +end subroutine large1 + + +subroutine large2 + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k2) :: inf, nan + + inf = ieee_value(inf, ieee_positive_inf) + nan = ieee_value(nan, ieee_quiet_nan) + + if (ieee_min_num (0._k2, 0._k2) /= 0._k2) stop 35 + if (ieee_min_num (-0._k2, -0._k2) /= -0._k2) stop 36 + if (.not. ieee_signbit (ieee_min_num (-0._k2, -0._k2))) stop 37 + if (ieee_min_num (0._k2, -0._k2) /= 0._k2) stop 38 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (0._k2, -0._k2))) stop 39 + if (ieee_min_num (-0._k2, 0._k2) /= 0._k2) stop 40 + ! Processor-dependent + !if (ieee_signbit (ieee_min_num (-0._k2, 0._k2))) stop 41 + + if (ieee_min_num (9._k2, 0._k2) /= 0._k2) stop 42 + if (ieee_min_num (0._k2, 9._k2) /= 0._k2) stop 43 + if (ieee_min_num (-9._k2, 0._k2) /= -9._k2) stop 44 + if (ieee_min_num (0._k2, -9._k2) /= -9._k2) stop 45 + + if (ieee_min_num (inf, 9._k2) /= 9._k2) stop 46 + if (ieee_min_num (0._k2, inf) /= 0._k2) stop 47 + if (ieee_min_num (-9._k2, inf) /= -9._k2) stop 48 + if (ieee_min_num (inf, -9._k2) /= -9._k2) stop 49 + if (ieee_min_num (-inf, 9._k2) /= -inf) stop 50 + if (ieee_min_num (0._k2, -inf) /= -inf) stop 51 + if (ieee_min_num (-9._k2, -inf) /= -inf) stop 52 + if (ieee_min_num (-inf, -9._k2) /= -inf) stop 53 + + if (ieee_min_num (0._k2, nan) /= 0._k2) stop 54 + if (ieee_min_num (nan, 0._k2) /= 0._k2) stop 55 + if (ieee_min_num (-0._k2, nan) /= -0._k2) stop 56 + if (.not. ieee_signbit (ieee_min_num (-0._k2, nan))) stop 57 + if (ieee_min_num (nan, -0._k2) /= -0._k2) stop 58 + if (.not. ieee_signbit (ieee_min_num (nan, -0._k2))) stop 59 + if (ieee_min_num (9._k2, nan) /= 9._k2) stop 60 + if (ieee_min_num (nan, 9._k2) /= 9._k2) stop 61 + if (ieee_min_num (-9._k2, nan) /= -9._k2) stop 62 + if (ieee_min_num (nan, -9._k2) /= -9._k2) stop 63 + + if (ieee_min_num (nan, inf) /= inf) stop 64 + if (ieee_min_num (inf, nan) /= inf) stop 65 + if (ieee_min_num (nan, -inf) /= -inf) stop 66 + if (ieee_min_num (-inf, nan) /= -inf) stop 67 + + if (.not. ieee_is_nan (ieee_min_num (nan, nan))) stop 68 +end subroutine large2 + diff --git a/Fortran/gfortran/regression/ieee/modes_1.f90 b/Fortran/gfortran/regression/ieee/modes_1.f90 index 205c47f38..e29d8c678 100644 --- a/Fortran/gfortran/regression/ieee/modes_1.f90 +++ b/Fortran/gfortran/regression/ieee/modes_1.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! +! { dg-skip-if "PR libfortran/78314" { aarch64*-*-gnu* arm*-*-gnueabi arm*-*-gnueabihf } } ! Test IEEE_MODES_TYPE, IEEE_GET_MODES and IEEE_SET_MODES diff --git a/Fortran/gfortran/regression/ieee/signaling_2.f90 b/Fortran/gfortran/regression/ieee/signaling_2.f90 index 03b04c783..79a85edef 100644 --- a/Fortran/gfortran/regression/ieee/signaling_2.f90 +++ b/Fortran/gfortran/regression/ieee/signaling_2.f90 @@ -1,9 +1,6 @@ ! { dg-do run { target { ! ia32 } } } ! x87 / x86-32 ABI is unsuitable for signaling NaNs ! -! { dg-require-effective-target issignaling } */ -! The companion C source needs access to the issignaling macro. -! ! { dg-additional-sources signaling_2_c.c } ! { dg-additional-options "-w" } ! The -w option is needed to make cc1 not report a warning for diff --git a/Fortran/gfortran/regression/ieee/signaling_2_c.c b/Fortran/gfortran/regression/ieee/signaling_2_c.c index ea7fc0467..dde09638c 100644 --- a/Fortran/gfortran/regression/ieee/signaling_2_c.c +++ b/Fortran/gfortran/regression/ieee/signaling_2_c.c @@ -1,8 +1,4 @@ -#define _GNU_SOURCE -#include -#include - -int isnansf (float x) { return issignaling (x) ? 1 : 0; } -int isnans (double x) { return issignaling (x) ? 1 : 0; } -int isnansl (long double x) { return issignaling (x) ? 1 : 0; } +int isnansf (float x) { return __builtin_issignaling (x) ? 1 : 0; } +int isnans (double x) { return __builtin_issignaling (x) ? 1 : 0; } +int isnansl (long double x) { return __builtin_issignaling (x) ? 1 : 0; } diff --git a/Fortran/gfortran/regression/ieee/tests.cmake b/Fortran/gfortran/regression/ieee/tests.cmake index 141a66527..4a6b81031 100644 --- a/Fortran/gfortran/regression/ieee/tests.cmake +++ b/Fortran/gfortran/regression/ieee/tests.cmake @@ -34,6 +34,9 @@ compile;large_4.f90;;;; compile;pr77372.f90;;;; compile;pr77507.f90;;;; +run;comparisons_1.f90;;;; +run;comparisons_2.f90;;;; +run;comparisons_3.F90;;-ffree-line-length-none;; run;dec_math_1.f90;;-cpp -std=gnu;; run;fma_1.f90;;;; run;ieee_1.F90;;-ffree-line-length-none;; @@ -53,6 +56,10 @@ run;intrinsics_2.F90;;-fno-range-check;; run;large_1.f90;;;; run;large_2.f90;;;; run;large_3.F90;;-ffree-line-length-none;; +run;minmax_1.f90;;;; +run;minmax_2.f90;;;; +run;minmax_3.f90;;;; +run;minmax_4.f90;;;; run;modes_1.f90;;;; run;rounding_1.f90;;;; run;rounding_2.f90;;;; diff --git a/Fortran/gfortran/regression/implied_do_io_8.f90 b/Fortran/gfortran/regression/implied_do_io_8.f90 new file mode 100644 index 000000000..c66a0f6fd --- /dev/null +++ b/Fortran/gfortran/regression/implied_do_io_8.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds" } +! PR fortran/111837 - out of bounds access with front-end optimization + +program implied_do_bug + implicit none + integer :: i,j,k + real :: arr(1,1,1) + integer :: ni(1) + ni(1) = 1 + arr = 1 + write(*,*) (((arr(i,j,k), i=1,ni(k)), k=1,1), j=1,1) + write(*,*) (((arr(i,j,k), i=1,ni(k)), j=1,1), k=1,1) + write(*,*) (((arr(k,i,j), i=1,ni(k)), k=1,1), j=1,1) + write(*,*) (((arr(k,i,j), i=1,ni(k)), j=1,1), k=1,1) + write(*,*) (((arr(j,k,i), i=1,ni(k)), k=1,1), j=1,1) + write(*,*) (((arr(j,k,i), i=1,ni(k)), j=1,1), k=1,1) +end diff --git a/Fortran/gfortran/regression/intent_out_16.f90 b/Fortran/gfortran/regression/intent_out_16.f90 new file mode 100644 index 000000000..e8d635fed --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_16.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! PR fortran/92178 +! Re-order argument deallocation + +program p + implicit none + integer, allocatable :: a(:) + class(*), allocatable :: c(:) + type t + integer, allocatable :: a(:) + end type t + type(t) :: b + integer :: k = -999 + + ! Test based on original PR + a = [1] + call assign (a, (max(a(1),0))) + if (allocated (a)) stop 9 + if (k /= 1) stop 10 + + ! Additional variations based on suggestions by Tobias Burnus + ! to check that argument expressions are evaluated early enough + a = [1, 2] + call foo (allocated (a), size (a), test (a), a, allocated (a)) + if (allocated (a)) stop 11 + + a = [1, 2] + k = 1 + call foo (allocated (a), size (a), test (k*a), a, allocated (a)) + if (allocated (a)) stop 12 + + b% a = [1, 2] + call foo (allocated (b% a), size (b% a), test (b% a), b% a, allocated (b% a)) + if (allocated (b% a)) stop 13 + + c = [3, 4] + call bar (allocated (c), size (c), test2 (c), c, & + allocated (c), size (c), test2 (c) ) + if (allocated (c)) stop 14 + +contains + + subroutine assign (a, i) + integer, allocatable, intent(out) :: a(:) + integer, value :: i + k = i + end subroutine + + subroutine foo (alloc, sz, tst, x, alloc2) + logical, value :: alloc, tst + integer, value :: sz + logical :: alloc2 + integer, allocatable, intent(out) :: x(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (sz /= 2) stop 3 + if (.not. tst) stop 4 + if (.not. alloc2) stop 15 + end subroutine foo + ! + logical function test (zz) + integer :: zz(2) + test = zz(2) == 2 + end function test + ! + subroutine bar (alloc, sz, tst, x, alloc2, sz2, tst2) + logical, value :: alloc, tst, alloc2, tst2 + integer, value :: sz, sz2 + class(*), allocatable, intent(out) :: x(:) + if (allocated (x)) stop 5 + if (.not. alloc) stop 6 + if (sz /= 2) stop 7 + if (.not. tst) stop 8 + if (.not. alloc2) stop 16 + if (sz2 /= 2) stop 17 + if (.not. tst2) stop 18 + end subroutine bar + ! + logical function test2 (zz) + class(*), intent(in) :: zz(:) + select type (zz) + type is (integer) + test2 = zz(2) == 4 + class default + stop 99 + end select + end function test2 +end diff --git a/Fortran/gfortran/regression/intent_out_17.f90 b/Fortran/gfortran/regression/intent_out_17.f90 new file mode 100644 index 000000000..bc9208dcf --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_17.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR fortran/92178 +! Contributed by Tobias Burnus + +program foo + implicit none (type, external) + + type t + end type t + + type, extends(t) :: t2 + end type t2 + + type(t2) :: x2 + class(t), allocatable :: aa + + call check_intentout_false(allocated(aa), aa, & + allocated(aa)) + if (allocated(aa)) stop 1 + + allocate(t2 :: aa) + if (.not.allocated(aa)) stop 2 + if (.not.same_type_as(aa, x2)) stop 3 + call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, & + allocated(aa), (same_type_as(aa, x2))) + if (allocated(aa)) stop 4 + +contains + subroutine check_intentout_false(alloc1, yy, alloc2) + logical, value :: alloc1, alloc2 + class(t), allocatable, intent(out) :: yy + if (allocated(yy)) stop 11 + if (alloc1) stop 12 + if (alloc2) stop 13 + end subroutine check_intentout_false + subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2) + logical, value :: alloc1, alloc2, same1, same2 + class(t), allocatable, intent(out) :: zz + if (allocated(zz)) stop 21 + if (.not.alloc1) stop 22 + if (.not.alloc2) stop 23 + if (.not.same1) stop 24 + if (.not.same2) stop 25 + end subroutine check_intentout_true +end program diff --git a/Fortran/gfortran/regression/intent_out_18.f90 b/Fortran/gfortran/regression/intent_out_18.f90 new file mode 100644 index 000000000..50f9948bf --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_18.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/92178 +! Contributed by Mikael Morin + +program p + implicit none + type t + integer :: i + integer, pointer :: pi + end type t + integer, target :: j + type(t), allocatable :: ta + j = 1 + ta = t(2, j) + call assign(ta, id(ta%pi)) + if (ta%i /= 1) stop 1 + if (associated(ta%pi)) stop 2 +contains + subroutine assign(a, b) + type(t), intent(out), allocatable :: a + integer, intent(in) , value :: b + allocate(a) + a%i = b + a%pi => null() + end subroutine assign + function id(a) + integer, pointer :: id, a + id => a + end function id +end program p diff --git a/Fortran/gfortran/regression/intent_out_19.f90 b/Fortran/gfortran/regression/intent_out_19.f90 new file mode 100644 index 000000000..03036ed38 --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_19.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that if a data reference passed is as actual argument whose dummy +! has INTENT(OUT) attribute, any other argument depending on the +! same data reference is evaluated before the data reference deallocation. + +program p + implicit none + class(*), allocatable :: c + c = 3 + call bar (allocated(c), c, allocated (c)) + if (allocated (c)) stop 14 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(*), allocatable, intent(out) :: x(..) + if (allocated (x)) stop 5 + if (.not. alloc) stop 6 + if (.not. alloc2) stop 16 + end subroutine bar +end diff --git a/Fortran/gfortran/regression/intent_out_20.f90 b/Fortran/gfortran/regression/intent_out_20.f90 new file mode 100644 index 000000000..8e5d8c690 --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_20.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that if a data reference passed is as actual argument whose dummy +! has INTENT(OUT) attribute, any other argument depending on the +! same data reference is evaluated before the data reference deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta + end type u + type(u), allocatable :: c(:) + allocate(c, source = [u(t(1)), u(t(4))]) + call bar ( & + allocated (c(c(1)%ta%i)%ta), & + c(c(1)%ta%i)%ta, & + allocated (c(c(1)%ta%i)%ta) & + ) + if (allocated (c(1)%ta)) stop 11 + if (.not. allocated (c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(..) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end diff --git a/Fortran/gfortran/regression/intent_out_21.f90 b/Fortran/gfortran/regression/intent_out_21.f90 new file mode 100644 index 000000000..5f61a5474 --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_21.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that in the case of a data reference depending on its own content +! passed as actual argument to an INTENT(OUT) dummy, no reference to the +! content happens after the deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta(:) + end type u + type(u), allocatable :: c(:) + c = [u([t(1), t(3)]), u([t(4), t(9)])] + call bar ( & + allocated (c(c(1)%ta(1)%i)%ta), & + c(c(1)%ta(1)%i)%ta, & + allocated (c(c(1)%ta(1)%i)%ta) & + ) + if (allocated(c(1)%ta)) stop 11 + if (.not. allocated(c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end diff --git a/Fortran/gfortran/regression/intent_out_22.f90 b/Fortran/gfortran/regression/intent_out_22.f90 new file mode 100644 index 000000000..a38afccf0 --- /dev/null +++ b/Fortran/gfortran/regression/intent_out_22.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR fortran/110618 +! Check that if a data reference is passed as actual argument whose dummy +! has INTENT(OUT) attribute, any other argument depending on the +! same data reference is evaluated before the data reference deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta(:) + end type u + type(u), allocatable :: c(:) + class(t), allocatable :: d(:) + allocate(c, source = [u([t(1), t(3)]), u([t(4), t(9)])]) + allocate(d, source = [t(1), t(5)]) + call bar ( & + allocated(c(d(1)%i)%ta), & + d, & + c(d(1)%i)%ta, & + allocated (c(d(1)%i)%ta) & + ) + if (allocated (c(1)%ta)) stop 11 + if (.not. allocated (c(2)%ta)) stop 11 +contains + subroutine bar (alloc, x, y, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(:) + class(t), allocatable, intent(out) :: y(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end diff --git a/Fortran/gfortran/regression/interface_50.f90 b/Fortran/gfortran/regression/interface_50.f90 new file mode 100644 index 000000000..212454832 --- /dev/null +++ b/Fortran/gfortran/regression/interface_50.f90 @@ -0,0 +1,98 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR98498, which was subject to an interpretation request +! as to whether or not the interface operator overrode the intrinsic use. +! (See PR for correspondence) +! +! Contributed by Paul Thomas +! +MODULE mytypes + IMPLICIT none + + TYPE pvar + character(len=20) :: name + integer :: level + end TYPE pvar + + interface operator (==) + module procedure star_eq + end interface + + interface operator (.not.) + module procedure star_not + end interface + +contains + function star_eq(a, b) + implicit none + class(*), intent(in) :: a, b + logical :: star_eq + select type (a) + type is (pvar) + select type (b) + type is (pvar) + if((a%level .eq. b%level) .and. (a%name .eq. b%name)) then + star_eq = .true. + else + star_eq = .false. + end if + type is (integer) + star_eq = (a%level == b) + end select + class default + star_eq = .false. + end select + end function star_eq + + function star_not (a) + implicit none + class(*), intent(in) :: a + type(pvar) :: star_not + select type (a) + type is (pvar) + star_not = a + star_not%level = -star_not%level + type is (real) + star_not = pvar ("real", -int(a)) + class default + star_not = pvar ("noname", 0) + end select + end function + +end MODULE mytypes + +program test_eq + use mytypes + implicit none + + type(pvar) x, y + integer :: i = 4 + real :: r = 2.0 + character(len = 4, kind =4) :: c = "abcd" +! Check that intrinsic use of .not. and == is not overridden. + if (.not.(i == 2*int (r))) stop 1 + if (r == 1.0) stop 2 + +! Test defined operator == + x = pvar('test 1', 100) + y = pvar('test 1', 100) + if (.not.(x == y)) stop 3 + y = pvar('test 2', 100) + if (x == y) stop 4 + if (x == r) stop 5 ! class default gives .false. + if (100 == x) stop 6 ! ditto + if (.not.(x == 100)) stop 7 ! integer selector gives a%level == b + if (i == "c") stop 8 ! type mismatch => calls star_eq + if (c == "abcd") stop 9 ! kind mismatch => calls star_eq + +! Test defined operator .not. + y = .not.x + if (y%level .ne. -x%level) stop 11 + y = .not.i + if (y%level .ne. 0 .and. trim(y%name) .ne. "noname") stop 12 + y = .not.r + if (y%level .ne. -2 .and. trim(y%name) .ne. "real") stop 13 +end program test_eq +! { dg-final { scan-tree-dump-times "star_eq" 14 "original" } } +! { dg-final { scan-tree-dump-times "star_not" 11 "original" } } diff --git a/Fortran/gfortran/regression/interface_procedure_1.f90 b/Fortran/gfortran/regression/interface_procedure_1.f90 new file mode 100644 index 000000000..6a58b6a7b --- /dev/null +++ b/Fortran/gfortran/regression/interface_procedure_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-additional-options "-std=f95" } +! +! PR fortran/48776 +! The following used to generate a segmentation fault in the front-end, +! because a pointer to the get1 symbol was remaining in the get interface +! after the procedure statement was rejected and the symbol freed. + + interface get + procedure get1 ! { dg-error "Fortran 2003: PROCEDURE statement" } + end interface + + integer :: h + call set1 (get (h)) ! { dg-error "no specific function for the generic 'get'" } +contains + subroutine set1 (a) + integer, intent(in) :: a + end subroutine + + integer function get1 (s) + integer :: s + end function +end diff --git a/Fortran/gfortran/regression/is_contiguous_4.f90 b/Fortran/gfortran/regression/is_contiguous_4.f90 new file mode 100644 index 000000000..cb066f883 --- /dev/null +++ b/Fortran/gfortran/regression/is_contiguous_4.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! PR fortran/114001 - IS_CONTIGUOUS and polymorphic dummy + +program main + implicit none + integer :: i, cnt = 0 + logical :: expect + integer, target :: m(10) = [(i,i=1,size(m))] + integer, pointer :: p(:) + type t + integer :: j + end type t + type(t), pointer :: tt(:), tp(:) ! Type pointer + class(t), pointer :: ct(:), cp(:) ! Class pointer + + p => m(1:3) + expect = is_contiguous (p) + print *, "is_contiguous (p)=", expect + if (.not. expect) stop 91 + call sub_star (p, expect) + p => m(1::3) + expect = is_contiguous (p) + print *, "is_contiguous (p)=", expect + if (expect) stop 92 + call sub_star (p, expect) + + allocate (tt(10)) + tt(:)% j = m + tp => tt(4:6) + expect = is_contiguous (tp) + if (.not. expect) stop 96 + print *, "is_contiguous (tp)=", expect + call sub_t (tp, expect) + tp => tt(4::3) + expect = is_contiguous (tp) + if (expect) stop 97 + print *, "is_contiguous (tp)=", expect + call sub_t (tp, expect) + + allocate (ct(10)) + ct(:)% j = m + cp => ct(7:9) + expect = is_contiguous (cp) + print *, "is_contiguous (cp)=", expect + if (.not. expect) stop 98 + call sub_t (cp, expect) + cp => ct(4::3) + expect = is_contiguous (cp) + print *, "is_contiguous (cp)=", expect + if (expect) stop 99 + call sub_t (cp, expect) + +contains + + subroutine sub_star (x, expect) + class(*), intent(in) :: x(:) + logical, intent(in) :: expect + cnt = cnt + 10 + if (is_contiguous (x) .neqv. expect) then + print *, "sub_star(1): is_contiguous (x)=", is_contiguous (x), expect + stop (cnt + 1) + end if + select type (x) + type is (integer) + if (is_contiguous (x) .neqv. expect) then + print *, "sub_star(2): is_contiguous (x)=", is_contiguous (x), expect + stop (cnt + 2) + end if + end select + end + + subroutine sub_t (x, expect) + class(t), intent(in) :: x(:) + logical, intent(in) :: expect + cnt = cnt + 10 + if (is_contiguous (x) .neqv. expect) then + print *, "sub_t: is_contiguous (x)=", is_contiguous (x), expect + stop (cnt + 3) + end if + end +end diff --git a/Fortran/gfortran/regression/ishftc_optional_size_1.f90 b/Fortran/gfortran/regression/ishftc_optional_size_1.f90 new file mode 100644 index 000000000..1ccf4b38c --- /dev/null +++ b/Fortran/gfortran/regression/ishftc_optional_size_1.f90 @@ -0,0 +1,97 @@ +! { dg-do run } +! +! PR fortran/67277 - ISHFTC and missing optional argument SIZE + +module m + implicit none +contains + ! Optional argument passed by reference + elemental function ishftc4_ref (i, shift, size_) result(r) + integer(4), intent(in) :: i + integer, intent(in) :: shift + integer, intent(in), optional :: size_ + integer :: r + r = ishftc (i, shift=shift, size=size_) + end + + elemental function ishftc1_ref (i, shift, size_) result(r) + integer(1), intent(in) :: i + integer, intent(in) :: shift + integer(1), intent(in), optional :: size_ + integer(1) :: r + r = ishftc (i, shift=shift, size=size_) + end + + ! Array valued argument i + function ishftc4_ref_4 (i, shift, size_) result(r) + integer(4), intent(in) :: i(4) + integer, intent(in) :: shift + integer, intent(in), optional :: size_ + integer :: r(size(i)) + r = ishftc (i, shift=shift, size=size_) + end + + ! Optional argument passed by value + elemental function ishftc4_val (i, shift, size_) result(r) + integer(4), intent(in) :: i + integer, intent(in) :: shift + integer, value, optional :: size_ + integer :: r + r = ishftc (i, shift=shift, size=size_) + end + + elemental function ishftc1_val (i, shift, size_) result(r) + integer(1), intent(in) :: i + integer, intent(in) :: shift + integer(1), value, optional :: size_ + integer(1) :: r + r = ishftc (i, shift=shift, size=size_) + end + + ! Array valued argument i + function ishftc4_val_4 (i, shift, size_) result(r) + integer(4), intent(in) :: i(4) + integer, intent(in) :: shift + integer, value, optional :: size_ + integer :: r(size(i)) + r = ishftc (i, shift=shift, size=size_) + end +end module m + +program p + use m + implicit none + integer :: shift = 1 + integer(4) :: i4 = 127, j4(4), k4(4) + integer(1) :: i1 = 127 + integer(4) :: expect4 + integer(1) :: expect1 + + ! Scalar variants + expect4 = 2*i4 + if (ishftc (i4, shift) /= expect4) stop 1 + if (ishftc4_ref (i4, shift) /= expect4) stop 2 + if (ishftc4_val (i4, shift) /= expect4) stop 3 + + expect1 = -2_1 + if (ishftc (i1, shift) /= expect1) stop 4 + if (ishftc1_ref (i1, shift) /= expect1) stop 5 + if (ishftc1_val (i1, shift) /= expect1) stop 6 + + ! Array arguments + expect4 = 2*i4 + j4 = i4 + k4 = ishftc (j4, shift) + if (any (k4 /= expect4)) stop 7 + + ! The following works on x86_64 but might currently fail on other systems: + ! (see PR113377) +! k4 = ishftc4_val_4 (j4, shift) +! if (any (k4 /= expect4)) stop 8 + + ! The following currently segfaults (might be a scalarizer issue): + ! (see PR113377) +! k4 = ishftc4_ref_4 (j4, shift) +! print *, k4 +! if (any (k4 /= expect4)) stop 9 +end program p diff --git a/Fortran/gfortran/regression/iso_fortran_env_8.f90 b/Fortran/gfortran/regression/iso_fortran_env_8.f90 new file mode 100644 index 000000000..d3661b3b5 --- /dev/null +++ b/Fortran/gfortran/regression/iso_fortran_env_8.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Check for the new Fortran 2023 ISO_FORTRAN_ENV named constants + +program test + use iso_fortran_env + implicit none + + ! These integer kinds are guaranteed on + integer(int8) :: i8 + integer(int16) :: i16 + integer(int32) :: i32 + integer(int64) :: i64 + + logical(logical8) :: l8 + logical(logical16) :: l16 + logical(logical32) :: l32 + logical(logical64) :: l64 + + ! We do not support REAL16 for now, but check it can + ! still be used in specification expressions + real(kind=max(real16, real32)) :: x + + if (logical8 /= int8) stop 1 + if (logical16 /= int16) stop 2 + if (logical32 /= int32) stop 3 + if (logical64 /= int64) stop 4 + + ! We do not support REAL16 for now + if (real16 /= -2) stop 101 + +end program test diff --git a/Fortran/gfortran/regression/iso_fortran_env_9.f90 b/Fortran/gfortran/regression/iso_fortran_env_9.f90 new file mode 100644 index 000000000..ffd70b231 --- /dev/null +++ b/Fortran/gfortran/regression/iso_fortran_env_9.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! +! Check diagnostics for new F2023 named constants +! in ISO_FORTRAN_ENV +! + +subroutine foo + use iso_fortran_env + implicit none + logical(kind=logical8) :: x ! { dg-error "has no IMPLICIT type" } +end subroutine + +subroutine bar + use iso_fortran_env, only : logical8 ! { dg-error "not in the selected standard" } + use iso_fortran_env, only : logical16 ! { dg-error "not in the selected standard" } + use iso_fortran_env, only : logical32 ! { dg-error "not in the selected standard" } + use iso_fortran_env, only : logical64 ! { dg-error "not in the selected standard" } + use iso_fortran_env, only : real16 ! { dg-error "not in the selected standard" } + implicit none +end subroutine + +subroutine gee + use iso_fortran_env, only : int8 + use iso_fortran_env, only : int16 + use iso_fortran_env, only : int32 + use iso_fortran_env, only : int64 + implicit none +end subroutine diff --git a/Fortran/gfortran/regression/line_length_10.f90 b/Fortran/gfortran/regression/line_length_10.f90 index 390e9a163..c244172e1 100644 --- a/Fortran/gfortran/regression/line_length_10.f90 +++ b/Fortran/gfortran/regression/line_length_10.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wno-line-truncation" } +! { dg-options "-std=f2018 -Wno-line-truncation" } ! ! By default, for free-form source code: Error out ! But due to the explicit -Wno-line-truncation, compile w/o warning diff --git a/Fortran/gfortran/regression/line_length_11.f90 b/Fortran/gfortran/regression/line_length_11.f90 index 67f1e29a0..2125f5458 100644 --- a/Fortran/gfortran/regression/line_length_11.f90 +++ b/Fortran/gfortran/regression/line_length_11.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wno-all" } +! { dg-options "-Wno-all -std=f2018" } ! ! By default, for free-form source code: Error out ! But due to the explicit -Wno-all, compile w/o warning diff --git a/Fortran/gfortran/regression/line_length_12.f90 b/Fortran/gfortran/regression/line_length_12.f90 new file mode 100644 index 000000000..c8a935a02 --- /dev/null +++ b/Fortran/gfortran/regression/line_length_12.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018" } +! { dg-prune-output "some warnings being treated as errors" } +! +! In Fortran 2018, the linelength is 132 characters. <<< Test this. +! In Fortran 2023, the linelength is 10,000 characters. + +implicit none +integer :: a, b, c, d + +a = & ! The next line has 9,999 characters -> OK + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +b = & ! The next line has 10,000 characters -> OK + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +c = & ! The next line has 10,001 characters -> TOO LONG + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 4242 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +d = & ! The next line has 10,002 characters -> TOO LONG + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42424 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +end diff --git a/Fortran/gfortran/regression/line_length_13.f90 b/Fortran/gfortran/regression/line_length_13.f90 new file mode 100644 index 000000000..861eeb9c9 --- /dev/null +++ b/Fortran/gfortran/regression/line_length_13.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2023" } +! { dg-prune-output "some warnings being treated as errors" } +! +! In Fortran 2018, the linelength is 132 characters. +! In Fortran 2023, the linelength is 10,000 characters. <<< Test this. + +implicit none +integer :: a, b, c, d + +a = & ! The next line has 9,999 characters -> OK + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42 + +b = & ! The next line has 10,000 characters -> OK + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42 + +c = & ! The next line has 10,001 characters -> TOO LONG + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 4242 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +d = & ! The next line has 10,002 characters -> TOO LONG + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 +4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 42424 + +! { dg-error "Line truncated at .1. \\\[-Werror=line-truncation\\\]" "" { target *-*-* } .-2 } + +end diff --git a/Fortran/gfortran/regression/line_length_2.f90 b/Fortran/gfortran/regression/line_length_2.f90 index e1ab7220d..ff44d8822 100644 --- a/Fortran/gfortran/regression/line_length_2.f90 +++ b/Fortran/gfortran/regression/line_length_2.f90 @@ -1,7 +1,7 @@ ! Testcase for -ffree-line-length-none ! See PR fortran/21302 ! { dg-do compile } -! { dg-options "-ffree-line-length-none" } +! { dg-options "-ffree-line-length-none -std=f2018" } program two if (abs(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa).gt.999.d0.or.abs(bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb).gt.999.d0.or.abs(cccccccccccccccccccc).gt.999.d0) THEN endif diff --git a/Fortran/gfortran/regression/line_length_5.f90 b/Fortran/gfortran/regression/line_length_5.f90 index 81832451e..ba9f2850b 100644 --- a/Fortran/gfortran/regression/line_length_5.f90 +++ b/Fortran/gfortran/regression/line_length_5.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wline-truncation" } +! { dg-options "-std=f2018 -Wline-truncation" } print *, 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' end ! { dg-error "Line truncated" " " { target *-*-* } 3 } diff --git a/Fortran/gfortran/regression/line_length_6.f90 b/Fortran/gfortran/regression/line_length_6.f90 index 8cdb02099..a88e2d247 100644 --- a/Fortran/gfortran/regression/line_length_6.f90 +++ b/Fortran/gfortran/regression/line_length_6.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "" } +! { dg-options "-std=f2018" } ! ! By default, for free-form source code: Error out ! diff --git a/Fortran/gfortran/regression/line_length_7.f90 b/Fortran/gfortran/regression/line_length_7.f90 index b4ebf49c4..6c6d73b01 100644 --- a/Fortran/gfortran/regression/line_length_7.f90 +++ b/Fortran/gfortran/regression/line_length_7.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wno-error" } +! { dg-options "-std=f2018 -Wno-error" } ! ! By default, for free-form source code: Error out ! But due to -Wno-error, we only expect a warning diff --git a/Fortran/gfortran/regression/line_length_8.f90 b/Fortran/gfortran/regression/line_length_8.f90 index afd6cc2df..822b09e80 100644 --- a/Fortran/gfortran/regression/line_length_8.f90 +++ b/Fortran/gfortran/regression/line_length_8.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wline-truncation" } +! { dg-options "-std=f2018 -Wline-truncation" } ! ! By default, for free-form source code: Error out ! Even with -Wline-truncation, we still get an error diff --git a/Fortran/gfortran/regression/line_length_9.f90 b/Fortran/gfortran/regression/line_length_9.f90 index 6c156afc1..9f07d9a58 100644 --- a/Fortran/gfortran/regression/line_length_9.f90 +++ b/Fortran/gfortran/regression/line_length_9.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-Wall" } +! { dg-options "-std=f2018 -Wall" } ! ! By default, for free-form source code: Error out ! Even with -Wall, we still get an error diff --git a/Fortran/gfortran/regression/lto/lto.exp b/Fortran/gfortran/regression/lto/lto.exp index 0f3bd0e7f..c9e3403fa 100644 --- a/Fortran/gfortran/regression/lto/lto.exp +++ b/Fortran/gfortran/regression/lto/lto.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2009-2023 Free Software Foundation, Inc. +# Copyright (C) 2009-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/regression/maxloc_5.f90 b/Fortran/gfortran/regression/maxloc_5.f90 new file mode 100644 index 000000000..5d722450c --- /dev/null +++ b/Fortran/gfortran/regression/maxloc_5.f90 @@ -0,0 +1,257 @@ +! { dg-do run } +! +! Check that the evaluation of MAXLOC's BACK argument is made only once +! before the scalarisation loops. + +program p + implicit none + integer, parameter :: data10(*) = (/ 7, 4, 7, 6, 6, 4, 6, 3, 9, 8 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer :: calls_count = 0 + call check_int_const_shape + call check_int_const_shape_scalar_mask + call check_int_const_shape_array_mask + call check_int_const_shape_optional_mask_present + call check_int_const_shape_optional_mask_absent + call check_int_const_shape_empty + call check_int_alloc + call check_int_alloc_scalar_mask + call check_int_alloc_array_mask + call check_int_alloc_empty + call check_real_const_shape + call check_real_const_shape_scalar_mask + call check_real_const_shape_array_mask + call check_real_const_shape_optional_mask_present + call check_real_const_shape_optional_mask_absent + call check_real_const_shape_empty + call check_real_alloc + call check_real_alloc_scalar_mask + call check_real_alloc_array_mask + call check_real_alloc_empty +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 11 + end subroutine + subroutine check_int_const_shape_scalar_mask() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 18 + end subroutine + subroutine check_int_const_shape_array_mask() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 32 + end subroutine + subroutine call_maxloc_int(r, a, m, b) + integer :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = maxloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_optional_mask_present() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + call call_maxloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) stop 39 + end subroutine + subroutine check_int_const_shape_optional_mask_absent() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + call call_maxloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 46 + end subroutine + subroutine check_int_const_shape_empty() + integer :: a(0) + logical :: m(0) + integer :: r + a = (/ integer:: /) + m = (/ logical:: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 53 + end subroutine + subroutine check_int_alloc() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 60 + end subroutine + subroutine check_int_alloc_scalar_mask() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 67 + end subroutine + subroutine check_int_alloc_array_mask() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 81 + end subroutine + subroutine check_int_alloc_empty() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 88 + end subroutine + subroutine check_real_const_shape() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 95 + end subroutine + subroutine check_real_const_shape_scalar_mask() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 102 + end subroutine + subroutine check_real_const_shape_array_mask() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 116 + end subroutine + subroutine call_maxloc_real(r, a, m, b) + real :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = maxloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_optional_mask_present() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + call call_maxloc_real(r, a, m, b = get_scalar_false()) + if (calls_count /= 1) stop 123 + end subroutine + subroutine check_real_const_shape_optional_mask_absent() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + call call_maxloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 130 + end subroutine + subroutine check_real_const_shape_empty() + real :: a(0) + logical :: m(0) + integer :: r + a = (/ real:: /) + m = (/ logical:: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 137 + end subroutine + subroutine check_real_alloc() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + r = maxloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 144 + end subroutine + subroutine check_real_alloc_scalar_mask() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by maxloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 151 + end subroutine + subroutine check_real_alloc_array_mask() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 165 + end subroutine + subroutine check_real_alloc_empty() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + a(:) = (/ real:: /) + m(:) = (/ logical :: /) + calls_count = 0 + r = maxloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 172 + end subroutine +end program p diff --git a/Fortran/gfortran/regression/minloc_5.f90 b/Fortran/gfortran/regression/minloc_5.f90 new file mode 100644 index 000000000..cb2cd0083 --- /dev/null +++ b/Fortran/gfortran/regression/minloc_5.f90 @@ -0,0 +1,257 @@ +! { dg-do run } +! +! Check that the evaluation of MINLOC's BACK argument is made only once +! before the scalarisation loops. + +program p + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 3, 3, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer :: calls_count = 0 + call check_int_const_shape + call check_int_const_shape_scalar_mask + call check_int_const_shape_array_mask + call check_int_const_shape_optional_mask_present + call check_int_const_shape_optional_mask_absent + call check_int_const_shape_empty + call check_int_alloc + call check_int_alloc_scalar_mask + call check_int_alloc_array_mask + call check_int_alloc_empty + call check_real_const_shape + call check_real_const_shape_scalar_mask + call check_real_const_shape_array_mask + call check_real_const_shape_optional_mask_present + call check_real_const_shape_optional_mask_absent + call check_real_const_shape_empty + call check_real_alloc + call check_real_alloc_scalar_mask + call check_real_alloc_array_mask + call check_real_alloc_empty +contains + function get_scalar_false() + logical :: get_scalar_false + calls_count = calls_count + 1 + get_scalar_false = .false. + end function + subroutine check_int_const_shape() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 11 + end subroutine + subroutine check_int_const_shape_scalar_mask() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 18 + end subroutine + subroutine check_int_const_shape_array_mask() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 32 + end subroutine + subroutine call_minloc_int(r, a, m, b) + integer :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = minloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_int_const_shape_optional_mask_present() + integer :: a(10) + logical :: m(10) + integer :: r + a = data10 + m = mask10 + calls_count = 0 + call call_minloc_int(r, a, m, get_scalar_false()) + if (calls_count /= 1) stop 39 + end subroutine + subroutine check_int_const_shape_optional_mask_absent() + integer :: a(10) + integer :: r + a = data10 + calls_count = 0 + call call_minloc_int(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 46 + end subroutine + subroutine check_int_const_shape_empty() + integer :: a(0) + logical :: m(0) + integer :: r + a = (/ integer:: /) + m = (/ logical:: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 53 + end subroutine + subroutine check_int_alloc() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 60 + end subroutine + subroutine check_int_alloc_scalar_mask() + integer, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = data10 + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 67 + end subroutine + subroutine check_int_alloc_array_mask() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 81 + end subroutine + subroutine check_int_alloc_empty() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 88 + end subroutine + subroutine check_real_const_shape() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 95 + end subroutine + subroutine check_real_const_shape_scalar_mask() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 102 + end subroutine + subroutine check_real_const_shape_array_mask() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 116 + end subroutine + subroutine call_minloc_real(r, a, m, b) + real :: a(:) + logical, optional :: m(:) + logical, optional :: b + integer :: r + r = minloc(a, dim = 1, mask = m, back = b) + end subroutine + subroutine check_real_const_shape_optional_mask_present() + real :: a(10) + logical :: m(10) + integer :: r + a = (/ real:: data10 /) + m = mask10 + calls_count = 0 + call call_minloc_real(r, a, m, b = get_scalar_false()) + if (calls_count /= 1) stop 123 + end subroutine + subroutine check_real_const_shape_optional_mask_absent() + real :: a(10) + integer :: r + a = (/ real:: data10 /) + calls_count = 0 + call call_minloc_real(r, a, b = get_scalar_false()) + if (calls_count /= 1) stop 130 + end subroutine + subroutine check_real_const_shape_empty() + real :: a(0) + logical :: m(0) + integer :: r + a = (/ real:: /) + m = (/ logical:: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 137 + end subroutine + subroutine check_real_alloc() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + r = minloc(a, dim = 1, back = get_scalar_false()) + if (calls_count /= 1) stop 144 + end subroutine + subroutine check_real_alloc_scalar_mask() + real, allocatable :: a(:) + integer :: r + allocate(a(10)) + a(:) = (/ real:: data10 /) + calls_count = 0 + ! We only check the case of a .true. mask. + ! If the mask is .false., the back argument is not necessary to deduce + ! the value returned by minloc, so the compiler is free to elide it, + ! and the value of calls_count is undefined in that case. + r = minloc(a, dim = 1, mask = .true., back = get_scalar_false()) + if (calls_count /= 1) stop 151 + end subroutine + subroutine check_real_alloc_array_mask() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 165 + end subroutine + subroutine check_real_alloc_empty() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer :: r + allocate(a(0), m(0)) + a(:) = (/ real:: /) + m(:) = (/ logical :: /) + calls_count = 0 + r = minloc(a, dim = 1, mask = m, back = get_scalar_false()) + if (calls_count /= 1) stop 172 + end subroutine +end program p diff --git a/Fortran/gfortran/regression/minmaxloc_17.f90 b/Fortran/gfortran/regression/minmaxloc_17.f90 new file mode 100644 index 000000000..7e6e586ab --- /dev/null +++ b/Fortran/gfortran/regression/minmaxloc_17.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! Check that the code necessary to evaluate MINLOC's or MAXLOC's MASK +! argument is correctly generated. + +program p + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 0, 6, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + type bool_wrapper + logical :: l + end type + call check_minloc + call check_maxloc +contains + subroutine check_minloc + integer :: a(10) + integer :: r + a = data10 + r = minloc(a, dim = 1, mask = sum(a) > 0) + if (r /= 4) stop 11 + end subroutine + subroutine check_maxloc + integer :: a(10) + integer :: r + a = data10 + r = maxloc(a, dim = 1, mask = sum(a) > 0) + if (r /= 5) stop 18 + end subroutine +end program diff --git a/Fortran/gfortran/regression/missing_optional_dummy_6a.f90 b/Fortran/gfortran/regression/missing_optional_dummy_6a.f90 index c08c97a2c..b5e1726d7 100644 --- a/Fortran/gfortran/regression/missing_optional_dummy_6a.f90 +++ b/Fortran/gfortran/regression/missing_optional_dummy_6a.f90 @@ -47,9 +47,9 @@ end subroutine scalar2 end program test -! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } } +! { dg-final { scan-tree-dump-times "scalar2 \\(.* slr1" 1 "original" } } -! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } } +! { dg-final { scan-tree-dump-times "= es1 != 0B" 2 "original" } } ! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } ! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } diff --git a/Fortran/gfortran/regression/missing_optional_dummy_7.f90 b/Fortran/gfortran/regression/missing_optional_dummy_7.f90 new file mode 100644 index 000000000..ad9ecd8f2 --- /dev/null +++ b/Fortran/gfortran/regression/missing_optional_dummy_7.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! PR fortran/112772 - test absent OPTIONAL, ALLOCATABLE/POINTER class dummies + +program main + implicit none + type t + end type t + call test_c_a () + call test_u_a () + call test_c_p () + call test_u_p () +contains + ! class, allocatable + subroutine test_c_a (msg1) + class(t), optional, allocatable :: msg1(:) + if (present (msg1)) stop 1 + call assert_c_a () + call assert_c_a (msg1) + end + + subroutine assert_c_a (msg2) + class(t), optional, allocatable :: msg2(:) + if (present (msg2)) stop 2 + end + + ! unlimited polymorphic, allocatable + subroutine test_u_a (msg1) + class(*), optional, allocatable :: msg1(:) + if (present (msg1)) stop 3 + call assert_u_a () + call assert_u_a (msg1) + end + + subroutine assert_u_a (msg2) + class(*), optional, allocatable :: msg2(:) + if (present (msg2)) stop 4 + end + + ! class, pointer + subroutine test_c_p (msg1) + class(t), optional, pointer :: msg1(:) + if (present (msg1)) stop 5 + call assert_c_p () + call assert_c_p (msg1) + end + + subroutine assert_c_p (msg2) + class(t), optional, pointer :: msg2(:) + if (present (msg2)) stop 6 + end + + ! unlimited polymorphic, pointer + subroutine test_u_p (msg1) + class(*), optional, pointer :: msg1(:) + if (present (msg1)) stop 7 + call assert_u_p () + call assert_u_p (msg1) + end + + subroutine assert_u_p (msg2) + class(*), optional, pointer :: msg2(:) + if (present (msg2)) stop 8 + end +end diff --git a/Fortran/gfortran/regression/namelist_57.f90 b/Fortran/gfortran/regression/namelist_57.f90 index a72b866d5..8f4c4ed14 100644 --- a/Fortran/gfortran/regression/namelist_57.f90 +++ b/Fortran/gfortran/regression/namelist_57.f90 @@ -6,7 +6,7 @@ n = 123 line = "" write(line,nml=stuff) - if (line(1) .ne. "&STUFF") STOP 1 + if (line(1) .ne. " &STUFF") STOP 1 if (line(2) .ne. " N=123 ,") STOP 2 if (line(3) .ne. " /") STOP 3 end diff --git a/Fortran/gfortran/regression/namelist_65.f90 b/Fortran/gfortran/regression/namelist_65.f90 index 2ca67f2d4..424c72295 100644 --- a/Fortran/gfortran/regression/namelist_65.f90 +++ b/Fortran/gfortran/regression/namelist_65.f90 @@ -13,7 +13,7 @@ program oneline enddo write(out,nl1) -if (out(1).ne."&NL1") STOP 1 +if (out(1).ne." &NL1") STOP 1 if (out(2).ne." A= 1.00000000 ,") STOP 2 if (out(3).ne." B= 2.00000000 ,") STOP 3 if (out(4).ne." C= 3.00000000 ,") STOP 4 diff --git a/Fortran/gfortran/regression/nint_p7.f90 b/Fortran/gfortran/regression/nint_p7.f90 index 2239824a7..ed178c08a 100644 --- a/Fortran/gfortran/regression/nint_p7.f90 +++ b/Fortran/gfortran/regression/nint_p7.f90 @@ -1,7 +1,8 @@ ! Fortran ! { dg-do compile { target { powerpc*-*-* } } } -! { dg-require-effective-target powerpc_vsx_ok } ! { dg-options "-O2 -mdejagnu-cpu=power7 -ffast-math" } +! { dg-require-effective-target powerpc_vsx } +! { dg-require-effective-target has_arch_ppc64 } ! { dg-final { scan-assembler-times "xsrdpi" 2 } } subroutine test_nint(x4,x8) diff --git a/Fortran/gfortran/regression/null_actual_4.f90 b/Fortran/gfortran/regression/null_actual_4.f90 new file mode 100644 index 000000000..e03d5c8f7 --- /dev/null +++ b/Fortran/gfortran/regression/null_actual_4.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR fortran/104819 +! +! Reject NULL without MOLD as actual to an assumed-rank dummy. +! See also interpretation request at +! https://j3-fortran.org/doc/year/22/22-101r1.txt +! +! Test nested NULL() + +program p + implicit none + integer, pointer :: a, a3(:,:,:) + character(10), pointer :: c + + call foo (a) + call foo (a3) + call foo (null (a)) + call foo (null (a3)) + call foo (null (null (a))) ! Valid: nested NULL()s + call foo (null (null (a3))) ! Valid: nested NULL()s + call foo (null ()) ! { dg-error "passed to assumed-rank dummy" } + + call str (null (c)) + call str (null (null (c))) + call str (null ()) ! { dg-error "passed to assumed-length dummy" } +contains + subroutine foo (x) + integer, pointer, intent(in) :: x(..) + print *, rank (x) + end + + subroutine str (x) + character(len=*), pointer, intent(in) :: x + end +end diff --git a/Fortran/gfortran/regression/null_actual_5.f90 b/Fortran/gfortran/regression/null_actual_5.f90 new file mode 100644 index 000000000..1198715b7 --- /dev/null +++ b/Fortran/gfortran/regression/null_actual_5.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! PR fortran/55978 +! +! Passing of NULL() with and without MOLD as actual argument +! +! Testcase derived from pr55978 comment#16 + +program pr55978_c16 + implicit none + + integer, pointer :: p(:) + integer, allocatable :: a(:) + character(10), pointer :: c + character(10), pointer :: cp(:) + + type t + integer, pointer :: p(:) + integer, allocatable :: a(:) + end type + + type(t) :: d + + ! (1) pointer + p => null() + call sub (p) + + ! (2) allocatable + call sub (a) + call sub (d%a) + + ! (3) pointer component + d%p => null () + call sub (d%p) + + ! (4) NULL + call sub (null (a)) ! OK + call sub (null (p)) ! OK + call sub (null (d%a)) ! OK + call sub (null (d%p)) ! OK + call sub (null ()) ! was erroneously rejected with: + ! Actual argument contains too few elements for dummy argument 'x' (1/4) + + call bla (null(c)) + call bla (null()) ! was erroneously rejected with: + ! Actual argument contains too few elements for dummy argument 'x' (1/10) + + call foo (null(cp)) + call foo (null()) + + call bar (null(cp)) + call bar (null()) ! was erroneously rejected with: + ! Actual argument contains too few elements for dummy argument 'x' (1/70) + +contains + + subroutine sub(x) + integer, intent(in), optional :: x(4) + if (present (x)) stop 1 + end + + subroutine bla(x) + character(len=10), intent(in), optional :: x + if (present (x)) stop 2 + end + + subroutine foo(x) + character(len=10), intent(in), optional :: x(:) + if (present (x)) stop 3 + end + + subroutine bar(x) + character(len=10), intent(in), optional :: x(7) + if (present (x)) stop 4 + end + +end diff --git a/Fortran/gfortran/regression/nullify_4.f90 b/Fortran/gfortran/regression/nullify_4.f90 index 0fd5056ee..240110fab 100644 --- a/Fortran/gfortran/regression/nullify_4.f90 +++ b/Fortran/gfortran/regression/nullify_4.f90 @@ -3,6 +3,7 @@ ! ! Check error recovery; was crashing before. ! +implicit none real, pointer :: ptr nullify(ptr, mesh%coarser) ! { dg-error "Symbol 'mesh' at .1. has no IMPLICIT type" } end diff --git a/Fortran/gfortran/regression/optional_absent_10.f90 b/Fortran/gfortran/regression/optional_absent_10.f90 new file mode 100644 index 000000000..acdabbdf1 --- /dev/null +++ b/Fortran/gfortran/regression/optional_absent_10.f90 @@ -0,0 +1,219 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test passing of missing optional arguments of intrinsic type +! to scalar dummies of elemental subroutines + +module m_char + implicit none +contains + subroutine test_char () + character :: k(7) = "#" + character(4) :: c(7) = "*" + call one (k) + call one_val (k) + call one_ij (k) + call one_jj (k) + call one_j4 (k) + call three (c) + call three_val (c) + call three_ij (c) + call three_jj (c) + call three_j4 (c) + end subroutine test_char + + subroutine one (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j + character, allocatable :: aa + character, pointer :: pp => NULL() + if (present (j)) stop 1 + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + call two_val (i, aa) + call two_val (i, pp) + end + + subroutine one_val (i, j) + character, intent(in) :: i(7) + character, value, optional :: j + if (present (j)) stop 2 + call two (i, j) + call two_val (i, j) + end + + subroutine one_ij (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j(7) + if (present (j)) stop 3 + call two (i, j) + call two_val (i, j) + end + + subroutine one_jj (i, j) + character, intent(in) :: i(7) + character, intent(in), optional :: j(:) + if (present (j)) stop 4 + call two (i, j) + call two_val (i, j) + end + + subroutine one_j4 (i, j) + character, intent(in) :: i(:) + character, intent(in), optional :: j(7) + if (present (j)) stop 5 + call two (i, j) + call two_val (i, j) + end + + elemental subroutine two (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 11 + end + + elemental subroutine two_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine three (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j + character(4), allocatable :: aa + character(4), pointer :: pp => NULL() + if (present (j)) stop 6 + call four (i, j) + call four_val (i, j) + call four (i, aa) + call four (i, pp) + call four_val (i, aa) + call four_val (i, pp) + end + + subroutine three_val (i, j) + character(4), intent(in) :: i(7) + character(4), value, optional :: j + if (present (j)) stop 7 + call four (i, j) + call four_val (i, j) + end + + subroutine three_ij (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j(7) + if (present (j)) stop 8 + call four (i, j) + call four_val (i, j) + end + + subroutine three_jj (i, j) + character(4), intent(in) :: i(7) + character(4), intent(in), optional :: j(:) + if (present (j)) stop 9 + call four (i, j) + call four_val (i, j) + end + + subroutine three_j4 (i, j) + character(4), intent(in) :: i(:) + character(4), intent(in), optional :: j(7) + if (present (j)) stop 10 + call four (i, j) + call four_val (i, j) + end + + elemental subroutine four (i, j) + character(4), intent(in) :: i + character(4), intent(in), optional :: j + if (present (j)) error stop 13 + end + + elemental subroutine four_val (i, j) + character(4), intent(in) :: i + character(4), value, optional :: j + if (present (j)) error stop 14 + end +end + +module m_int + implicit none +contains + subroutine test_int () + integer :: k(4) = 1 + call one (k) + call one_val (k) + call one_ij (k) + call one_jj (k) + call one_j4 (k) + end + + subroutine one (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j + integer, allocatable :: aa + integer, pointer :: pp => NULL() + if (present (j)) stop 21 + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + call two_val (i, aa) + call two_val (i, pp) + end + + subroutine one_val (i, j) + integer, intent(in) :: i(4) + integer, value, optional :: j + if (present (j)) stop 22 + call two (i, j) + call two_val (i, j) + end + + subroutine one_ij (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j(4) + if (present (j)) stop 23 + call two (i, j) + call two_val (i, j) + end + + subroutine one_jj (i, j) + integer, intent(in) :: i(4) + integer, intent(in), optional :: j(:) + if (present (j)) stop 24 + call two (i, j) + call two_val (i, j) + end + + subroutine one_j4 (i, j) + integer, intent(in) :: i(:) + integer, intent(in), optional :: j(4) + if (present (j)) stop 25 + call two (i, j) + call two_val (i, j) + end + + elemental subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 31 + end + + elemental subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 32 + end +end + +program p + use m_int + use m_char + implicit none + call test_int () + call test_char () +end diff --git a/Fortran/gfortran/regression/optional_absent_11.f90 b/Fortran/gfortran/regression/optional_absent_11.f90 new file mode 100644 index 000000000..1f63def46 --- /dev/null +++ b/Fortran/gfortran/regression/optional_absent_11.f90 @@ -0,0 +1,99 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test that a NULL actual argument to an optional dummy is not present +! (see also F2018:15.5.2.12 on argument presence) + +program test_null_actual_is_absent + implicit none + integer :: k(4) = 1 + character :: c(4) = "#" + call one (k) + call three (c) +contains + subroutine one (i) + integer, intent(in) :: i(4) + integer :: kk = 2 + integer, allocatable :: aa + integer, pointer :: pp => NULL() + print *, "Scalar integer" + call two (kk, aa) + call two (kk, pp) + call two (kk, NULL()) + call two (kk, NULL(aa)) + call two (kk, NULL(pp)) + print *, "Elemental integer" + call two (i, aa) + call two (i, pp) + call two (i, NULL()) + call two (i, NULL(aa)) + call two (i, NULL(pp)) + print *, "Scalar integer; value" + call two_val (kk, aa) + call two_val (kk, pp) + call two_val (kk, NULL()) + call two_val (kk, NULL(aa)) + call two_val (kk, NULL(pp)) + print *, "Elemental integer; value" + call two_val (i, aa) + call two_val (i, pp) + call two_val (i, NULL()) + call two_val (i, NULL(aa)) + call two_val (i, NULL(pp)) + end + + elemental subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 11 + end + + elemental subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine three (y) + character, intent(in) :: y(4) + character :: zz = "*" + character, allocatable :: aa + character, pointer :: pp => NULL() + print *, "Scalar character" + call four (zz, aa) + call four (zz, pp) + call four (zz, NULL()) + call four (zz, NULL(aa)) + call four (zz, NULL(pp)) + print *, "Elemental character" + call four (y, aa) + call four (y, pp) + call four (y, NULL()) + call four (y, NULL(aa)) + call four (y, NULL(pp)) + print *, "Scalar character; value" + call four_val (zz, aa) + call four_val (zz, pp) + call four_val (zz, NULL()) + call four_val (zz, NULL(aa)) + call four_val (zz, NULL(pp)) + print *, "Elemental character; value" + call four_val (y, aa) + call four_val (y, pp) + call four_val (y, NULL()) + call four_val (y, NULL(aa)) + call four_val (y, NULL(pp)) + end + + elemental subroutine four (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 21 + end + + elemental subroutine four_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 22 + end +end diff --git a/Fortran/gfortran/regression/optional_absent_12.f90 b/Fortran/gfortran/regression/optional_absent_12.f90 new file mode 100644 index 000000000..1e61d91fb --- /dev/null +++ b/Fortran/gfortran/regression/optional_absent_12.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=array-temps" } +! +! PR fortran/55978 - comment#19 +! +! Test passing of (missing) optional dummy to optional array argument + +program test + implicit none + integer, pointer :: p(:) => null() + call one (p) + call one (null()) + call one () + call three () +contains + subroutine one (y) + integer, pointer, optional, intent(in) :: y(:) + call two (y) + end subroutine one + + subroutine three (z) + integer, allocatable, optional, intent(in) :: z(:) + call two (z) + end subroutine three + + subroutine two (x) + integer, optional, intent(in) :: x(*) + if (present (x)) stop 1 + end subroutine two +end diff --git a/Fortran/gfortran/regression/optional_absent_9.f90 b/Fortran/gfortran/regression/optional_absent_9.f90 new file mode 100644 index 000000000..063dd2129 --- /dev/null +++ b/Fortran/gfortran/regression/optional_absent_9.f90 @@ -0,0 +1,340 @@ +! { dg-do run } +! PR fortran/113377 +! +! Test passing of missing optional scalar dummies of intrinsic type + +module m_int + implicit none +contains + subroutine test_int () + integer :: k = 1 + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + integer, intent(in) :: i + integer ,optional :: j + integer, allocatable :: aa + integer, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + call two_val (i, aa) + call two_val (i, pp) + end + + subroutine one_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + integer, intent(in) :: i + integer, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! dto. + call two_all (i, j) + end + + subroutine one_ptr (i, j) + integer, intent(in) :: i + integer, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! dto. + call two_ptr (i, j) + end + + subroutine two (i, j) + integer, intent(in) :: i + integer, intent(in), optional :: j + if (present (j)) error stop 11 + end + + subroutine two_val (i, j) + integer, intent(in) :: i + integer, value, optional :: j + if (present (j)) error stop 12 + end + + subroutine two_all (i, j) + integer, intent(in) :: i + integer, allocatable,optional :: j + if (present (j)) error stop 13 + end + + subroutine two_ptr (i, j) + integer, intent(in) :: i + integer, pointer, optional :: j + if (present (j)) error stop 14 + end +end + +module m_char + implicit none +contains + subroutine test_char () + character :: k = "#" + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + character, intent(in) :: i + character ,optional :: j + character, allocatable :: aa + character, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + character, intent(in) :: i + character, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! dto. + call two_all (i, j) + end + + subroutine one_ptr (i, j) + character, intent(in) :: i + character, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! dto. + call two_ptr (i, j) + end + + subroutine two (i, j) + character, intent(in) :: i + character, intent(in), optional :: j + if (present (j)) error stop 21 + end + + subroutine two_val (i, j) + character, intent(in) :: i + character, value, optional :: j + if (present (j)) error stop 22 + end + + subroutine two_all (i, j) + character, intent(in) :: i + character, allocatable,optional :: j + if (present (j)) error stop 23 + end + + subroutine two_ptr (i, j) + character, intent(in) :: i + character, pointer, optional :: j + if (present (j)) error stop 24 + end +end + +module m_char4 + implicit none +contains + subroutine test_char4 () + character(kind=4) :: k = 4_"#" + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + character(kind=4), intent(in) :: i + character(kind=4) ,optional :: j + character(kind=4), allocatable :: aa + character(kind=4), pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + character(kind=4), intent(in) :: i + character(kind=4), value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + character(kind=4), intent(in) :: i + character(kind=4), allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! dto. + call two_all (i, j) + end + + subroutine one_ptr (i, j) + character(kind=4), intent(in) :: i + character(kind=4), pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! dto. + call two_ptr (i, j) + end + + subroutine two (i, j) + character(kind=4), intent(in) :: i + character(kind=4), intent(in), optional :: j + if (present (j)) error stop 31 + end + + subroutine two_val (i, j) + character(kind=4), intent(in) :: i + character(kind=4), value, optional :: j + if (present (j)) error stop 32 + end + + subroutine two_all (i, j) + character(kind=4), intent(in) :: i + character(kind=4), allocatable,optional :: j + if (present (j)) error stop 33 + end + + subroutine two_ptr (i, j) + character(kind=4), intent(in) :: i + character(kind=4), pointer, optional :: j + if (present (j)) error stop 34 + end +end + +module m_complex + implicit none +contains + subroutine test_complex () + complex :: k = 3. + call one (k) + call one_val (k) + call one_all (k) + call one_ptr (k) + end + + subroutine one (i, j) + complex, intent(in) :: i + complex ,optional :: j + complex, allocatable :: aa + complex, pointer :: pp => NULL() + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + call two (i, aa) + call two (i, pp) + end + + subroutine one_val (i, j) + complex, intent(in) :: i + complex, value, optional :: j + if (present (j)) error stop "j is present" + call two (i, j) + call two_val (i, j) + end + + subroutine one_all (i, j) + complex, intent(in) :: i + complex, allocatable,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 8 +! call two_val (i, j) ! dto. + call two_all (i, j) + end + + subroutine one_ptr (i, j) + complex, intent(in) :: i + complex, pointer ,optional :: j + if (present (j)) error stop "j is present" +! call two (i, j) ! invalid per F2018:15.5.2.12, par. 3, clause 7 +! call two_val (i, j) ! dto. + call two_ptr (i, j) + end + + subroutine two (i, j) + complex, intent(in) :: i + complex, intent(in), optional :: j + if (present (j)) error stop 41 + end + + subroutine two_val (i, j) + complex, intent(in) :: i + complex, value, optional :: j + if (present (j)) error stop 42 + end + + subroutine two_all (i, j) + complex, intent(in) :: i + complex, allocatable,optional :: j + if (present (j)) error stop 43 + end + + subroutine two_ptr (i, j) + complex, intent(in) :: i + complex, pointer, optional :: j + if (present (j)) error stop 44 + end +end + +module m_mm + ! Test suggested by Mikael Morin + implicit none + type :: t + integer, allocatable :: c + integer, pointer :: p => NULL() + end type +contains + subroutine test_mm () + call s1 (t()) + end + + subroutine s1 (a) + type(t) :: a + call s2 (a% c) + call s2 (a% p) + end + + subroutine s2 (a) + integer, value, optional :: a + if (present(a)) stop 1 + end +end + +program p + use m_int + use m_char + use m_char4 + use m_complex + use m_mm + implicit none + call test_int () + call test_char () + call test_char4 () + call test_complex () + call test_mm () +end diff --git a/Fortran/gfortran/regression/optional_deferred_char_1.f90 b/Fortran/gfortran/regression/optional_deferred_char_1.f90 new file mode 100644 index 000000000..d399dd11c --- /dev/null +++ b/Fortran/gfortran/regression/optional_deferred_char_1.f90 @@ -0,0 +1,100 @@ +! { dg-do run } +! PR fortran/93762 +! PR fortran/100651 - deferred-length character as optional dummy argument + +program main + implicit none + character(:), allocatable :: err_msg, msg3(:) + character(:), pointer :: err_msg2 => NULL() + + ! Subroutines with optional arguments + call to_int () + call to_int_p () + call test_rank1 () + call assert_code () + call assert_p () + call assert_rank1 () + + ! Test passing of optional arguments + call to_int (err_msg) + if (.not. allocated (err_msg)) stop 1 + if (len (err_msg) /= 7) stop 2 + if (err_msg(1:7) /= "foo bar") stop 3 + + call to_int2 (err_msg) + if (.not. allocated (err_msg)) stop 4 + if (len (err_msg) /= 7) stop 5 + if (err_msg(1:7) /= "foo bar") stop 6 + deallocate (err_msg) + + call to_int_p (err_msg2) + if (.not. associated (err_msg2)) stop 11 + if (len (err_msg2) /= 8) stop 12 + if (err_msg2(1:8) /= "poo bla ") stop 13 + deallocate (err_msg2) + + call to_int2_p (err_msg2) + if (.not. associated (err_msg2)) stop 14 + if (len (err_msg2) /= 8) stop 15 + if (err_msg2(1:8) /= "poo bla ") stop 16 + deallocate (err_msg2) + + call test_rank1 (msg3) + if (.not. allocated (msg3)) stop 21 + if (len (msg3) /= 2) stop 22 + if (size (msg3) /= 42) stop 23 + if (any (msg3 /= "ok")) stop 24 + deallocate (msg3) + +contains + + ! Deferred-length character, allocatable: + subroutine assert_code (err_msg0) + character(:), optional, allocatable :: err_msg0 + if (present (err_msg0)) err_msg0 = 'foo bar' + end + ! Test: optional argument + subroutine to_int (err_msg1) + character(:), optional, allocatable :: err_msg1 + call assert_code (err_msg1) + end + ! Control: non-optional argument + subroutine to_int2 (err_msg2) + character(:), allocatable :: err_msg2 + call assert_code (err_msg2) + end + + ! Rank-1: + subroutine assert_rank1 (msg) + character(:), optional, allocatable, intent(out) :: msg(:) + if (present (msg)) then + allocate (character(2) :: msg(42)) + msg(:) = "ok" + end if + end + + subroutine test_rank1 (msg1) + character(:), optional, allocatable, intent(out) :: msg1(:) + call assert_rank1 (msg1) + end + + ! Deferred-length character, pointer: + subroutine assert_p (err_msg0) + character(:), optional, pointer :: err_msg0 + if (present (err_msg0)) then + if (associated (err_msg0)) deallocate (err_msg0) + allocate (character(8) :: err_msg0) + err_msg0 = 'poo bla' + end if + end + + subroutine to_int_p (err_msg1) + character(:), optional, pointer :: err_msg1 + call assert_p (err_msg1) + end + + subroutine to_int2_p (err_msg2) + character(:), pointer :: err_msg2 + call assert_p (err_msg2) + end +end diff --git a/Fortran/gfortran/regression/overload_5.f90 b/Fortran/gfortran/regression/overload_5.f90 new file mode 100644 index 000000000..f8c93af35 --- /dev/null +++ b/Fortran/gfortran/regression/overload_5.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! PR fortran/109641 +! +! Check overloading of intrinsic binary operators for numeric operands +! Reported by Adelson Oliveira + +MODULE TESTEOP + IMPLICIT NONE + INTERFACE OPERATOR(.MULT.) + MODULE PROCEDURE MULTr4 + MODULE PROCEDURE MULTc4 + END INTERFACE + INTERFACE OPERATOR(*) + MODULE PROCEDURE MULTr4 + MODULE PROCEDURE MULTc4 + END INTERFACE + INTERFACE OPERATOR(==) + MODULE PROCEDURE MULTr4 + MODULE PROCEDURE MULTc4 + MODULE PROCEDURE MULTr8 + END INTERFACE + INTERFACE OPERATOR(<) + MODULE PROCEDURE MULTc4 + MODULE PROCEDURE MULTi4 + END INTERFACE + INTERFACE OPERATOR(**) + MODULE PROCEDURE MULTc4 + MODULE PROCEDURE MULTi4 + END INTERFACE + interface copy + MODULE PROCEDURE copy + end interface copy +CONTAINS + elemental function copy (z) + complex, intent(in) :: z + complex :: copy + copy = z + end function copy + FUNCTION MULTr4(v,m) + REAL, INTENT(IN) :: v(:) + REAL, INTENT(IN) :: m(:,:) + REAL :: MULTr4(SIZE(m,DIM=1),SIZE(m,DIM=2)) + INTEGER :: i + FORALL(i=1:SIZE(v)) MULTr4(:,i)=m(:,i)*v(i) + END FUNCTION MULTr4 + FUNCTION MULTr8(v,m) + REAL, INTENT(IN) :: v(:) + double precision, INTENT(IN) :: m(:,:) + double precision :: MULTr8(SIZE(m,DIM=1),SIZE(m,DIM=2)) + INTEGER :: i + FORALL(i=1:SIZE(v)) MULTr8(:,i)=m(:,i)*v(i) + END FUNCTION MULTr8 + FUNCTION MULTc4(v,m) + REAL, INTENT(IN) :: v(:) + COMPLEX, INTENT(IN) :: m(:,:) + COMPLEX :: MULTc4(SIZE(m,DIM=1),SIZE(m,DIM=2)) + INTEGER :: i + FORALL(i=1:SIZE(v)) MULTc4(:,i)=m(:,i)*v(i) + END FUNCTION MULTc4 + FUNCTION MULTi4(v,m) + REAL, INTENT(IN) :: v(:) + integer, INTENT(IN) :: m(:,:) + REAL :: MULTi4(SIZE(m,DIM=1),SIZE(m,DIM=2)) + INTEGER :: i + FORALL(i=1:SIZE(v)) MULTi4(:,i)=m(:,i)*v(i) + END FUNCTION MULTi4 +END MODULE TESTEOP +PROGRAM TESTE + USE TESTEOP + implicit none + type t + complex :: c(3,3) + end type t + real, parameter :: vv(3) = 42. + complex, parameter :: zz(3,3) = (1.0,0.0) + integer, parameter :: kk(3,3) = 2 + double precision :: dd(3,3) = 3.d0 + COMPLEX, ALLOCATABLE :: m(:,:),r(:,:), s(:,:) + REAL, ALLOCATABLE :: v(:) + type(t) :: z(1) = t(zz) + ALLOCATE(v(3),m(3,3),r(3,3),s(3,3)) + v = vv + m = zz + ! Original bug report + r=v.MULT.m ! Reference + s=v*m + if (any (r /= s)) stop 1 + if (.not. all (r == s)) stop 2 + ! Check other binary intrinsics + s=v==m + if (any (r /= s)) stop 3 + s=v==copy(m) + if (any (r /= s)) stop 4 + s=v==zz + if (any (r /= s)) stop 5 + s=v==copy(zz) + if (any (r /= s)) stop 6 + s=vv==m + if (any (r /= s)) stop 7 + s=vv==copy(m) + if (any (r /= s)) stop 8 + s=vv==zz + if (any (r /= s)) stop 9 + s=vv==copy(zz) + if (any (r /= s)) stop 10 + ! check if .eq. same operator as == etc. + s=v.eq.m + if (any (r /= s)) stop 11 + s=v.lt.z(1)%c + if (any (r /= s)) stop 12 + s=v<((z(1)%c)) + if (any (r /= s)) stop 13 + if (.not. all ( 1. < (vv**kk))) stop 14 + if (.not. all ( 1. < (vv< kk))) stop 15 + if (.not. all ((42.,0.) == (v < m ))) stop 16 + if (.not. all ((42.,0.) == (v** m ))) stop 17 + if (.not. all ( 126.d0 == (vv==dd))) stop 18 +END PROGRAM TESTE diff --git a/Fortran/gfortran/regression/pdt_33.f03 b/Fortran/gfortran/regression/pdt_33.f03 new file mode 100644 index 000000000..3b2fe7243 --- /dev/null +++ b/Fortran/gfortran/regression/pdt_33.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Test the fix for PR102003, where len parameters where not returned as constants. +! +! Contributed by Harald Anlauf +! +program pr102003 + type pdt(n) + integer, len :: n = 8 + character(len=n) :: c + end type pdt + type(pdt(42)) :: p + integer, parameter :: m = len (p% c) + integer, parameter :: lm = p% c% len + + if (m /= 42) stop 1 + if (len (p% c) /= 42) stop 2 + if (lm /= 42) stop 3 + if (p% c% len /= 42) stop 4 +end + diff --git a/Fortran/gfortran/regression/pdt_33.f90 b/Fortran/gfortran/regression/pdt_33.f90 new file mode 100644 index 000000000..0521513f2 --- /dev/null +++ b/Fortran/gfortran/regression/pdt_33.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/106050 +! The following used to trigger an error recovery ICE by releasing +! the symbol T before the symbol K which was leading to releasing +! K twice as it's in T's namespace. +! +! Contributed by G. Steinmetz + +program p + a = 1 + type t(k) ! { dg-error "Unexpected derived type declaration" } + integer, kind :: k = 4 ! { dg-error "not allowed outside a TYPE definition" } + end type ! { dg-error "Expecting END PROGRAM" } +end diff --git a/Fortran/gfortran/regression/pdt_34.f03 b/Fortran/gfortran/regression/pdt_34.f03 new file mode 100644 index 000000000..c601071ba --- /dev/null +++ b/Fortran/gfortran/regression/pdt_34.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! Contributed by Alexander Westbrooks +! +module m + public :: foo, bar, foobar + + type, public :: good_type(n) + integer, len :: n = 1 + contains + procedure :: foo + end type + + type, public :: good_type2(k) + integer, kind :: k = 1 + contains + procedure :: bar + end type + + type, public :: good_type3(n, k) + integer, len :: n = 1 + integer, kind :: k = 1 + contains + procedure :: foobar + end type + + contains + subroutine foo(this) + class(good_type(*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(good_type2(2)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(good_type3(*,2)), intent(inout) :: this + end subroutine + + end module \ No newline at end of file diff --git a/Fortran/gfortran/regression/pdt_35.f03 b/Fortran/gfortran/regression/pdt_35.f03 new file mode 100644 index 000000000..8b99948fa --- /dev/null +++ b/Fortran/gfortran/regression/pdt_35.f03 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! This test focuses on inheritance for the type bound procedures. +! +! Contributed by Alexander Westbrooks +! +module m + + public :: foo, bar, foobar + + type, public :: goodpdt_lvl_0(a, b) + integer, kind :: a = 1 + integer, len :: b + contains + procedure :: foo + end type + + type, public, EXTENDS(goodpdt_lvl_0) :: goodpdt_lvl_1 (c) + integer, len :: c + contains + procedure :: bar + end type + + type, public, EXTENDS(goodpdt_lvl_1) :: goodpdt_lvl_2 (d) + integer, len :: d + contains + procedure :: foobar + end type + +contains + subroutine foo(this) + class(goodpdt_lvl_0(1,*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(goodpdt_lvl_1(1,*,*)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(goodpdt_lvl_2(1,*,*,*)), intent(inout) :: this + end subroutine + +end module \ No newline at end of file diff --git a/Fortran/gfortran/regression/pdt_36.f03 b/Fortran/gfortran/regression/pdt_36.f03 new file mode 100644 index 000000000..a351c0e4f --- /dev/null +++ b/Fortran/gfortran/regression/pdt_36.f03 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Tests the fixes for PR82943. +! +! This test focuses on calling the type bound procedures in a program. +! +! Contributed by Alexander Westbrooks +! +module testmod + + public :: foo + + type, public :: tough_lvl_0(a, b) + integer, kind :: a = 1 + integer, len :: b + contains + procedure :: foo + end type + + type, public, EXTENDS(tough_lvl_0) :: tough_lvl_1 (c) + integer, len :: c + contains + procedure :: bar + end type + + type, public, EXTENDS(tough_lvl_1) :: tough_lvl_2 (d) + integer, len :: d + contains + procedure :: foobar + end type + +contains + subroutine foo(this) + class(tough_lvl_0(1,*)), intent(inout) :: this + end subroutine + + subroutine bar(this) + class(tough_lvl_1(1,*,*)), intent(inout) :: this + end subroutine + + subroutine foobar(this) + class(tough_lvl_2(1,*,*,*)), intent(inout) :: this + end subroutine + +end module + +PROGRAM testprogram + USE testmod + + TYPE(tough_lvl_0(1,5)) :: test_pdt_0 + TYPE(tough_lvl_1(1,5,6)) :: test_pdt_1 + TYPE(tough_lvl_2(1,5,6,7)) :: test_pdt_2 + + CALL test_pdt_0%foo() + + CALL test_pdt_1%foo() + CALL test_pdt_1%bar() + + CALL test_pdt_2%foo() + CALL test_pdt_2%bar() + CALL test_pdt_2%foobar() + + +END PROGRAM testprogram + \ No newline at end of file diff --git a/Fortran/gfortran/regression/pdt_37.f03 b/Fortran/gfortran/regression/pdt_37.f03 new file mode 100644 index 000000000..6753a9b2b --- /dev/null +++ b/Fortran/gfortran/regression/pdt_37.f03 @@ -0,0 +1,74 @@ +! { dg-do compile } +! +! Tests the fixes for PR82943. +! +! This test focuses on the errors produced by incorrect LEN parameters for dummy +! arguments of PDT Typebound Procedures. +! +! Contributed by Alexander Westbrooks +! +module test_len_param + implicit none + type :: param_deriv_type(a) + integer, len :: a + contains + procedure :: assumed_len_param ! Good. No error expected. + procedure :: assumed_len_param_ptr ! { dg-error "must not be POINTER" } + procedure :: assumed_len_param_alloc ! { dg-error "must not be ALLOCATABLE" } + procedure :: deferred_len_param ! { dg-error "must be ASSUMED" } + procedure :: deferred_len_param_ptr ! { dg-error "must be ASSUMED" } + procedure :: deferred_len_param_alloc ! { dg-error "must be ASSUMED" } + procedure :: fixed_len_param ! { dg-error "must be ASSUMED" } + procedure :: fixed_len_param_ptr ! { dg-error "must be ASSUMED" } + procedure :: fixed_len_param_alloc ! { dg-error "must be ASSUMED" } + + end type + +contains + subroutine assumed_len_param(this) + class(param_deriv_type(*)), intent(inout) :: this ! Good. No error expected. + ! TYPE(param_deriv_type(*)), intent(inout) :: that ! Good. No error expected. + end subroutine + + subroutine assumed_len_param_ptr(this, that) + class(param_deriv_type(*)), intent(inout), pointer :: this ! Good. No error expected. + TYPE(param_deriv_type(*)), intent(inout), allocatable :: that ! Good. No error expected. + end subroutine + + subroutine assumed_len_param_alloc(this, that) + class(param_deriv_type(*)), intent(inout), allocatable :: this ! Good. No error expected. + TYPE(param_deriv_type(*)), intent(inout), allocatable :: that ! Good. No error expected. + end subroutine + + subroutine deferred_len_param(this, that) ! { dg-error "requires either the POINTER or ALLOCATABLE attribute" } + class(param_deriv_type(:)), intent(inout) :: this + TYPE(param_deriv_type(:)), intent(inout) :: that ! Good. No error expected. + end subroutine + + subroutine deferred_len_param_ptr(this, that) + class(param_deriv_type(:)), intent(inout), pointer :: this ! Good. No error expected. + TYPE(param_deriv_type(:)), intent(inout), pointer :: that ! Good. No error expected. + end subroutine + + subroutine deferred_len_param_alloc(this, that) + class(param_deriv_type(:)), intent(inout), allocatable :: this ! Good. No error expected. + TYPE(param_deriv_type(:)), intent(inout), allocatable :: that ! Good. No error expected. + end subroutine + + subroutine fixed_len_param(this, that) + class(param_deriv_type(10)), intent(inout) :: this ! Good. No error expected. + TYPE(param_deriv_type(10)), intent(inout) :: that ! Good. No error expected. + end subroutine + + subroutine fixed_len_param_ptr(this, that) + class(param_deriv_type(10)), intent(inout), pointer :: this ! Good. No error expected. + TYPE(param_deriv_type(10)), intent(inout), pointer :: that ! Good. No error expected. + end subroutine + + subroutine fixed_len_param_alloc(this, that) + class(param_deriv_type(10)), intent(inout), allocatable :: this ! Good. No error expected. + TYPE(param_deriv_type(10)), intent(inout), allocatable :: that ! Good. No error expected. + end subroutine + +end module + diff --git a/Fortran/gfortran/regression/pdt_4.f03 b/Fortran/gfortran/regression/pdt_4.f03 index 37412e4ca..f74ac89bf 100644 --- a/Fortran/gfortran/regression/pdt_4.f03 +++ b/Fortran/gfortran/regression/pdt_4.f03 @@ -96,7 +96,7 @@ module bad_vars subroutine foo(arg) type (mytype(4, *)) :: arg ! OK end subroutine - subroutine bar(arg) ! { dg-error "is neither allocatable nor a pointer" } + subroutine bar(arg) ! { dg-error "requires either the POINTER or ALLOCATABLE attribute" } type (thytype(8, :, 4)) :: arg end subroutine subroutine foobar(arg) ! OK diff --git a/Fortran/gfortran/regression/pointer_init_6.f90 b/Fortran/gfortran/regression/pointer_init_6.f90 index 3abad4ae1..477626e66 100644 --- a/Fortran/gfortran/regression/pointer_init_6.f90 +++ b/Fortran/gfortran/regression/pointer_init_6.f90 @@ -21,7 +21,7 @@ end module m1 module m2 - + implicit none type :: t procedure(s), pointer, nopass :: ppc end type diff --git a/Fortran/gfortran/regression/pr100193.f90 b/Fortran/gfortran/regression/pr100193.f90 new file mode 100644 index 000000000..07a3634cb --- /dev/null +++ b/Fortran/gfortran/regression/pr100193.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +module m + implicit none + type t + procedure(f), pointer, nopass :: g + end type +contains + function f() + character(:), allocatable :: f + f = 'abc' + end + subroutine s + type(t) :: z + z%g = 'x' ! { dg-error "is a procedure pointer" } + if ( z%g() /= 'abc' ) stop + end +end diff --git a/Fortran/gfortran/regression/pr100988.f90 b/Fortran/gfortran/regression/pr100988.f90 new file mode 100644 index 000000000..b7e1ae4a2 --- /dev/null +++ b/Fortran/gfortran/regression/pr100988.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/100988 - RESTRICT was missing for optional arguments + + ! There should be restrict qualifiers for a AND b: (4 cases) + subroutine plain (a, b) + integer :: a, b + optional :: b + end subroutine + + subroutine alloc (a, b) + integer :: a, b + allocatable :: a, b + optional :: b + end subroutine + + subroutine upoly (a, b) + class(*) :: a, b + optional :: b + end subroutine + + subroutine upoly_a (a, b) + class(*) :: a, b + allocatable :: a, b + optional :: b + end subroutine + +! { dg-final { scan-tree-dump "plain .* restrict a, .* restrict b\\)" "original" } } +! { dg-final { scan-tree-dump "alloc .* restrict a, .* restrict b\\)" "original" } } +! { dg-final { scan-tree-dump "upoly .* restrict a, .* restrict b\\)" "original" } } +! { dg-final { scan-tree-dump "upoly_a .* restrict a, .* restrict b\\)" "original" } } + + ! There should be no restrict qualifiers for the below 4 cases: + subroutine ptr (a, b) + integer :: a, b + pointer :: a, b + optional :: b + end subroutine + + subroutine tgt (a, b) + integer :: a, b + target :: a, b + optional :: b + end subroutine + + subroutine upoly_p (a, b) + class(*) :: a, b + pointer :: a, b + optional :: b + end subroutine + + subroutine upoly_t (a, b) + class(*) :: a, b + target :: a, b + optional :: b + end subroutine + +! { dg-final { scan-tree-dump-not "ptr .* restrict " "original" } } +! { dg-final { scan-tree-dump-not "tgt .* restrict " "original" } } +! { dg-final { scan-tree-dump-not "upoly_p .* restrict " "original" } } +! { dg-final { scan-tree-dump-not "upoly_t .* restrict " "original" } } diff --git a/Fortran/gfortran/regression/pr101026.f b/Fortran/gfortran/regression/pr101026.f index 9576d8802..e05e21c89 100644 --- a/Fortran/gfortran/regression/pr101026.f +++ b/Fortran/gfortran/regression/pr101026.f @@ -1,6 +1,6 @@ ! { dg-do compile } ! { dg-options "-Ofast -frounding-math" } - SUBROUTINE PASSB4 (CC,CH) + SUBROUTINE PASSB4 (CC,CH,IDO,L1) DIMENSION CC(IDO,4,L1), CH(IDO,L1,*) DO 103 I=2,IDO,2 TI4 = CC0-CC(I,4,K) diff --git a/Fortran/gfortran/regression/pr101267.f90 b/Fortran/gfortran/regression/pr101267.f90 index 12723cf9c..99a6dcfa3 100644 --- a/Fortran/gfortran/regression/pr101267.f90 +++ b/Fortran/gfortran/regression/pr101267.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-options "-Ofast" } ! { dg-additional-options "-march=znver2" { target x86_64-*-* i?86-*-* } } - SUBROUTINE sfddagd( regime, znt,ite ,jte ) + SUBROUTINE sfddagd( regime, znt,ite ,jte, ime, IN ) REAL, DIMENSION( ime, IN) :: regime, znt REAL, DIMENSION( ite, jte) :: wndcor_u LOGICAL wrf_dm_on_monitor diff --git a/Fortran/gfortran/regression/pr101329.f90 b/Fortran/gfortran/regression/pr101329.f90 index b82210d4e..aca171bd4 100644 --- a/Fortran/gfortran/regression/pr101329.f90 +++ b/Fortran/gfortran/regression/pr101329.f90 @@ -8,6 +8,6 @@ program p integer(c_int64_t), pointer :: ip8 print *, c_sizeof (c_null_ptr) ! valid print *, c_sizeof (null ()) ! { dg-error "is not interoperable" } - print *, c_sizeof (null (ip4)) ! { dg-error "is not interoperable" } - print *, c_sizeof (null (ip8)) ! { dg-error "is not interoperable" } + print *, c_sizeof (null (ip4)) ! valid + print *, c_sizeof (null (ip8)) ! valid end diff --git a/Fortran/gfortran/regression/pr102109.f90 b/Fortran/gfortran/regression/pr102109.f90 new file mode 100644 index 000000000..2155a4559 --- /dev/null +++ b/Fortran/gfortran/regression/pr102109.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Contributed by Brad Richardson +! +program main + type :: sub_obj_t + integer :: val + end type + + type :: compound_obj_t + type(sub_obj_t) :: sub_obj + end type + + associate(initial_sub_obj => sub_obj_t(42)) +! print *, initial_sub_obj%val ! Used to work with this uncommented + associate(obj => compound_obj_t(initial_sub_obj)) + if (obj%sub_obj%val .ne. 42) stop 1 + end associate + end associate +end program diff --git a/Fortran/gfortran/regression/pr102112.f90 b/Fortran/gfortran/regression/pr102112.f90 new file mode 100644 index 000000000..720579072 --- /dev/null +++ b/Fortran/gfortran/regression/pr102112.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Contributed by Brad Richardson +! +program main + implicit none + + type :: sub_t + integer :: val + end type + + type :: obj_t + type(sub_t) :: sub_obj + end type + + associate(initial_sub => sub_t(42)) + associate(obj => obj_t(initial_sub)) + associate(sub_obj => obj%sub_obj) + if (sub_obj%val .ne. 42) stop 1 + end associate + end associate + end associate +end program diff --git a/Fortran/gfortran/regression/pr102190.f90 b/Fortran/gfortran/regression/pr102190.f90 new file mode 100644 index 000000000..dd6d953b4 --- /dev/null +++ b/Fortran/gfortran/regression/pr102190.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! +! Contributed by Brad Richardson +! +module sub_m + type :: sub_t + private + integer :: val + end type + + interface sub_t + module procedure constructor + end interface + + interface sub_t_val + module procedure t_val + end interface +contains + function constructor(val) result(sub) + integer, intent(in) :: val + type(sub_t) :: sub + + sub%val = val + end function + + function t_val(val) result(res) + integer :: res + type(sub_t), intent(in) :: val + res = val%val + end function +end module + +module obj_m + use sub_m, only: sub_t + type :: obj_t + private + type(sub_t) :: sub_obj_ + contains + procedure :: sub_obj + end type + + interface obj_t + module procedure constructor + end interface +contains + function constructor(sub_obj) result(obj) + type(sub_t), intent(in) :: sub_obj + type(obj_t) :: obj + + obj%sub_obj_ = sub_obj + end function + + function sub_obj(self) + class(obj_t), intent(in) :: self + type(sub_t) :: sub_obj + + sub_obj = self%sub_obj_ + end function +end module + +program main + use sub_m, only: sub_t, sub_t_val + use obj_m, only: obj_t + type(sub_t), allocatable :: z + + associate(initial_sub => sub_t(42)) + associate(obj => obj_t(initial_sub)) + associate(sub_obj => obj%sub_obj()) + allocate (z, source = obj%sub_obj()) + end associate + end associate + end associate + if (sub_t_val (z) .ne. 42) stop 1 +end program diff --git a/Fortran/gfortran/regression/pr102532.f90 b/Fortran/gfortran/regression/pr102532.f90 new file mode 100644 index 000000000..714379a6a --- /dev/null +++ b/Fortran/gfortran/regression/pr102532.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Contributed by Gerhard Steinmetz +! +subroutine foo + character(:), allocatable :: x[:] + associate (y => x(:)(2:)) ! { dg-error "Rank mismatch|deferred type parameter" } + end associate +end + +subroutine bar + character(:), allocatable :: x[:] + associate (y => x(:)(:)) ! { dg-error "Rank mismatch|deferred type parameter" } + end associate +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/pr102597.f90 b/Fortran/gfortran/regression/pr102597.f90 new file mode 100644 index 000000000..c2d875f89 --- /dev/null +++ b/Fortran/gfortran/regression/pr102597.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Check that PR102597 does not resurface. Regression caused ICE at associate +! statement. +! Contributed by Gerhard Steinmetz +program p + use iso_fortran_env + associate (y => (compiler_version)) ! { dg-error "is a procedure name" } + end associate +end diff --git a/Fortran/gfortran/regression/pr102860.f90 b/Fortran/gfortran/regression/pr102860.f90 index 6b1feaa9d..ca38811e0 100644 --- a/Fortran/gfortran/regression/pr102860.f90 +++ b/Fortran/gfortran/regression/pr102860.f90 @@ -1,7 +1,7 @@ ! PR middle-end/102860 ! { dg-do compile { target { powerpc*-*-* } } } -! { dg-require-effective-target powerpc_vsx_ok } ! { dg-options "-O2 -mdejagnu-cpu=power10" } +! { dg-require-effective-target powerpc_vsx } function foo(a) integer(kind=4) :: a(1024) diff --git a/Fortran/gfortran/regression/pr103312.f90 b/Fortran/gfortran/regression/pr103312.f90 new file mode 100644 index 000000000..deacc70bf --- /dev/null +++ b/Fortran/gfortran/regression/pr103312.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! +! Test the fix for pr103312, in which the use of a component call in +! initialization expressions, eg. character(this%size()), caused ICEs. +! +! Contributed by Arseny Solokha +! +module example + + type, abstract :: foo + integer :: i + contains + procedure(foo_size), deferred :: size + procedure(foo_func), deferred :: func + end type + + interface + function foo_func (this) result (string) + import :: foo + class(foo) :: this + character(this%size()) :: string + end function + pure integer function foo_size (this) + import foo + class(foo), intent(in) :: this + end function + end interface + +end module + +module extension + use example + implicit none + type, extends(foo) :: bar + contains + procedure :: size + procedure :: func + end type + +contains + pure integer function size (this) + class(bar), intent(in) :: this + size = this%i + end function + function func (this) result (string) + class(bar) :: this + character(this%size()) :: string + string = repeat ("x", len (string)) + end function + +end module + +module unextended + implicit none + type :: foobar + integer :: i + contains + procedure :: size + procedure :: func + end type + +contains + pure integer function size (this) + class(foobar), intent(in) :: this + size = this%i + end function + function func (this) result (string) + class(foobar) :: this + character(this%size()) :: string + character(:), allocatable :: chr + string = repeat ("y", len (string)) + allocate (character(this%size()) :: chr) + if (len (string) .ne. len (chr)) stop 1 + end function + +end module + + use example + use extension + use unextended + type(bar) :: a + type(foobar) :: b + a%i = 5 + if (a%func() .ne. 'xxxxx') stop 2 + b%i = 7 + if (b%func() .ne. 'yyyyyyy') stop 3 +end diff --git a/Fortran/gfortran/regression/pr103389.f90 b/Fortran/gfortran/regression/pr103389.f90 new file mode 100644 index 000000000..565551564 --- /dev/null +++ b/Fortran/gfortran/regression/pr103389.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer, allocatable :: a(:) + end type + type(t) :: y + y%a = [1,2] + call s((y)) + if (any (y%a .ne. [3,4])) stop 1 +contains + subroutine s(x) + class(*) :: x + select type (x) + type is (t) + x%a = x%a + 2 + class default + stop 2 + end select + end +end diff --git a/Fortran/gfortran/regression/pr103471.f90 b/Fortran/gfortran/regression/pr103471.f90 new file mode 100644 index 000000000..695446e03 --- /dev/null +++ b/Fortran/gfortran/regression/pr103471.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Test the fix for PR103471 in which, rather than giving a "no IMPLICIT type" +! message, gfortran took to ICEing. The fuzzy symbol check for 'kk' demonstrates +! that the error is being detected at the right place. +! +! Contributed by Gerhard Steinmetz +! +program p + implicit none + integer, parameter :: x(4) = [1,2,3,4] + real, external :: y + integer :: kk + print *, [real(y(l))] ! { dg-error "has no IMPLICIT type" } + print *, [real(x(k))] ! { dg-error "has no IMPLICIT type; did you mean .kk.\\?" } +! This silently suppresses the error in the previous line. With the line before +! commented out, the error occurs in trans-decl.cc. +! print *, [real(y(k))] +end diff --git a/Fortran/gfortran/regression/pr103628.f90 b/Fortran/gfortran/regression/pr103628.f90 index 255d5bdd7..98ec0f484 100644 --- a/Fortran/gfortran/regression/pr103628.f90 +++ b/Fortran/gfortran/regression/pr103628.f90 @@ -1,5 +1,5 @@ ! { dg-do compile { target powerpc*-*-* } } -! { dg-options "-O2 -mabi=ibmlongdouble" } +! { dg-options "-O2 -mlong-double-128 -mabi=ibmlongdouble" } ! Test to ensure that it reports an "Cannot simplify expression" error ! instead of throwing an ICE when the memory represent of the HOLLERITH diff --git a/Fortran/gfortran/regression/pr103715.f90 b/Fortran/gfortran/regression/pr103715.f90 new file mode 100644 index 000000000..72c5a31fb --- /dev/null +++ b/Fortran/gfortran/regression/pr103715.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/103715 - ICE in gfc_find_gsymbol +! +! valgrind did report an invalid read in check_externals_procedure + +program p + select type (y => g()) ! { dg-error "Selector shall be polymorphic" } + end select + call g() +end + +! { dg-prune-output "already being used as a FUNCTION" } diff --git a/Fortran/gfortran/regression/pr103716.f90 b/Fortran/gfortran/regression/pr103716.f90 new file mode 100644 index 000000000..4f7890083 --- /dev/null +++ b/Fortran/gfortran/regression/pr103716.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! The gimplifier used to throw a fit on thes two functions. +! +! Contributed by Gerhard Steinmetz +! +function f1(x) + character(*) :: x(*) + print *, g(x%len) +end + +function f2(x) + character(*) :: x(3) + print *, g(x%len) +end diff --git a/Fortran/gfortran/regression/pr104351.f90 b/Fortran/gfortran/regression/pr104351.f90 new file mode 100644 index 000000000..86b47e033 --- /dev/null +++ b/Fortran/gfortran/regression/pr104351.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/104351 +! Contributed by G.Steinmetz + +program p + implicit none + type t + end type + type(t) :: f +contains + real function f() result(z) ! { dg-error "has an explicit interface" } + z = 0.0 ! { dg-error "assignment" } + end function f ! { dg-error "Expecting END PROGRAM" } +end diff --git a/Fortran/gfortran/regression/pr104429.f90 b/Fortran/gfortran/regression/pr104429.f90 new file mode 100644 index 000000000..39761fd59 --- /dev/null +++ b/Fortran/gfortran/regression/pr104429.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +module m + type t + real :: r + contains + procedure :: op + procedure :: assign + generic :: operator(*) => op + generic :: assignment(=) => assign + end type +contains + function op (x, y) + class(t), allocatable :: op + class(t), intent(in) :: x + real, intent(in) :: y + allocate (op, source = t (x%r * y)) + end + subroutine assign (z, x) + type(t), intent(in) :: x + class(t), intent(out) :: z + z%r = x%r + end +end +program p + use m + class(t), allocatable :: x + real :: y = 2 + allocate (x, source = t (2.0)) + x = x * y + if (int (x%r) .ne. 4) stop 1 + if (allocated (x)) deallocate (x) +end diff --git a/Fortran/gfortran/regression/pr104555.f90 b/Fortran/gfortran/regression/pr104555.f90 new file mode 100644 index 000000000..1fc5b5bb9 --- /dev/null +++ b/Fortran/gfortran/regression/pr104555.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! Test the fix for PR104555 in which the select type statement caused an +! ICE because the selector expression was type(t) rather than class(t). +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), allocatable :: a + end type + call s(t("abcd")) + call s([t("efgh")]) +contains + subroutine s(x) + class(t) :: x(..) + select rank (x) + rank (0) + print *, "|", x%a, "|" + select type (y => x) + type is (t) + print *, "|", y%a, "|" + end select + rank (1) + print *, "|", x(1)%a, "|" + select type (y => x) + type is (t) + print *, "|", y(1)%a, "|" + end select + end select + end +end diff --git a/Fortran/gfortran/regression/pr104625.f90 b/Fortran/gfortran/regression/pr104625.f90 new file mode 100644 index 000000000..84e7a9a15 --- /dev/null +++ b/Fortran/gfortran/regression/pr104625.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! Check the fix for PR104625 in which the selectors in parentheses used +! to cause ICEs. The "Unclassifiable statement" errors were uncovered once +! the ICEs were fixed. +! +! Contributed by Gerhard Steinmetz +! +program p + implicit none + type t + integer :: a + end type +contains + subroutine s(x) +! class(t) :: x ! Was OK + class(t) :: x(:) ! Used to ICE in combination with below + class(t), allocatable :: r(:) + + select type (y => x) ! OK + type is (t) + y%a = 99 + end select + select type (z => (x)) ! Used to ICE + type is (t) + r = z(1) ! Used to give "Unclassifiable statement" error + z%a = 99 ! { dg-error "cannot be used in a variable definition" } + end select + select type (u => ((x))) ! Used to ICE + type is (t) + r = u(1) ! Used to give "Unclassifiable statement" error + u%a = 99 ! { dg-error "cannot be used in a variable definition" } + end select + end +end diff --git a/Fortran/gfortran/regression/pr104649.f90 b/Fortran/gfortran/regression/pr104649.f90 new file mode 100644 index 000000000..f301ffcde --- /dev/null +++ b/Fortran/gfortran/regression/pr104649.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-w" } +! PR fortran/104649 +! Contributed by G.Steinmetz + +module m + interface + module subroutine s(x) + real :: x + end + end interface +end +submodule(m) m2 +contains + module subroutine s(*) ! { dg-error "conflicts with alternate return" } + end +end + +module n + interface + module subroutine s(*) + end + end interface +end +submodule(n) n2 +contains + module subroutine s(x) ! { dg-error "formal argument is alternate return" } + real :: x + end +end + +module p + interface + module subroutine s(x) + real :: x + end + end interface +end +submodule(p) p2 +contains + module subroutine s(y) ! { dg-error "Mismatch in MODULE PROCEDURE formal argument names" } + real :: y + end +end diff --git a/Fortran/gfortran/regression/pr104908.f90 b/Fortran/gfortran/regression/pr104908.f90 new file mode 100644 index 000000000..c3a30b000 --- /dev/null +++ b/Fortran/gfortran/regression/pr104908.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-additional-options "-fcheck=bounds -fdump-tree-original" } +! +! PR fortran/104908 - incorrect out-of-bounds runtime error + +program test + implicit none + type vec + integer :: x(3) = [2,4,6] + end type vec + type(vec) :: w(2) + call sub(w) +contains + subroutine sub (v) + class(vec), intent(in) :: v(:) + integer :: k, q(3) + q = [ (v(1)%x(k), k = 1, 3) ] ! <-- was failing here after r11-1235 + print *, q + end +end + +subroutine sub2 (zz) + implicit none + type vec + integer :: x(2,1) + end type vec + class(vec), intent(in) :: zz(:) ! used to ICE after r11-1235 + integer :: k + k = zz(1)%x(2,1) +end + +! { dg-final { scan-tree-dump-times " above upper bound " 4 "original" } } diff --git a/Fortran/gfortran/regression/pr105152.f90 b/Fortran/gfortran/regression/pr105152.f90 new file mode 100644 index 000000000..561b2a6c7 --- /dev/null +++ b/Fortran/gfortran/regression/pr105152.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + use iso_c_binding + type, bind(c) :: t + integer(c_int) :: a + end type + interface + function f(x) bind(c) result(z) + import :: c_int, t + type(t) :: x(:) + integer(c_int) :: z + end + end interface + class(*), allocatable :: y(:) + n = f(y) ! { dg-error "either an unlimited polymorphic or assumed type" } +end diff --git a/Fortran/gfortran/regression/pr105361.f90 b/Fortran/gfortran/regression/pr105361.f90 new file mode 100644 index 000000000..e2d3b07ca --- /dev/null +++ b/Fortran/gfortran/regression/pr105361.f90 @@ -0,0 +1,41 @@ +! { dg-do run } + +module x + implicit none + type foo + real :: r + end type foo + interface read(formatted) + module procedure read_formatted + end interface read(formatted) +contains + subroutine read_formatted (dtv, unit, iotype, vlist, iostat, iomsg) + class (foo), intent(inout) :: dtv + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + read (unit,*,iostat=iostat,iomsg=iomsg) dtv%r + !print *,dtv%r + end subroutine read_formatted +end module x + +program main + use x + implicit none + type(foo) :: a, b + real :: c, d + open(10, access="stream") + write(10) "1 2" ! // NEW_LINE('A') + close(10) + open(10) + read(10,*) c, d + if ((c /= 1.0) .or. (d /= 2.0)) stop 1 + rewind(10) + !print *, c,d + read (10,*) a, b + close(10, status="delete") + if ((a%r /= 1.0) .or. (b%r /= 2.0)) stop 2 + !print *, a,b +end program main diff --git a/Fortran/gfortran/regression/pr105456-nmlr.f90 b/Fortran/gfortran/regression/pr105456-nmlr.f90 new file mode 100644 index 000000000..5ce5d0821 --- /dev/null +++ b/Fortran/gfortran/regression/pr105456-nmlr.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted + end type +contains + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (iotype.eq."NAMELIST") then + write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k + else + read (unit,*) dtv%c, comma, dtv%k + endif + iostat = 42 + iomsg = "The users message" + if (comma /= ',') STOP 1 + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.' &NML X=a, 5 /') STOP 1 + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 +end +! { dg-output "Fortran runtime error: The users message" } diff --git a/Fortran/gfortran/regression/pr105456-nmlw.f90 b/Fortran/gfortran/regression/pr105456-nmlw.f90 new file mode 100644 index 000000000..2c496e611 --- /dev/null +++ b/Fortran/gfortran/regression/pr105456-nmlw.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted + end type +contains + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (iotype.eq."NAMELIST") then + write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + iostat = 42 + iomsg = "The users message" + end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k + else + read (unit,*) dtv%c, comma, dtv%k + end if + if (comma /= ',') STOP 1 + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.' &NML X=a, 5 /') STOP 1 + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 +end +! { dg-output "Fortran runtime error: The users message" } diff --git a/Fortran/gfortran/regression/pr105456-ruf.f90 b/Fortran/gfortran/regression/pr105456-ruf.f90 new file mode 100644 index 000000000..c176c4aa1 --- /dev/null +++ b/Fortran/gfortran/regression/pr105456-ruf.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface read (unformatted) + module procedure read_unformatted + end interface read (unformatted) +contains + subroutine read_unformatted (dtv, unit, piostat, piomsg) + class (char), intent(inout) :: dtv + integer, intent(in) :: unit + !character (len=*), intent(in) :: iotype + !integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine read_unformatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, form='unformatted', status='scratch') + write (10) 'X' + rewind (10) + read (10) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/Fortran/gfortran/regression/pr105456-wf.f90 b/Fortran/gfortran/regression/pr105456-wf.f90 new file mode 100644 index 000000000..f1c5350cc --- /dev/null +++ b/Fortran/gfortran/regression/pr105456-wf.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface write (formatted) + module procedure write_formatted + end interface write (formatted) +contains + subroutine write_formatted (dtv, unit, iotype, vlist, piostat, piomsg) + class (char), intent(in) :: dtv + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine write_formatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, status='scratch') + write (10,*) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/Fortran/gfortran/regression/pr105456-wuf.f90 b/Fortran/gfortran/regression/pr105456-wuf.f90 new file mode 100644 index 000000000..2b637b704 --- /dev/null +++ b/Fortran/gfortran/regression/pr105456-wuf.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface write (unformatted) + module procedure write_unformatted + end interface write (unformatted) +contains + subroutine write_unformatted (dtv, unit, piostat, piomsg) + class (char), intent(in) :: dtv + integer, intent(in) :: unit + !character (len=*), intent(in) :: iotype + !integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine write_unformatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, form='unformatted', status='scratch') + write (10) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/Fortran/gfortran/regression/pr105456.f90 b/Fortran/gfortran/regression/pr105456.f90 new file mode 100644 index 000000000..60cd3b6f3 --- /dev/null +++ b/Fortran/gfortran/regression/pr105456.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface read (formatted) + module procedure read_formatted + end interface read (formatted) +contains + subroutine read_formatted (dtv, unit, iotype, vlist, piostat, piomsg) + class (char), intent(inout) :: dtv + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + character :: ch + read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) ch + piostat = 42 + piomsg="The users message containing % and %% and %s and other stuff" + dtv%ch = ch + end subroutine read_formatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + open (10,status="scratch") + write (10,'(A)') '', 'a' + rewind (10) + read (10,*) x + write (*,'(10(A))') "Read: '",x%ch,"'" +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message containing % and %% and %s and other stuff" } diff --git a/Fortran/gfortran/regression/pr105473.f90 b/Fortran/gfortran/regression/pr105473.f90 new file mode 100644 index 000000000..863a312c7 --- /dev/null +++ b/Fortran/gfortran/regression/pr105473.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR libgfortran/105473 + implicit none + integer n,m,ios + real r + real :: x(3) + complex z + character(40):: testinput + n = 999; m = 777; r=1.2345 + z = cmplx(0.0,0.0) + +! Check that semi-colon is not allowed as separator with decimal=point. + ios=0 + testinput = '1;17;3.14159' + read(testinput,*,decimal='point',iostat=ios) n, m, r + if (ios /= 5010) stop 1 + +! Check that semi-colon allowed as a separator with decimal=point. + ios=0 + testinput = '1.23435 1243.24 13.24 ;' + read(testinput, *, iostat=ios) x + if (ios /= 0) stop 2 + +! Check that comma is not allowed as a separator with decimal=comma. + ios=0 + testinput = '1,17,3,14159' + read(testinput,*,decimal='comma',iostat=ios) n, m, r + if (ios /= 5010) stop 3 + +! Check a good read. + ios=99 + testinput = '1;17;3,14159' + read(testinput,*,decimal='comma',iostat=ios) n, m, r + if (ios /= 0) stop 4 + +! Check that comma is not allowed as a separator with decimal=comma. + ios=99; z = cmplx(0.0,0.0) + testinput = '1,17, (3,14159, 1,7182)' + read(testinput,*,decimal='comma', iostat=ios) n, m, z + if (ios /= 5010) stop 5 + +! Check that semi-colon is not allowed as separator with decimal=point. + ios=99; z = cmplx(0.0,0.0) + testinput = '1,17; (3.14159; 1.7182)' + read(testinput,*,decimal='point', iostat=ios) n, m, z + if (ios /= 5010) stop 6 + +! Check a good read. + ios=99;z = cmplx(0.0,0.0) + testinput = '1;17; (3,14159; 1,7182)' + read(testinput,*,decimal='comma', iostat=ios) n, m, z + if (ios /= 0) stop 7 +end program diff --git a/Fortran/gfortran/regression/pr105847.f90 b/Fortran/gfortran/regression/pr105847.f90 new file mode 100644 index 000000000..9a89d3971 --- /dev/null +++ b/Fortran/gfortran/regression/pr105847.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +module m + integer :: name_in_module = 123 +end module + +program foo + + use m, name_in_program => name_in_module + namelist /nl/ name_in_program + + if (name_in_program /= 123) stop 1 + + open(unit=10, file='fort.10', status='replace') + write(10,nl) + close(10) + + name_in_program = 42 + if (name_in_program /= 42) stop 2 + + open(unit=10, file='fort.10', status='old') + read(10,nl) + if (name_in_program /= 123) stop 3 + close(10) + + call bar + + contains + + subroutine bar + integer name_in_program + namelist /nl/ name_in_program + name_in_program = 0 + open(unit=10, file='fort.10', status='old') + read(10,nl) + if (name_in_program /= 123) stop 4 + close(10,status='delete') + end subroutine bar + +end diff --git a/Fortran/gfortran/regression/pr106999.f90 b/Fortran/gfortran/regression/pr106999.f90 new file mode 100644 index 000000000..f05a27006 --- /dev/null +++ b/Fortran/gfortran/regression/pr106999.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Test the fix for PR106999 +! Contributed by Gerhard Steinmetz +program p + type t + integer :: i + procedure(g), pointer :: f + end type + class(t), allocatable :: y, z + procedure(g), pointer :: ff + allocate (z) + z%i = 42 + z%f => g + ff => g + call r(z%f) + call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" } + call s(ff) ! { dg-error "Interface mismatch in dummy procedure" } +contains + subroutine g(x) + class(t) :: x + x%i = 84 + end + subroutine r(x) + procedure(g) :: x + print *, "in r" + allocate (y) + call x(y) + print *, y%i + end + subroutine s(x) + class(*) :: x + end subroutine +end diff --git a/Fortran/gfortran/regression/pr107068.f90 b/Fortran/gfortran/regression/pr107068.f90 new file mode 100644 index 000000000..c5ea0c1d2 --- /dev/null +++ b/Fortran/gfortran/regression/pr107068.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program test + implicit none + integer :: error + logical, dimension(3,3) :: flc,flp + namelist/inputdata/flc, flp + + flc = .false. + flp = .false. + + open(10, file="inputfile") + write(10,*) "&INPUTDATA" + write(10,*) " FLC = T, " + write(10,*) " FLP(1,2) = T," + write(10,*) "/" + rewind(10) + !write(*, nml=inputdata) + !open(10,file="inputfile") + read(10,inputdata,iostat=error) + close(10, status='delete') + if (error /= 0) stop 20 +end program test diff --git a/Fortran/gfortran/regression/pr107397.f90 b/Fortran/gfortran/regression/pr107397.f90 index fd59bf160..f77b4b00d 100644 --- a/Fortran/gfortran/regression/pr107397.f90 +++ b/Fortran/gfortran/regression/pr107397.f90 @@ -1,6 +1,7 @@ !{ dg-do compile } ! program p + implicit none type t real :: a = 1.0 end type diff --git a/Fortran/gfortran/regression/pr107821.f90 b/Fortran/gfortran/regression/pr107821.f90 new file mode 100644 index 000000000..5d86997d9 --- /dev/null +++ b/Fortran/gfortran/regression/pr107821.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + associate (a => 1) + print *, [character((a(1))) :: '1'] ! { dg-error "has an array reference" } + end associate +end diff --git a/Fortran/gfortran/regression/pr107900.f90 b/Fortran/gfortran/regression/pr107900.f90 new file mode 100644 index 000000000..2bd80a7d5 --- /dev/null +++ b/Fortran/gfortran/regression/pr107900.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Contributed by Karl Kaiser +! +program test + + class(*), pointer :: ptr1, ptr2(:) + integer, target :: i = 42 + integer :: check = 0 +! First with associate name and no selector in select types + associate (c => ptr1) + select type (c) ! Segfault - vptr not set + type is (integer) + stop 1 + class default + check = 1 + end select + end associate +! Now do the same with the array version + associate (c => ptr2) + select type (d =>c) ! Segfault - vptr not set + type is (integer) + stop 2 + class default + check = check + 10 + end select + end associate + +! And now with the associate name and selector + associate (c => ptr1) + select type (d => c) ! Segfault - vptr not set + type is (integer) + stop 3 + class default + check = check + 100 + end select + end associate +! Now do the same with the array version +! ptr2 => NULL() !This did not fix the problem + associate (c => ptr2) + select type (d => c) ! Segfault - vptr not set + type is (integer) + stop 4 + class default + check = check + 1000 + end select + end associate + if (check .ne. 1111) stop 5 +end program test diff --git a/Fortran/gfortran/regression/pr108889.f90 b/Fortran/gfortran/regression/pr108889.f90 new file mode 100644 index 000000000..7fd4e3882 --- /dev/null +++ b/Fortran/gfortran/regression/pr108889.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-Wall -fdump-tree-original" } +! +! Contributed by Tobias Burnus +! +program main + implicit none + + type :: struct + real, allocatable :: var(:) + end type struct + + type(struct) :: single + real, allocatable :: ref1(:), ref2(:), ref3(:), ref4(:) + + ref2 = [1,2,3,4,5] ! Warnings here + + single%var = ref2 ! No warnings for components + ref1 = single%var ! Warnings here + ref1 = [1,2,3,4,5] ! Should not add to tree dump count + + allocate (ref3(5)) + ref3 = single%var ! No warnings following allocation + + call set_ref4 + + call test (ref1) + call test (ref2) + call test (ref3) + call test (ref4) + +contains + subroutine test (arg) + real, allocatable :: arg(:) + if (size(arg) /= size(single%var)) stop 1 + if (lbound(arg, 1) /= 1) stop 2 + if (any (arg /= single%var)) stop 3 + end + subroutine set_ref4 + ref4 = single%var ! Warnings in contained scope + end +end +! { df-final { scan-tree-dump-times "ubound = 0" 3 "original" } } \ No newline at end of file diff --git a/Fortran/gfortran/regression/pr108961.f90 b/Fortran/gfortran/regression/pr108961.f90 new file mode 100644 index 000000000..3e6c9df48 --- /dev/null +++ b/Fortran/gfortran/regression/pr108961.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Contributed by Jeffrey Hill +! +module associate_ptr + use iso_c_binding +contains + subroutine c_f_strpointer(cptr, ptr2) + type(c_ptr), target, intent(in) :: cptr + character(kind=c_char,len=4), pointer :: ptr1 + character(kind=c_char,len=:), pointer, intent(out) :: ptr2 + call c_f_pointer(cptr, ptr1) + if (ptr1 .ne. 'abcd') stop 1 + ptr2 => ptr1 ! Failed here + end subroutine +end module + +program test_associate_ptr + use associate_ptr + character(kind=c_char, len=1), target :: char_array(7) + character(kind=c_char,len=:), pointer :: ptr2 + char_array = ['a', 'b', 'c', 'd', c_null_char, 'e', 'f'] +! The first argument was providing a constant hidden string length => segfault + call c_f_strpointer(c_loc(char_array), ptr2) + if (ptr2 .ne. 'abcd') stop 2 +end program diff --git a/Fortran/gfortran/regression/pr109358.f90 b/Fortran/gfortran/regression/pr109358.f90 new file mode 100644 index 000000000..501398409 --- /dev/null +++ b/Fortran/gfortran/regression/pr109358.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR109358, test that tabs during stream io are correct. +program tabs + implicit none + integer :: fd + character(64) :: line + open(newunit=fd, file="otabs.txt", form="formatted", access="stream") + write(fd, "(i4, t40, i4, t20, i5.5)") 1234, 5555, 67890 + close(fd) + open(newunit=fd, file="otabs.txt", form="formatted") + read(fd,"(a)") line + close(fd, status='delete') + if (line .ne. "1234 67890 5555") stop 10 +end program tabs diff --git a/Fortran/gfortran/regression/pr109662-a.f90 b/Fortran/gfortran/regression/pr109662-a.f90 new file mode 100644 index 000000000..dc05d6b7a --- /dev/null +++ b/Fortran/gfortran/regression/pr109662-a.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-std=f2003" } +! PR109662-a semi-colon after namelist name accepted on input. +program testnmlread + implicit none + character(16) :: line = '&stuff; n = 759/' + character(100)::message + integer :: n, i, ioresult + namelist/stuff/n + message = "" + ioresult = 0 + n = 99 + read(line,nml=stuff,iostat=ioresult) + if (ioresult == 0) STOP 13 ! Should error with the semi-colon in there. + + ! Intentional short input (-> EOF) + line = "&stuff" + ! Problem manifests on two bad reads on same string. + do i = 1, 6 + n = -1 + ioresult = 0 + + read (line,nml=stuff,iostat=ioresult) + if (n /= -1) STOP 24 + if (ioresult == 0) STOP 25 + end do + +end program testnmlread diff --git a/Fortran/gfortran/regression/pr109662.f90 b/Fortran/gfortran/regression/pr109662.f90 new file mode 100644 index 000000000..988cfab73 --- /dev/null +++ b/Fortran/gfortran/regression/pr109662.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=f2003" } +! PR109662 a comma after namelist name accepted on input. +program testnmlread + implicit none + character(16) :: list = '&stuff, n = 759/' + character(100)::message + integer :: n, ioresult + namelist/stuff/n + message = "" + ioresult = 0 + n = 99 + read(list,nml=stuff,iostat=ioresult) + if (ioresult == 0) STOP 13 +end program testnmlread diff --git a/Fortran/gfortran/regression/pr109948.f90 b/Fortran/gfortran/regression/pr109948.f90 new file mode 100644 index 000000000..41d54d8c7 --- /dev/null +++ b/Fortran/gfortran/regression/pr109948.f90 @@ -0,0 +1,114 @@ +! { dg-do compile } +! +! Tests the fix for PR109948 +! +! Contributed by Rimvydas Jasinskas +! +module mm + implicit none + interface operator(==) + module procedure eq_1_2 + end interface operator(==) + private :: eq_1_2 +contains + logical function eq_1_2 (x, y) + integer, intent(in) :: x(:) + real, intent(in) :: y(:,:) + eq_1_2 = .true. + end function eq_1_2 +end module mm + +program pr109948 + use mm + implicit none + type tlap + integer, allocatable :: z(:) + end type tlap + type ulap + type(tlap) :: u(2) + end type ulap + integer :: pid = 1 + call comment0 ! Original problem + call comment1 + call comment3 ([5,4,3,2,1]) + call comment10 + call comment11 ([5,4,3,2,1]) +contains + subroutine comment0 + type(tlap) :: y_in + integer :: x_out(3) =[0.0,0.0,0.0] + y_in%z = [1,-2,3] + call foo(y_in, x_out) + if (any (x_out .ne. [0, -2, 0])) stop 1 + call foo(y_in, x_out) + if (any (x_out .ne. [1, -2, 3])) stop 2 + end subroutine comment0 + + subroutine foo(y, x) + type(tlap) :: y + integer :: x(:) + associate(z=>y%z) + if (pid == 1) then + where ( z < 0 ) x(:) = z(:) + else + where ( z > 0 ) x(:) = z(:) + endif + pid = pid + 1 + end associate + end subroutine foo + + subroutine comment1 + type(tlap) :: grib + integer :: i + grib%z = [3,2,1] + associate(k=>grib%z) + i = k(1) + if (any(k==1)) i = 1 + end associate + if (i .eq. 3) stop 3 + end subroutine comment1 + + subroutine comment3(k_2d) + implicit none + integer :: k_2d(:) + integer :: i + associate(k=>k_2d) + i = k(1) + if (any(k==1)) i = 1 + end associate + if (i .eq. 3) stop 4 + end subroutine comment3 + + subroutine comment11(k_2d) + implicit none + integer :: k_2d(:) + integer :: m(1) = 42 + real :: r(1,1) = 3.0 + if ((m == r) .neqv. .true.) stop 5 + associate (k=>k_2d) + if ((k == r) .neqv. .true.) stop 6 ! failed to find user defined operator + end associate + associate (k=>k_2d(:)) + if ((k == r) .neqv. .true.) stop 7 + end associate + end subroutine comment11 + + subroutine comment10 + implicit none + type(ulap) :: z(2) + integer :: i + real :: r(1,1) = 3.0 + z(1)%u = [tlap([1,2,3]),tlap([4,5,6])] + z(2)%u = [tlap([7,8,9]),tlap([10,11,12])] + associate (k=>z(2)%u(1)%z) + i = k(1) + if (any(k==8)) i = 1 + end associate + if (i .ne. 1) stop 8 + associate (k=>z(1)%u(2)%z) + if ((k == r) .neqv. .true.) stop 9 + if (any (k .ne. [4,5,6])) stop 10 + end associate + end subroutine comment10 +end program pr109948 + diff --git a/Fortran/gfortran/regression/pr110221.f b/Fortran/gfortran/regression/pr110221.f new file mode 100644 index 000000000..8b5738431 --- /dev/null +++ b/Fortran/gfortran/regression/pr110221.f @@ -0,0 +1,17 @@ +C PR middle-end/68146 +C { dg-do compile } +C { dg-options "-O2 -w" } +C { dg-additional-options "-mavx512f --param vect-partial-vector-usage=2" { target avx512f } } + SUBROUTINE CJYVB(V,Z,V0,CBJ,CDJ,CBY,CYY) + IMPLICIT DOUBLE PRECISION (A,B,G,O-Y) + IMPLICIT COMPLEX*16 (C,Z) + DIMENSION CBJ(0:*),CDJ(0:*),CBY(0:*) + N=INT(V) + CALL GAMMA2(VG,GA) + DO 65 K=1,N + CBY(K)=CYY +65 CONTINUE + CDJ(0)=V0/Z*CBJ(0)-CBJ(1) + DO 70 K=1,N +70 CDJ(K)=-(K+V0)/Z*CBJ(K)+CBJ(K-1) + END diff --git a/Fortran/gfortran/regression/pr110224.f90 b/Fortran/gfortran/regression/pr110224.f90 new file mode 100644 index 000000000..186bbf5fe --- /dev/null +++ b/Fortran/gfortran/regression/pr110224.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! Contributed by Neil Carlson +! +module mod + type :: foo + real, pointer :: var + contains + procedure :: var_ptr + end type +contains + function var_ptr(this) result(ref) + class(foo) :: this + real, pointer :: ref + ref => this%var + end function +end module +program main + use mod + type(foo) :: x + allocate (x%var, source = 2.0) + associate (var => x%var_ptr()) + var = 1.0 + end associate + if (x%var .ne. 1.0) stop 1 + x%var_ptr() = 2.0 + if (x%var .ne. 2.0) stop 2 + deallocate (x%var) +end program diff --git a/Fortran/gfortran/regression/pr110415.f90 b/Fortran/gfortran/regression/pr110415.f90 new file mode 100644 index 000000000..f647cc4c5 --- /dev/null +++ b/Fortran/gfortran/regression/pr110415.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Contributed by Brad Richardson +! + type, abstract :: p + end type p + + type, extends(p) :: c + end type c + + class(p), allocatable :: a + + a = func() +contains + function func() result(a) + class(p), allocatable :: a + + a = c() + end function func +end program diff --git a/Fortran/gfortran/regression/pr110996.f90 b/Fortran/gfortran/regression/pr110996.f90 new file mode 100644 index 000000000..0e7551059 --- /dev/null +++ b/Fortran/gfortran/regression/pr110996.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/110996 +! This example used to result in memory errors and sometimes internal compiler +! errors, because the rejection of the subroutine statement was causing the +! symbol D to be freed without also freeing the symbol C which remained in the +! namespace with a dangling pointer to D. +! +! Original testcase from Jeremy Bennett + +PROGRAM p +CONTAINS + SUBROUTINE c(d) e { dg-error "Syntax error" } + SUBROUTINE f + END +END diff --git a/Fortran/gfortran/regression/pr111022.f90 b/Fortran/gfortran/regression/pr111022.f90 new file mode 100644 index 000000000..eef55ff5c --- /dev/null +++ b/Fortran/gfortran/regression/pr111022.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +program pr111022 + character(20) :: buffer + write(buffer,"(EN0.3E0)") .6660_4 + if (buffer.ne."666.000E-3") stop 1 + write(buffer,"(EN0.3E0)") 6.660_4 + if (buffer.ne."6.660E+0") stop 2 + write(buffer,"(EN0.3E0)") 66.60_4 + if (buffer.ne."66.600E+0") stop 3 + write(buffer,"(EN0.3E0)") 666.0_4 + if (buffer.ne."666.000E+0") stop 4 + write(buffer,"(EN0.3E0)") 6660.0_4 + if (buffer.ne."6.660E+3") stop 5 + write(buffer,"(EN0.3E0)") 66600.0_4 + if (buffer.ne."66.600E+3") stop 6 + + write(buffer,"(EN0.0E0)") 666.0_4 + if (buffer.ne."666.E+0") stop 7 + write(buffer,"(EN0.0E1)") 666.0_4 + if (buffer.ne."666.E+0") stop 8 + write(buffer,"(EN0.0E2)") 666.0_4 + if (buffer.ne."666.E+00") stop 9 + write(buffer,"(EN0.0E3)") 666.0_4 + if (buffer.ne."666.E+000") stop 10 + write(buffer,"(EN0.0E4)") 666.0_4 + if (buffer.ne."666.E+0000") stop 11 + write(buffer,"(EN0.0E5)") 666.0_4 + if (buffer.ne."666.E+00000") stop 12 + write(buffer,"(EN0.0E6)") 666.0_4 + if (buffer.ne."666.E+000000") stop 13 + + write(buffer,"(ES0.3E0)") .6660_4 + if (buffer.ne."6.660E-1") stop 14 + write(buffer,"(ES0.3E0)") 6.660_4 + if (buffer.ne."6.660E+0") stop 15 + write(buffer,"(ES0.3E0)") 66.60_4 + if (buffer.ne."6.660E+1") stop 16 + write(buffer,"(ES0.3E0)") 666.0_4 + if (buffer.ne."6.660E+2") stop 17 + write(buffer,"(ES0.3E0)") 6660.0_4 + if (buffer.ne."6.660E+3") stop 18 + write(buffer,"(ES0.3E0)") 66600.0_4 + if (buffer.ne."6.660E+4") stop 19 + + write(buffer,"(ES0.0E0)") 666.0_4 + if (buffer.ne."7.E+2") stop 20 + write(buffer,"(ES0.0E1)") 666.0_4 + if (buffer.ne."7.E+2") stop 21 + write(buffer,"(ES0.0E2)") 666.0_4 + if (buffer.ne."7.E+02") stop 22 + write(buffer,"(ES0.0E3)") 666.0_4 + if (buffer.ne."7.E+002") stop 23 + write(buffer,"(ES0.0E4)") 666.0_4 + if (buffer.ne."7.E+0002") stop 24 + write(buffer,"(ES0.0E5)") 666.0_4 + if (buffer.ne."7.E+00002") stop 25 + write(buffer,"(ES0.0E6)") 666.0_4 + if (buffer.ne."7.E+000002") stop 26 + + write(buffer,"(E0.3E0)") .6660_4 + if (buffer.ne."0.666E+0") stop 27 + write(buffer,"(E0.3)") .6660_4 + if (buffer.ne."0.666E+0") stop 28 + write(buffer,"(E0.1E0)") .6660_4 + if (buffer.ne."0.7E+0") stop 29 + write(buffer,"(E0.1)") .6660_4 + if (buffer.ne."0.7E+0") stop 30 + write(buffer,"(E0.5E0)") .6660_4 + if (buffer.ne."0.66600E+0") stop 31 + write(buffer,"(E0.5)") .6660_4 + if (buffer.ne."0.66600E+0") stop 32 +end program pr111022 diff --git a/Fortran/gfortran/regression/pr111853.f90 b/Fortran/gfortran/regression/pr111853.f90 new file mode 100644 index 000000000..8f0b26664 --- /dev/null +++ b/Fortran/gfortran/regression/pr111853.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! A null dereference fixed +! +! Contributed by Daniel Otero +! +subroutine foo (rvec) + TYPE vec_rect_2D_real_acc + INTEGER :: arr + END TYPE + CLASS(vec_rect_2D_real_acc) rvec + + ASSOCIATE (arr=>rvec%arr) + call bar(arr*arr) + end associate +end diff --git a/Fortran/gfortran/regression/pr111880.f90 b/Fortran/gfortran/regression/pr111880.f90 new file mode 100644 index 000000000..c0cd98a93 --- /dev/null +++ b/Fortran/gfortran/regression/pr111880.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/111880 - redundant warning of obsolescent COMMON with submodule + +module third_party_module + integer :: some_param + common /not_my_code/ some_param ! { dg-warning "COMMON block" } +end module third_party_module + +module foo + use third_party_module + interface + module subroutine bar() + end subroutine bar + end interface +end module foo + +submodule (foo) foo_submod ! We do not need a warning here! +contains + module procedure bar + end procedure bar +end submodule foo_submod diff --git a/Fortran/gfortran/regression/pr111891.f90 b/Fortran/gfortran/regression/pr111891.f90 new file mode 100644 index 000000000..1167ed60f --- /dev/null +++ b/Fortran/gfortran/regression/pr111891.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O2" } +! { dg-additional-options "-mavx" { target avx } } + +!GCC$ builtin (powf) attributes simd (notinbranch) if('x86_64') + +PARAMETER (NX=3, G=1.4) +DIMENSION T(NX,NX), P(NX,NX) +INTEGER Apx +COMMON P, T + +DO i = 1, 3 + IF (i < 0.0 ) THEN + P(Apx,i) = i**G + T(Apx,i) = i**G + ELSE + P(Apx,i) = 0 + T(Apx,i) = 0 + ENDIF +ENDDO +END diff --git a/Fortran/gfortran/regression/pr112316.f90 b/Fortran/gfortran/regression/pr112316.f90 new file mode 100644 index 000000000..df4dad76c --- /dev/null +++ b/Fortran/gfortran/regression/pr112316.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! +! This contains both testcases in the PR +! +! Contributed by Tomas Trnka +! +! First testcase +module BogusPointerArgError + implicit none + + type :: AType + end type + +contains + + subroutine A () + + class(AType), allocatable :: x + + allocate(x) + call B (x) ! Was an error here + end subroutine + + subroutine B (y) + class(AType), intent(in) :: y + end subroutine + + subroutine C (z) + class(AType), intent(in) :: z(:) + + associate (xxx => z(1)) + end associate + + end subroutine + +end module + +! Second testcase +module AModule + implicit none + private + + public AType + + type, abstract :: AType + contains + generic, public :: assignment(=) => Assign + + procedure, private :: Assign + end type AType + +contains + + subroutine Assign(lhs, rhs) + class(AType), intent(inout) :: lhs + class(AType), intent(in) :: rhs + end subroutine + +end module AModule + + + +module ICEGetDescriptorField + use AModule + implicit none + +contains + + subroutine Foo (x) + class(AType), intent(in) :: x(:) + + class(AType), allocatable :: y + + associate (xxx => x(1)) + y = xxx ! Was an ICE here + end associate + end subroutine + +end module ICEGetDescriptorField diff --git a/Fortran/gfortran/regression/pr112404.f90 b/Fortran/gfortran/regression/pr112404.f90 new file mode 100644 index 000000000..4508bbc87 --- /dev/null +++ b/Fortran/gfortran/regression/pr112404.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +! { dg-additional-options "-mavx2" { target avx2 } } + SUBROUTINE sfddagd( regime, znt, ite, jte, ime, IN ) + REAL, DIMENSION( ime, IN) :: regime, znt + REAL, DIMENSION( ite, jte) :: wndcor_u + LOGICAL wrf_dm_on_monitor + IF( int4 == 1 ) THEN + DO j=jts,jtf + DO i=itsu,itf + reg = regime(i-1, j) + IF( reg > 10.0 ) THEN + znt0 = znt(i-1, j) + znt(i, j) + IF( znt0 <= 0.2) THEN + wndcor_u(i,j) = 0.2 + ENDIF + ENDIF + ENDDO + ENDDO + IF ( wrf_dm_on_monitor()) THEN + ENDIF + ENDIF + END diff --git a/Fortran/gfortran/regression/pr112406.f90 b/Fortran/gfortran/regression/pr112406.f90 new file mode 100644 index 000000000..27e96df7e --- /dev/null +++ b/Fortran/gfortran/regression/pr112406.f90 @@ -0,0 +1,21 @@ +! { dg-do compile { target { aarch64-*-* || riscv*-*-* } } } +! { dg-options "-Ofast -w -fprofile-generate" } +! { dg-additional-options "-march=rv64gcv -mabi=lp64d" { target riscv*-*-* } } +! { dg-additional-options "-march=armv8-a+sve" { target aarch64-*-* } } + +module brute_force + integer, parameter :: r=9 + integer sudoku1(1, r) + contains +subroutine brute +integer l(r), u(r) + where(sudoku1(1, :) /= 1) + l = 1 + u = 1 + end where +do i1 = 1, u(1) + do + end do + end do +end +end diff --git a/Fortran/gfortran/regression/pr112407a.f90 b/Fortran/gfortran/regression/pr112407a.f90 new file mode 100644 index 000000000..470f41916 --- /dev/null +++ b/Fortran/gfortran/regression/pr112407a.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! Test of an issue found in the investigation of PR112407 +! Contributed by Tomas Trnka +! +module m + private new_t + + type s + procedure(),pointer,nopass :: op + end type + + type :: t + integer :: i + type (s) :: s + contains + procedure :: new_t + procedure :: bar + procedure :: add_t + generic :: new => new_t, bar + generic, public :: assignment(=) => add_t + final :: final_t + end type + + integer :: i = 0, finals = 0 + +contains + recursive subroutine new_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + i = i + 1 + + print "(a,2i4)", "new_t", arg1%i, arg2%i + if (i .ge. 10) return + +! According to F2018(8.5.10), arg1 should be undefined on invocation, unless +! any sub-components are default initialised. gfc used to set arg1%i = 0. + if (arg1%i .ne. arg2%i) then + arg1%i = arg2%i + call arg1%new(arg2) + endif + end + + subroutine bar(arg) + class(t), intent(out) :: arg + call arg%new(t(42, s(new_t))) + end + + subroutine add_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + call arg1%new (arg2) + end + + impure elemental subroutine final_t (arg1) + type(t), intent(in) :: arg1 + finals = finals + 1 + end +end + + use m + class(t), allocatable :: x + allocate(x) + x%i = 0 + call x%new() ! gfortran used to output 10*'new_t' + print "(3i4)", x%i, i, finals ! -||- 0 10 11 +! +! The other brands output 2*'new_t' + 42 2 3 and now so does gfc :-) + if (x%i .ne. 42) stop 1 + if (i .ne. 2) stop 2 + if (finals .ne. 3) stop 3 +end diff --git a/Fortran/gfortran/regression/pr112407b.f90 b/Fortran/gfortran/regression/pr112407b.f90 new file mode 100644 index 000000000..b4653f808 --- /dev/null +++ b/Fortran/gfortran/regression/pr112407b.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! Test of an issue found in the investigation of PR112407. The dg-option is +! set to avoid regression once the F2018 RECURSIVE by default in implemented. +! Contributed by Tomas Trnka +! +module m + private new_t + + type s + procedure(),pointer,nopass :: op + end type + + type :: t + integer :: i + type (s) :: s + contains + procedure :: new_t + procedure :: bar + procedure :: add_t + generic :: new => new_t, bar + generic, public :: assignment(=) => add_t + final :: final_t + end type + + integer :: i = 0, finals = 0 + +contains + subroutine new_t (arg1, arg2) ! gfortran didn't detect the recursion + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + i = i + 1 + + print *, "new_t", arg1%i, arg2%i + if (i .ge. 10) return + + if (arg1%i .ne. arg2%i) then + arg1%i = arg2%i + call arg1%new(arg2) ! { dg-warning "possibly calling itself recursively" } + endif + end + + subroutine bar(arg) + class(t), intent(out) :: arg + call arg%new(t(42, s(new_t))) + end + + subroutine add_t (arg1, arg2) + class(t), intent(out) :: arg1 + type(t), intent(in) :: arg2 + call arg1%new (arg2) + end + + impure elemental subroutine final_t (arg1) + type(t), intent(in) :: arg1 + finals = finals + 1 + end +end diff --git a/Fortran/gfortran/regression/pr112459.f90 b/Fortran/gfortran/regression/pr112459.f90 new file mode 100644 index 000000000..7db243c22 --- /dev/null +++ b/Fortran/gfortran/regression/pr112459.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-w -fdump-tree-original" } +! +! Contributed by Sebastian Bardeau +! +module mymod + type mysubtype + integer(kind=4), allocatable :: a(:) + end type mysubtype + type :: mytype + integer :: i + type(mysubtype) :: sub + contains + final :: mytype_final + end type mytype +contains + subroutine mysubtype_final(sub) + type(mysubtype), intent(inout) :: sub + print *,'MYSUBTYPE>FINAL' + if (allocated(sub%a)) deallocate(sub%a) + end subroutine mysubtype_final + subroutine mytype_final(typ) + type(mytype), intent(inout) :: typ + print *,"MYTYPE>FINAL" + call mysubtype_final(typ%sub) + end subroutine mytype_final +end module mymod +! +program myprog + use mymod + type(mytype), pointer :: c + print *,"Before allocation" + allocate(c) + print *,"After allocation" +end program myprog +! Final subroutines were called with std=gnu and -w = > 14 "_final"s. +! { dg-final { scan-tree-dump-times "_final" 12 "original" } } diff --git a/Fortran/gfortran/regression/pr113363.f90 b/Fortran/gfortran/regression/pr113363.f90 new file mode 100644 index 000000000..99d4f2076 --- /dev/null +++ b/Fortran/gfortran/regression/pr113363.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! Test the fix for comment 1 in PR113363, which failed as in comments below. +! Contributed by Harald Anlauf +program p + implicit none + class(*), allocatable :: x(:), y + character(*), parameter :: arr(2) = ["hello ","bye "], & + sca = "Have a nice day" + character(10) :: const + +! Bug was detected in polymorphic array function results + allocate(x, source = foo ()) + call check1 (x, arr) ! Wrong output "6 hello e" + deallocate (x) + x = foo () + call check1 (x, arr) ! Wrong output "0 " + associate (var => foo ()) ! OK after r14-9489-g3fd46d859cda10 + call check1 (var, arr) ! Now OK - outputs: "6 hello bye " + end associate + +! Check scalar function results ! All OK + allocate (y, source = bar()) + call check2 (y, sca) + deallocate (y) + y = bar () + call check2 (y, sca) + deallocate (y) + associate (var => bar ()) + call check2 (var, sca) + end associate + +! Finally variable expressions... + allocate (y, source = x(1)) ! Gave zero length here + call check2 (y, "hello") + y = x(2) ! Segfaulted here + call check2 (y, "bye ") + associate (var => x(2)) ! Gave zero length here + call check2 (var, "bye ") + end associate + +! ...and constant expressions ! All OK + deallocate(y) + allocate (y, source = "abcde") + call check2 (y, "abcde") + const = "hijklmnopq" + y = const + call check2 (y, "hijklmnopq") + associate (var => "mnopq") + call check2 (var, "mnopq") + end associate + deallocate (x, y) + +contains + + function foo() result(res) + class(*), allocatable :: res(:) + res = arr + end function foo + + function bar() result(res) + class(*), allocatable :: res + res = sca + end function bar + + subroutine check1 (x, carg) + class(*), intent(in) :: x(:) + character(*) :: carg(:) + select type (x) + type is (character(*)) + if (any (x .ne. carg)) stop 1 + class default + stop 2 + end select + end subroutine check1 + + subroutine check2 (x, carg) + class(*), intent(in) :: x + character(*) :: carg + select type (x) + type is (character(*)) + if (x .ne. carg) stop 3 + class default + stop 4 + end select + end subroutine check2 +end diff --git a/Fortran/gfortran/regression/pr113503_1.f90 b/Fortran/gfortran/regression/pr113503_1.f90 new file mode 100644 index 000000000..37c178e2c --- /dev/null +++ b/Fortran/gfortran/regression/pr113503_1.f90 @@ -0,0 +1,18 @@ +! PR fortran/113503 +! { dg-do compile } +! { dg-options "-O2 -fno-inline -Wuninitialized" } + +program pr113503 + implicit none + type :: T + character(len=:), allocatable :: u + end type + character(len=20) :: us(1) = 'foobar' + type(T) :: x + x = T(u = trim (us(1))) ! { dg-bogus "is used uninitialized" } + call foo +contains + subroutine foo + if (x%u /= 'foobar') stop 1 + end subroutine +end diff --git a/Fortran/gfortran/regression/pr113503_2.f90 b/Fortran/gfortran/regression/pr113503_2.f90 new file mode 100644 index 000000000..9dfb245fc --- /dev/null +++ b/Fortran/gfortran/regression/pr113503_2.f90 @@ -0,0 +1,12 @@ +! PR fortran/113503 +! { dg-do compile } + +program pr113503 + implicit none + type :: T + character(len=:), allocatable :: u + end type + character(len=20) :: us(1) = 'foo' + type(T) :: x + x = T(u = us(1)) +end diff --git a/Fortran/gfortran/regression/pr113956.f90 b/Fortran/gfortran/regression/pr113956.f90 new file mode 100644 index 000000000..229e891f8 --- /dev/null +++ b/Fortran/gfortran/regression/pr113956.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Test the fix for PR113956 +! Contributed by David Binderman +module m +contains + subroutine test_array_char(p, x) + character(*), target :: x(:) + character(:), pointer :: p(:) + p => x ! ICE + end subroutine +end module + + use m + character(:), allocatable, target :: chr(:) + character(:), pointer :: p(:) + chr = ["ab","cd"] + call test_array_char (p, chr) + if (loc (chr) .ne. loc (p)) stop 1 + if (len (p) .ne. 2) stop 2 + if (any (p .ne. chr)) stop 3 +end diff --git a/Fortran/gfortran/regression/pr114012.f90 b/Fortran/gfortran/regression/pr114012.f90 new file mode 100644 index 000000000..9dbb031c6 --- /dev/null +++ b/Fortran/gfortran/regression/pr114012.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! PR fortran/114012 +! +! Polymorphic functions were evaluated twice in assignment + +program test + implicit none + + type :: custom_int + integer :: val = 2 + end type + + interface assignment(=) + procedure assign + end interface + interface operator(-) + procedure neg + end interface + + type(custom_int) :: i + integer :: count_assign, count_neg + + count_assign = 0 + count_neg = 0 + + i = 1 + if (count_assign /= 1 .or. count_neg /= 0) stop 1 + + i = -i + if (count_assign /= 2 .or. count_neg /= 1) stop 2 + if (i% val /= -1) stop 3 + + i = neg(i) + if (count_assign /= 3 .or. count_neg /= 2) stop 4 + if (i% val /= 1) stop 5 + + i = (neg(i)) + if (count_assign /= 4 .or. count_neg /= 3) stop 6 + if (i% val /= -1) stop 7 + + i = - neg(i) + if (count_assign /= 5 .or. count_neg /= 5) stop 8 + if (i% val /= -1) stop 9 + +contains + + subroutine assign (field, val) + type(custom_int), intent(out) :: field + class(*), intent(in) :: val + + count_assign = count_assign + 1 + + select type (val) + type is (integer) +! print *, " in assign(integer)", field%val, val + field%val = val + type is (custom_int) +! print *, " in assign(custom)", field%val, val%val + field%val = val%val + class default + error stop + end select + + end subroutine assign + + function neg (input_field) result(output_field) + type(custom_int), intent(in), target :: input_field + class(custom_int), allocatable :: output_field + allocate (custom_int :: output_field) + + count_neg = count_neg + 1 + + select type (output_field) + type is (custom_int) +! print *, " in neg", output_field%val, input_field%val + output_field%val = -input_field%val + class default + error stop + end select + end function neg +end program test diff --git a/Fortran/gfortran/regression/pr114304-2.f90 b/Fortran/gfortran/regression/pr114304-2.f90 new file mode 100644 index 000000000..5ef5874f5 --- /dev/null +++ b/Fortran/gfortran/regression/pr114304-2.f90 @@ -0,0 +1,82 @@ +! { dg-do run } +! +! PR fortran/114304 +! +! Ensure that '\t' (tab) is supported as separator in list-directed input +! While not really standard conform, this is widely used in user input and +! widely supported. +! + +use iso_c_binding +implicit none +character(len=*,kind=c_char), parameter :: tab = C_HORIZONTAL_TAB + +! Accept '' as variant to ' ' as separator +! Check that and are handled + +character(len=*,kind=c_char), parameter :: nml_str & + = '&inparm'//C_CARRIAGE_RETURN // C_NEW_LINE // & + 'first'//tab//'='//tab//' .true.'// C_NEW_LINE // & + ' , other'//tab//' ='//tab//'3'//tab//', 2'//tab//'/' + +! Check that is handled, + +! Note: For new line, Unix uses \n, Windows \r\n but old Apple systems used '\r' +! +! Gfortran does not seem to support all \r, but the following is supported +! since ages, ! which seems to be a gfortran extension as ifort and flang don't like it. + +character(len=*,kind=c_char), parameter :: nml_str2 & + = '&inparm'//C_CARRIAGE_RETURN // C_NEW_LINE // & + 'first'//C_NEW_LINE//'='//tab//' .true.'// C_CARRIAGE_RETURN // & + ' , other'//tab//' ='//tab//'3'//tab//', 2'//tab//'/' + +character(len=*,kind=c_char), parameter :: str & + = tab//'1'//tab//'2,'//tab//'3'//tab//',4'//tab//','//tab//'5'//tab//'/' +character(len=*,kind=c_char), parameter :: str2 & + = tab//'1'//tab//'2;'//tab//'3'//tab//';4'//tab//';'//tab//'5'//tab//'/' +logical :: first +integer :: other(4) +integer :: ints(6) +namelist /inparm/ first , other + +other = 1 + +open(99, file="test.inp") +write(99, '(a)') nml_str +rewind(99) +read(99,nml=inparm) +close(99, status="delete") + +if (.not.first .or. any (other /= [3,2,1,1])) stop 1 + +other = 9 + +open(99, file="test.inp") +write(99, '(a)') nml_str2 +rewind(99) +read(99,nml=inparm) +close(99, status="delete") + +if (.not.first .or. any (other /= [3,2,9,9])) stop 2 + +ints = 66 + +open(99, file="test.inp", decimal='point') +write(99, '(a)') str +rewind(99) +read(99,*) ints +close(99, status="delete") + +if (any (ints /= [1,2,3,4,5,66])) stop 3 + +ints = 77 + +open(99, file="test.inp", decimal='comma') +write(99, '(a)') str2 +rewind(99) +read(99,*) ints +close(99, status="delete") + +if (any (ints /= [1,2,3,4,5,77])) stop 4 +end diff --git a/Fortran/gfortran/regression/pr114304.f90 b/Fortran/gfortran/regression/pr114304.f90 new file mode 100644 index 000000000..2f913f1ab --- /dev/null +++ b/Fortran/gfortran/regression/pr114304.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! +! PR fortran/114304 +! +! See also PR fortran/105473 +! +! Testing: Does list-directed reading an integer/real allow some non-integer input? +! +! Note: GCC result comments before fix of this PR. + + implicit none + call t(.true., 'comma', ';') ! No error shown + call t(.false., 'point', ';') ! /!\ gfortran: no error, others: error + call t(.false., 'comma', ',') ! Error shown + call t(.true., 'point', ',') ! No error shown + call t(.false., 'comma', '.') ! Error shown + call t(.false., 'point', '.') ! Error shown + call t(.false., 'comma', '5.') ! Error shown + call t(.false., 'point', '5.') ! gfortran/flang: Error shown, ifort: no error + call t(.false., 'comma', '5,') ! gfortran: error; others: no error + call t(.true., 'point', '5,') ! No error shown + call t(.true., 'comma', '5;') ! No error shown + call t(.false., 'point', '5;') ! /!\ gfortran: no error shown, others: error + call t(.true., 'comma', '7 .') ! No error shown + call t(.true., 'point', '7 .') ! No error shown + call t(.true., 'comma', '7 ,') ! /!\ gfortran: error; others: no error + call t(.true., 'point', '7 ,') ! No error shown + call t(.true., 'comma', '7 ;') ! No error shown + call t(.true., 'point', '7 ;') ! No error shown + +! print *, '---------------' + + call t(.false., 'comma', '8.', .true.) ! Error shown + call t(.true., 'point', '8.', .true.) ! gfortran/flang: Error shown, ifort: no error + call t(.true., 'comma', '8,', .true.) ! gfortran: error; others: no error + call t(.true., 'point', '8,', .true.) ! No error shown + call t(.true., 'comma', '8;', .true.) ! No error shown + call t(.false., 'point', '8;', .true.) ! /!\ gfortran: no error shown, others: error + call t(.true., 'comma', '9 .', .true.) ! No error shown + call t(.true., 'point', '9 .', .true.) ! No error shown + call t(.true., 'comma', '9 ,', .true.) ! /!\ gfortran: error; others: no error + call t(.true., 'point', '9 ,', .true.) ! No error shown + call t(.true., 'comma', '9 ;', .true.) ! No error shown + call t(.true., 'point', '9 ;', .true.) ! No error shown + call t(.false., 'comma', '3,3.', .true.) ! Error shown + call t(.false., 'point', '3.3.', .true.) ! Error shown + call t(.false., 'comma', '3,3,', .true.) ! gfortran/flang: no error; ifort: error + call t(.true., 'comma', '3,3;', .true.) ! No error shown + call t(.false., 'point', '3.3;', .true.) ! gfortran/flang: no error; ifort: error + call t(.true., 'comma', '4,4 .', .true.) ! N error shown + call t(.true., 'point', '4.4 .', .true.) ! No error shown + call t(.true., 'comma', '4,4 ,', .true.) ! /!\ gfortran: error; others: no error + call t(.true., 'point', '4.4 ,', .true.) ! No error shown + call t(.true., 'comma', '4,4 ;', .true.) ! No error shown + call t(.true., 'point', '4.4 ;', .true.) ! No error shown + +! print *, '---------------' + + call t(.true., 'comma', '8', .true.) + call t(.true., 'point', '8', .true.) + call t(.true., 'point', '9 ;', .true.) + call t(.true., 'comma', '3;3.', .true.) + call t(.true., 'point', '3,3.', .true.) + call t(.true., 'comma', '3;3,', .true.) + call t(.true., 'comma', '3;3;', .true.) + call t(.true., 'point', '3,3;', .true.) + call t(.true., 'comma', '4;4 .', .true.) + call t(.true., 'point', '4,4 .', .true.) + call t(.true., 'comma', '4;4 ,', .true.) + call t(.true., 'point', '4,4 ,', .true.) + call t(.true., 'comma', '4;4 ;', .true.) + call t(.true., 'point', '4,4 ;', .true.) + + call t2('comma', ',2') + call t2('point', '.2') + call t2('comma', ',2;') + call t2('point', '.2,') + call t2('comma', ',2 ,') + call t2('point', '.2 .') +contains +subroutine t2(dec, testinput) + character(*) :: dec, testinput + integer ios + real :: r + r = 42 + read(testinput,*,decimal=dec, iostat=ios) r + if (ios /= 0 .or. abs(r - 0.2) > epsilon(r)) then + stop 3 + end if +end +subroutine t(valid, dec, testinput, isreal) + logical, value :: valid + character(len=*) :: dec, testinput + logical, optional :: isreal + logical :: isreal2 + integer n,ios + real :: r + r = 42; n = 42 + isreal2 = .false. + if (present(isreal)) isreal2 = isreal + + if (isreal2) then + read(testinput,*,decimal=dec,iostat=ios) r + if ((valid .and. ios /= 0) .or. (.not.valid .and. ios == 0)) then + stop 1 + end if + else + read(testinput,*,decimal=dec,iostat=ios) n + if ((valid .and. ios /= 0) .or. (.not.valid .and. ios == 0)) then + stop 1 + end if + end if +end +end program diff --git a/Fortran/gfortran/regression/pr114535d.f90 b/Fortran/gfortran/regression/pr114535d.f90 new file mode 100644 index 000000000..7ce178a1e --- /dev/null +++ b/Fortran/gfortran/regression/pr114535d.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-compile-aux-modules "pr114535iv.f90" } +! Contributed by Andrew Benson +! +module d + implicit none +contains + function en() result(dd) + use :: iv + implicit none + type(vs) :: dd + dd%i = 1 + end function en +end module d + +! Delete line 1 and all brands complain that 'vs' is an undefined type. +! Delete lines 1 and line 2 recreates the original problem. +module ni + implicit none +contains + subroutine iss1() +! use :: iv ! line 1 + use :: d + implicit none +! type(vs) :: ans; ans = en(); ! line 2 + end subroutine iss1 + subroutine iss2() + use :: d + implicit none + end subroutine iss2 +end module ni ! Used to give an ICE: in gfc_trans_call, at fortran/trans-stmt.cc:400 + + use ni + use iv + type(vs) :: x + call iss1() + call iss1() + if ((ctr .eq. 0) .or. (ctr .ne. 6)) stop 1 ! Depends whether lines 1 & 2 are present + call iss2() + x = vs(42) + if ((ctr .eq. 1) .or. (ctr .ne. 7)) stop 2 ! Make sure destructor available here +end diff --git a/Fortran/gfortran/regression/pr114535iv.f90 b/Fortran/gfortran/regression/pr114535iv.f90 new file mode 100644 index 000000000..be6299910 --- /dev/null +++ b/Fortran/gfortran/regression/pr114535iv.f90 @@ -0,0 +1,18 @@ +! Compiled with pr114535d.f90 +! Contributed by Andrew Benson +! +module iv + type, public :: vs + integer :: i + contains + final :: destructor + end type vs + integer :: ctr = 0 +contains + impure elemental subroutine destructor(s) + type(vs), intent(inout) :: s + s%i = 0 + ctr = ctr + 1 + end subroutine destructor +end module iv + diff --git a/Fortran/gfortran/regression/pr114739.f90 b/Fortran/gfortran/regression/pr114739.f90 new file mode 100644 index 000000000..eb82cb3f6 --- /dev/null +++ b/Fortran/gfortran/regression/pr114739.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! The fix here was triggered by an ICE prior to r14-9489-g3fd46d859cda10 +! Before that gfortran gave an incorrect "no implicit type" error for all +! three statements. +program main + implicit complex(z) + implicit character(c) + z2%re = 1. + z2%im = 2. + print *, z2, c%kind +end diff --git a/Fortran/gfortran/regression/pr114874_1.f90 b/Fortran/gfortran/regression/pr114874_1.f90 new file mode 100644 index 000000000..e385bb156 --- /dev/null +++ b/Fortran/gfortran/regression/pr114874_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Test fix for regression caused by r14-9489 - valid code only. +! Contributed by Harald Anlauf +! +module p + implicit none +contains + subroutine foo + class(*), allocatable :: c + c = 'abc' + select type (c) + type is (character(*)) + if (c .ne. 'abc') stop 1 +! Regression caused ICE here - valid substring reference + if (c(2:2) .ne. 'b') stop 2 + end select + end + subroutine bar ! This worked correctly + class(*), allocatable :: c(:) + c = ['abc','def'] + select type (c) + type is (character(*)) + if (any (c .ne. ['abc','def'])) stop 3 + if (any (c(:)(2:2) .ne. ['b','e'])) stop 4 + end select + end +end module p + + use p + call foo + call bar +end diff --git a/Fortran/gfortran/regression/pr114874_2.f90 b/Fortran/gfortran/regression/pr114874_2.f90 new file mode 100644 index 000000000..5028830ca --- /dev/null +++ b/Fortran/gfortran/regression/pr114874_2.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! Test fix for regression caused by r14-9489 - invalid code. +! Contributed by Harald Anlauf + +module q + type :: s + integer :: j + end type + type :: t + integer :: i + class(s), allocatable :: ca + end type +contains + subroutine foobar + class(*), allocatable :: c + c = t (1) + select type (c) + type is (t) +! Regression caused ICE here in translation or error was missed - invalid array reference + if (c(1)%i .ne. 1) stop 5 ! { dg-error "Syntax error in IF-expression" } + if (allocated (c%ca)) then +! Make sure that response is correct if problem is "nested". + select type (ca => c%ca) + type is (s) +! Regression caused ICE here in translation or error was missed - invalid array reference + if (ca(1)%j .ne. 1) stop 6 ! { dg-error "Syntax error in IF-expression" } + end select + select type (ca(1) => c%ca) ! { dg-error "parse error in SELECT TYPE" } + type is (s) ! { dg-error "Unexpected TYPE IS statement" } + if (ca(1)%j .ne. 1) stop 6 ! { dg-error "nonderived-type variable" } + end select ! { dg-error " Expecting END IF statement" } + endif + end select + +! This problem was found in the course of the fix: Chunk taken from associate_64.f90, +! the derived type and component names adapted and the invalid array reference added. + associate (var4 => bar4()) + if (var4%i .ne. 84) stop 33 + if (var4%ca%j .ne. 168) stop 34 + select type (x => var4) + type is (t) + if (x(1)%i .ne. var4%i) stop 35 ! { dg-error "Invalid array reference" } + if (x%ca%j .ne. var4%ca%j) stop 36 + class default + stop 37 + end select + end associate + end + function bar4() result(res) + class(t), allocatable :: res + res = t(84, s(168)) + end +end module q diff --git a/Fortran/gfortran/regression/pr114883.f90 b/Fortran/gfortran/regression/pr114883.f90 new file mode 100644 index 000000000..3fec1d278 --- /dev/null +++ b/Fortran/gfortran/regression/pr114883.f90 @@ -0,0 +1,53 @@ +! PR tree-optimization/114883 +! { dg-do compile } +! { dg-options "-O2 -fvect-cost-model=cheap" } +! { dg-additional-options "-march=x86-64-v4" { target i?86-*-* x86_64-*-* } } + +subroutine pr114883_1(a, b, c, d, e, f, g, h, o) + real(8) :: c(1011), d(1011), e(0:1011) + real(8) :: p, q, f, r, g(1011), h(1011), b, bar + integer :: o(100), a, t, u + p = 0.0_8 + r = bar() + u = 1 + do i = 1,a + do k = 1,1011 + km1 = max0(k-1,1) + h(k) = c(k) * e(k-1) * d(km1) + f = g(k) + h(k) + if(f.gt.1.e-6)then + p = min(p,r) + endif + end do + q = 0.9_8 * p + t = integer(b/q + 1) + if(t>100)then + u = t + endif + o(u) = o(u) + 1 + end do +end subroutine pr114883_1 +subroutine pr114883_2(a, b, c, d, e, f, g, h, o) + real(8) :: c(1011), d(1011), e(0:1011) + real(8) :: p, q, f, r, g(1011), h(1011), b, bar + integer :: o(100), a, t, u + p = 0.0_8 + r = bar() + u = 1 + do i = 1,a + do k = 1,1011 + km1 = max0(k-1,1) + h(k) = c(k) * e(k-1) * d(km1) + f = g(k) + h(k) + if(f.gt.1.e-6)then + p = max(p,r) + endif + end do + q = 0.9_8 * p + t = integer(b/q + 1) + if(t>100)then + u = t + endif + o(u) = o(u) + 1 + end do +end subroutine pr114883_2 diff --git a/Fortran/gfortran/regression/pr114959.f90 b/Fortran/gfortran/regression/pr114959.f90 new file mode 100644 index 000000000..5cc3c052c --- /dev/null +++ b/Fortran/gfortran/regression/pr114959.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Fix the regression caused by r14-9752 (fix for PR112407) +! Contributed by Orion Poplawski +! Problem isolated by Jakub Jelinek and further +! reduced here. +! +module m + type :: smoother_type + integer :: i + end type + type :: onelev_type + class(smoother_type), allocatable :: sm + class(smoother_type), allocatable :: sm2a + end type +contains + subroutine save_smoothers(level,save1, save2) + Implicit None + type(onelev_type), intent(inout) :: level + class(smoother_type), allocatable , intent(inout) :: save1, save2 + integer(4) :: info + + info = 0 +! r14-9752 causes the 'stat' declaration from the first ALLOCATE statement +! to disappear, which triggers an ICE in gimplify_var_or_parm_decl. The +! second ALLOCATE statement has to be present for the ICE to occur. + allocate(save1, mold=level%sm,stat=info) + allocate(save2, mold=level%sm2a,stat=info) + end subroutine save_smoothers +end module m +! Two 'stat's from the allocate statements and two from the final wrapper. +! { dg-final { scan-tree-dump-times "integer\\(kind..\\) stat" 4 "original" } } diff --git a/Fortran/gfortran/regression/pr115281.f90 b/Fortran/gfortran/regression/pr115281.f90 new file mode 100644 index 000000000..80aa822e7 --- /dev/null +++ b/Fortran/gfortran/regression/pr115281.f90 @@ -0,0 +1,39 @@ +! { dg-options "-O3" } +! { dg-additional-options "-mcpu=neoverse-v1" { target aarch64*-*-* } } + +SUBROUTINE fn0(ma, mb, nt) + CHARACTER ca + REAL r0(ma) + INTEGER i0(mb) + REAL r1(3,mb) + REAL r2(3,mb) + REAL r3(3,3) + zero=0.0 + do na = 1, nt + nt = i0(na) + do l = 1, 3 + r1 (l, na) = r0 (nt) + r2(l, na) = zero + enddo + enddo + if (ca .ne.'z') then + do j = 1, 3 + do i = 1, 3 + r4 = zero + enddo + enddo + do na = 1, nt + do k = 1, 3 + do l = 1, 3 + do m = 1, 3 + r3 = r4 * v + enddo + enddo + enddo + do i = 1, 3 + do k = 1, ifn (r3) + enddo + enddo + enddo + endif +END diff --git a/Fortran/gfortran/regression/pr25623-2.f90 b/Fortran/gfortran/regression/pr25623-2.f90 new file mode 100644 index 000000000..c7a4fe0c3 --- /dev/null +++ b/Fortran/gfortran/regression/pr25623-2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-optimized-blocks-details -O3" } + +SUBROUTINE S42(a,b,c,N) + IMPLICIT NONE + integer :: N + real*8 :: a(N),b(N),c(N),tmp,tmp2,tmp4 + real*8, parameter :: p=1.0D0/3.0D0 + integer :: i + c=0.0D0 + DO i=1,N + tmp=a(i)**p ! could even be done with a cube root + tmp2=tmp*tmp + tmp4=tmp2*tmp2 + b(i)=b(i)+tmp4 + c(i)=c(i)+tmp2 + ENDDO +END SUBROUTINE +! { dg-final { scan-tree-dump-not "Invalid sum" "optimized" } } diff --git a/Fortran/gfortran/regression/pr25623.f90 b/Fortran/gfortran/regression/pr25623.f90 new file mode 100644 index 000000000..7302f3718 --- /dev/null +++ b/Fortran/gfortran/regression/pr25623.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-optimized-blocks-details -O2" } + +SUBROUTINE S42(a,b,c,N) + IMPLICIT NONE + integer :: N + real*8 :: a(N),b(N),c(N),tmp,tmp2,tmp4 + real*8, parameter :: p=1.0D0/3.0D0 + integer :: i + c=0.0D0 + DO i=1,N + tmp=a(i)**p ! could even be done with a cube root + tmp2=tmp*tmp + tmp4=tmp2*tmp2 + b(i)=b(i)+tmp4 + c(i)=c(i)+tmp2 + ENDDO +END SUBROUTINE +! { dg-final { scan-tree-dump-not "Invalid sum" "optimized" } } diff --git a/Fortran/gfortran/regression/pr43984.f90 b/Fortran/gfortran/regression/pr43984.f90 index 130d11446..dce26b0ef 100644 --- a/Fortran/gfortran/regression/pr43984.f90 +++ b/Fortran/gfortran/regression/pr43984.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O2 -fno-tree-dominator-opts -fdump-tree-pre" } +! { dg-options "-O2 -fno-tree-dominator-opts -fdump-tree-pre -fno-tree-sra" } module test type shell1quartet_type diff --git a/Fortran/gfortran/regression/pr49213.f90 b/Fortran/gfortran/regression/pr49213.f90 new file mode 100644 index 000000000..293dce848 --- /dev/null +++ b/Fortran/gfortran/regression/pr49213.f90 @@ -0,0 +1,109 @@ +! { dg-do run } +! +! Contributed by Neil Carlson +! +program main + character(2) :: c + + type :: S + integer :: n + end type + type(S) :: Sobj + + type, extends(S) :: S2 + integer :: m + end type + type(S2) :: S2obj + + type :: T + class(S), allocatable :: x + end type + + type tContainer + class(*), allocatable :: x + end type + + type(T) :: Tobj + + Sobj = S(1) + Tobj = T(Sobj) + + S2obj = S2(1,2) + Tobj = T(S2obj) ! Failed here + select type (x => Tobj%x) + type is (S2) + if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 1 + class default + stop 2 + end select + + c = " " + call pass_it (T(Sobj)) + if (c .ne. "S ") stop 3 + call pass_it (T(S2obj)) ! and here + if (c .ne. "S2") stop 4 + + call bar + +contains + + subroutine pass_it (foo) + type(T), intent(in) :: foo + select type (x => foo%x) + type is (S) + c = "S " + if (x%n .ne. 1) stop 5 + type is (S2) + c = "S2" + if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 6 + class default + stop 7 + end select + end subroutine + + subroutine check_it (t, errno) + type(tContainer) :: t + integer :: errno + select type (x => t%x) + type is (integer) + if (x .ne. 42) stop errno + type is (integer(8)) + if (x .ne. 42_8) stop errno + type is (real(8)) + if (int(x**2) .ne. 2) stop errno + type is (character(*, kind=1)) + if (x .ne. "end of tests") stop errno + type is (character(*, kind=4)) + if ((x .ne. 4_"hello!") .and. (x .ne. 4_"goodbye")) stop errno + class default + stop errno + end select + end subroutine + + subroutine bar + ! Test from comment #29 extended by Harald Anlauf to check kinds /= default + integer(8), parameter :: i = 0_8 + integer :: j = 42 + character(7,kind=4) :: chr4 = 4_"goodbye" + type(tContainer) :: cont + + cont%x = j + call check_it (cont, 8) + + cont = tContainer(i+42_8) + call check_it (cont, 9) + + cont = tContainer(sqrt (2.0_8)) + call check_it (cont, 10) + + cont = tContainer(4_"hello!") + call check_it (cont, 11) + + cont = tContainer(chr4) + call check_it (cont, 12) + + cont = tContainer("end of tests") + call check_it (cont, 13) + + end subroutine bar +end program diff --git a/Fortran/gfortran/regression/pr67740.f90 b/Fortran/gfortran/regression/pr67740.f90 new file mode 100644 index 000000000..bf70ff223 --- /dev/null +++ b/Fortran/gfortran/regression/pr67740.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for the testcase in comment 4, where the hidden string length +! component of the array pointer component was not set. +! +! Contributed by Sebastien Bardeau +! +program test2 + implicit none + character(len=10), allocatable, target :: s(:) + character(len=:), pointer :: sptr(:) + type :: pointer_typec0_t + character(len=:), pointer :: data0 + character(len=:), pointer :: data1(:) + end type pointer_typec0_t + type(pointer_typec0_t) :: co + ! + allocate(s(3)) + s(1) = '1234567890' + s(2) = 'qwertyuio ' + s(3) = 'asdfghjk ' + ! + sptr => s + co%data0 => s(1) + co%data1 => s + ! + if (any (sptr .ne. s)) stop 1 + if (co%data0 .ne. s(1)) stop 2 + if (any (co%data1 .ne. s)) stop 3 ! Hidden string length was not set +end program test2 +! { dg-final { scan-tree-dump-times "co._data1_length = 10;" 1 "original" } } \ No newline at end of file diff --git a/Fortran/gfortran/regression/pr68155.f90 b/Fortran/gfortran/regression/pr68155.f90 new file mode 100644 index 000000000..2bd6f7880 --- /dev/null +++ b/Fortran/gfortran/regression/pr68155.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Fix for PR68155 in which initializers of constant length, character +! components of derived types were not being padded if they were too short. +! Originally, mismatched lengths caused ICEs. This seems to have been fixed +! in 9-branch. +! +! Contributed by Gerhard Steinmetz +! +program p + implicit none + type t + character(3) :: c1(2) = [ 'b', 'c'] ! OK + character(3) :: c2(2) = [ character(1) :: 'b', 'c'] // "" ! OK + character(3) :: c3(2) = [ 'b', 'c'] // "" ! was not padded + character(3) :: c4(2) = [ '' , '' ] // "" ! was not padded + character(3) :: c5(2) = [ 'b', 'c'] // 'a' ! was not padded + character(3) :: c6(2) = [ 'b', 'c'] // 'ax' ! OK + character(3) :: c7(2) = [ 'b', 'c'] // 'axy' ! OK trimmed + end type t + type(t) :: z + if (z%c1(2) .ne. 'c ') stop 1 + if (z%c2(2) .ne. 'c ') stop 2 + if (z%c3(2) .ne. 'c ') stop 3 + if (z%c4(2) .ne. ' ') stop 4 + if (z%c5(2) .ne. 'ca ') stop 5 + if (z%c6(2) .ne. 'cax') stop 6 + if (z%c7(2) .ne. 'cax') stop 7 +end diff --git a/Fortran/gfortran/regression/pr78061.f b/Fortran/gfortran/regression/pr78061.f index 7e4dd3de8..9061dea74 100644 --- a/Fortran/gfortran/regression/pr78061.f +++ b/Fortran/gfortran/regression/pr78061.f @@ -1,6 +1,6 @@ ! { dg-do compile } ! { dg-options "-O3 -fsplit-loops" } - SUBROUTINE SSYMM(C) + SUBROUTINE SSYMM(C,LDC) REAL C(LDC,*) LOGICAL LSAME LOGICAL UPPER diff --git a/Fortran/gfortran/regression/pr79315.f90 b/Fortran/gfortran/regression/pr79315.f90 index 8cd89691c..b754a2b32 100644 --- a/Fortran/gfortran/regression/pr79315.f90 +++ b/Fortran/gfortran/regression/pr79315.f90 @@ -10,7 +10,11 @@ SUBROUTINE wsm32D(t, & its,& ite, & kts, & - kte & + kte, & + ims, & + ime, & + kms, & + kme & ) REAL, DIMENSION( its:ite , kts:kte ), & INTENT(INOUT) :: & diff --git a/Fortran/gfortran/regression/pr82774.f90 b/Fortran/gfortran/regression/pr82774.f90 new file mode 100644 index 000000000..81c22ab38 --- /dev/null +++ b/Fortran/gfortran/regression/pr82774.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! Contributed by Steve Kargl +! +program main + implicit none + type stuff + character(:), allocatable :: key + end type stuff + type(stuff) nonsense, total + nonsense = stuff('Xe') + total = stuff(nonsense%key) ! trim nonsense%key made this work + if (nonsense%key /= total%key) call abort + if (len(total%key) /= 2) call abort +end program main diff --git a/Fortran/gfortran/regression/pr84868.f90 b/Fortran/gfortran/regression/pr84868.f90 new file mode 100644 index 000000000..459a1c3c8 --- /dev/null +++ b/Fortran/gfortran/regression/pr84868.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! Test the fix for PR84868. Module 'orig' and the call to 'f_orig' is the +! original bug. The rest tests variants and the fix for a gimplifier ICE. +! +! Subroutine 'h' and calls to it were introduced to check the corrections +! needed to fix additional problems, noted in the review of the patch by +! Harald Anlauf +! +! Contributed by Gerhard Steinmetz +! +module orig + character(:), allocatable :: c + integer :: ans1(3,3), ans2(3), ans3(2) +contains + function f_orig(n) result(z) + character(2), parameter :: c(3) = ['x1', 'y ', 'z2'] + integer, intent(in) :: n + character(len_trim(c(n))) :: z + z = c(n) + end + function h(n) result(z) + integer, intent(in) :: n + character(2), parameter :: c(3,3) = & + reshape (['ab','c ','de','f ','gh','i ','jk','l ','mn'],[3,3]) + character(4), parameter :: chr(3) = ['ab ',' cd','e f '] + character(len_trim(c(n,n))) :: z + z = c(n,n) +! Make sure that full arrays are correctly scalarized both having been previously +! used with an array reference and not previously referenced. + ans1 = len_trim (c) + ans2 = len_trim (chr) +! Finally check a slightly more complicated array reference + ans3 = len_trim (c(1:n+1:2,n-1)) + end +end module orig + +module m + character(:), allocatable :: c +contains + function f(n, c) result(z) + character (2) :: c(:) + integer, intent(in) :: n + character(len_trim(c(n))) :: z + z = c(n) + end + subroutine foo (pc) + character(2) :: pc(:) + if (any ([(len (f(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 1 + end +end +program p + use m + use orig + character (2) :: pc(3) = ['x1', 'y ', 'z2'] + integer :: i + + if (any ([(len (f_orig(i)), i = 1,3)] .ne. [2,1,2])) stop 2 ! ICE + + call foo (pc) + if (any ([(len (g(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 3 + if (any ([(bar1(i), i = 1,3)] .ne. [2,1,2])) stop 4 + if (any ([(bar2(i), i = 1,3)] .ne. [2,1,2])) stop 5 + + if (h(2) .ne. 'gh') stop 6 + if (any (ans1 .ne. reshape ([2,1,2,1,2,1,2,1,2],[3,3]))) stop 7 + if (any (ans2 .ne. [2,4,3])) stop 8 + if (any (ans3 .ne. [2,2])) stop 9 +contains + function g(n, c) result(z) + character (2) :: c(:) + integer, intent(in) :: n + character(len_trim(c(n))) :: z + z = c(n) + end + integer function bar1 (i) + integer :: i + bar1 = len (f(i, pc)) ! ICE in is_gimple_min_invariant + end + integer function bar2 (i) + integer :: i + bar2 = len (g(i, pc)) + end +end diff --git a/Fortran/gfortran/regression/pr87907.f90 b/Fortran/gfortran/regression/pr87907.f90 index 0fe4e5090..5c2acaf9b 100644 --- a/Fortran/gfortran/regression/pr87907.f90 +++ b/Fortran/gfortran/regression/pr87907.f90 @@ -12,12 +12,14 @@ module function g(x) result(z) submodule(m) m2 contains - subroutine g(x) ! { dg-error "mismatch in argument" } + subroutine g(x) ! { dg-error "FUNCTION attribute conflicts with SUBROUTINE" } end end program p - use m ! { dg-error "has a type" } + use m integer :: x = 3 - call g(x) ! { dg-error "which is not consistent with" } + call g(x) end + +! { dg-prune-output "Two main PROGRAMs" } diff --git a/Fortran/gfortran/regression/pr87946.f90 b/Fortran/gfortran/regression/pr87946.f90 new file mode 100644 index 000000000..793d37a7f --- /dev/null +++ b/Fortran/gfortran/regression/pr87946.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Contributed by Gerhard Steinmetz +! +module m + type t + contains + generic :: h => g + procedure, private :: g + end type +contains + function g(x, y) result(z) + class(t), intent(in) :: x + real, intent(in) :: y(:, :) + real :: z(size(y, 2)) + integer :: i + do i = 1, size(y, 2) + z(i) = i + end do + end +end +module m2 + use m + type t2 + class(t), allocatable :: u(:) + end type +end + use m2 + type(t2) :: x + real :: y(1,5) + allocate (x%u(1)) + if (any (int(f (x, y)) .ne. [1,2,3,4,5])) stop 1 + deallocate (x%u) +contains + function f(x, y) result(z) + use m2 + type(t2) :: x + real :: y(:, :) + real :: z(size(y, 2)) + z = x%u(1)%h(y) ! Used to segfault here + end +end diff --git a/Fortran/gfortran/regression/pr88138.f90 b/Fortran/gfortran/regression/pr88138.f90 index c4019a6ca..f1130cf2b 100644 --- a/Fortran/gfortran/regression/pr88138.f90 +++ b/Fortran/gfortran/regression/pr88138.f90 @@ -1,5 +1,6 @@ ! { dg-do compile } program p + implicit none type t character :: c = 'c' end type diff --git a/Fortran/gfortran/regression/pr88552.f90 b/Fortran/gfortran/regression/pr88552.f90 new file mode 100644 index 000000000..15e1b372f --- /dev/null +++ b/Fortran/gfortran/regression/pr88552.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/88552 +! Contributed by G.Steinmetz + +integer(len((c)) :: n ! { dg-error "must be CHARACTER" } +end diff --git a/Fortran/gfortran/regression/pr88624.f90 b/Fortran/gfortran/regression/pr88624.f90 new file mode 100644 index 000000000..e88ac907c --- /dev/null +++ b/Fortran/gfortran/regression/pr88624.f90 @@ -0,0 +1,21 @@ +!{ dg-do compile } +!{ dg-options "-fcoarray=lib" } + +! Check that PR fortran/88624 is fixed. +! Contributed by Modrzejewski +! Reduced to the essence of the issue. + +program test + implicit none + integer, dimension(:), allocatable :: x[:] + call g(x) +contains + subroutine g(x) + integer, dimension(:), allocatable :: x[:] + call g2(x) + end subroutine g + subroutine g2(x) + integer, dimension(:) :: x[*] + end subroutine g2 +end program test + diff --git a/Fortran/gfortran/regression/pr88688.f90 b/Fortran/gfortran/regression/pr88688.f90 new file mode 100644 index 000000000..3d65118aa --- /dev/null +++ b/Fortran/gfortran/regression/pr88688.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! +! Contributed by Thomas Fanning +! +! +module mod + + type test + class(*), pointer :: ptr + contains + procedure :: setref + end type + +contains + + subroutine setref(my,ip) + implicit none + class(test) :: my + integer, pointer :: ip + my%ptr => ip + end subroutine + + subroutine set7(ptr) + implicit none + class(*), pointer :: ptr + select type (ptr) + type is (integer) + ptr = 7 + end select + end subroutine + +end module +!--------------------------------------- + +!--------------------------------------- +program bug +use mod +implicit none + + integer, pointer :: i, j + type(test) :: tp + class(*), pointer :: lp + + allocate(i,j) + i = 3; j = 4 + + call tp%setref(i) + select type (ap => tp%ptr) + class default + call tp%setref(j) + lp => ap + call set7(lp) + end select + +! gfortran used to give i=3 and j=7 because the associate name was not pointing +! to the target of tp%ptr as required by F2018:19.5.1.6 but, rather, to the +! selector itself. + if (i .ne. 7) stop 1 + if (j .ne. 4) stop 2 + +end program +!--------------------------------------- diff --git a/Fortran/gfortran/regression/pr89462.f90 b/Fortran/gfortran/regression/pr89462.f90 new file mode 100644 index 000000000..b2a4912fc --- /dev/null +++ b/Fortran/gfortran/regression/pr89462.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-pedantic-errors" } +! Test the fix for PR89462 in which the shared 'cl' field of the typespec +! shared between 'test', 'TR' and 'aTP' caused the compiler to go into an +! infinite loop. +! Contributed by Sergei Trofimovich + CHARACTER*1 FUNCTION test(H) ! { dg-warning "Old-style character length" } + CHARACTER*1 test2,TR,aTP ! { dg-warning "Old-style character length" } + ENTRY test2(L) + CALL ttest3(aTP) + test = TR + RETURN + END diff --git a/Fortran/gfortran/regression/pr89943_3.f90 b/Fortran/gfortran/regression/pr89943_3.f90 index 38b723e24..84a9fb747 100644 --- a/Fortran/gfortran/regression/pr89943_3.f90 +++ b/Fortran/gfortran/regression/pr89943_3.f90 @@ -22,7 +22,7 @@ end module Foo_mod module subroutine runFoo4C(ndim) bind(C, name="runFu") ! { dg-error "Mismatch in BIND" } use, intrinsic :: iso_c_binding ! { dg-error "Unexpected USE statement" } implicit none ! { dg-error "Unexpected IMPLICIT NONE statement" } - integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Unexpected data declaration" } + integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Symbol 'c_int32_t' at .1. has no IMPLICIT type" } end subroutine runFoo4C ! { dg-error " Expecting END SUBMODULE" } end submodule Foo_smod diff --git a/Fortran/gfortran/regression/pr89943_4.f90 b/Fortran/gfortran/regression/pr89943_4.f90 index 8eba2eda1..cb955d01c 100644 --- a/Fortran/gfortran/regression/pr89943_4.f90 +++ b/Fortran/gfortran/regression/pr89943_4.f90 @@ -23,7 +23,7 @@ end module Foo_mod module function runFoo4C(ndim) bind(C, name="runFu") ! { dg-error "Mismatch in BIND" } use, intrinsic :: iso_c_binding ! { dg-error "Unexpected USE statement in" } implicit none ! { dg-error "Unexpected IMPLICIT NONE statement" } - integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Unexpected data declaration" } + integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Symbol 'c_int32_t' at .1. has no IMPLICIT type" } end function runFoo4C ! { dg-error "Expecting END SUBMODULE" } end submodule Foo_smod diff --git a/Fortran/gfortran/regression/pr92586.f90 b/Fortran/gfortran/regression/pr92586.f90 new file mode 100644 index 000000000..40ad50cb7 --- /dev/null +++ b/Fortran/gfortran/regression/pr92586.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! +! Contributed by Emanuele Pagone +! +module foo_m + implicit none + + type :: string + character(len=:), allocatable :: s + end type string + + type :: foo_t + type(string), allocatable :: foo_s(:) + contains + procedure, public :: get_s + end type foo_t + + type :: data_t + integer :: n_foo_s + type(foo_t), allocatable :: foo(:) + contains + procedure, public :: data_get_foo_s + end type data_t + +contains + + function get_s(self) + class(foo_t), intent(in) :: self + type(string) :: get_s( size(self%foo_s) ) + get_s = self%foo_s + end function get_s + + function data_get_foo_s(self, ith) + class(data_t), intent(in) :: self + integer, intent(in) :: ith + type(string) :: data_get_foo_s(self%n_foo_s) + + data_get_foo_s = self%foo(ith)%get_s() ! The lhs was not dereferenced in a byref call. + + end function data_get_foo_s + +end module foo_m + + +program bug_stringifor + use foo_m + implicit none + + type(data_t) :: data + type(string), allocatable :: bar(:) + + allocate( data%foo(1) ) + data%foo(1)%foo_s = [string("alpha"), string("bravo"), string("charlie"), & + string("delta"), string("foxtrot")] + data%n_foo_s = 5 + + bar = data%data_get_foo_s(1) + + print *, "bar = ", bar(1)%s + +end program bug_stringifor diff --git a/Fortran/gfortran/regression/pr93635.f90 b/Fortran/gfortran/regression/pr93635.f90 new file mode 100644 index 000000000..4ef33fecf --- /dev/null +++ b/Fortran/gfortran/regression/pr93635.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/93635 +! +! Test that some attribute conflicts are properly diagnosed + +program p + implicit none + character(len=:),allocatable :: r,s + namelist /args/ r,s + equivalence(r,s) ! { dg-error "EQUIVALENCE attribute conflicts with ALLOCATABLE" } + allocate(character(len=1024) :: r) +end + +subroutine sub (p, q) + implicit none + real, pointer, intent(inout) :: p(:), q(:) + namelist /nml/ p,q + equivalence(p,q) ! { dg-error "EQUIVALENCE attribute conflicts with DUMMY" } +end diff --git a/Fortran/gfortran/regression/pr93678.f90 b/Fortran/gfortran/regression/pr93678.f90 new file mode 100644 index 000000000..403bedd0c --- /dev/null +++ b/Fortran/gfortran/regression/pr93678.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Test the fix for PR93678 in which the charlen for the 'unpackbytes' +! vtable field was incomplete and caused the ICE as indicated. +! Contributed by Luis Kornblueh +! +! The testcase was reduced by various gfortran regulars. +module mo_a + implicit none + type t_b + integer :: i + contains + procedure :: unpackbytes => b_unpackbytes + end type t_b +contains + function b_unpackbytes (me) result (res) + class(t_b), intent(inout) :: me + character :: res(1) + res = char (me%i) + end function b_unpackbytes + subroutine b_unpackint (me, c) + class(t_b), intent(inout) :: me + character, intent(in) :: c +! print *, b_unpackbytes (me) ! ok + if (any (me% unpackbytes () .ne. c)) stop 1 ! ICEd here + end subroutine b_unpackint +end module mo_a + + use mo_a + class(t_b), allocatable :: z + allocate (z, source = t_b(97)) + call b_unpackint (z, "a") +end diff --git a/Fortran/gfortran/regression/pr94380.f90 b/Fortran/gfortran/regression/pr94380.f90 new file mode 100644 index 000000000..e29594f2f --- /dev/null +++ b/Fortran/gfortran/regression/pr94380.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Contributed by Vladimir Nikishkin +! +module test + type testtype + class(*), allocatable :: t + end type testtype +contains + subroutine testproc( x ) + class(testtype) :: x + associate ( temp => x%t) + select type (temp) + type is (integer) + end select + end associate + end subroutine testproc +end module test diff --git a/Fortran/gfortran/regression/pr95398.f90 b/Fortran/gfortran/regression/pr95398.f90 index 81cc076c1..7576f3844 100644 --- a/Fortran/gfortran/regression/pr95398.f90 +++ b/Fortran/gfortran/regression/pr95398.f90 @@ -1,5 +1,7 @@ ! { dg-do compile } +! { dg-options "-std=f2008" } + program test implicit none @@ -46,8 +48,8 @@ subroutine sub_with_in_and_inout_param(y, z) end -! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 } -! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 } -! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 } +! { dg-error "being used in a variable definition context .assignment." " " { target *-*-* } 23 } +! { dg-error "being used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 25 } ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 } +! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 39 } diff --git a/Fortran/gfortran/regression/pr95690.f90 b/Fortran/gfortran/regression/pr95690.f90 index 47a5df9e8..143293743 100644 --- a/Fortran/gfortran/regression/pr95690.f90 +++ b/Fortran/gfortran/regression/pr95690.f90 @@ -2,8 +2,8 @@ module m contains subroutine s - print *, (erfc) ! { dg-error "not a floating constant" "" { target i?86-*-* x86_64-*-* sparc*-*-* cris-*-* } } - end ! { dg-error "not a floating constant" "" { target { ! "i?86-*-* x86_64-*-* sparc*-*-* cris-*-*" } } } + print *, (erfc) ! { dg-error "not a floating constant" "" { target i?86-*-* x86_64-*-* sparc*-*-* cris-*-* hppa*-*-* } } + end ! { dg-error "not a floating constant" "" { target { ! "i?86-*-* x86_64-*-* sparc*-*-* cris-*-* hppa*-*-*" } } } function erfc() end end diff --git a/Fortran/gfortran/regression/pr95710.f90 b/Fortran/gfortran/regression/pr95710.f90 new file mode 100644 index 000000000..566c38d0a --- /dev/null +++ b/Fortran/gfortran/regression/pr95710.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/95710 - ICE on duplicate declaration of class variable +! Contributed by G.Steinmetz + +module m + interface + module function s() + end + end interface +end +submodule(m) m2 +contains + module function s() + class(*), allocatable :: x + class(*), allocatable :: x ! { dg-error "Unclassifiable statement" } + end +end diff --git a/Fortran/gfortran/regression/pr96436_4.f90 b/Fortran/gfortran/regression/pr96436_4.f90 index 335ce5fb0..7d2cfef0e 100644 --- a/Fortran/gfortran/regression/pr96436_4.f90 +++ b/Fortran/gfortran/regression/pr96436_4.f90 @@ -17,9 +17,9 @@ if (buffer.ne.">0.30E+1<") stop 4 fmt = "(1a1,en0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00<") stop 5 +if (buffer.ne.">3.00E+0<") stop 5 fmt = "(1a1,es0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00<") stop 6 +if (buffer.ne.">3.00E+0<") stop 6 end diff --git a/Fortran/gfortran/regression/pr96436_5.f90 b/Fortran/gfortran/regression/pr96436_5.f90 index a45df8963..3870d988f 100644 --- a/Fortran/gfortran/regression/pr96436_5.f90 +++ b/Fortran/gfortran/regression/pr96436_5.f90 @@ -17,9 +17,9 @@ if (buffer.ne.">0.30E+1<") stop 4 fmt = "(1a1,en0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00<") stop 5 +if (buffer.ne.">3.00E+0<") stop 5 fmt = "(1a1,es0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00<") stop 6 +if (buffer.ne.">3.00E+0<") stop 6 end diff --git a/Fortran/gfortran/regression/pr99139.f90 b/Fortran/gfortran/regression/pr99139.f90 new file mode 100644 index 000000000..a064103cc --- /dev/null +++ b/Fortran/gfortran/regression/pr99139.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-finit-local-zero" } +! +! Contributed by Gerhard Steinmetz +! +! Original implicitly typed 'x' gave a bad symbol ICE +subroutine s1(x) + target :: x(..) + select rank (y => x) + rank (1) + rank (2) + end select +end + +! Comment #2: Failed with above option +subroutine s2(x, z) + real, target :: x(..) + real :: z(10) + select rank (y => x) ! Error was:Assumed-rank variable y at (1) may only be + ! used as actual argument + rank (1) + rank (2) + end select +end diff --git a/Fortran/gfortran/regression/pr99210.f90 b/Fortran/gfortran/regression/pr99210.f90 new file mode 100644 index 000000000..9fd2fb468 --- /dev/null +++ b/Fortran/gfortran/regression/pr99210.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR99210 X editing for reading file with encoding='utf-8' +program test_bug_format_x + use iso_fortran_env + integer, parameter :: u = selected_char_kind('ISO_10646') + + character(kind=u, len=1) a, b, a1, b1, b2 + + open(unit=10, file='test_bug_format_x.tmp', encoding='UTF-8') + + a = char(int(z'03B1'), u) + b = char(int(z'03B2'), u) + write(10, '(a1, a1)') a, b + + rewind(10) + read(10, '(a1, a1)') a1, b1 + + rewind(10) + read(10, '(1x, a1)') b2 + + close (10, status="delete") + if(a /= a1 .or. b /= b1) then + error stop 1 + end if + + if(b /= b2) then + error stop 2 + end if +end program test_bug_format_x diff --git a/Fortran/gfortran/regression/pr99326.f90 b/Fortran/gfortran/regression/pr99326.f90 new file mode 100644 index 000000000..75d1f50c2 --- /dev/null +++ b/Fortran/gfortran/regression/pr99326.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! internal compiler error: in gfc_build_dummy_array_decl, at +! fortran/trans-decl.cc:1317 +! +! Contributed by Gerhard Steinmetz +! +program p + type t0 + integer :: i + end type + type t + class(t0), allocatable :: a(:) + end type + class(t0), allocatable :: arg(:) + allocate (arg, source = [t0(1), t0(2)]) + call s(arg) +contains + subroutine s(x) + class(t0) :: x(:) + type(t) :: z + associate (y => x) + z%a = y + end associate + if (size(z%a) .ne. 2) stop 1 + end +end diff --git a/Fortran/gfortran/regression/pr99350.f90 b/Fortran/gfortran/regression/pr99350.f90 new file mode 100644 index 000000000..ec198810f --- /dev/null +++ b/Fortran/gfortran/regression/pr99350.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), pointer :: a + end type + type(t) :: z + character((0.)/0), target :: c = 'abc' ! { dg-error "Arithmetic NaN" } + z%a => c +! The associate statement was not needed to trigger the ICE. + associate (y => z%a) + print *, y + end associate +end diff --git a/Fortran/gfortran/regression/pr99368.f90 b/Fortran/gfortran/regression/pr99368.f90 new file mode 100644 index 000000000..9ba04251a --- /dev/null +++ b/Fortran/gfortran/regression/pr99368.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + type y ! { dg-error "Derived type" } + end type +contains + subroutine s1 + namelist /x/ y ! { dg-error "conflicts with namelist object" } + character(3) y + end + subroutine s2 + namelist /z/ y ! { dg-error "conflicts with namelist object" } + character(3) y + end +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/proc_ptr_53.f90 b/Fortran/gfortran/regression/proc_ptr_53.f90 new file mode 100644 index 000000000..29dd08d9f --- /dev/null +++ b/Fortran/gfortran/regression/proc_ptr_53.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR fortran/97245 - ASSOCIATED intrinsic did not recognize a +! pointer variable the second time it is used + +MODULE formulaciones + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE proc_void() + END SUBROUTINE proc_void + end INTERFACE + + PROCEDURE(proc_void), POINTER :: pADJSensib => NULL() + +CONTAINS + + subroutine calculo() + PROCEDURE(proc_void), POINTER :: otherprocptr => NULL() + + IF (associated(pADJSensib)) THEN + CALL pADJSensib () + ENDIF + IF (associated(pADJSensib)) THEN ! this was erroneously rejected + CALL pADJSensib () + END IF + + IF (associated(otherprocptr)) THEN + CALL otherprocptr () + ENDIF + IF (associated(otherprocptr)) THEN + CALL otherprocptr () + END IF + end subroutine calculo + +END MODULE formulaciones diff --git a/Fortran/gfortran/regression/proc_ptr_comp_53.f90 b/Fortran/gfortran/regression/proc_ptr_comp_53.f90 new file mode 100644 index 000000000..affb59222 --- /dev/null +++ b/Fortran/gfortran/regression/proc_ptr_comp_53.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! PR fortran/110826 - procedure pointer component in DT array + +module m + implicit none + + type pp + procedure(func_template), pointer, nopass :: f =>null() + end type pp + + abstract interface + function func_template(state) result(dstate) + implicit none + real, dimension(:,:), intent(in) :: state + real, dimension(size(state,1), size(state,2)) :: dstate + end function + end interface + +contains + + function zero_state(state) result(dstate) + real, dimension(:,:), intent(in) :: state + real, dimension(size(state,1), size(state,2)) :: dstate + dstate = 0. + end function zero_state + +end module m + +program test_func_array + use m + implicit none + + real, dimension(4,6) :: state + type(pp) :: func_scalar + type(pp) :: func_array(4) + + func_scalar %f => zero_state + func_array(1)%f => zero_state + print *, func_scalar %f(state) + print *, func_array(1)%f(state) + if (.not. all (shape (func_scalar %f(state)) == shape (state))) stop 1 + if (.not. all (shape (func_array(1)%f(state)) == shape (state))) stop 2 +end program test_func_array diff --git a/Fortran/gfortran/regression/prof/prof.exp b/Fortran/gfortran/regression/prof/prof.exp index 5f6d7dddd..1a5531485 100644 --- a/Fortran/gfortran/regression/prof/prof.exp +++ b/Fortran/gfortran/regression/prof/prof.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2001-2023 Free Software Foundation, Inc. +# Copyright (C) 2001-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/regression/ptr-func-5.f90 b/Fortran/gfortran/regression/ptr-func-5.f90 new file mode 100644 index 000000000..05fd56703 --- /dev/null +++ b/Fortran/gfortran/regression/ptr-func-5.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! PR fortran/109846 +! CLASS pointer function result in variable definition context + +module foo + implicit none + type :: parameter_list + contains + procedure :: sublist, sublist_nores + end type +contains + function sublist (this) result (slist) + class(parameter_list), intent(inout) :: this + class(parameter_list), pointer :: slist + allocate (slist) + end function + function sublist_nores (this) + class(parameter_list), intent(inout) :: this + class(parameter_list), pointer :: sublist_nores + allocate (sublist_nores) + end function +end module + +program example + use foo + implicit none + type(parameter_list) :: plist + call sub1 (plist%sublist()) + call sub1 (plist%sublist_nores()) + call sub2 (plist%sublist()) + call sub2 (plist%sublist_nores()) +contains + subroutine sub1 (plist) + type(parameter_list), intent(inout) :: plist + end subroutine + subroutine sub2 (plist) + type(parameter_list) :: plist + end subroutine +end program diff --git a/Fortran/gfortran/regression/repeat_8.f90 b/Fortran/gfortran/regression/repeat_8.f90 new file mode 100644 index 000000000..9dd379ac9 --- /dev/null +++ b/Fortran/gfortran/regression/repeat_8.f90 @@ -0,0 +1,123 @@ +! { dg-do compile } +! { dg-additional-options "-Wconversion-extra" } +! +! Test fix for PR fortran/96724 +! +! Contributed by José Rui Faustino de Sousa + +program repeat_p + use, intrinsic :: iso_fortran_env, only: int8, int16, int32, int64 + implicit none + + integer, parameter :: n = 20 + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + + integer(kind=int8), parameter :: p08 = int(n, kind=int8) + integer(kind=int16), parameter :: p16 = int(n, kind=int16) + integer(kind=int16), parameter :: p32 = int(n, kind=int32) + integer(kind=int16), parameter :: p64 = int(n, kind=int64) + + integer(kind=int8) :: i08 + integer(kind=int16) :: i16 + integer(kind=int32) :: i32 + integer(kind=int64) :: i64 + + character(len=n,kind=1) :: c + character(len=n,kind=ucs4) :: d + + i08 = p08 + c = repeat('X', 20_int8) + c = repeat('X', i08) + c = repeat('X', p08) + c = repeat('X', len08(c)) + d = repeat(ucs4_'X', 20_int8) + d = repeat(ucs4_'X', i08) + d = repeat(ucs4_'X', p08) + d = repeat(ucs4_'X', len08(c)) + i16 = p16 + c = repeat('X', 20_int16) + c = repeat('X', i16) + c = repeat('X', p16) + c = repeat('X', len16(c)) + d = repeat(ucs4_'X', 20_int16) + d = repeat(ucs4_'X', i16) + d = repeat(ucs4_'X', p16) + d = repeat(ucs4_'X', len16(c)) + i32 = p32 + c = repeat('X', 20_int32) + c = repeat('X', i32) + c = repeat('X', p32) + c = repeat('X', len32(c)) + d = repeat(ucs4_'X', 20_int32) + d = repeat(ucs4_'X', i32) + d = repeat(ucs4_'X', p32) + d = repeat(ucs4_'X', len32(c)) + i64 = p64 + c = repeat('X', 20_int64) + c = repeat('X', i64) + c = repeat('X', p64) + c = repeat('X', len64(c)) + d = repeat(ucs4_'X', 20_int64) + d = repeat(ucs4_'X', i64) + d = repeat(ucs4_'X', p64) + d = repeat(ucs4_'X', len64(c)) + +contains + + function len08(x) result(l) + character(len=*), intent(in) :: x + integer(kind=int8) :: l + + l = int(len(x), kind=int8) + end function len08 + + function len16(x) result(l) + character(len=*), intent(in) :: x + integer(kind=int16) :: l + + l = int(len(x), kind=int16) + end function len16 + + function len32(x) result(l) + character(len=*), intent(in) :: x + integer(kind=int32) :: l + + l = int(len(x), kind=int32) + end function len32 + + function len64(x) result(l) + character(len=*), intent(in) :: x + integer(kind=int64) :: l + + l = int(len(x), kind=int64) + end function len64 + + function ulen08(x) result(l) + character(len=*,kind=ucs4), intent(in) :: x + integer(kind=int8) :: l + + l = int(len(x), kind=int8) + end function ulen08 + + function ulen16(x) result(l) + character(len=*,kind=ucs4), intent(in) :: x + integer(kind=int16) :: l + + l = int(len(x), kind=int16) + end function ulen16 + + function ulen32(x) result(l) + character(len=*,kind=ucs4), intent(in) :: x + integer(kind=int32) :: l + + l = int(len(x), kind=int32) + end function ulen32 + + function ulen64(x) result(l) + character(len=*,kind=ucs4), intent(in) :: x + integer(kind=int64) :: l + + l = int(len(x), kind=int64) + end function ulen64 + +end program repeat_p diff --git a/Fortran/gfortran/regression/reshape_10.f90 b/Fortran/gfortran/regression/reshape_10.f90 new file mode 100644 index 000000000..a148e0a20 --- /dev/null +++ b/Fortran/gfortran/regression/reshape_10.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fmax-array-constructor=65536 -fdump-tree-original" } +! PR fortran/103794 + +program p + integer :: i, j + integer, parameter :: a(2) = 2 + integer, parameter :: e(*) = [(reshape([1,2,3,4], (a*i)), i=1,1)] + integer, parameter :: f(*,*) = reshape([1,2,3,4], [(a*i, i=1,1)]) + integer, parameter :: g(*,*) = reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]) + integer, parameter :: s1(*) = & + shape(reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)])) + logical, parameter :: l1 = all (e == [1,2,3,4]) + logical, parameter :: l2 = all (f == reshape([1,2,3,4],[2,2])) + logical, parameter :: l3 = size (s1) == 2 .and. all (s1 == 2) + logical, parameter :: l4 = all (f == g) + print *, e + print *, f + if (.not. l1) stop 1 + if (.not. l2) stop 2 + if (.not. l3) stop 3 + if (.not. l4) stop 4 + if (any (shape (reshape([1,2], [([2]*i, i=1,1)])) /= 2)) stop 5 + ! The following is compile-time simplified due to shape(): + print *, shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])) + if (any (shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])) /= 2)) stop 6 + if (any (reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]) /= f)) stop 7 + ! The following is not compile-time simplified: + print *, reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]) + if (any (reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]) /= f)) stop 8 +end + +! { dg-final { scan-tree-dump-times "_gfortran_reshape_4" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 1 "original" } } diff --git a/Fortran/gfortran/regression/reshape_11.f90 b/Fortran/gfortran/regression/reshape_11.f90 new file mode 100644 index 000000000..17c140614 --- /dev/null +++ b/Fortran/gfortran/regression/reshape_11.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fmax-array-constructor=65536" } +! PR fortran/103794 + +program p + integer :: i, j + integer, parameter :: a(2) = 2, m = 20000 + integer, parameter :: e(*) = & + [(reshape([1,2,3], (a*i)), i=1,1)] ! { dg-error "not enough elements" } + integer, parameter :: g(*,*) = & + reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)]) ! { dg-error "number of elements" } + print *, reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)]) + print *, reshape([1,2,3], [(a*i, i=1,1)]) ! { dg-error "not enough elements" } + print *, [(reshape([1,2,3], (a*i)),i=1,1)] ! { dg-error "not enough elements" } +end diff --git a/Fortran/gfortran/regression/reshape_8.f90 b/Fortran/gfortran/regression/reshape_8.f90 index 01799ac5c..56812124c 100644 --- a/Fortran/gfortran/regression/reshape_8.f90 +++ b/Fortran/gfortran/regression/reshape_8.f90 @@ -11,4 +11,4 @@ program test a = reshape([1,2,3,4], [2,0]) print *, a end -! { dg-final { scan-tree-dump-times "data" 4 "original" } } +! { dg-final { scan-tree-dump-not "data..0. =" "original" } } diff --git a/Fortran/gfortran/regression/select_rank_6.f90 b/Fortran/gfortran/regression/select_rank_6.f90 new file mode 100644 index 000000000..d0121777b --- /dev/null +++ b/Fortran/gfortran/regression/select_rank_6.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! PR fortran/100607 - fix diagnostics for SELECT RANK +! Contributed by T.Burnus + +program p + implicit none + integer, allocatable :: A(:,:,:) + + allocate(a(5:6,-2:2, 99:100)) + call foo(a) + call bar(a) + +contains + + subroutine foo(x) + integer, allocatable :: x(..) + if (rank(x) /= 3) stop 1 + if (any (lbound(x) /= [5, -2, 99])) stop 2 + + select rank (x) + rank(3) + if (any (lbound(x) /= [5, -2, 99])) stop 3 + end select + + select rank (x) ! { dg-error "pointer or allocatable selector at .2." } + rank(*) ! { dg-error "pointer or allocatable selector at .2." } + if (rank(x) /= 1) stop 4 + if (lbound(x, 1) /= 1) stop 5 + end select + end + + subroutine bar(x) + integer :: x(..) + if (rank(x) /= 3) stop 6 + if (any (lbound(x) /= 1)) stop 7 + + select rank (x) + rank(3) + if (any (lbound(x) /= 1)) stop 8 + end select + + select rank (x) + rank(*) + if (rank(x) /= 1) stop 9 + if (lbound(x, 1) /= 1) stop 10 + end select + end +end diff --git a/Fortran/gfortran/regression/selected_logical_kind_1.f90 b/Fortran/gfortran/regression/selected_logical_kind_1.f90 new file mode 100644 index 000000000..18d8dedd5 --- /dev/null +++ b/Fortran/gfortran/regression/selected_logical_kind_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program selected + implicit none + + integer, parameter :: k = max(1, selected_logical_kind(128)) + logical(kind=k) :: l + + ! This makes assumptions about the targets, but they are true + ! for all targets that gfortran supports + + if (selected_logical_kind(1) /= 1) STOP 1 + if (selected_logical_kind(8) /= 1) STOP 2 + if (selected_logical_kind(9) /= 2) STOP 3 + if (selected_logical_kind(16) /= 2) STOP 4 + if (selected_logical_kind(17) /= 4) STOP 5 + if (selected_logical_kind(32) /= 4) STOP 6 + if (selected_logical_kind(33) /= 8) STOP 7 + if (selected_logical_kind(64) /= 8) STOP 8 + + ! This should not exist + + if (selected_logical_kind(17921) /= -1) STOP 9 + + ! We test for a kind larger than 64 bits separately + + if (storage_size(l) /= 8 * k) STOP 10 + +end program diff --git a/Fortran/gfortran/regression/selected_logical_kind_2.f90 b/Fortran/gfortran/regression/selected_logical_kind_2.f90 new file mode 100644 index 000000000..6f18958eb --- /dev/null +++ b/Fortran/gfortran/regression/selected_logical_kind_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } + +program selected + implicit none + + logical(selected_logical_kind(1)) :: l ! { dg-error "has no IMPLICIT type" } + print *, selected_logical_kind(1) ! { dg-error "has no IMPLICIT type" } +end program diff --git a/Fortran/gfortran/regression/selected_logical_kind_3.f90 b/Fortran/gfortran/regression/selected_logical_kind_3.f90 new file mode 100644 index 000000000..ac948e9c2 --- /dev/null +++ b/Fortran/gfortran/regression/selected_logical_kind_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-require-effective-target fortran_integer_16 } + +program selected + implicit none + + integer, parameter :: k1 = selected_logical_kind(128) + logical(kind=k1) :: l + + integer, parameter :: k2 = selected_int_kind(25) + integer(kind=k2) :: i + + if (storage_size(l) /= 8 * k1) STOP 1 + if (storage_size(i) /= 8 * k2) STOP 2 + if (bit_size(i) /= 8 * k2) STOP 3 + if (k1 /= k2) STOP 4 + +end program diff --git a/Fortran/gfortran/regression/selected_logical_kind_4.f90 b/Fortran/gfortran/regression/selected_logical_kind_4.f90 new file mode 100644 index 000000000..0510991b1 --- /dev/null +++ b/Fortran/gfortran/regression/selected_logical_kind_4.f90 @@ -0,0 +1,23 @@ +! { dg-do run } + +! Check that SELECTED_LOGICAL_KIND works in a non-constant context +! (which is rare but allowed) + +subroutine foo(i, j) + implicit none + integer :: i, j + if (selected_logical_kind(i) /= j) STOP j +end subroutine + +program selected + implicit none + + call foo(1, 1) + call foo(8, 1) + call foo(9, 2) + call foo(16, 2) + call foo(17, 4) + call foo(32, 4) + call foo(33, 8) + call foo(64, 8) +end program diff --git a/Fortran/gfortran/regression/set_exponent_1.f90 b/Fortran/gfortran/regression/set_exponent_1.f90 new file mode 100644 index 000000000..4c063e833 --- /dev/null +++ b/Fortran/gfortran/regression/set_exponent_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR fortran/109511 +! Check compile-time simplification of SET_EXPONENT against runtime + +program exponent + implicit none + integer :: i + i = 0 + print *, i, set_exponent(1., 0), set_exponent(1., i) + if (set_exponent(1., 0) /= set_exponent(1., i)) stop 1 + i = 1 + print *, i, set_exponent(1., 1), set_exponent(1., i) + if (set_exponent(1., 1) /= set_exponent(1., i)) stop 2 + i = 2 + print *, i, set_exponent(-1.75, 2), set_exponent(-1.75, i) + if (set_exponent(-1.75, 2) /= set_exponent(-1.75, i)) stop 3 + print *, i, set_exponent(0.1875, 2), set_exponent(0.1875, i) + if (set_exponent(0.1875, 2) /= set_exponent(0.1875, i)) stop 4 + i = 3 + print *, i, set_exponent(0.75, 3), set_exponent(0.75, i) + if (set_exponent(0.75, 3) /= set_exponent(0.75, i)) stop 5 + i = 4 + print *, i, set_exponent(-2.5, 4), set_exponent(-2.5, i) + if (set_exponent(-2.5, 4) /= set_exponent(-2.5, i)) stop 6 + i = -1 + print *, i, set_exponent(1., -1), set_exponent(1., i) + if (set_exponent(1., -1) /= set_exponent(1., i)) stop 7 + i = -2 + print *, i, set_exponent(1.125, -2), set_exponent(1.125, i) + if (set_exponent(1.125, -2) /= set_exponent(1.125, i)) stop 8 + print *, i, set_exponent(-0.25, -2), set_exponent(-0.25, i) + if (set_exponent(-0.25, -2) /= set_exponent(-0.25, i)) stop 9 + i = -3 + print *, i, set_exponent(0.75, -3), set_exponent(0.75, i) + if (set_exponent(0.75, -3) /= set_exponent(0.75, i)) stop 10 +end program exponent diff --git a/Fortran/gfortran/regression/shape_12.f90 b/Fortran/gfortran/regression/shape_12.f90 new file mode 100644 index 000000000..e672e1ff9 --- /dev/null +++ b/Fortran/gfortran/regression/shape_12.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! PR fortran/115150 +! +! Check that SHAPE handles zero-sized arrays correctly +! +implicit none +call one +call two + +contains + +subroutine one + real,allocatable :: A(:),B(:,:) + allocate(a(3:0), b(5:1, 2:5)) + + if (any (shape(a) /= [0])) stop 1 + if (any (shape(b) /= [0, 4])) stop 2 + if (size(a) /= 0) stop 3 + if (size(b) /= 0) stop 4 + if (any (lbound(a) /= [1])) stop 5 + if (any (lbound(b) /= [1, 2])) stop 6 + if (any (ubound(a) /= [0])) stop 5 + if (any (ubound(b) /= [0,5])) stop 6 +end + +subroutine two +integer :: x1(10), x2(10,10) +call f(x1, x2, -3) +end + +subroutine f(y1, y2, n) + integer, value :: n + integer :: y1(1:n) + integer :: y2(1:n,4,2:*) + call g(y1, y2) +end + +subroutine g(z1, z2) + integer :: z1(..), z2(..) + + if (any (shape(z1) /= [0])) stop 1 + if (any (shape(z2) /= [0, 4, -1])) stop 2 + if (size(z1) /= 0) stop 3 + if (size(z2) /= 0) stop 4 + if (any (lbound(z1) /= [1])) stop 5 + if (any (lbound(z2) /= [1, 1, 1])) stop 6 + if (any (ubound(z1) /= [0])) stop 5 + if (any (ubound(z2) /= [0, 4, -1])) stop 6 +end +end diff --git a/Fortran/gfortran/regression/simd-builtins-1.h b/Fortran/gfortran/regression/simd-builtins-1.h index 88d555cf4..08b73514a 100644 --- a/Fortran/gfortran/regression/simd-builtins-1.h +++ b/Fortran/gfortran/regression/simd-builtins-1.h @@ -1,4 +1,3 @@ -!GCC$ builtin (sin) attributes simd (inbranch) !GCC$ builtin (sinf) attributes simd (notinbranch) !GCC$ builtin (cosf) attributes simd !GCC$ builtin (cosf) attributes simd (notinbranch) diff --git a/Fortran/gfortran/regression/simd-builtins-6.f90 b/Fortran/gfortran/regression/simd-builtins-6.f90 index 60bcac78f..2c68f9f18 100644 --- a/Fortran/gfortran/regression/simd-builtins-6.f90 +++ b/Fortran/gfortran/regression/simd-builtins-6.f90 @@ -2,7 +2,6 @@ ! { dg-additional-options "-nostdinc -Ofast -fdump-tree-optimized" } ! { dg-additional-options "-msse2 -mno-avx" { target i?86-*-linux* x86_64-*-linux* } } -!GCC$ builtin (sin) attributes simd (inbranch) !GCC$ builtin (sinf) attributes simd (notinbranch) !GCC$ builtin (cosf) attributes simd !GCC$ builtin (cosf) attributes simd (notinbranch) diff --git a/Fortran/gfortran/regression/size_dim_2.f90 b/Fortran/gfortran/regression/size_dim_2.f90 new file mode 100644 index 000000000..27a71d90a --- /dev/null +++ b/Fortran/gfortran/regression/size_dim_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/104350 - ICE with SIZE and bad DIM in initialization expression +! Contributed by G. Steinmetz + +program p + implicit none + integer :: k + integer, parameter :: x(2,3) = 42 + integer, parameter :: s(*) = [(size(x,dim=k),k=1,rank(x))] + integer, parameter :: t(*) = [(size(x,dim=k),k=1,3)] ! { dg-error "out of range" } + integer, parameter :: u(*) = [(size(x,dim=k),k=0,3)] ! { dg-error "out of range" } + integer, parameter :: v = product(shape(x)) + integer, parameter :: w = product([(size(x,k),k=0,3)]) ! { dg-error "out of range" } + print *, ([(size(x,dim=k),k=1,rank(x))]) + print *, [(size(x,dim=k),k=1,rank(x))] + print *, [(size(x,dim=k),k=0,rank(x))] + print *, product([(size(x,dim=k),k=1,rank(x))]) + print *, product([(size(x,dim=k),k=0,rank(x))]) +end diff --git a/Fortran/gfortran/regression/size_optional_dim_2.f90 b/Fortran/gfortran/regression/size_optional_dim_2.f90 new file mode 100644 index 000000000..698702b09 --- /dev/null +++ b/Fortran/gfortran/regression/size_optional_dim_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/113245 - SIZE, optional DIM argument, w/ OPTIONAL+VALUE attributes + +program p + implicit none + real :: a(2,3) + integer :: expect + expect = size (a,2) + call ref (a,2) + call val (a,2) + expect = size (a) + call ref (a) + call val (a) +contains + subroutine ref (x, dim) + real, intent(in) :: x(:,:) + integer, optional, intent(in) :: dim + print *, "present(dim), size(a,dim) =", present (dim), size (x,dim=dim) + if (size (x,dim=dim) /= expect) stop 1 + end + subroutine val (x, dim) + real, intent(in) :: x(:,:) + integer, optional, value :: dim + print *, "present(dim), size(a,dim) =", present (dim), size (x,dim=dim) + if (size (x,dim=dim) /= expect) stop 2 + end +end + +! Ensure inline code is generated: +! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } } diff --git a/Fortran/gfortran/regression/sizeof_2.f90 b/Fortran/gfortran/regression/sizeof_2.f90 index e6661a56b..d1655c634 100644 --- a/Fortran/gfortran/regression/sizeof_2.f90 +++ b/Fortran/gfortran/regression/sizeof_2.f90 @@ -15,7 +15,7 @@ subroutine foo(x, y) ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" } ii = sizeof (y) ! { dg-error "shall not be an assumed-size array" } - ii = c_sizeof (y) ! { dg-error "shall not be an assumed-size array" } + ii = c_sizeof (y) ! { dg-error "\[Aa\]ssumed-size array" } ii = storage_size (y) ! okay, element-size is known ii = sizeof (proc) ! { dg-error "shall not be a procedure" } diff --git a/Fortran/gfortran/regression/spec_expr_10.f90 b/Fortran/gfortran/regression/spec_expr_10.f90 new file mode 100644 index 000000000..287b5a8d6 --- /dev/null +++ b/Fortran/gfortran/regression/spec_expr_10.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR fortran/114475 +! The array specification of PP in OL_EVAL used to be rejected in the submodule +! because the compiler was not able to see the host-association of N_EXTERNAL +! there. +! +! Contributed by Jürgen Reuter . + +module t1 + use, intrinsic :: iso_c_binding + implicit none + private + public :: t1_t + integer :: N_EXTERNAL = 0 + + type :: t1_t + contains + procedure :: set_n_external => t1_set_n_external + end type t1_t + + abstract interface + subroutine ol_eval (id, pp, emitter) bind(C) + import + real(kind = c_double), intent(in) :: pp(5 * N_EXTERNAL) + end subroutine ol_eval + end interface + interface + module subroutine t1_set_n_external (object, n) + class(t1_t), intent(inout) :: object + integer, intent(in) :: n + end subroutine t1_set_n_external + end interface + +end module t1 + +submodule (t1) t1_s + implicit none +contains + module subroutine t1_set_n_external (object, n) + class(t1_t), intent(inout) :: object + integer, intent(in) :: n + N_EXTERNAL = n + end subroutine t1_set_n_external + +end submodule t1_s diff --git a/Fortran/gfortran/regression/spec_expr_8.f90 b/Fortran/gfortran/regression/spec_expr_8.f90 new file mode 100644 index 000000000..77e141564 --- /dev/null +++ b/Fortran/gfortran/regression/spec_expr_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/111781 +! We used to reject the example below because the dummy procedure g was +! setting the current namespace without properly restoring it, which broke +! the specification expression check for the dimension of A later on. +! +! Contributed by Rasmus Vikhamar-Sandberg + +program example + implicit none + integer :: n + +contains + + subroutine f(g,A) + real, intent(out) :: A(n) + interface + pure real(8) function g(x) + real(8), intent(in) :: x + end function + end interface + end subroutine +end program diff --git a/Fortran/gfortran/regression/spec_expr_9.f90 b/Fortran/gfortran/regression/spec_expr_9.f90 new file mode 100644 index 000000000..9024909b4 --- /dev/null +++ b/Fortran/gfortran/regression/spec_expr_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/111781 +! Used to fail with Error: Variable ‘n’ cannot appear in the +! expression at (1) for line 16. +! +program is_it_valid + dimension y(3) + integer :: n = 3 + interface + function func(x) + import + dimension func(n) + end function + end interface + y=func(1.0) + print *, y + stop +end diff --git a/Fortran/gfortran/regression/statement_function_5.f90 b/Fortran/gfortran/regression/statement_function_5.f90 new file mode 100644 index 000000000..bc5a5dba7 --- /dev/null +++ b/Fortran/gfortran/regression/statement_function_5.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/115039 +! +! Check that inquiry refs work with statement functions +! +! { dg-additional-options "-std=legacy -fdump-tree-optimized" } +! { dg-prune-output " Obsolescent feature" } +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } } + +program testit + implicit none + complex :: x + real :: im + integer :: slen + character(5) :: s + im(x) = x%im + x%re + x%kind + slen(s) = s%len + if (im((1.0,3.0) + (2.0,4.0)) /= 14.) stop 1 + if (slen('abcdef') /= 5) stop 2 +end program testit diff --git a/Fortran/gfortran/regression/storage_size_7.f90 b/Fortran/gfortran/regression/storage_size_7.f90 new file mode 100644 index 000000000..e32ca1b6a --- /dev/null +++ b/Fortran/gfortran/regression/storage_size_7.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027. +! Contributed by Steve Kargl +! and José Rui Faustino de Sousa +program p + use, intrinsic :: ISO_FORTRAN_ENV, only: int64 + type t + integer i + end type + type s + class(t), allocatable :: c(:) + end type + integer :: rslt, class_rslt + integer(kind=int64), target :: tgt + class(t), allocatable, target :: t_alloc(:) + class(s), allocatable, target :: s_alloc(:) + character(:), allocatable, target :: chr(:) + class(*), pointer :: ptr_s, ptr_a(:) + + allocate (t_alloc(2), source=t(1)) + rslt = storage_size(t_alloc(1)) ! Scalar arg - the original testcase + if (rslt .ne. 32) stop 1 + + rslt = storage_size(t_alloc) ! Array arg + if (rslt .ne. 32) stop 2 + + call pr100027 + + allocate (s_alloc(2), source=s([t(1), t(2)])) +! This, of course, is processor dependent: gfortran gives 576, NAG 448 +! and Intel 1216. + class_rslt = storage_size(s_alloc) ! Type with a class component + ptr_s => s_alloc(2) +! However, the unlimited polymorphic result should be the same + if (storage_size (ptr_s) .ne. class_rslt) stop 3 + ptr_a => s_alloc + if (storage_size (ptr_a) .ne. class_rslt) stop 4 + + rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg + if (rslt .ne. 32) stop 5 + + rslt = storage_size(s_alloc(1)%c) ! Scalar component of array arg + if (rslt .ne. 32) stop 6 + + ptr_s => tgt + rslt = storage_size (ptr_s) ! INTEGER(8) target + if (rslt .ne. 64) stop 7 + + allocate (chr(2), source = ["abcde", "fghij"]) + ptr_s => chr(2) + rslt = storage_size (ptr_s) ! CHARACTER(5) scalar + if (rslt .ne. 40) stop 8 + + ptr_a => chr + rslt = storage_size (ptr_a) ! CHARACTER(5) array + if (rslt .ne. 40) stop 9 + + deallocate (t_alloc, s_alloc, chr) ! For valgrind check + +contains + +! Original testcase from José Rui Faustino de Sousa + subroutine pr100027 + implicit none + + integer, parameter :: n = 11 + + type :: foo_t + end type foo_t + + type, extends(foo_t) :: bar_t + end type bar_t + + class(*), pointer :: apu(:) + class(foo_t), pointer :: apf(:) + class(bar_t), pointer :: apb(:) + type(bar_t), target :: atb(n) + + integer :: m + + apu => atb + m = storage_size(apu) + if (m .ne. 0) stop 10 + apf => atb + m = storage_size(apf) + if (m .ne. 0) stop 11 + apb => atb + m = storage_size(apb) + if (m .ne. 0) stop 12 + end +end program p diff --git a/Fortran/gfortran/regression/streamio_9.f90 b/Fortran/gfortran/regression/streamio_9.f90 index b6bddb973..f29ded6ba 100644 --- a/Fortran/gfortran/regression/streamio_9.f90 +++ b/Fortran/gfortran/regression/streamio_9.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options "-ffloat-store" } ! PR29053 Stream IO test 9. ! Contributed by Jerry DeLisle . ! Test case derived from that given in PR by Steve Kargl. diff --git a/Fortran/gfortran/regression/string_array_constructor_4.f90 b/Fortran/gfortran/regression/string_array_constructor_4.f90 new file mode 100644 index 000000000..b5b81f073 --- /dev/null +++ b/Fortran/gfortran/regression/string_array_constructor_4.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! PR fortran/103115 - character array constructor with >= 4 constant elements +! +! This used to ICE when the first element is deferred-length character +! or could lead to wrong results. + +program pr103115 + implicit none + integer :: i + character(*), parameter :: expect(*) = [ "1","2","3","4","5" ] + character(5) :: abc = "12345" + character(5), parameter :: def = "12345" + character(:), dimension(:), allocatable :: list + character(:), dimension(:), allocatable :: titles + titles = ["1"] + titles = [ titles& + ,"2"& + ,"3"& + ,"4"& + ,"5"& ! used to ICE + ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 1 + if (any (titles /= expect)) stop 2 + titles = ["1"] + titles = [ titles, (char(48+i),i=2,5) ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 3 + if (any (titles /= expect)) stop 4 + titles = ["1"] + titles = [ titles, ("2345"(i:i),i=1,4) ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 5 + if (any (titles /= expect)) stop 6 + titles = ["1"] + titles = [ titles, (def(i:i),i=2,5) ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 7 + if (any (titles /= expect)) stop 8 + list = [ (char(48+i),i=1,5) ] + titles = [ list(1), (char(48+i),i=2,5) ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 9 + if (any (titles /= expect)) stop 10 + titles = ["1"] + titles = [ titles, (abc(i:i),i=2,5) ] + if (len (titles) /= 1 .or. size (titles) /= 5) stop 11 + if (any (titles /= expect)) stop 12 + + ! with typespec: + list = [ (char(48+i),i=1,5) ] + titles = [ character(2) :: list(1), (char(48+i),i=2,5) ] + if (len (titles) /= 2 .or. size (titles) /= 5) stop 13 + if (any (titles /= expect)) stop 14 + titles = ["1"] + titles = [ character(2) :: titles, (char(48+i),i=2,5) ] + if (len (titles) /= 2 .or. size (titles) /= 5) stop 15 + if (any (titles /= expect)) stop 16 + titles = ["1"] + titles = [ character(2) :: titles, (def(i:i),i=2,5) ] + if (len (titles) /= 2 .or. size (titles) /= 5) stop 17 + if (any (titles /= expect)) stop 18 + deallocate (titles, list) +end diff --git a/Fortran/gfortran/regression/submodule_33.f08 b/Fortran/gfortran/regression/submodule_33.f08 new file mode 100644 index 000000000..b61d750de --- /dev/null +++ b/Fortran/gfortran/regression/submodule_33.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/99798 +! This example used to trigger an ICE caused by a premature release of the G +! symbol (with its argument X) following the rejection of the subroutine in +! the submodule. + +module m + interface + module integer function g(x) + integer, intent(in) :: x + end + end interface +end +submodule(m) m2 +contains + subroutine g(x) ! { dg-error "FUNCTION attribute conflicts with SUBROUTINE" } + integer, intent(in) :: x ! { dg-error "Unexpected data declaration" } + end +end diff --git a/Fortran/gfortran/regression/system_clock_1.f90 b/Fortran/gfortran/regression/system_clock_1.f90 index 41027deb2..0cb0145e8 100644 --- a/Fortran/gfortran/regression/system_clock_1.f90 +++ b/Fortran/gfortran/regression/system_clock_1.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options "-std=f2003" } integer :: i, j, k integer(kind=8) :: i8, j8, k8 diff --git a/Fortran/gfortran/regression/system_clock_3.f08 b/Fortran/gfortran/regression/system_clock_3.f08 index e52a51a7d..c12849b77 100644 --- a/Fortran/gfortran/regression/system_clock_3.f08 +++ b/Fortran/gfortran/regression/system_clock_3.f08 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options "-std=f2008" } ! PR64432 program countem implicit none diff --git a/Fortran/gfortran/regression/system_clock_4.f90 b/Fortran/gfortran/regression/system_clock_4.f90 new file mode 100644 index 000000000..1bb42efac --- /dev/null +++ b/Fortran/gfortran/regression/system_clock_4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +! PR fortran/112609 - F2023 restrictions on integer arguments to SYSTEM_CLOCK + +program p + implicit none + integer :: i, j, k + integer(2) :: i2, j2, k2 + integer(8) :: i8, j8, k8 + real :: x + + call system_clock(count=i2) ! { dg-error "kind smaller than default integer" } + call system_clock(count_rate=j2) ! { dg-error "kind smaller than default integer" } + call system_clock(count_max=k2) ! { dg-error "kind smaller than default integer" } + + call system_clock(count=i8,count_rate=x,count_max=k8) + call system_clock(count=i, count_rate=j8) ! { dg-error "different kind" } + call system_clock(count=i8,count_rate=j) ! { dg-error "different kind" } + call system_clock(count=i, count_max=k8) ! { dg-error "different kind" } + call system_clock(count=i8,count_max=k) ! { dg-error "different kind" } + call system_clock(count_rate=j, count_max=k8) ! { dg-error "different kind" } + call system_clock(count_rate=j8,count_max=k) ! { dg-error "different kind" } + call system_clock(i,x,k8) ! { dg-error "different kind" } +end diff --git a/Fortran/gfortran/regression/tests.cmake b/Fortran/gfortran/regression/tests.cmake index 2ef0e917f..2d33e9143 100644 --- a/Fortran/gfortran/regression/tests.cmake +++ b/Fortran/gfortran/regression/tests.cmake @@ -44,6 +44,8 @@ preprocess;warning-directive-4.F90;;-std=f95 -fdiagnostics-show-option -Wno-cpp; assemble;module_naming_1.f90;;;; assemble;same_name_1.f90;;;; compile;20181025-1.f;;-Ofast;; +compile;20231103-1.f90;;-Ofast;; +compile;20231103-2.f90;;-Ofast;; compile;abstract_type_1.f90;xfail;-std=f95;; compile;abstract_type_2.f03;xfail;;; compile;abstract_type_3.f03;xfail;;; @@ -88,8 +90,10 @@ compile;alloc_comp_initializer_3.f90;;;; compile;alloc_comp_result_2.f90;;;; compile;alloc_comp_std.f90;xfail;-std=f95;; compile;allocatable_dummy_2.f90;xfail;;; +compile;allocatable_function_11.f90;xfail;;; compile;allocatable_function_2.f90;xfail;;; compile;allocatable_function_4.f90;;-fdump-tree-original;; +compile;allocatable_length.f90;;-Werror -Wall;; compile;allocatable_module_1.f90;;;; compile;allocatable_scalar_11.f90;xfail;;; compile;allocatable_scalar_2.f90;xfail;-std=f95;; @@ -131,7 +135,9 @@ compile;allocate_with_source_17.f03;;;; compile;allocate_with_source_19.f08;xfail;-std=f2008;; compile;allocate_with_source_21.f03;;;; compile;allocate_with_source_25.f90;;-fdump-tree-original;; +compile;allocate_with_source_29.f90;xfail;-std=f2008;; compile;allocate_with_source_3.f90;;;; +compile;allocate_with_source_33.f90;;-O0;; compile;allocate_with_source_4.f90;xfail;;; compile;allocate_with_typespec_1.f90;;;; compile;allocate_with_typespec_2.f;;;; @@ -185,6 +191,8 @@ compile;arith_divide_2.f90;xfail;;; compile;arith_divide_3.f90;xfail;-fcoarray=single;; compile;arith_divide_no_check.f;xfail;-fno-range-check;; compile;arithmetic_overflow_1.f90;xfail;;; +compile;arithmetic_overflow_2.f90;xfail;-frange-check;; +compile;arithmetic_overflow_3.f90;xfail;-frange-check;; compile;array_3.f90;;;; compile;array_4.f90;;;; compile;array_5.f90;;;; @@ -233,6 +241,7 @@ compile;array_memcpy_2.f90;;-O2 -fdump-tree-original;; compile;array_memcpy_3.f90;;-O2 -fdump-tree-original;; compile;array_memcpy_4.f90;;-O2 -fdump-tree-original;; compile;array_memset_1.f90;;-O2 -fdump-tree-original;; +compile;array_memset_3.f90;;-O2 -fdump-tree-original;; compile;array_section_2.f90;;-fdump-tree-original;; compile;array_section_3.f90;xfail;;; compile;array_simplify_1.f90;;;; @@ -278,6 +287,8 @@ compile;associate_57.f90;;;; compile;associate_58.f90;;;; compile;associate_59.f90;xfail;;; compile;associate_6.f03;;-std=f2003 -fdump-tree-original;; +compile;associate_62.f90;;;; +compile;associate_69.f90;;-Og -Wuninitialized -Wmaybe-uninitialized -fdump-tree-optimized;; compile;associated_3.f90;xfail;;; compile;associated_7.f90;xfail;;; compile;associated_target_1.f90;xfail;;; @@ -369,6 +380,7 @@ compile;bind_c_18.f90;xfail;;; compile;bind_c_array_params.f03;xfail;-std=f2003;; compile;bind_c_array_params_2.f90;;-std=f2008ts -fdump-tree-original;; compile;bind_c_bool_1.f90;xfail;-std=f2003;; +compile;bind_c_char_11.f90;;-Wuninitialized;; compile;bind_c_char_6.f90;xfail;-std=f2003 -fimplicit-none;; compile;bind_c_char_7.f90;xfail;-std=f2008 -fimplicit-none;; compile;bind_c_char_8.f90;xfail;-fimplicit-none;; @@ -439,6 +451,7 @@ compile;block_10.f90;;;; compile;block_12.f90;xfail;;; compile;block_15.f08;xfail;;; compile;block_16.f08;;;; +compile;block_17.f90;;;; compile;block_3.f90;xfail;-std=f95;; compile;block_4.f08;xfail;-std=f2008;; compile;block_5.f08;xfail;-std=legacy;; @@ -474,16 +487,18 @@ compile;bounds_check_16.f90;;-fcheck=bounds;; compile;bounds_check_18.f90;xfail;;; compile;bounds_check_21.f90;;-Warray-bounds -O2;; compile;bounds_check_22.f90;;-fcheck=bounds;; +compile;bounds_check_24.f90;;-fcheck=bounds -fdump-tree-original;; compile;bounds_check_3.f90;;;; compile;bounds_check_array_ctor_3.f90;xfail;;; compile;bounds_check_array_ctor_5.f90;xfail;;; +compile;bounds_check_fail_8.f90;;-fcheck=bounds -g -fdump-tree-original;; compile;bounds_temporaries_1.f90;xfail;;; compile;boz_10.f90;xfail;-std=f95;; compile;boz_12.f90;;;; compile;boz_4.f90;;-fallow-invalid-boz;; compile;boz_5.f90;xfail;;; compile;boz_7.f90;xfail;-std=f95 -pedantic;; -compile;boz_8.f90;;;; +compile;boz_8.f90;xfail;-std=f2003;; compile;boz_complex_1.f90;xfail;;; compile;boz_complex_2.f90;;-fallow-invalid-boz;; compile;boz_dshift_1.f90;xfail;;; @@ -509,6 +524,7 @@ compile;c_f_pointer_tests_5.f90;xfail;;; compile;c_f_pointer_tests_6.f90;xfail;;; compile;c_f_pointer_tests_7.f90;xfail;;; compile;c_f_pointer_tests_8.f90;;-std=f2003;; +compile;c_f_pointer_tests_9.f90;xfail;;; compile;c_funloc_tests_2.f03;xfail;;; compile;c_funloc_tests_5.f03;xfail;-std=f2003;; compile;c_funloc_tests_6.f90;xfail;-std=f2008;; @@ -547,7 +563,8 @@ compile;c_ptr_tests_17.f90;;;; compile;c_ptr_tests_18.f90;;;; compile;c_ptr_tests_5.f03;xfail;;; compile;c_sizeof_2.f90;xfail;-std=f2003 -Wall -Wno-conversion;; -compile;c_sizeof_6.f90;xfail;;; +compile;c_sizeof_6.f90;;;; +compile;c_sizeof_7.f90;xfail;;; compile;change_symbol_attributes_1.f90;;;; compile;char_array_arg_1.f90;;;; compile;char_array_constructor_2.f90;;;; @@ -655,6 +672,8 @@ compile;class_72.f90;xfail;;; compile;class_73.f90;xfail;;; compile;class_74.f90;;-fcoarray=single;; compile;class_75.f90;xfail;-fcoarray=single;; +compile;class_76.f90;;-fdump-tree-original;; +compile;class_77.f90;;-fdump-tree-original;; compile;class_8.f03;xfail;;; compile;class_allocate_16.f90;;-fdump-tree-original;; compile;class_allocate_17.f90;;-fdump-tree-original;; @@ -822,6 +841,7 @@ compile;common_24.f;xfail;;; compile;common_25.f90;xfail;;; compile;common_26.f90;xfail;;; compile;common_27.f90;xfail;;; +compile;common_28.f90;xfail;;; compile;common_3.f90;xfail;;; compile;common_5.f;;;; compile;common_6.f90;xfail;;; @@ -857,6 +877,8 @@ compile;contains_empty_2.f03;;-std=f2008 -pedantic;; compile;contiguous_1.f90;xfail;-fcoarray=single;; compile;contiguous_11.f90;xfail;;; compile;contiguous_12.f90;xfail;;; +compile;contiguous_13.f90;;;; +compile;contiguous_14.f90;;;; compile;contiguous_2.f90;xfail;-std=f2003;; compile;contiguous_3.f90;;-O0 -fdump-tree-original;; compile;contiguous_4.f90;xfail;;; @@ -867,6 +889,8 @@ compile;contiguous_9.f90;xfail;;; compile;continuation_10.f90;;-std=f95;; compile;continuation_15.f90;;-std=f95;; compile;continuation_16.f90;;-std=f95 -nostdinc -fpre-include=simd-builtins-1.h;; +compile;continuation_17.f90;;-std=f2018;; +compile;continuation_18.f90;;-std=f2023;; compile;continuation_2.f90;xfail;;; compile;continuation_3.f90;;-std=f95;; compile;continuation_4.f90;;-std=f2003;; @@ -896,9 +920,11 @@ compile;data_array_3.f90;xfail;;; compile;data_array_4.f90;;;; compile;data_array_5.f90;xfail;;; compile;data_array_6.f;;;; -compile;data_bounds_1.f90;xfail;-std=gnu;; +compile;data_bounds_1.f90;xfail;-std=gnu -w;; +compile;data_bounds_2.f90;xfail;-std=f2018;; compile;data_char_4.f90;xfail;-w;; compile;data_char_5.f90;xfail;;; +compile;data_char_6.f90;xfail;;; compile;data_components_1.f90;;;; compile;data_constraints_1.f90;xfail;;; compile;data_constraints_2.f90;xfail;-std=f95;; @@ -907,12 +933,15 @@ compile;data_implied_do_2.f90;xfail;;; compile;data_initialized.f90;xfail;-std=f95;; compile;data_initialized_2.f90;xfail;;; compile;data_initialized_3.f90;;;; +compile;data_initialized_4.f90;;-std=legacy;; compile;data_inquiry_ref.f90;xfail;;; compile;data_invalid.f90;xfail;-std=f95 -fmax-errors=0;; compile;data_pointer_1.f90;xfail;;; compile;data_pointer_2.f90;xfail;-O -g;; +compile;data_pointer_3.f90;;;; compile;data_substring.f90;xfail;;; compile;data_value_1.f90;xfail;;; +compile;date_and_time_2.f90;xfail;-std=f2018;; compile;deallocate_alloc_opt_1.f90;xfail;;; compile;deallocate_alloc_opt_2.f90;xfail;;; compile;deallocate_error_3.f90;xfail;;; @@ -1100,6 +1129,7 @@ compile;do_check_9.f90;xfail;;; compile;do_concurrent_1.f90;xfail;-fcoarray=single;; compile;do_concurrent_3.f90;xfail;;; compile;do_concurrent_6.f90;;-fdump-tree-original;; +compile;do_concurrent_7.f90;;-fdump-tree-original;; compile;do_corner_warn.f90;;-Wundefined-do-loop;; compile;do_iterator.f90;xfail;;; compile;do_pointer_1.f90;;;; @@ -1298,12 +1328,15 @@ compile;finalize_35.f90;;-fdump-tree-original;; compile;finalize_4.f03;;;; compile;finalize_49.f90;;-fdump-tree-original;; compile;finalize_5.f03;xfail;;; +compile;finalize_53.f90;;;; +compile;finalize_54.f90;;;; +compile;finalize_57.f90;;-fdump-tree-original;; compile;finalize_6.f90;xfail;-std=f95;; compile;finalize_7.f03;;-Wsurprising;; -compile;finalize_8.f03;xfail;;; compile;finalize_9.f90;xfail;;; compile;findloc_1.f90;xfail;;; compile;findloc_7.f90;xfail;;; +compile;findloc_9.f90;;-fdump-tree-original;; compile;fmt_error.f90;xfail;;; compile;fmt_error_2.f90;xfail;-std=legacy;; compile;fmt_error_3.f90;xfail;;; @@ -1626,6 +1659,7 @@ compile;interface_46.f90;xfail;;; compile;interface_47.f90;;;; compile;interface_48.f90;;;; compile;interface_5.f90;xfail;;; +compile;interface_50.f90;;-fdump-tree-original;; compile;interface_6.f90;xfail;;; compile;interface_7.f90;xfail;;; compile;interface_8.f90;;;; @@ -1645,6 +1679,7 @@ compile;interface_operator_1.f90;xfail;;; compile;interface_operator_2.f90;xfail;;; compile;interface_operator_3.f90;xfail;;; compile;interface_proc_end.f90;;;; +compile;interface_procedure_1.f90;xfail;-std=f95;; compile;internal_dummy_1.f90;xfail;-std=f2003;; compile;internal_io_unf.f90;xfail;;; compile;internal_pack_11.f90;;-O0 -fdump-tree-original;; @@ -1755,6 +1790,7 @@ compile;iso_fortran_env_2.f90;;;; compile;iso_fortran_env_4.f90;xfail;;; compile;iso_fortran_env_5.f90;;-O2 -fdump-tree-original;; compile;iso_fortran_env_6.f90;xfail;-std=f2003;; +compile;iso_fortran_env_9.f90;xfail;-std=f2018;; compile;keyword_symbol_1.f90;xfail;;; compile;kind_1.f90;xfail;;; compile;kind_tests_2.f03;;;; @@ -1770,16 +1806,18 @@ compile;ldist-pr43023.f90;;-O2 -ftree-loop-distribution;; compile;ldist-pr45199.f;;-O3 -fdump-tree-ldist-details;; compile;len_trim.f90;;-O -Wall -Wconversion-extra -fdump-tree-original;; compile;line_length_1.f;;-ffixed-line-length-none;; -compile;line_length_10.f90;;-Wno-line-truncation;; -compile;line_length_11.f90;;-Wno-all;; -compile;line_length_2.f90;;-ffree-line-length-none;; +compile;line_length_10.f90;;-std=f2018 -Wno-line-truncation;; +compile;line_length_11.f90;;-Wno-all -std=f2018;; +compile;line_length_12.f90;xfail;-std=f2018;; +compile;line_length_13.f90;xfail;-std=f2023;; +compile;line_length_2.f90;;-ffree-line-length-none -std=f2018;; compile;line_length_3.f;;-std=gnu -ffixed-form -Wline-truncation;; compile;line_length_4.f90;xfail;-Wline-truncation -ffree-line-length-80;; -compile;line_length_5.f90;xfail;-Wline-truncation;; -compile;line_length_6.f90;xfail;;; -compile;line_length_7.f90;;-Wno-error;; -compile;line_length_8.f90;xfail;-Wline-truncation;; -compile;line_length_9.f90;xfail;-Wall;; +compile;line_length_5.f90;xfail;-std=f2018 -Wline-truncation;; +compile;line_length_6.f90;xfail;-std=f2018;; +compile;line_length_7.f90;;-std=f2018 -Wno-error;; +compile;line_length_8.f90;xfail;-std=f2018 -Wline-truncation;; +compile;line_length_9.f90;xfail;-std=f2018 -Wall;; compile;linefile.f90;;-Wall;; compile;linked_list_1.f90;;;; compile;literal_constants.f;;-ffixed-form;; @@ -1956,6 +1994,8 @@ compile;null_8.f90;;;; compile;null_actual.f90;xfail;-std=f2003;; compile;null_actual_2.f90;;;; compile;null_actual_3.f90;xfail;-fallow-argument-mismatch -w;; +compile;null_actual_4.f90;xfail;;; +compile;null_actual_5.f90;;;; compile;nullify_1.f;;;; compile;nullify_2.f90;xfail;;; compile;nullify_4.f90;xfail;;; @@ -1965,7 +2005,7 @@ compile;old_style_init.f90;xfail;;; compile;oldstyle_2.f90;xfail;;; compile;oldstyle_3.f90;xfail;;; compile;oldstyle_4.f90;;-std=f95;; -compile;oldstyle_5.f;;;; +compile;oldstyle_5.f;xfail;;; compile;open_access_1.f90;xfail;;; compile;open_nounit.f90;xfail;;; compile;operator_2.f90;xfail;;; @@ -2015,6 +2055,10 @@ compile;pdt_24.f03;xfail;;; compile;pdt_29.f03;xfail;;; compile;pdt_30.f90;xfail;;; compile;pdt_32.f03;xfail;;; +compile;pdt_33.f90;xfail;;; +compile;pdt_34.f03;;;; +compile;pdt_35.f03;;;; +compile;pdt_37.f03;xfail;;; compile;pdt_4.f03;xfail;;; compile;pdt_6.f03;xfail;;; compile;pdt_8.f03;xfail;;; @@ -2057,7 +2101,9 @@ compile;power2.f90;;;; compile;power_6.f90;;-O1 -fdump-tree-optimized;; compile;pr100154.f90;xfail;-std=gnu;; compile;PR10018.f90;xfail;;; +compile;pr100193.f90;xfail;;; compile;pr100949.f90;;;; +compile;pr100988.f90;;-fdump-tree-original;; compile;pr101026.f;;-Ofast -frounding-math;; compile;pr101121.f;;-Ofast -std=legacy;; compile;pr101158.f90;;-O1 -ftree-slp-vectorize -fwrapv;; @@ -2068,12 +2114,17 @@ compile;pr101329.f90;xfail;;; compile;pr101514.f90;xfail;;; compile;pr101536.f90;xfail;;; compile;pr101762.f90;xfail;;; +compile;pr102109.f90;;;; +compile;pr102112.f90;;;; compile;pr102180.f90;xfail;-fcoarray=lib;; +compile;pr102190.f90;;;; compile;pr102332.f90;xfail;;; compile;pr102366.f90;;-fdump-tree-original -Wall;; compile;pr102458.f90;xfail;-fcoarray=lib;; compile;pr102458b.f90;;-fdump-tree-original;; compile;pr102520.f90;xfail;;; +compile;pr102532.f90;xfail;-fcoarray=single;; +compile;pr102597.f90;xfail;;; compile;pr102685.f90;xfail;;; compile;pr102715.f90;xfail;;; compile;pr102816.f90;xfail;;; @@ -2083,6 +2134,7 @@ compile;pr103258.f90;xfail;-Wno-pedantic;; compile;pr103259.f90;xfail;;; compile;pr103286.f90;xfail;std=gnu;; compile;pr103366.f90;;;; +compile;pr103471.f90;xfail;;; compile;pr103475.f90;xfail;-O2 -Wall;; compile;pr103504.f90;xfail;;; compile;pr103505.f90;xfail;;; @@ -2092,10 +2144,12 @@ compile;pr103606.f90;xfail;;; compile;pr103607.f90;xfail;;; compile;pr103608.f90;xfail;-w;; compile;pr103609.f90;xfail;;; -compile;pr103628.f90;xfail;-O2 -mabi=ibmlongdouble;powerpc.+-.+-.+; +compile;pr103628.f90;xfail;-O2 -mlong-double-128 -mabi=ibmlongdouble;powerpc.+-.+-.+; compile;pr103691.f90;;-O2 -g;; compile;pr103692.f90;;-fdump-tree-original;; compile;pr103694.f90;xfail;;; +compile;pr103715.f90;xfail;;; +compile;pr103716.f90;;;; compile;pr103779.f90;xfail;;; compile;pr103898.f90;;;; compile;pr104210.f90;xfail;-fcoarray=single;; @@ -2104,16 +2158,23 @@ compile;pr104313.f;;-ff2c -fdump-tree-original;; compile;pr104314.f90;xfail;;; compile;pr104330.f90;;-fcoarray=lib;; compile;pr104349.f90;xfail;;; +compile;pr104351.f90;xfail;;; compile;pr104466.f90;;-std=legacy -O2 --param max-inline-insns-auto=0 --param max-inline-insns-single=0 -fdump-tree-lim2-details;; compile;pr104528.f;;-O2 -fpeel-loops -ftree-loop-vectorize -fno-tree-scev-cprop --param iv-max-considered-uses=2;; compile;pr104554.f90;xfail;;; +compile;pr104555.f90;;;; compile;pr104571.f90;xfail;-std=legacy;; compile;pr104572.f90;xfail;-w;; +compile;pr104625.f90;xfail;;; +compile;pr104649.f90;xfail;-w;; compile;pr104716.f;;-std=legacy -O2 -ftree-loop-distribution -fno-move-loop-stores -fno-tree-dominator-opts;; compile;pr104849.f90;xfail;;; +compile;pr104908.f90;;-fcheck=bounds -fdump-tree-original;; +compile;pr105152.f90;xfail;;; compile;pr105230.f90;xfail;;; compile;pr105501.f90;xfail;;; compile;pr105633.f90;xfail;;; +compile;PR105658.f90;;-Warray-temporaries;; compile;pr105954.f90;;-fdump-tree-original;; compile;pr106209.f90;xfail;;; compile;pr106226.f;;-O3 -std=legacy;; @@ -2124,6 +2185,7 @@ compile;pr106934.f90;;-O;; compile;pr106945.f90;;-fcoarray=single -fcheck=bounds -ftrapv;; compile;pr106985.f90;xfail;;; compile;pr106986.f90;xfail;;; +compile;pr106999.f90;xfail;;; compile;pr107000.f90;xfail;;; compile;pr107054.f90;xfail;;; compile;pr107215.f90;xfail;;; @@ -2137,6 +2199,7 @@ compile;pr107679.f90;;;; compile;pr107680.f90;;-fdump-tree-original;; compile;pr107681.f90;xfail;-fcoarray=lib;; compile;pr107707.f90;xfail;;; +compile;pr107821.f90;xfail;;; compile;pr107899.f90;xfail;-fcoarray=single;; compile;pr107995.f90;xfail;;; compile;pr108193.f90;;-pthread -O2 -fsplit-loops -ftree-parallelize-loops=2 -fno-tree-dominator-opts;; @@ -2150,8 +2213,31 @@ compile;pr108528.f90;xfail;;; compile;pr108529.f90;xfail;;; compile;pr108544.f90;xfail;;; compile;pr108592.f90;;-Winteger-division;; +compile;pr108889.f90;;-Wall -fdump-tree-original;; compile;pr109209.f90;;;; compile;pr109265.f90;;-O3 -w;; +compile;pr109948.f90;;;; +compile;pr110221.f;;-O2 -w;; +compile;pr110224.f90;;;; +compile;pr110996.f90;xfail;;; +compile;pr111853.f90;;;; +compile;pr111880.f90;;-std=f2018;; +compile;pr111891.f90;;-O2;; +compile;pr112316.f90;;;; +compile;pr112404.f90;;-Ofast;; +compile;pr112406.f90;;-Ofast -w -fprofile-generate;; +compile;pr112407b.f90;;-std=f2008;; +compile;pr112459.f90;;-w -fdump-tree-original;; +compile;PR113061.f90;;-fno-move-loop-invariants -Oz;; +compile;pr113503_1.f90;;-O2 -fno-inline -Wuninitialized;; +compile;pr113503_2.f90;;;; +compile;pr114535d.f90 pr114535iv.f90;;;; +compile;pr114739.f90;;;; +compile;pr114874_1.f90;;;; +compile;pr114874_2.f90;xfail;;; +compile;pr114883.f90;;-O2 -fvect-cost-model=cheap;; +compile;pr114959.f90;;-fdump-tree-original;; +compile;pr115281.f90;;-O3;; compile;pr15164.f90;;;; compile;pr15754.f90;xfail;;; compile;pr16433.f;xfail;;; @@ -2164,6 +2250,8 @@ compile;pr20865.f90;xfail;-std=legacy;; compile;pr23095.f;;-w -O2 -ffloat-store -fgcse-after-reload;; compile;PR24188.f;;-O2;; compile;pr24823.f;;-O2 -std=legacy;; +compile;pr25623-2.f90;;-fdump-tree-optimized-blocks-details -O3;; +compile;pr25623.f90;;-fdump-tree-optimized-blocks-details -O2;; compile;pr25923.f90;;-O -Wuninitialized;; compile;pr26246_1.f90;;-fdump-tree-original;; compile;pr26246_2.f90;;-fdump-tree-original -fno-automatic;; @@ -2237,7 +2325,7 @@ compile;pr43505.f90;;;; compile;pr43688.f90;;-O0 -fipa-reference;; compile;pr43793.f90;;;; compile;pr43796.f90;;-O2 -fcheck=bounds;; -compile;pr43984.f90;;-O2 -fno-tree-dominator-opts -fdump-tree-pre;; +compile;pr43984.f90;;-O2 -fno-tree-dominator-opts -fdump-tree-pre -fno-tree-sra;; compile;pr43996.f90;xfail;;; compile;pr44491.f90;xfail;-std=gnu;; compile;pr44691.f;;-O2 -fselective-scheduling2;powerpc.+-.+-.+ ia64-.+-.+ i.86-.+-.+ x86_64-.+-.+; @@ -2346,6 +2434,7 @@ compile;pr67526.f90;xfail;;; compile;pr67614.f90;xfail;-std=legacy;; compile;pr67615.f90;xfail;-std=legacy;; compile;pr67616.f90;;;; +compile;pr67740.f90;;-fdump-tree-original;; compile;pr67802.f90;xfail;;; compile;pr67803.f90;xfail;;; compile;pr67804.f90;xfail;;; @@ -2542,6 +2631,8 @@ compile;pr88357_2.f90;xfail;;; compile;pr88376.f90;xfail;;; compile;pr88379.f90;;-fcoarray=single;; compile;pr88467.f90;xfail;;; +compile;pr88552.f90;xfail;;; +compile;pr88624.f90;;-fcoarray=lib;; compile;pr88833.f90;;-O3 -march=armv8.2-a+sve --save-temps;; compile;pr88902.f90;;-flto --param ggc-min-heapsize=0;; compile;pr88932.f90;;-O1 -fpredictive-commoning -fno-tree-ch -fno-tree-dominator-opts -fno-tree-fre;; @@ -2550,6 +2641,7 @@ compile;pr88964.f90;;-O3 -fno-tree-forwprop --param sccvn-max-alias-queries-per- compile;pr89253.f;;-fsplit-loops -fno-tree-dominator-opts -std=legacy -w;; compile;pr89344.f90;xfail;;; compile;pr89451.f90;;-O2;; +compile;pr89462.f90;;-pedantic-errors;; compile;pr89492.f90;xfail;;; compile;pr89574.f90;;;; compile;pr89646.f90;;;; @@ -2612,6 +2704,7 @@ compile;pr92094.f90;;-O3;; compile;pr92161.f;;-O1 -ftree-loop-vectorize -fno-signed-zeros -fno-trapping-math;; compile;pr92277.f90;;;; compile;pr92537.f90;;-O2 -ftree-vectorize -fno-inline;; +compile;pr92586.f90;;;; compile;pr92781.f90;;;; compile;pr92874.f90;;-O2;; compile;pr92882.f;;-O2 -fno-inline;; @@ -2638,6 +2731,8 @@ compile;pr93600_1.f90;xfail;;; compile;pr93601.f90;xfail;;; compile;pr93603.f90;xfail;;; compile;pr93604.f90;xfail;;; +compile;pr93635.f90;xfail;;; +compile;pr93678.f90;;;; compile;pr93685_2.f90;xfail;;; compile;pr93686_1.f90;xfail;;; compile;pr93686_2.f90;xfail;;; @@ -2653,6 +2748,7 @@ compile;PR94104b.f90;xfail;-std=f2008;; compile;PR94110.f90;xfail;;; compile;pr94285.f90;;-Os -fno-tree-dominator-opts -fno-tree-vrp -fcompare-debug;; compile;pr94329.f90;;-O1 -fno-tree-loop-optimize -fwrapv -fcompare-debug;; +compile;pr94380.f90;;;; compile;pr94708.f90;;-O2 -funsafe-math-optimizations -fdump-rtl-combine;aarch64.+-.+-.+; compile;pr95053.f;;;; compile;pr95053_2.f90;;;; @@ -2666,7 +2762,7 @@ compile;pr95342.f90;xfail;;; compile;PR95352.f90;;;; compile;pr95373_1.f90;xfail;-std=f95;; compile;pr95373_2.f90;xfail;-std=f2003;; -compile;pr95398.f90;xfail;;; +compile;pr95398.f90;xfail;-std=f2008;; compile;pr95446.f90;;-pedantic-errors;; compile;pr95500.f90;;;; compile;pr95502.f90;xfail;;; @@ -2690,6 +2786,7 @@ compile;pr95690.f90;xfail;;; compile;pr95707.f90;;-fsecond-underscore;; compile;pr95708.f90;xfail;;; compile;pr95709.f90;xfail;-std=legacy;; +compile;pr95710.f90;xfail;;; compile;pr95826.f90;;-fsecond-underscore;; compile;pr95827.f90;;-fcoarray=lib -fsecond-underscore;; compile;pr95828.f90;;-fsecond-underscore;; @@ -2732,8 +2829,12 @@ compile;pr98974.F90;;-Ofast;; compile;pr99036.f90;xfail;;; compile;pr99060.f90;xfail;;; compile;pr99112.f90;;-fcheck=pointer -fdump-tree-original;; +compile;pr99139.f90;;-finit-local-zero;; compile;pr99204.f90;;-O2 -w;; +compile;pr99326.f90;;;; compile;pr99349.f90;xfail;;; +compile;pr99350.f90;xfail;;; +compile;pr99368.f90;xfail;;; compile;pr99545.f90;;-fcheck=mem;; compile;pr99602.f90;;-fcheck=pointer -fdump-tree-original;; compile;pr99602a.f90;;-fcheck=pointer -fdump-tree-original;; @@ -2822,6 +2923,7 @@ compile;proc_ptr_45.f90;;;; compile;proc_ptr_46.f90;xfail;;; compile;proc_ptr_49.f90;;;; compile;proc_ptr_50.f90;;;; +compile;proc_ptr_53.f90;;;; compile;proc_ptr_9.f90;;;; compile;proc_ptr_common_2.f90;xfail;;; compile;proc_ptr_comp_10.f90;;;; @@ -2855,6 +2957,7 @@ compile;proc_ptr_comp_49.f90;;;; compile;proc_ptr_comp_50.f90;;;; compile;proc_ptr_comp_51.f90;;-fdump-tree-original;; compile;proc_ptr_comp_52.f90;;;; +compile;proc_ptr_comp_53.f90;;;; compile;proc_ptr_comp_7.f90;;;; compile;proc_ptr_comp_pass_4.f90;xfail;;; compile;proc_ptr_comp_pass_6.f90;;-fcheck=bounds;; @@ -2876,6 +2979,7 @@ compile;protected_8.f90;xfail;;; compile;protected_9.f90;xfail;;; compile;ptr-func-1.f90;;-std=f2008;; compile;ptr-func-2.f90;xfail;-std=f2003;; +compile;ptr-func-5.f90;;;; compile;ptr_func_assign_2.f08;xfail;-std=f2003;; compile;ptr_func_assign_4.f08;xfail;;; compile;public_private_module.f90;xfail;;; @@ -2951,6 +3055,9 @@ compile;redefined_intrinsic_assignment_2.f90;xfail;;; compile;repeat_4.f90;xfail;;; compile;repeat_5.f90;;;; compile;repeat_7.f90;;;; +compile;repeat_8.f90;;-Wconversion-extra;; +compile;reshape_10.f90;;-fmax-array-constructor=65536 -fdump-tree-original;; +compile;reshape_11.f90;xfail;-fmax-array-constructor=65536;; compile;reshape_5.f90;xfail;;; compile;reshape_6.f90;;;; compile;reshape_7.f90;xfail;;; @@ -2993,6 +3100,7 @@ compile;select_char_3.f90;;-O2 -Wuninitialized;; compile;select_rank_2.f90;xfail;;; compile;select_rank_3.f90;xfail;;; compile;select_rank_4.f90;xfail;;; +compile;select_rank_6.f90;xfail;;; compile;select_type_1.f03;xfail;;; compile;select_type_10.f03;;;; compile;select_type_11.f03;xfail;;; @@ -3022,6 +3130,7 @@ compile;select_type_47.f90;;;; compile;select_type_9.f03;xfail;;; compile;selected_char_kind_2.f90;xfail;;; compile;selected_char_kind_3.f90;xfail;-std=f95 -pedantic -Wall -Wno-intrinsics-std;; +compile;selected_logical_kind_2.f90;xfail;-std=f2018;; compile;selected_real_kind_1.f90;xfail;;; compile;selected_real_kind_3.f90;xfail;-std=f2003;; compile;semicolon_fixed.f;xfail;-std=f2003;; @@ -3050,6 +3159,7 @@ compile;simd-builtins-8.f90;;-nostdinc -Ofast -fpre-include=simd-builtins-8.h -f compile;simpleif_2.f90;xfail;;; compile;simplify_cshift_2.f90;;;; compile;simplify_cshift_3.f90;;;; +compile;size_dim_2.f90;xfail;;; compile;size_kind.f90;;;; compile;size_kind_2.f90;;-fdump-tree-original;; compile;size_kind_3.f90;xfail;;; @@ -3058,11 +3168,14 @@ compile;sizeof_3.f90;;-fdump-tree-original;; compile;sizeof_5.f90;;;; compile;sizeof_proc.f90;xfail;;; compile;spec_expr_1.f90;xfail;;; +compile;spec_expr_10.f90;;;; compile;spec_expr_2.f90;;;; compile;spec_expr_3.f90;;;; compile;spec_expr_4.f90;;;; compile;spec_expr_5.f90;;;; compile;spec_expr_6.f90;xfail;;; +compile;spec_expr_8.f90;;;; +compile;spec_expr_9.f90;;;; compile;specification_type_resolution_1.f90;;;; compile;specification_type_resolution_2.f90;;;; compile;specifics_2.f90;;;; @@ -3079,6 +3192,7 @@ compile;statement_function_1.f90;xfail;;; compile;statement_function_2.f90;xfail;;; compile;statement_function_3.f;xfail;;; compile;statement_function_4.f90;xfail;;; +compile;statement_function_5.f90;;-std=legacy -fdump-tree-optimized;; compile;stfunc_2.f90;xfail;;; compile;stfunc_3.f90;xfail;-std=legacy;; compile;stfunc_5.f90;xfail;;; @@ -3132,6 +3246,7 @@ compile;submodule_24.f08;;;; compile;submodule_25.f08;xfail;;; compile;submodule_26.f08;;-fcoarray=single;; compile;submodule_3.f08;xfail;-std=f2003;; +compile;submodule_33.f08;xfail;;; compile;submodule_4.f08;xfail;;; compile;submodule_5.f08;xfail;;; compile;submodule_9.f08;xfail;;; @@ -3144,6 +3259,7 @@ compile;substr_10.f90;xfail;;; compile;substring_equivalence.f90;;;; compile;substring_integer_index.f90;xfail;;; compile;system_clock_2.f90;xfail;-std=f95;; +compile;system_clock_4.f90;xfail;-std=f2023;; compile;tab_continuation.f;xfail;;; compile;temporary_2.f90;;;; compile;test_bind_c_parens.f03;xfail;;; @@ -3322,6 +3438,7 @@ compile;use_28.f90;xfail;;; compile;use_29.f90;xfail;;; compile;use_3.f90;xfail;;; compile;use_30.f90;xfail;;; +compile;use_31.f90;xfail;;; compile;use_4.f90;xfail;;; compile;use_6.f90;xfail;-std=f95;; compile;use_7.f90;xfail;;; @@ -3513,6 +3630,7 @@ compile;wunused-parameter_2.f90;;-Wunused-parameter -Wunused-dummy-argument;; compile;zero_sized_10.f90;xfail;;; compile;zero_sized_11.f90;;;; compile;zero_sized_12.f90;;;; +compile;zero_sized_13.f90;xfail;-w;; compile;zero_sized_2.f90;;;; compile;zero_sized_6.f90;xfail;;; compile;zero_sized_7.f90;;;; @@ -3625,6 +3743,7 @@ run;allocatable_function_6.f90;;;; run;allocatable_function_7.f90;;;; run;allocatable_function_8.f90;;;; run;allocatable_function_9.f90;;;; +run;allocatable_length_2.f90;;;; run;allocatable_scalar_1.f90;;;; run;allocatable_scalar_10.f90;;;; run;allocatable_scalar_12.f90;;;; @@ -3666,6 +3785,11 @@ run;allocate_with_source_22.f03;;;; run;allocate_with_source_23.f03;xfail;-fcheck=bounds;; run;allocate_with_source_24.f90;;;; run;allocate_with_source_26.f90;;;; +run;allocate_with_source_27.f90;;;; +run;allocate_with_source_28.f90;;;; +run;allocate_with_source_30.f90;xfail;-std=f2008 -fcheck=bounds -g -fdump-tree-original;; +run;allocate_with_source_31.f90;;-std=gnu -fcheck=no-bounds;; +run;allocate_with_source_32.f90;;;; run;allocate_with_source_5.f90;;;; run;allocate_with_source_6.f90;;-fbounds-check;; run;allocate_with_source_7.f08;;;; @@ -3675,6 +3799,7 @@ run;allocate_zerosize_1.f90;;;; run;allocate_zerosize_2.f90;;;; run;allocate_zerosize_3.f;;;; run;allocated_1.f90;;;; +run;allocated_4.f90;;;; run;altreturn_3.f90;;-std=gnu;; run;altreturn_5.f90;;-std=gnu;; run;altreturn_9_0.f90 altreturn_9_1.f90;;-std=gnu;; @@ -3809,6 +3934,13 @@ run;associate_47.f90;;;; run;associate_48.f90;;;; run;associate_49.f90;;;; run;associate_60.f90;;;; +run;associate_61.f90;;;; +run;associate_63.f90;;;; +run;associate_64.f90;;-fdump-tree-original;; +run;associate_65.f90;;;; +run;associate_66.f90;;-fdump-tree-original;; +run;associate_67.f90;;;; +run;associate_68.f90;;;; run;associate_7.f03;;-std=f2003;; run;associate_8.f03;;-std=f2003;; run;associate_9.f03;;-std=f2003;; @@ -3849,6 +3981,7 @@ run;assumed_rank_bounds_2.f90;;;; run;assumed_rank_bounds_3.f90;;;; run;assumed_shape_ranks_2.f90;;;; run;assumed_type_13.f90 assumed_type_13.c;;;; +run;assumed_type_18.f90;;;; run;assumed_type_2a.f90;;;; run;assumed_type_9.f90;;;; run;atan2_1.f90;;-ffloat-store;; @@ -3898,6 +4031,7 @@ run;bind_c_coms.f90 bind_c_coms_driver.c;;-w;; run;bind_c_dts.f90 bind_c_dts_driver.c;;;; run;bind_c_dts_2.f03 bind_c_dts_2_driver.c;;;; run;bind_c_optional-1.f90;;;; +run;bind_c_optional-2.f90;;;; run;bind_c_procs_3.f90;;;; run;bind_c_usage_10.f03 bind_c_usage_10_c.c;;;; run;bind_c_usage_15.f90;;;; @@ -3924,6 +4058,8 @@ run;block_8.f08;;-std=f2008;; run;blockdata_1.f90;;;; run;blockdata_11.f90;;;; run;bound_1.f90;;;; +run;bound_10.f90;;;; +run;bound_11.f90;;;; run;bound_2.f90;;-std=gnu;; run;bound_3.f90;;;; run;bound_4.f90;;;; @@ -3946,6 +4082,7 @@ run;bounds_check_19.f90;;-fbounds-check;; run;bounds_check_2.f;;-fbounds-check;; run;bounds_check_20.f90;;-fcheck=bounds -ffrontend-optimize;; run;bounds_check_23.f90;;-fcheck=bounds -fdump-tree-original;; +run;bounds_check_25.f90;;-fcheck=bounds -fdump-tree-original;; run;bounds_check_4.f90;;-fbounds-check;; run;bounds_check_5.f90;;-fbounds-check;; run;bounds_check_6.f90;;-fbounds-check;; @@ -3962,6 +4099,9 @@ run;bounds_check_fail_1.f90;xfail;-fbounds-check;; run;bounds_check_fail_2.f90;xfail;-fbounds-check;; run;bounds_check_fail_3.f90;xfail;-fbounds-check;; run;bounds_check_fail_4.f90;xfail;-fbounds-check;; +run;bounds_check_fail_5.f90;xfail;-fcheck=bounds -g -fdump-tree-original;; +run;bounds_check_fail_6.f90;xfail;-fcheck=bounds -g -fdump-tree-original;; +run;bounds_check_fail_7.f90;xfail;-fcheck=bounds -g;; run;bounds_check_strlen_1.f90;xfail;-fbounds-check;; run;bounds_check_strlen_2.f90;xfail;-fbounds-check;; run;bounds_check_strlen_3.f90;xfail;-fbounds-check;; @@ -4022,6 +4162,7 @@ run;c_ptr_tests_9.f03;;-std=gnu;; run;c_size_t_test.f03 c_size_t_driver.c;;;; run;c_sizeof_1.f90;;;; run;c_sizeof_5.f90;;-fcray-pointer;; +run;c_sizeof_8.f90;;;; run;char4-subscript.f90;;-fdump-tree-original;; run;char4_decl-2.f90;;-fdump-tree-original;; run;char4_decl.f90;;-fdump-tree-original;; @@ -4123,6 +4264,7 @@ run;class_65.f90;;;; run;class_66.f90;;;; run;class_67.f90;;;; run;class_70.f03;;;; +run;class_78.f90;;;; run;class_9.f03;;;; run;class_alias.f90;;-fdump-tree-original;; run;class_allocate_1.f03;;;; @@ -4164,6 +4306,7 @@ run;class_assign_4.f90;;;; run;class_defined_operator_1.f03;;;; run;class_defined_operator_2.f03;;;; run;class_dummy_1.f03;;;; +run;class_dummy_11.f90;;;; run;class_dummy_2.f03;;;; run;class_dummy_6.f90;;;; run;class_dummy_7.f90;;;; @@ -4239,12 +4382,14 @@ run;contained_3.f90;;;; run;contained_equivalence_1.f90;;;; run;contained_module_proc_1.f90;;;; run;contiguous_10.f90;;-fdump-tree-original;; +run;contiguous_15.f90;;-fdump-tree-original;; run;contiguous_8.f90;;;; run;continuation_1.f90;;-Wampersand;; run;continuation_11.f90;;-Wall -pedantic;; run;continuation_12.f90;;;; run;continuation_13.f90;;-std=gnu;; run;continuation_14.f;;-std=gnu;; +run;continuation_19.f;;-std=f2023;; run;continuation_8.f90;;;; run;convert_2.f90;;;; run;convert_implied_open.f90;;-fconvert=swap;; @@ -4266,6 +4411,7 @@ run;cshift_large_1.f90;;;; run;cshift_nan_1.f90;;;; run;csqrt_2.f;;;; run;data_array_1.f90;;;; +run;data_array_7.f90;;;; run;data_char_1.f90;;-std=gnu;; run;data_char_2.f90;;-std=legacy;; run;data_char_3.f90;;-O2;; @@ -4273,7 +4419,10 @@ run;data_derived_1.f90;;;; run;data_implied_do_1.f90;;;; run;data_namelist_conflict.f90;;;; run;data_stmt_pointer.f90;;;; +run;data_vector_section.f90;;;; run;date_and_time_1.f90;;;; +run;date_and_time_3.f90;;-std=f2018;; +run;date_and_time_4.f90;;-std=f2018;; run;deallocate_alloc_opt_3.f90;;;; run;deallocate_error_1.f90;xfail;;; run;deallocate_error_2.f90;xfail;;; @@ -4364,6 +4513,8 @@ run;deferred_character_32.f90;;;; run;deferred_character_33.f90 deferred_character_33a.f90;;;; run;deferred_character_34.f90;;;; run;deferred_character_36.f90;;;; +run;deferred_character_37.f90;;;; +run;deferred_character_38.f90;;;; run;deferred_character_4.f90;;;; run;deferred_character_5.f90;;;; run;deferred_character_6.f90;;;; @@ -4409,6 +4560,8 @@ run;dependency_55.f90;;;; run;dependency_58.f90;;-ffrontend-optimize -Warray-temporaries;; run;dependency_60.f90;;;; run;dependent_decls_1.f90;;;; +run;dependent_decls_2.f90;;;; +run;dependent_decls_3.f90;;;; run;der_array_1.f90;;;; run;der_array_io_1.f90;;-std=legacy;; run;der_array_io_2.f90;;-std=legacy;; @@ -4539,6 +4692,7 @@ run;endfile.f90;;;; run;endfile_2.f90;;;; run;endfile_3.f90;xfail;;; run;endfile_4.f90;xfail;;; +run;endfile_5.f90;;;; run;entry_1.f90;;;; run;entry_10.f90;;;; run;entry_12.f90;;;; @@ -4641,6 +4795,10 @@ run;finalize_48.f90;;;; run;finalize_50.f90;;;; run;finalize_51.f90;;;; run;finalize_52.f90;;;; +run;finalize_55.f90;;;; +run;finalize_56.f90;;;; +run;finalize_8.f03;;;; +run;findloc_10.f90;;-fdump-tree-original;; run;findloc_2.f90;;;; run;findloc_3.f90;;;; run;findloc_4.f90;;;; @@ -4792,6 +4950,7 @@ run;implied_do_io_4.f90;;-ffrontend-optimize -fdump-tree-original;; run;implied_do_io_5.f90;;-ffrontend-optimize;; run;implied_do_io_6.f90;;-ffrontend-optimize;; run;implied_do_io_7.f90;;;; +run;implied_do_io_8.f90;;-fcheck=bounds;; run;implied_shape_1.f08;;-std=f2008;; run;implied_shape_4.f90;;-std=f2008;; run;import.f90;;;; @@ -4881,7 +5040,14 @@ run;intent_optimize_9.f90;;-fno-inline -fno-ipa-modref -fdump-tree-optimized -fd run;intent_out_12.f90;;;; run;intent_out_13.f90;;;; run;intent_out_14.f90;;;; +run;intent_out_16.f90;;;; +run;intent_out_17.f90;;;; +run;intent_out_18.f90;;;; +run;intent_out_19.f90;;;; run;intent_out_2.f90;;;; +run;intent_out_20.f90;;;; +run;intent_out_21.f90;;;; +run;intent_out_22.f90;;;; run;intent_out_5.f90;;;; run;intent_out_6.f90;;;; run;interface_12.f90;;;; @@ -4950,10 +5116,12 @@ run;iostat_5.f90;;;; run;is_contiguous_1.f90;;;; run;is_contiguous_2.f90;;;; run;is_contiguous_3.f90;;-fdump-tree-original;; +run;is_contiguous_4.f90;;;; run;is_iostat_end_eor_1.f90;;;; run;ishft_1.f90;;;; run;ishft_2.f90;;;; run;ishft_4.f90;;-fdump-tree-original;; +run;ishftc_optional_size_1.f90;;;; run;isnan_1.f90;;;; run;isnan_2.f90;;-fno-range-check;; run;iso_c_binding_rename_1.f03 iso_c_binding_rename_1_driver.c;;;; @@ -4979,6 +5147,7 @@ run;ISO_Fortran_binding_9.f90 ISO_Fortran_binding_9.c;;-lc;; run;iso_fortran_binding_uint8_array.f90 iso_fortran_binding_uint8_array_driver.c;;;; run;iso_fortran_env_1.f90;;;; run;iso_fortran_env_3.f90;;;; +run;iso_fortran_env_8.f90;;;; run;itime_idate_1.f;;;; run;itime_idate_2.f;;-fdefault-integer-8;; run;large_integer_kind_1.f90;;;; @@ -5067,6 +5236,7 @@ run;maxloc_1.f90;;;; run;maxloc_2.f90;;;; run;maxloc_3.f90;;;; run;maxloc_4.f90;;;; +run;maxloc_5.f90;;;; run;maxloc_bounds_1.f90;xfail;-fbounds-check;; run;maxloc_bounds_2.f90;xfail;-fbounds-check;; run;maxloc_bounds_3.f90;xfail;-fbounds-check;; @@ -5103,6 +5273,7 @@ run;minloc_1.f90;;;; run;minloc_2.f90;;;; run;minloc_3.f90;;;; run;minloc_4.f90;;;; +run;minloc_5.f90;;;; run;minloc_string_1.f90;;;; run;minlocval_1.f90;;;; run;minlocval_2.f90;;;; @@ -5115,6 +5286,7 @@ run;minmaxloc_11.f90;;;; run;minmaxloc_12.f90;;;; run;minmaxloc_13.f90;;;; run;minmaxloc_16.f90;;-fdump-tree-original;; +run;minmaxloc_17.f90;;;; run;minmaxloc_2.f90;;;; run;minmaxloc_3.f90;;-fdefault-integer-8;; run;minmaxloc_4.f90;;;; @@ -5131,6 +5303,7 @@ run;minval_char_5.f90;;;; run;minval_parameter_1.f90;;;; run;missing_optional_dummy_1.f90;;;; run;missing_optional_dummy_6.f90;;-fdump-tree-original;; +run;missing_optional_dummy_7.f90;;;; run;missing_parens_2.f90;;;; run;mixed_io_1.f90 mixed_io_1.c;;-w;; run;mod_large_1.f90;;;; @@ -5308,6 +5481,9 @@ run;open_status_2.f90;;;; run;open_status_3.f90;;;; run;operator_1.f90;;;; run;optional_absent_1.f90;;-std=f2008;; +run;optional_absent_10.f90;;;; +run;optional_absent_11.f90;;;; +run;optional_absent_12.f90;;-fcheck=array-temps;; run;optional_absent_2.f90;;;; run;optional_absent_3.f90;;;; run;optional_absent_4.f90;;;; @@ -5315,14 +5491,17 @@ run;optional_absent_5.f90;;;; run;optional_absent_6.f90;;;; run;optional_absent_7.f90;;-fdump-tree-original;; run;optional_absent_8.f90;;;; +run;optional_absent_9.f90;;;; run;optional_assumed_charlen_2.f90;;;; run;optional_class_1.f90;;;; +run;optional_deferred_char_1.f90;;;; run;optional_dim_2.f90;;;; run;optional_dim_3.f90;;;; run;output_exponents_1.f90;;-std=legacy;; run;overload_1.f90;;;; run;overload_3.f90;;-fno-tree-vrp;; run;overload_4.f90;;-Wno-intrinsic-shadow;; +run;overload_5.f90;;;; run;overwrite_1.f;;;; run;pack_bounds_1.f90;xfail;-fbounds-check;; run;pack_mask_1.f90;;;; @@ -5364,6 +5543,8 @@ run;pdt_27.f03;;;; run;pdt_28.f03;;-fbounds-check;; run;pdt_3.f03;;;; run;pdt_31.f03;;;; +run;pdt_33.f03;;;; +run;pdt_36.f03;;;; run;pdt_7.f03;;;; run;pointer_1.f90;;;; run;pointer_array_1.f90;;;; @@ -5441,14 +5622,40 @@ run;PR100911.f90 PR100911.c;;;; run;PR100914.f90 PR100914.c;;-Wno-pedantic;; run;PR100915.f90 PR100915.c;;;; run;pr100950.f90;;-fdump-tree-original;; +run;pr103312.f90;;;; +run;pr103389.f90;;;; +run;pr104429.f90;;;; run;pr105205.f90;;;; +run;pr105361.f90;;;; +run;pr105456-nmlr.f90;xfail;;; +run;pr105456-nmlw.f90;xfail;;; +run;pr105456-ruf.f90;xfail;;; +run;pr105456-wf.f90;xfail;;; +run;pr105456-wuf.f90;xfail;;; +run;pr105456.f90;xfail;;; +run;pr105473.f90;;;; +run;pr105847.f90;;;; run;pr106331.f90;;-Og;; run;pr106557.f90;;-fdump-tree-original;; run;pr106731.f90;;;; run;pr106918.f90;;;; +run;pr107068.f90;;;; run;pr107872.f90;;;; +run;pr107900.f90;;;; run;pr108010.f90;;;; run;pr108131.f90;;-fdump-tree-original;; +run;pr108961.f90;;;; +run;pr109358.f90;;;; +run;pr109662-a.f90;;-std=f2003;; +run;pr109662.f90;;-std=f2003;; +run;pr110415.f90;;;; +run;pr111022.f90;;;; +run;pr112407a.f90;;;; +run;pr113363.f90;;;; +run;pr113956.f90;;;; +run;pr114012.f90;;;; +run;pr114304-2.f90;;;; +run;pr114304.f90;;;; run;pr12884.f;;;; run;pr15129.f90;;-std=legacy;; run;pr15140.f90;;;; @@ -5525,6 +5732,7 @@ run;pr47757-3.f90;;;; run;pr47878.f90;;;; run;pr48958.f90;xfail;-fcheck=pointer -fdump-tree-original;; run;pr49103.f90;;;; +run;pr49213.f90;;;; run;PR49268.f90;;-fcray-pointer;; run;pr50069_1.f90;;;; run;pr51434.f90;;;; @@ -5554,6 +5762,7 @@ run;pr67524.f90;;;; run;pr67885.f90;;;; run;pr68053.f90;;;; run;pr68078.f90 set_vm_limit.c;;;i.86-.+-linux.+ x86_64-.+-linux.+; +run;pr68155.f90;;;; run;pr68566.f90;;;; run;pr69455_1.f90;;;; run;pr69455_2.f90;;;; @@ -5573,6 +5782,7 @@ run;pr81509_1.f90;;;; run;pr81849.f90;;;; run;pr82004.f90;;-Ofast;; run;pr82314.f90;;;; +run;pr82774.f90;;;; run;pr83149_1.f90 pr83149.f90 pr83149.f90;;;; run;pr83149_b.f90 pr83149_a.f90 pr83149_a.f90;;;; run;pr83864.f90;;;; @@ -5580,6 +5790,7 @@ run;pr83874.f90;;;; run;pr84088.f90;;;; run;pr84155.f90;;;; run;pr84523.f90;;;; +run;pr84868.f90;;;; run;pr85520.f90;;;; run;pr85786.f90;;;; run;PR85868A.f90;;;; @@ -5589,6 +5800,7 @@ run;pr86322_3.f90;;;; run;pr86328.f90;;;; run;pr86760.f90;;;; run;pr87045.f90;;-fcheck=bounds;; +run;pr87946.f90;;;; run;pr87993.f90;;;; run;pr87994_1.f90;;;; run;pr87994_2.f90;;;; @@ -5597,6 +5809,7 @@ run;pr88116_2.f90;;;; run;pr88169_1.f90;;;; run;pr88169_2.f90;;;; run;pr88611.f90;;-fdefault-integer-8 -fno-tree-forwprop -O3 -fno-tree-ccp;; +run;pr88688.f90;;;; run;pr89077.f90;;;; run;pr89084.f90;;;; run;pr89266.f90;;;; @@ -5650,6 +5863,7 @@ run;pr97500.f90;;-ftree-vectorize -fno-guess-branch-probability;; run;pr98017.f90;;;; run;pr98076.f90;;;; run;pr98408.f90;;;; +run;pr99210.f90;;;; run;pr99602b.f90;;-fcheck=pointer;; run;print_c_kinds.f90;;;; run;print_fmt_1.f90;;;; @@ -5916,7 +6130,12 @@ run;select_type_8.f03;;;; run;selected_char_kind_1.f90;;;; run;selected_char_kind_4.f90;;;; run;selected_kind_1.f90;;-fdefault-integer-8;; +run;selected_logical_kind_1.f90;;;; +run;selected_logical_kind_3.f90;;;; +run;selected_logical_kind_4.f90;;;; run;selected_real_kind_2.f90;;-std=f2008;; +run;set_exponent_1.f90;;;; +run;shape_12.f90;;;; run;shape_2.f90;;;; run;shape_3.f90;;;; run;shape_4.f90;;;; @@ -5939,6 +6158,7 @@ run;simplify_modulo.f90;;;; run;single_char_string.f90;;-fdump-tree-original;; run;size_dim.f90;;;; run;size_optional_dim_1.f90;;-fdump-tree-original;; +run;size_optional_dim_2.f90;;-fdump-tree-original;; run;sizeof.f90;;;; run;sizeof_4.f90;;;; run;sizeof_6.f90;;;; @@ -5961,6 +6181,7 @@ run;stop_4.f90;;-fdump-tree-original -std=f2018;; run;stop_shouldfail.f90;xfail;;; run;storage_size_1.f08;;;; run;storage_size_3.f08;;;; +run;storage_size_7.f90;;;; run;streamio_1.f90;;;; run;streamio_10.f90;;;; run;streamio_11.f90;;;; @@ -5978,8 +6199,9 @@ run;streamio_5.f90;;;; run;streamio_6.f90;;;; run;streamio_7.f90;;;; run;streamio_8.f90;;;; -run;streamio_9.f90;;;; +run;streamio_9.f90;;-ffloat-store;; run;string_array_constructor_2.f90;;;; +run;string_array_constructor_4.f90;;;; run;string_assign_2.f90;;-ffrontend-optimize;; run;string_compare_1.f90;;;; run;string_compare_2.f90;;;; @@ -6027,8 +6249,8 @@ run;substr_alloc_string_comp_1.f90;;;; run;substr_simplify.f90;;;; run;sum_init_expr.f03;;-fno-inline;; run;sum_zero_array_1.f90;;;; -run;system_clock_1.f90;;;; -run;system_clock_3.f08;;;; +run;system_clock_1.f90;;-std=f2003;; +run;system_clock_3.f08;;-std=f2008;; run;t_editing.f;;;; run;team_change_1.f90;;-fcoarray=single;; run;team_end_1.f90;;-fcoarray=single;; @@ -6049,6 +6271,7 @@ run;transfer_assumed_size_1.f90;;;; run;transfer_char_kind4.f90;;;; run;transfer_class_2.f90;;;; run;transfer_class_3.f90;;;; +run;transfer_class_4.f90;;;; run;transfer_intrinsic_2.f90;;;; run;transfer_intrinsic_3.f90;;;; run;transfer_intrinsic_5.f90;;;; @@ -6172,6 +6395,8 @@ run;value_1.f90;;-std=f2003;; run;value_4.f90 value_4.c;;-ff2c -w -O0;; run;value_6.f03;;;; run;value_7.f03;;;; +run;value_9.f90;;;; +run;value_optional_1.f90;;;; run;value_test.f90;;;; run;value_tests_f03.f90;;;; run;vector_subscript_1.f90;;;; @@ -6227,8 +6452,10 @@ run;zero_array_components_1.f90;;;; run;zero_length_1.f90;;;; run;zero_length_2.f90;;;; run;zero_sized_1.f90;;;; +run;zero_sized_14.f90;;;; +run;zero_sized_15.f90;;;; run;zero_sized_3.f90;;;; run;zero_sized_4.f90;;;; run;zero_sized_5.f90;;;; run;zero_sized_8.f90;;;; -run;zero_sized_9.f90;;;; +run;zero_sized_9.f90;;;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/transfer_class_4.f90 b/Fortran/gfortran/regression/transfer_class_4.f90 new file mode 100644 index 000000000..604874e1e --- /dev/null +++ b/Fortran/gfortran/regression/transfer_class_4.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! +! Fix TRANSFER intrinsic for unlimited polymorphic SOURCEs - PR98534 +! Note that unlimited polymorphic MOLD is a TODO. +! +! Contributed by Paul Thomas +! + use, intrinsic :: ISO_FORTRAN_ENV, only: real32 + implicit none + character(*), parameter :: string = "abcdefgh" + character(len=:), allocatable :: string_a(:) + class(*), allocatable :: star + class(*), allocatable :: star_a(:) + character(len=:), allocatable :: chr + character(len=:), allocatable :: chr_a(:) + integer :: sz, sum1, sum2, i + real(real32) :: r = 1.0 + +! Part 1: worked correctly + star = r + sz = storage_size (star)/8 + allocate (character(len=sz) :: chr) + chr = transfer (star, chr) + sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + chr = transfer(1.0, chr) + sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + + if (sz /= storage_size (r)/8) stop 1 + if (sum1 /= sum2) stop 2 + + deallocate (star) ! The automatic reallocation causes invalid writes + ! and memory leaks. Even with this deallocation + ! The invalid writes still occur. + deallocate (chr) + +! Part 2: Got everything wrong because '_len' field of unlimited polymorphic +! expressions was not used. + star = string + sz = storage_size (star)/8 + if (sz /= len (string)) stop 3 ! storage_size failed + + sz = len (string) ! Ignore previous error in storage_size + allocate (character(len=sz) :: chr) + chr = transfer (star, chr) + sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + chr = transfer(string, chr) + sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) + if (sum1 /= sum2) stop 4 ! transfer failed + +! Check that arrays are OK for transfer + star_a = ['abcde','fghij'] + allocate (character (len = 5) :: chr_a(2)) + chr_a = transfer (star_a, chr_a) + if (any (chr_a .ne. ['abcde','fghij'])) stop 5 + +! Check that string length and size are correctly handled + string_a = ["abcdefgh", "ijklmnop"] + star_a = string_a; + chr_a = transfer (star_a, chr_a) ! Old string length used for size + if (size(chr_a) .ne. 4) stop 6 + if (len(chr_a) .ne. 5) stop 7 + if (trim (chr_a(3)) .ne. "klmno") stop 8 + if (chr_a(4)(1:1) .ne. "p") stop 9 + + chr_a = transfer (star_a, string_a) ! Use correct string_length for payload + if (size(chr_a) .ne. 2) stop 10 + if (len(chr_a) .ne. 8) stop 11 + if (any (chr_a .ne. string_a)) stop 12 + +! Check that an unlimited polymorphic function result is transferred OK + deallocate (chr_a) + string_a = ['abc', 'def', 'hij'] + chr_a = transfer (foo (string_a), string_a) + if (any (chr_a .ne. string_a)) stop 13 + +! Finally, check that the SIZE gives correct results with unlimited sources. + chr_a = transfer (star_a, chr_a, 4) + if (chr_a (4) .ne. 'jkl') stop 14 + + deallocate (star, chr, star_a, chr_a, string_a) +contains + function foo (arg) result(res) + character(*), intent(in) :: arg(:) + class(*), allocatable :: res(:) + res = arg + end +end diff --git a/Fortran/gfortran/regression/ubsan/DisabledFiles.cmake b/Fortran/gfortran/regression/ubsan/DisabledFiles.cmake index 8fa3fcdfc..e020ea91a 100644 --- a/Fortran/gfortran/regression/ubsan/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/ubsan/DisabledFiles.cmake @@ -9,8 +9,12 @@ # There are currently no unsupported files. set(UNSUPPORTED_FILES "") -# There are currently no unimplemented files. -set(UNIMPLEMENTED_FILES "") +# These tests are disabled because they trigger "not yet implemented" +# assertions in flang. +file(GLOB UNIMPLEMENTED_FILES CONFIGURE_DEPENDS + # not yet implemented: assumed-rank variable in procedure + missing_optional_dummy_8.f90 +) # There are currently no skipped files. set(SKIPPED_FILES "") diff --git a/Fortran/gfortran/regression/ubsan/missing_optional_dummy_8.f90 b/Fortran/gfortran/regression/ubsan/missing_optional_dummy_8.f90 new file mode 100644 index 000000000..fd3914934 --- /dev/null +++ b/Fortran/gfortran/regression/ubsan/missing_optional_dummy_8.f90 @@ -0,0 +1,108 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original -fsanitize=undefined" } +! +! PR fortran/101135 - Load of null pointer when passing absent +! assumed-shape array argument for an optional dummy argument +! +! Based on testcase by Marcel Jacobse + +program main + implicit none + character(len=3) :: a(6) = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs'] + call as () + call as (a(::2)) + call as_c () + call as_c (a(2::2)) + call test_wrapper + call test_wrapper_c + call test_ar_wrapper + call test_ar_wrapper_c +contains + subroutine as (xx) + character(len=*), optional, intent(in) :: xx(*) + if (.not. present (xx)) return + print *, xx(1:3) + end subroutine as + + subroutine as_c (zz) bind(c) + character(len=*), optional, intent(in) :: zz(*) + if (.not. present (zz)) return + print *, zz(1:3) + end subroutine as_c + + subroutine test_wrapper (x) + real, dimension(1), intent(out), optional :: x + call test (x) + call test1 (x) + call test_c (x) + call test1_c (x) + end subroutine test_wrapper + + subroutine test_wrapper_c (w) bind(c) + real, dimension(1), intent(out), optional :: w + call test (w) + call test1 (w) + call test_c (w) + call test1_c (w) + end subroutine test_wrapper_c + + subroutine test (y) + real, dimension(:), intent(out), optional :: y + if (present (y)) y=0. + end subroutine test + + subroutine test_c (y) bind(c) + real, dimension(:), intent(out), optional :: y + if (present (y)) y=0. + end subroutine test_c + + subroutine test1 (y) + real, dimension(1), intent(out), optional :: y + if (present (y)) y=0. + end subroutine test1 + + subroutine test1_c (y) bind(c) + real, dimension(1), intent(out), optional :: y + if (present (y)) y=0. + end subroutine test1_c + + subroutine test_ar_wrapper (p, q, r) + real, intent(out), optional :: p + real, dimension(1), intent(out), optional :: q + real, dimension(:), intent(out), optional :: r + call test_ar (p) + call test_ar (q) + call test_ar (r) + call test_ar_c (p) + call test_ar_c (q) + call test_ar_c (r) + end subroutine test_ar_wrapper + + subroutine test_ar_wrapper_c (u, v, s) bind(c) + real, intent(out), optional :: u + real, dimension(1), intent(out), optional :: v + real, dimension(:), intent(out), optional :: s + call test_ar (u) + call test_ar (v) +! call test_ar (s) ! Disabled due to runtime segfault, see pr114355 + call test_ar_c (u) + call test_ar_c (v) + call test_ar_c (s) + end subroutine test_ar_wrapper_c + + subroutine test_ar (z) + real, dimension(..), intent(out), optional :: z + end subroutine test_ar + + subroutine test_ar_c (z) bind(c) + real, dimension(..), intent(out), optional :: z + end subroutine test_ar_c +end program + +! { dg-final { scan-tree-dump-times "data = v != 0B " 2 "original" } } +! { dg-final { scan-tree-dump-times "data = w != 0B " 2 "original" } } +! { dg-final { scan-tree-dump-times "data = q != 0B " 2 "original" } } +! { dg-final { scan-tree-dump-times "data = x != 0B " 2 "original" } } +! { dg-final { scan-tree-dump-times "data = xx.0 != 0B " 1 "original" } } +! { dg-output " abcghinop(\n|\r\n|\r)" }" +! { dg-output " defjlmqrs(\n|\r\n|\r)" }" diff --git a/Fortran/gfortran/regression/ubsan/tests.cmake b/Fortran/gfortran/regression/ubsan/tests.cmake index 0bbfd3e1c..1f181a712 100644 --- a/Fortran/gfortran/regression/ubsan/tests.cmake +++ b/Fortran/gfortran/regression/ubsan/tests.cmake @@ -33,4 +33,5 @@ # compile;pr101624.f90;;-O2 -fsanitize=undefined;; compile;pr106062.f90;;-O2 -fsanitize=undefined;; -run;bind-c-intent-out-2.f90;;-fsanitize=undefined -fcheck=all;; \ No newline at end of file +run;bind-c-intent-out-2.f90;;-fsanitize=undefined -fcheck=all;; +run;missing_optional_dummy_8.f90;;-fdump-tree-original -fsanitize=undefined;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/ubsan/ubsan.exp b/Fortran/gfortran/regression/ubsan/ubsan.exp index 64f557c48..b2360785e 100644 --- a/Fortran/gfortran/regression/ubsan/ubsan.exp +++ b/Fortran/gfortran/regression/ubsan/ubsan.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2021-2023 Free Software Foundation, Inc. +# Copyright (C) 2021-2024 Free Software Foundation, Inc. # # This file is part of GCC. # @@ -22,10 +22,10 @@ load_lib gfortran-dg.exp load_lib ubsan-dg.exp - # Initialize `dg'. dg-init -ubsan_init +# libubsan uses libstdc++ so make sure we provide paths for it. +ubsan_init 1 # Main loop. if [check_effective_target_fsanitize_undefined] { diff --git a/Fortran/gfortran/regression/unlimited_polymorphic_11.f90 b/Fortran/gfortran/regression/unlimited_polymorphic_11.f90 index bbd3d067f..653992f40 100644 --- a/Fortran/gfortran/regression/unlimited_polymorphic_11.f90 +++ b/Fortran/gfortran/regression/unlimited_polymorphic_11.f90 @@ -10,4 +10,4 @@ call move_alloc(a,c) end -! { dg-final { scan-tree-dump "\\(struct __vtype__STAR \\*\\) c._vptr = \\(struct __vtype__STAR \\*\\) a._vptr;" "original" } } +! { dg-final { scan-tree-dump "c._vptr = a._vptr;" "original" } } diff --git a/Fortran/gfortran/regression/use_31.f90 b/Fortran/gfortran/regression/use_31.f90 new file mode 100644 index 000000000..89a9ab30d --- /dev/null +++ b/Fortran/gfortran/regression/use_31.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/107426 +! This example used to generate an ICE, caused by the use stmt from the nested +! procedure declaration setting the result of the C_LOC global intrinsic symbol +! to the symbol of C_PTR from ISO_C_BINDING being imported, before freeing the +! latter symbol because of the rejection of the use statement. +! +! Contributed by Gerhard Steinmetz + +module m +contains + subroutine p() bind(c) + use, intrinsic :: iso_c_binding + integer, target :: a = 1 + type(c_ptr) :: z + interface + subroutine s(x) bind(cc) ! { dg-error "Missing closing paren" } + use, intrinsic :: iso_c_binding ! { dg-error "Unexpected USE statement in INTERFACE block" } + integer(c_int), value :: x ! { dg-error "Parameter 'c_int' at .1. has not been declared" } + end ! { dg-error "END INTERFACE statement expected" } + end interface + z = c_loc(a) + call s(z) + end +end diff --git a/Fortran/gfortran/regression/value_9.f90 b/Fortran/gfortran/regression/value_9.f90 new file mode 100644 index 000000000..4813250eb --- /dev/null +++ b/Fortran/gfortran/regression/value_9.f90 @@ -0,0 +1,105 @@ +! { dg-do run } +! PR fortran/110360 - ABI for scalar character(len=1),value dummy argument + +program p + implicit none + character, allocatable :: ca + character, pointer :: cp + character(len=:), allocatable :: cd + character (kind=4), allocatable :: ca4 + character (kind=4), pointer :: cp4 + character(len=:,kind=4), allocatable :: cd4 + character :: c = "1" + character (kind=4) :: c4 = 4_"4" + character(len=3) :: d = "210" + character(len=3,kind=4) :: d4 = 4_"321" + integer :: a = 65 + integer :: l = 2 + allocate (ca, cp, ca4, cp4) + + ! Check len=1 actual argument cases first + ca = "a"; cp = "b"; cd = "c" + ca4 = 4_"d"; cp4 = 4_"e"; cd4 = 4_"f" + call val ("B","B", 1, 2) + call val ("A",char(65), 3, 4) + call val ("A",char(a), 5, 6) + call val ("A",mychar(65), 7, 8) + call val ("A",mychar(a), 9, 10) + call val ("1",c, 11, 12) + call val ("1",(c), 13, 14) + call val4 (4_"C",4_"C", 15, 16) + call val4 (4_"A",char(65,kind=4), 17, 18) + call val4 (4_"A",char(a, kind=4), 19, 20) + call val4 (4_"4",c4, 21, 22) + call val4 (4_"4",(c4), 23, 24) + call val (ca,ca, 25, 26) + call val (cp,cp, 27, 28) + call val (cd,cd, 29, 30) + call val (ca,(ca), 31, 32) + call val4 (ca4,ca4, 33, 34) + call val4 (cp4,cp4, 35, 36) + call val4 (cd4,cd4, 37, 38) + call val4 (cd4,(cd4), 39, 40) + call sub ("S", 41, 42) + call sub4 (4_"T", 43, 44) + + ! Check that always the first character of the string is finally used + call val ( "U++", "U--", 45, 46) + call val4 (4_"V**",4_"V//", 47, 48) + call sub ( "WTY", 49, 50) + call sub4 (4_"ZXV", 51, 52) + call val ( "234", d , 53, 54) + call val4 (4_"345", d4 , 55, 56) + call val ( "234", (d) , 57, 58) + call val4 (4_"345", (d4) , 59, 60) + call val ( "234", d (1:2), 61, 62) + call val4 (4_"345", d4(1:2), 63, 64) + call val ( "234", d (1:l), 65, 66) + call val4 (4_"345", d4(1:l), 67, 68) + call val ("1",c // d, 69, 70) + call val ("1",trim (c // d), 71, 72) + call val4 (4_"4",c4 // d4, 73, 74) + call val4 (4_"4",trim (c4 // d4), 75, 76) + cd = "gkl"; cd4 = 4_"hmn" + call val (cd,cd, 77, 78) + call val4 (cd4,cd4, 79, 80) + call sub (cd, 81, 82) + call sub4 (cd4, 83, 84) + deallocate (ca, cp, ca4, cp4, cd, cd4) +contains + subroutine val (x, c, err1, err2) + character(kind=1), intent(in) :: x ! control: pass by reference + character(kind=1), value :: c + integer, intent(in) :: err1, err2 + print *, "by value(kind=1): ", c + if (c /= x) stop err1 + c = "*" + if (c /= "*") stop err2 + end + + subroutine val4 (x, c, err1, err2) + character(kind=4), intent(in) :: x ! control: pass by reference + character(kind=4), value :: c + integer, intent(in) :: err1, err2 + print *, "by value(kind=4): ", c + if (c /= x) stop err1 + c = 4_"#" + if (c /= 4_"#") stop err2 + end + + subroutine sub (s, err1, err2) + character(*), intent(in) :: s + integer, intent(in) :: err1, err2 + call val (s, s, err1, err2) + end + subroutine sub4 (s, err1, err2) + character(kind=4,len=*), intent(in) :: s + integer, intent(in) :: err1, err2 + call val4 (s, s, err1, err2) + end + + character function mychar (i) + integer, intent(in) :: i + mychar = char (i) + end +end diff --git a/Fortran/gfortran/regression/value_optional_1.f90 b/Fortran/gfortran/regression/value_optional_1.f90 new file mode 100644 index 000000000..2f95316de --- /dev/null +++ b/Fortran/gfortran/regression/value_optional_1.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! PR fortran/92887 +! +! Test passing nullified/disassociated pointer or unalloc allocatable +! to OPTIONAL + VALUE + +program p + implicit none !(type, external) + integer, allocatable :: aa + real, pointer :: pp + character, allocatable :: ca + character, pointer :: cp + complex, allocatable :: za + complex, pointer :: zp + type t + integer, allocatable :: aa + real, pointer :: pp => NULL() + complex, allocatable :: za + end type t + type(t) :: tt + nullify (pp, cp, zp) + call sub (aa, pp, ca, cp, za) + call sub (tt% aa, tt% pp, z=tt% za) + allocate (aa, pp, ca, cp, za, zp, tt% za) + aa = 1; pp = 2.; ca = "c"; cp = "d"; za = 3.; zp = 4.; tt% za = 4. + call ref (1, 2., "c", "d", (3.,0.)) + call ref (aa, pp, ca, cp, za) + call val (1, 2., "c", "d", (4.,0.)) + call val (aa, pp, ca, cp, zp) + call opt (1, 2., "c", "d", (4.,0.)) + call opt (aa, pp, ca, cp, tt% za) + deallocate (aa, pp, ca, cp, za, zp, tt% za) +contains + subroutine sub (x, y, c, d, z) + integer, value, optional :: x + real, value, optional :: y + character, value, optional :: c, d + complex, value, optional :: z + if (present(x)) stop 1 + if (present(y)) stop 2 + if (present(c)) stop 3 + if (present(d)) stop 4 + if (present(z)) stop 5 + end + ! call by reference + subroutine ref (x, y, c, d, z) + integer :: x + real :: y + character :: c, d + complex :: z + print *, "by reference :", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 11 + if (c /= "c" .or. d /= "d") stop 12 + if (z /= (3.,0.) ) stop 13 + end + ! call by value + subroutine val (x, y, c, d, z) + integer, value :: x + real, value :: y + character, value :: c, d + complex, value :: z + print *, "by value :", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 21 + if (c /= "c" .or. d /= "d") stop 22 + if (z /= (4.,0.) ) stop 23 + end + ! call by value, optional arguments + subroutine opt (x, y, c, d, z) + integer, value, optional :: x + real, value, optional :: y + character, value, optional :: c, d + complex, value, optional :: z + if (.not. present(x)) stop 31 + if (.not. present(y)) stop 32 + if (.not. present(c)) stop 33 + if (.not. present(d)) stop 34 + if (.not. present(z)) stop 35 + print *, "value+optional:", x, y, c, d, z + if (x /= 1 .or. y /= 2.0) stop 36 + if (c /= "c" .or. d /= "d") stop 37 + if (z /= (4.,0.) ) stop 38 + end +end diff --git a/Fortran/gfortran/regression/vect/DisabledFiles.cmake b/Fortran/gfortran/regression/vect/DisabledFiles.cmake index 4f0dc3c44..a73fb0ff1 100644 --- a/Fortran/gfortran/regression/vect/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/vect/DisabledFiles.cmake @@ -23,4 +23,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS pr97761.f90 pr99746.f90 vect-8-epilogue.F90 + + # The cause of failure of this test needs to be investigated + pr49955.f ) diff --git a/Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f b/Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f index 08965cc5e..2e5487482 100644 --- a/Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f +++ b/Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f @@ -1,7 +1,8 @@ ! { dg-do compile } ! { dg-require-effective-target vect_double } -! { dg-options "-O3 --param vect-max-peeling-for-alignment=0 -fpredictive-commoning -fdump-tree-pcom-details -std=legacy" } +! { dg-additional-options "-O3 --param vect-max-peeling-for-alignment=0 -fpredictive-commoning -fdump-tree-pcom-details -std=legacy" } ! { dg-additional-options "-mprefer-avx128" { target { i?86-*-* x86_64-*-* } } } +! { dg-additional-options "-mlsx" { target { loongarch*-*-* } } } ! { dg-additional-options "-mzarch" { target { s390*-*-* } } } ******* RESID COMPUTES THE RESIDUAL: R = V - AU diff --git a/Fortran/gfortran/regression/vect/pr107254.f90 b/Fortran/gfortran/regression/vect/pr107254.f90 index 85bcb5f3f..adce6bedc 100644 --- a/Fortran/gfortran/regression/vect/pr107254.f90 +++ b/Fortran/gfortran/regression/vect/pr107254.f90 @@ -1,5 +1,3 @@ -! { dg-do run } - subroutine dlartg( f, g, s, r ) implicit none double precision :: f, g, r, s diff --git a/Fortran/gfortran/regression/vect/pr110451.f b/Fortran/gfortran/regression/vect/pr110451.f new file mode 100644 index 000000000..ba77b0dd1 --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr110451.f @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-require-effective-target vect_condition } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-ffast-math -floop-interchange -fdump-tree-linterchange-details -fdump-tree-vect-details" } +! { dg-additional-options "-mprefer-vector-width=128" { target x86_64-*-* i?86-*-* } } + + subroutine mat_times_vec(y,x,a,axp,ayp,azp,axm,aym,azm, + $ nb,nx,ny,nz) + implicit none + integer nb,nx,ny,nz,i,j,k,m,l,kit,im1,ip1,jm1,jp1,km1,kp1 + + real*8 y(nb,nx,ny,nz),x(nb,nx,ny,nz) + + real*8 a(nb,nb,nx,ny,nz), + 1 axp(nb,nb,nx,ny,nz),ayp(nb,nb,nx,ny,nz),azp(nb,nb,nx,ny,nz), + 2 axm(nb,nb,nx,ny,nz),aym(nb,nb,nx,ny,nz),azm(nb,nb,nx,ny,nz) + + + do k=1,nz + km1=mod(k+nz-2,nz)+1 + kp1=mod(k,nz)+1 + do j=1,ny + jm1=mod(j+ny-2,ny)+1 + jp1=mod(j,ny)+1 + do i=1,nx + im1=mod(i+nx-2,nx)+1 + ip1=mod(i,nx)+1 + do l=1,nb + y(l,i,j,k)=0.0d0 + do m=1,nb + y(l,i,j,k)=y(l,i,j,k)+ + 1 a(l,m,i,j,k)*x(m,i,j,k)+ + 2 axp(l,m,i,j,k)*x(m,ip1,j,k)+ + 3 ayp(l,m,i,j,k)*x(m,i,jp1,k)+ + 4 azp(l,m,i,j,k)*x(m,i,j,kp1)+ + 5 axm(l,m,i,j,k)*x(m,im1,j,k)+ + 6 aym(l,m,i,j,k)*x(m,i,jm1,k)+ + 7 azm(l,m,i,j,k)*x(m,i,j,km1) + enddo + enddo + enddo + enddo + enddo + return + end + +! loop interchange adds a conditional on m != 1 in the innermost loop +! verify that is hoisted and thus not affecting the vectorization factor + +! { dg-final { scan-tree-dump-times "is interchanged" 1 "linterchange" } } +! { dg-final { scan-tree-dump "vectorization factor = 2" "vect" { target x86_64-*-* i?86-*-* } } } diff --git a/Fortran/gfortran/regression/vect/pr114736.f90 b/Fortran/gfortran/regression/vect/pr114736.f90 new file mode 100644 index 000000000..cdbfb6f41 --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr114736.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-O3" } + +SUBROUTINE MY_ROUTINE (N, A, B ) +IMPLICIT NONE +INTEGER, INTENT(IN) :: N +COMPLEX, INTENT(IN) :: A(N) +COMPLEX, INTENT(OUT) :: B(N) +INTEGER :: II +B(:) = (1.,0.) +DO II = 1, N-1 + B(II) = A(N-II+1) / A(N-II) +ENDDO +END SUBROUTINE MY_ROUTINE diff --git a/Fortran/gfortran/regression/vect/pr115528.f b/Fortran/gfortran/regression/vect/pr115528.f new file mode 100644 index 000000000..764a4b92b --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr115528.f @@ -0,0 +1,27 @@ +! { dg-additional-options "-fno-inline" } + + subroutine init(COEF1,FORM1,AA) + double precision COEF1,X + double complex FORM1 + double precision AA(4,4) + COEF1=0 + FORM1=0 + AA=0 + end + subroutine curr(HADCUR) + double precision COEF1 + double complex HADCUR(4),FORM1 + double precision AA(4,4) + call init(COEF1,FORM1,AA) + do i = 1,4 + do j = 1,4 + HADCUR(I)= + $ HADCUR(I)+CMPLX(COEF1)*FORM1*AA(I,J) + end do + end do + end + program test + double complex HADCUR(4) + hadcur=0 + call curr(hadcur) + end diff --git a/Fortran/gfortran/regression/vect/pr115710.f90 b/Fortran/gfortran/regression/vect/pr115710.f90 new file mode 100644 index 000000000..3749210ac --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr115710.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast" } +! { dg-require-effective-target vect_float } +! { dg-require-effective-target vect_call_sqrtf } + +! { dg-final { scan-tree-dump "LOOP VECTORIZED" "vect" } } +! CABS expansion should allow for the vectorization to happen. + +subroutine foo(a,b,n) + complex(kind(1.0))::a(*) + real(kind(1.0))::b(*) + integer::i,n + + do i=1,n + b(i)=abs(a(i))**2 + end do + +end subroutine foo diff --git a/Fortran/gfortran/regression/vect/pr45714-b.f b/Fortran/gfortran/regression/vect/pr45714-b.f index abf33cd25..bf2a2eb6c 100644 --- a/Fortran/gfortran/regression/vect/pr45714-b.f +++ b/Fortran/gfortran/regression/vect/pr45714-b.f @@ -1,5 +1,5 @@ ! { dg-do compile { target powerpc*-*-* } } -! { dg-additional-options "-O3 -mcpu=power7 -mno-power9-vector -mno-power8-vector -ffast-math -mveclibabi=mass" } +! { dg-additional-options "-O3 -mdejagnu-cpu=power7 -mvsx -ffast-math -mveclibabi=mass" } integer index(18),i,j,k,l,ipiv(18),info,ichange,neq,lda,ldb, & nrhs,iplas diff --git a/Fortran/gfortran/regression/vect/pr49955.f b/Fortran/gfortran/regression/vect/pr49955.f new file mode 100644 index 000000000..a73cd5ada --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr49955.f @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-additional-options "-ffast-math -fdump-tree-slp1" } + + subroutine shell(nx,ny,nz,q,dt,cfl,dx,dy,dz,cfll,gm,Pr,Re) + implicit none + integer nx,ny,nz,i,j,k + real*8 cfl,dx,dy,dz,dt + real*8 gm,Re,Pr,cfll,t1,t2,t3,t4,t5,t6,t7,t8,mu + real*8 q(5,nx,ny,nz) + + if (cfll.ge.cfl) cfll=cfl + t8=0.0d0 + + do k=1,nz + do j=1,ny + do i=1,nx + t1=q(1,i,j,k) + t2=q(2,i,j,k)/t1 + t3=q(3,i,j,k)/t1 + t4=q(4,i,j,k)/t1 + t5=(gm-1.0d0)*(q(5,i,j,k)-0.5d0*t1*(t2*t2+t3*t3+t4*t4)) + t6=dSQRT(gm*t5/t1) + mu=gm*Pr*(gm*t5/t1)**0.75d0*2.0d0/Re/t1 + t7=((dabs(t2)+t6)/dx+mu/dx**2)**2 + + 1 ((dabs(t3)+t6)/dy+mu/dy**2)**2 + + 2 ((dabs(t4)+t6)/dz+mu/dz**2)**2 + t7=DSQRT(t7) + t8=max(t8,t7) + enddo + enddo + enddo + dt=cfll / t8 + + return + end + +! We don't have an effective target for reduc_plus_scal optab support +! { dg-final { scan-tree-dump ".REDUC_PLUS" "slp1" { target x86_64-*-* } } } diff --git a/Fortran/gfortran/regression/vect/pr60510.f b/Fortran/gfortran/regression/vect/pr60510.f index ecd50dd55..d4fd42a66 100644 --- a/Fortran/gfortran/regression/vect/pr60510.f +++ b/Fortran/gfortran/regression/vect/pr60510.f @@ -1,4 +1,3 @@ -! { dg-do run } ! { dg-require-effective-target vect_double } ! { dg-require-effective-target vect_intdouble_cvt } ! { dg-additional-options "-fno-inline -ffast-math" } @@ -17,6 +16,7 @@ subroutine foo(a,x,y,n) program test real*8 x(1024),y(1024),a + a = 0.0 do i=1,1024 x(i) = i y(i) = i+1 diff --git a/Fortran/gfortran/regression/vect/pr68855.f90 b/Fortran/gfortran/regression/vect/pr68855.f90 new file mode 100644 index 000000000..90d444c86 --- /dev/null +++ b/Fortran/gfortran/regression/vect/pr68855.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +! { dg-final { scan-tree-dump "LOOP VECTORIZED" "vect" } } +! PAREN_EXPR should not cause the vectorization of complex float add to be missed. + +subroutine foo(a,n) + + complex (kind(1.0)) :: a(*) + integer :: i,n + + do i=1,n + a(i)=(a(i)+(6.0,1.0)) + enddo + +end subroutine foo diff --git a/Fortran/gfortran/regression/vect/pr77848.f b/Fortran/gfortran/regression/vect/pr77848.f index 4752205f5..2a5e5bfea 100644 --- a/Fortran/gfortran/regression/vect/pr77848.f +++ b/Fortran/gfortran/regression/vect/pr77848.f @@ -1,6 +1,6 @@ ! PR 77848: Verify versioning is on when vectorization fails ! { dg-do compile } -! { dg-options "-O3 -ffast-math -fdump-tree-ifcvt -fdump-tree-vect-details" } +! { dg-additional-options "-O3 -ffast-math -fdump-tree-ifcvt -fdump-tree-vect-details" } ! { dg-additional-options "-mzarch" { target { s390*-*-* } } } subroutine sub(x,a,n,m) diff --git a/Fortran/gfortran/regression/vect/pr85853.f90 b/Fortran/gfortran/regression/vect/pr85853.f90 index 68f4a0043..4c0e3b81a 100644 --- a/Fortran/gfortran/regression/vect/pr85853.f90 +++ b/Fortran/gfortran/regression/vect/pr85853.f90 @@ -1,5 +1,4 @@ ! Taken from execute/where_2.f90, but with special flags. -! { dg-do run } ! { dg-additional-options "-fno-tree-loop-vectorize" } ! Program to test the WHERE constructs diff --git a/Fortran/gfortran/regression/vect/pr90681.f b/Fortran/gfortran/regression/vect/pr90681.f index 03d3987b1..49f1d50ab 100644 --- a/Fortran/gfortran/regression/vect/pr90681.f +++ b/Fortran/gfortran/regression/vect/pr90681.f @@ -1,6 +1,6 @@ C { dg-do compile } C { dg-additional-options "-march=armv8.2-a+sve" { target { aarch64*-*-* } } } - SUBROUTINE HMU (H1) + SUBROUTINE HMU (H1,NORBS) COMMON DD(107) DIMENSION H1(NORBS,*) DO 70 J1 = IA,I1 diff --git a/Fortran/gfortran/regression/vect/pr90913.f90 b/Fortran/gfortran/regression/vect/pr90913.f90 index d0f225159..1529cee37 100644 --- a/Fortran/gfortran/regression/vect/pr90913.f90 +++ b/Fortran/gfortran/regression/vect/pr90913.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O3 -ffast-math" } +! { dg-additional-options "-O3 -ffast-math" } ! { dg-additional-options "-mavx -mveclibabi=svml" { target i?86-*-* x86_64-*-* } } subroutine foo (a, b, c, d, e, f, g, h, k, l) implicit none diff --git a/Fortran/gfortran/regression/vect/pr97761.f90 b/Fortran/gfortran/regression/vect/pr97761.f90 index 250e2bf01..401ef06e4 100644 --- a/Fortran/gfortran/regression/vect/pr97761.f90 +++ b/Fortran/gfortran/regression/vect/pr97761.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } ! { dg-additional-options "-O1" } -subroutine ni (ps) +subroutine ni (ps, inout) type vector real x, y end type diff --git a/Fortran/gfortran/regression/vect/pr99746.f90 b/Fortran/gfortran/regression/vect/pr99746.f90 index fe947ae7c..121d67d56 100644 --- a/Fortran/gfortran/regression/vect/pr99746.f90 +++ b/Fortran/gfortran/regression/vect/pr99746.f90 @@ -1,6 +1,6 @@ ! { dg-do compile } ! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } -SUBROUTINE CLAREF(A, WANTZ, Z, ICOL1, ITMP1, ITMP2, T1, T2, V2) +SUBROUTINE CLAREF(A, WANTZ, Z, ICOL1, ITMP1, ITMP2, T1, T2, V2, LDA) LOGICAL BLOCK, WANTZ COMPLEX T1, T2, V2 COMPLEX A(LDA, *), VECS, Z(LDA, *) diff --git a/Fortran/gfortran/regression/vect/tests.cmake b/Fortran/gfortran/regression/vect/tests.cmake index 3cf63feb4..55ab2bf39 100644 --- a/Fortran/gfortran/regression/vect/tests.cmake +++ b/Fortran/gfortran/regression/vect/tests.cmake @@ -52,25 +52,33 @@ compile;O3-pr49957.f;;;; compile;Ofast-pr50414.f90;;-std=legacy;; compile;pr100981-1.f90;;-O3 -ftree-parallelize-loops=2 -fno-signed-zeros -fno-trapping-math;; compile;pr106253.f;;;; +compile;pr107254.f90;;;; compile;pr108979.f90;;-fnon-call-exceptions;; +compile;pr110451.f;;-ffast-math -floop-interchange -fdump-tree-linterchange-details -fdump-tree-vect-details;; +compile;pr114736.f90;;-O3;; +compile;pr115528.f;;-fno-inline;; +compile;pr115710.f90;;-Ofast;; compile;pr19049.f90;;;; compile;pr32377.f90;;;; compile;pr32380.f;;-O3 -fcray-pointer;; compile;pr33301.f;;;; compile;pr39318.f90;;-fopenmp -fopenmp -fexceptions;; compile;pr45714-a.f;;-O3 -march=core2 -mavx -ffast-math -mveclibabi=svml;i.86-.+-.+ x86_64-.+-.+; -compile;pr45714-b.f;;-O3 -mcpu=power7 -mno-power9-vector -mno-power8-vector -ffast-math -mveclibabi=mass;powerpc.+-.+-.+; +compile;pr45714-b.f;;-O3 -mdejagnu-cpu=power7 -mvsx -ffast-math -mveclibabi=mass;powerpc.+-.+-.+; compile;pr46213.f90;;-O -fno-tree-loop-ivcanon -fno-tree-ccp -fno-tree-ch -finline-small-functions;; compile;pr48329.f90;;-ffast-math;; +compile;pr49955.f;;-ffast-math -fdump-tree-slp1;; compile;pr50178.f90;;;; compile;pr50412.f90;;;; compile;pr51058-2.f90;;;; compile;pr51058.f90;;;; compile;pr51285.f90;;;; compile;pr52580.f;;-std=legacy;; +compile;pr60510.f;;-fno-inline -ffast-math;; compile;pr61171.f;;-Ofast;; compile;pr62283-2.f;;-fdump-tree-slp2-details;; compile;pr62283.f;;-fvect-cost-model=dynamic -fno-ipa-icf;; +compile;pr68855.f90;;;; compile;pr69466.f90;;;; compile;pr69882.f90;;-Ofast;; compile;pr69980.f90;;-Ofast -fno-inline;; @@ -79,6 +87,7 @@ compile;pr77848.f;;-O3 -ffast-math -fdump-tree-ifcvt -fdump-tree-vect-details;; compile;pr81303.f;;-O3 -ffast-math -floop-interchange -fdump-tree-linterchange-details;; compile;pr83232.f90;;-funroll-loops --param vect-max-peeling-for-alignment=0 -fdump-tree-slp-details;; compile;pr84913.f90;;;; +compile;pr85853.f90;;-fno-tree-loop-vectorize;; compile;pr86421.f90;;-fopenmp-simd;; compile;pr89535.f90;;;; compile;pr90681.f;;;; @@ -93,6 +102,7 @@ compile;pr99807.f90;;;; compile;pr99825.f90;;;; compile;pr99924.f90;;;; compile;vect-1.f90;;;; +compile;vect-10.f90;;;; compile;vect-2.f90;;--param vect-max-peeling-for-alignment=0;; compile;vect-3.f90;;--param vect-max-peeling-for-alignment=0;; compile;vect-4.f90;;--param vect-epilogues-nomask=0 --param vect-max-peeling-for-alignment=0;; @@ -102,9 +112,7 @@ compile;vect-7.f90;;;; compile;vect-8-epilogue.F90;;-finline-matmul-limit=0 --param vect-epilogues-nomask=1;; compile;vect-8.f90;;-fno-tree-loop-distribute-patterns -finline-matmul-limit=0;; compile;vect-9.f90;;-Ofast;; +compile;vect-alias-check-1.F90;;-fno-inline;; compile;vect-do-concurrent-1.f90;;-O3 -fopt-info-vec-optimized;; -compile;vect-gems.f90;;;; -run;pr107254.f90;;;; -run;pr60510.f;;-fno-inline -ffast-math;; -run;pr85853.f90;;-fno-tree-loop-vectorize;; -run;vect-alias-check-1.F90;;-fno-inline;; \ No newline at end of file +compile;vect-early-break_1-pr113808.f90;;-fopenmp-simd;; +compile;vect-gems.f90;;;; \ No newline at end of file diff --git a/Fortran/gfortran/regression/vect/vect-10.f90 b/Fortran/gfortran/regression/vect/vect-10.f90 new file mode 100644 index 000000000..b85bc2702 --- /dev/null +++ b/Fortran/gfortran/regression/vect/vect-10.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast -mlsx -fvect-cost-model=dynamic" { target loongarch64*-*-* } } + +MODULE material_mod + +IMPLICIT NONE + +integer, parameter :: dfp = selected_real_kind (13, 99) +integer, parameter :: rfp = dfp + +PUBLIC Mat_updateE, iepx, iepy, iepz + +PRIVATE + +integer, dimension (:, :, :), allocatable :: iepx, iepy, iepz +real (kind = rfp), dimension (:), allocatable :: Dbdx, Dbdy, Dbdz +integer :: imin, jmin, kmin +integer, dimension (6) :: Exsize +integer, dimension (6) :: Eysize +integer, dimension (6) :: Ezsize +integer, dimension (6) :: Hxsize +integer, dimension (6) :: Hysize +integer, dimension (6) :: Hzsize + +CONTAINS + +SUBROUTINE mat_updateE (nx, ny, nz, Hx, Hy, Hz, Ex, Ey, Ez) + +integer, intent (in) :: nx, ny, nz + +real (kind = rfp), intent (inout), & + dimension (Exsize (1) : Exsize (2), Exsize (3) : Exsize (4), Exsize (5) : Exsize (6)) :: Ex +real (kind = rfp), intent (inout), & + dimension (Eysize (1) : Eysize (2), Eysize (3) : Eysize (4), Eysize (5) : Eysize (6)) :: Ey +real (kind = rfp), intent (inout), & + dimension (Ezsize (1) : Ezsize (2), Ezsize (3) : Ezsize (4), Ezsize (5) : Ezsize (6)) :: Ez +real (kind = rfp), intent (in), & + dimension (Hxsize (1) : Hxsize (2), Hxsize (3) : Hxsize (4), Hxsize (5) : Hxsize (6)) :: Hx +real (kind = rfp), intent (in), & + dimension (Hysize (1) : Hysize (2), Hysize (3) : Hysize (4), Hysize (5) : Hysize (6)) :: Hy +real (kind = rfp), intent (in), & + dimension (Hzsize (1) : Hzsize (2), Hzsize (3) : Hzsize (4), Hzsize (5) : Hzsize (6)) :: Hz + +integer :: i, j, k, mp + +do k = kmin, nz + do j = jmin, ny + do i = imin, nx + mp = iepx (i, j, k) + Ex (i, j, k) = Ex (i, j, k) + & + Dbdy (mp) * (Hz (i, j, k ) - Hz (i, j-1, k)) + & + Dbdz (mp) * (Hy (i, j, k-1) - Hy (i, j , k)) + + mp = iepy (i, j, k) + Ey (i, j, k) = Ey (i, j, k) + & + Dbdz (mp) * (Hx (i , j, k) - Hx (i, j, k-1)) + & + Dbdx (mp) * (Hz (i-1, j, k) - Hz (i, j, k )) + + mp = iepz (i, j, k) + Ez (i, j, k) = Ez (i, j, k) + & + Dbdx (mp) * (Hy (i, j , k) - Hy (i-1, j, k)) + & + Dbdy (mp) * (Hx (i, j-1, k) - Hx (i , j, k)) + end do + end do +end do + +END SUBROUTINE mat_updateE + +END MODULE material_mod + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target loongarch64*-*-* } } } diff --git a/Fortran/gfortran/regression/vect/vect-8.f90 b/Fortran/gfortran/regression/vect/vect-8.f90 index ca72ddcff..f77ec9fb8 100644 --- a/Fortran/gfortran/regression/vect/vect-8.f90 +++ b/Fortran/gfortran/regression/vect/vect-8.f90 @@ -1,6 +1,8 @@ ! { dg-do compile } ! { dg-require-effective-target vect_double } ! { dg-additional-options "-fno-tree-loop-distribute-patterns -finline-matmul-limit=0" } +! PR113249 +! { dg-options "-fno-schedule-insns -fno-schedule-insns2" { target { riscv*-*-* } } } module lfk_prec integer, parameter :: dp=kind(1.d0) @@ -704,7 +706,7 @@ SUBROUTINE kernel(tk) RETURN END SUBROUTINE kernel -! { dg-final { scan-tree-dump-times "vectorized 25 loops" 1 "vect" { target aarch64_sve } } } -! { dg-final { scan-tree-dump-times "vectorized 24 loops" 1 "vect" { target { aarch64*-*-* && { ! aarch64_sve } } } } } +! { dg-final { scan-tree-dump-times "vectorized 2\[56\] loops" 1 "vect" { target aarch64_sve } } } +! { dg-final { scan-tree-dump-times "vectorized 2\[45\] loops" 1 "vect" { target { aarch64*-*-* && { ! aarch64_sve } } } } } ! { dg-final { scan-tree-dump-times "vectorized 2\[234\] loops" 1 "vect" { target { vect_intdouble_cvt && { ! aarch64*-*-* } } } } } ! { dg-final { scan-tree-dump-times "vectorized 17 loops" 1 "vect" { target { { ! vect_intdouble_cvt } && { ! aarch64*-*-* } } } } } diff --git a/Fortran/gfortran/regression/vect/vect-alias-check-1.F90 b/Fortran/gfortran/regression/vect/vect-alias-check-1.F90 index 3014ff9f3..85ae9b151 100644 --- a/Fortran/gfortran/regression/vect/vect-alias-check-1.F90 +++ b/Fortran/gfortran/regression/vect/vect-alias-check-1.F90 @@ -1,4 +1,3 @@ -! { dg-do run } ! { dg-additional-options "-fno-inline" } #define N 200 diff --git a/Fortran/gfortran/regression/vect/vect-early-break_1-pr113808.f90 b/Fortran/gfortran/regression/vect/vect-early-break_1-pr113808.f90 new file mode 100644 index 000000000..6f92e9095 --- /dev/null +++ b/Fortran/gfortran/regression/vect/vect-early-break_1-pr113808.f90 @@ -0,0 +1,21 @@ +! { dg-add-options vect_early_break } +! { dg-require-effective-target vect_early_break } +! { dg-require-effective-target vect_long_long } +! { dg-additional-options "-fopenmp-simd" } + +! { dg-final { scan-tree-dump "LOOP VECTORIZED" "vect" } } + +program main + integer :: n, i,k + n = 11 + do i = 1, n,2 + !$omp simd + do k = 1, i + 41 + if (k > 11 + 41 .or. k < 1) error stop + end do + end do + if (k /= 53) then + print *, k, 53 + error stop + endif +end diff --git a/Fortran/gfortran/regression/vect/vect.exp b/Fortran/gfortran/regression/vect/vect.exp index eb2fe760f..31c865918 100644 --- a/Fortran/gfortran/regression/vect/vect.exp +++ b/Fortran/gfortran/regression/vect/vect.exp @@ -1,4 +1,4 @@ -# Copyright (C) 1997-2023 Free Software Foundation, Inc. +# Copyright (C) 1997-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/regression/zero_sized_13.f90 b/Fortran/gfortran/regression/zero_sized_13.f90 new file mode 100644 index 000000000..4035d458b --- /dev/null +++ b/Fortran/gfortran/regression/zero_sized_13.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-w" } +! +! PR fortran/95374 +! PR fortran/104352 - Various ICEs for bounds violation with zero-sized arrays +! +! Contributed by G. Steinmetz + +program p + implicit none + integer :: i + integer, parameter :: a(0) = 0 + integer, parameter :: b(0:-5) = 0 + integer, parameter :: c(*) = [(a(i:i), i=0,0)] ! { dg-error "out of bounds" } + integer, parameter :: d(*) = [(b(i:i), i=1,1)] ! { dg-error "out of bounds" } + integer, parameter :: e(1) = [(a(i) , i=1,1)] ! { dg-error "out of bounds" } + integer, parameter :: f(1) = [(a(i:i), i=1,1)] ! { dg-error "out of bounds" } + integer :: g(1) = [(a(i:i), i=0,0)] ! { dg-error "out of bounds" } + integer :: h(1) = [(a(i:i), i=1,1)] ! { dg-error "out of bounds" } + print *, [(a(i:i), i=0,0)] ! { dg-error "out of bounds" } + print *, [(a(i:i), i=1,1)] ! { dg-error "out of bounds" } + print *, any (a(1:1) == 1) ! { dg-error "out of bounds" } + print *, all (a(0:0) == 1) ! { dg-error "out of bounds" } + print *, sum (a(1:1)) ! { dg-error "out of bounds" } + print *, iall (a(0:0)) ! { dg-error "out of bounds" } + print *, minloc (a(0:0),1) ! { dg-error "out of bounds" } + print *, dot_product(a(1:1),a(1:1)) ! { dg-error "out of bounds" } +end diff --git a/Fortran/gfortran/regression/zero_sized_14.f90 b/Fortran/gfortran/regression/zero_sized_14.f90 new file mode 100644 index 000000000..32c7ae28e --- /dev/null +++ b/Fortran/gfortran/regression/zero_sized_14.f90 @@ -0,0 +1,181 @@ +! { dg-do run } +! PR fortran/86277 +! +! Check proper detection of presence of optional array dummy arguments +! for zero-sized actual array arguments or array constructors: +! tests for REAL (as non-character intrinsic type) and empty derived type + +program test + implicit none + real, parameter :: m(0) = 42. + real, parameter :: n(1) = 23. + real :: x(0) = 1. + real :: z(1) = 2. + real :: w(0) + real, pointer :: p(:) + real, allocatable :: y(:) + integer :: k = 0, l = 0 ! Test/failure counter + type dt + ! Empty type + end type dt + type(dt), parameter :: t0(0) = dt() + type(dt), parameter :: t1(1) = dt() + type(dt) :: t2(0) = dt() + type(dt) :: t3(1) = dt() + type(dt) :: t4(0) + type(dt), allocatable :: tt(:) + ! + allocate (p(0)) + allocate (y(0)) + allocate (tt(0)) + call a0 () + call a1 () + call a2 () + call a3 () + call all_missing () + print *, "Total tests:", k, " failed:", l +contains + subroutine a0 () + print *, "Variables as actual argument" + call i (m) + call i (n) + call i (x) + call i (w) + call i (y) + call i (p) + call j (t0) + call j (t1) + call j (t2) + call j (t3) + call j (t4) + call j (tt) + print *, "Array section as actual argument" + call i (m(1:0)) + call i (n(1:0)) + call i (x(1:0)) + call i (w(1:0)) + call i (z(1:0)) + call i (p(1:0)) + call j (t0(1:0)) + call j (t1(1:0)) + call j (t2(1:0)) + call j (t3(1:0)) + call j (t4(1:0)) + call j (tt(1:0)) + end subroutine a0 + ! + subroutine a1 () + print *, "Explicit temporary as actual argument" + call i ((m)) + call i ((n)) + call i ((n(1:0))) + call i ((x)) + call i ((w)) + call i ((z(1:0))) + call i ((y)) + call i ((p)) + call i ((p(1:0))) + call j ((t0)) + call j ((t1)) + call j ((tt)) + call j ((t1(1:0))) + call j ((tt(1:0))) + end subroutine a1 + ! + subroutine a2 () + print *, "Array constructor as actual argument" + call i ([m]) + call i ([n]) + call i ([x]) + call i ([w]) + call i ([z]) + call i ([m(1:0)]) + call i ([n(1:0)]) + call i ([m,n(1:0)]) + call i ([x(1:0)]) + call i ([w(1:0)]) + call i ([z(1:0)]) + call i ([y]) + call i ([p]) + call i ([y,y]) + call i ([p,p]) + call i ([y(1:0)]) + call i ([p(1:0)]) + call j ([t0]) + call j ([t0,t0]) + call j ([t1]) + call j ([tt]) + call j ([tt,tt]) + call j ([t1(1:0)]) + call j ([tt(1:0)]) + end subroutine a2 + ! + subroutine a3 () + print *, "Array constructor with type-spec as actual argument" + call i ([real:: ]) + call i ([real:: 7]) + call i ([real:: m]) + call i ([real:: n]) + call i ([real:: x]) + call i ([real:: w]) + call i ([real:: m(1:0)]) + call i ([real:: n(1:0)]) + call i ([real:: m,n(1:0)]) + call i ([real:: x(1:0)]) + call i ([real:: w(1:0)]) + call i ([real:: z(1:0)]) + call i ([real:: y]) + call i ([real:: p]) + call i ([real:: y,y]) + call i ([real:: p,p]) + call i ([real:: y(1:0)]) + call i ([real:: p(1:0)]) + call j ([ dt :: ]) + call j ([ dt :: t0]) + call j ([ dt :: t0,t0]) + call j ([ dt :: t1]) + call j ([ dt :: tt]) + call j ([ dt :: tt,tt]) + call j ([ dt :: t1(1:0)]) + call j ([ dt :: tt(1:0)]) + end subroutine a3 + ! + subroutine i (arg) + real, optional, intent(in) :: arg(:) + logical :: t + t = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = l + 1 + if (.not. t) stop k + end subroutine i + ! + subroutine j (arg) + type(dt), optional, intent(in) :: arg(:) + logical :: t + t = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = l + 1 + if (.not. t) stop k + end subroutine j + ! + subroutine all_missing (arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8) + real, optional, intent(in) :: arg1(:) + real, optional, allocatable :: arg2(:) + real, optional, pointer :: arg3(:) + character(*), optional, intent(in) :: arg4(:) + character(*), optional, allocatable :: arg5(:) + character(*), optional, pointer :: arg6(:) + character(:), optional, pointer :: arg7(:) + character(:), optional, allocatable :: arg8(:) + if (present (arg1)) stop 101 + if (present (arg2)) stop 102 + if (present (arg3)) stop 103 + if (present (arg4)) stop 104 + if (present (arg5)) stop 105 + if (present (arg6)) stop 106 + if (present (arg7)) stop 107 + if (present (arg8)) stop 108 + end subroutine all_missing +end program diff --git a/Fortran/gfortran/regression/zero_sized_15.f90 b/Fortran/gfortran/regression/zero_sized_15.f90 new file mode 100644 index 000000000..c7d12ae71 --- /dev/null +++ b/Fortran/gfortran/regression/zero_sized_15.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! PR fortran/86277 +! +! Check proper detection of presence of optional array dummy arguments +! for zero-sized actual array arguments or array constructors: +! tests for CHARACTER + +program test + implicit none + character(0), parameter :: c0(0) = "" + character(0), parameter :: c1(1) = "" + character(1), parameter :: d0(0) = "" + character(1), parameter :: d1(1) = "" + character(0) :: w0(0) + character(0) :: w1(1) + character(:), allocatable :: cc(:) + integer :: k = 0, l = 0 ! Test/failure counter + ! + allocate (character(0) :: cc(0)) + call a0 () + call a1 () + call a2 () + call a3 () + print *, "Total tests:", k, " failed:", l +contains + subroutine a0 () + print *, "Variables as actual argument" + call i (c0) + call i (c1) + call i (d0) + call i (d1) + call i (w0) + call i (w1) + call i (cc) + print *, "Array section as actual argument" + call i (c1(1:0)) + call i (c1(1:0)(1:0)) + call i (w1(1:0)) + call i (w1(1:0)(1:0)) + call i (cc(1:0)) + call i (cc(1:0)(1:0)) + end subroutine a0 + ! + subroutine a1 () + print *, "Explicit temporary as actual argument" + call i ((c0)) + call i ((c1)) + call i ((d0)) + call i ((d1)) + call i ((w0)) + call i ((w1)) + call i ((cc)) + call i ((c1(1:0))) + call i ((c1(1:0)(1:0))) + call i ((w1(1:0))) + call i ((w1(1:0)(1:0))) + call i ((cc(1:0))) + call i ((cc(1:0)(1:0))) + end subroutine a1 + ! + subroutine a2 () + print *, "Array constructor as actual argument" + call i ([c0]) + call i ([c1]) + call i ([d0]) + call i ([d1]) + call i ([w0]) + call i ([w1]) + call i ([cc]) + call i ([c0,c0]) + call i ([c1,c1]) + call i ([d0,d0]) + call i ([cc,cc]) + call i ([c1(1:0)]) + call i ([c1(1:0)(1:0)]) + call i ([w1(1:0)]) + call i ([w1(1:0)(1:0)]) + call i ([cc(1:0)]) + call i ([cc(1:0)(1:0)]) + end subroutine a2 + ! + subroutine a3 () + print *, "Array constructor with type-spec as actual argument" + call i ([character(0) :: ]) + call i ([character(0) :: ""]) + call i ([character(0) :: c0]) + call i ([character(0) :: c1]) + call i ([character(0) :: d0]) + call i ([character(0) :: d1]) + call i ([character(0) :: w0]) + call i ([character(0) :: w1]) + call i ([character(0) :: cc]) + call i ([character(0) :: c0,c0]) + call i ([character(0) :: c1,c1]) + call i ([character(0) :: d0,d0]) + call i ([character(0) :: cc,cc]) + call i ([character(0) :: c1(1:0)]) + call i ([character(0) :: c1(1:0)(1:0)]) + call i ([character(0) :: w1(1:0)]) + call i ([character(0) :: w1(1:0)(1:0)]) + call i ([character(0) :: cc(1:0)]) + call i ([character(0) :: cc(1:0)(1:0)]) + end subroutine a3 + ! + subroutine i(arg) + character(*), optional, intent(in) :: arg(:) + logical :: t + t = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = l + 1 + if (.not. t) stop k + end subroutine i +end program diff --git a/Fortran/gfortran/torture/compile/compile.exp b/Fortran/gfortran/torture/compile/compile.exp index 80f50d762..6634c148b 100644 --- a/Fortran/gfortran/torture/compile/compile.exp +++ b/Fortran/gfortran/torture/compile/compile.exp @@ -1,5 +1,5 @@ # Expect driver script for GCC Regression Tests -# Copyright (C) 2003-2023 Free Software Foundation, Inc. +# Copyright (C) 2003-2024 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/torture/execute/DisabledFiles.cmake b/Fortran/gfortran/torture/execute/DisabledFiles.cmake index f7484787b..fbfaf0fef 100644 --- a/Fortran/gfortran/torture/execute/DisabledFiles.cmake +++ b/Fortran/gfortran/torture/execute/DisabledFiles.cmake @@ -31,6 +31,9 @@ file(GLOB SKIPPED_FILES CONFIGURE_DEPENDS # error: '[SYM]' is not a known intrinsic procedure specifics.f90 + + # conflicting debug info for argument + entry_5.f90 ) # These tests are disabled because they fail at runtime when they should pass. diff --git a/Fortran/gfortran/torture/execute/execute.exp b/Fortran/gfortran/torture/execute/execute.exp index cec67378c..b551cd473 100644 --- a/Fortran/gfortran/torture/execute/execute.exp +++ b/Fortran/gfortran/torture/execute/execute.exp @@ -1,4 +1,4 @@ -# Copyright (C) 2003-2023 Free Software Foundation, Inc. +# Copyright (C) 2003-2024 Free Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/Fortran/gfortran/torture/execute/math.f90 b/Fortran/gfortran/torture/execute/math.f90 index 17cc78f7a..6c97eba3f 100644 --- a/Fortran/gfortran/torture/execute/math.f90 +++ b/Fortran/gfortran/torture/execute/math.f90 @@ -1,9 +1,15 @@ ! Program to test mathematical intrinsics + +! This file is also 'include'd in: +! - 'libgomp/testsuite/libgomp.fortran/fortran-torture_execute_math.f90' (thus the '!$omp' directives) +! - 'libgomp/testsuite/libgomp.oacc-fortran/fortran-torture_execute_math.f90' (thus the '!$acc' directives) + subroutine dotest (n, val4, val8, known) implicit none real(kind=4) val4, known real(kind=8) val8 integer n + !$acc routine seq if (abs (val4 - known) .gt. 0.001) STOP 1 if (abs (real (val8, kind=4) - known) .gt. 0.001) STOP 2 @@ -14,17 +20,20 @@ subroutine dotestc (n, val4, val8, known) complex(kind=4) val4, known complex(kind=8) val8 integer n + !$acc routine seq + if (abs (val4 - known) .gt. 0.001) STOP 3 if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) STOP 4 end subroutine -program testmath +subroutine testmath implicit none real(kind=4) r, two4, half4 real(kind=8) q, two8, half8 complex(kind=4) cr complex(kind=8) cq external dotest, dotestc + !$acc routine seq two4 = 2.0 two8 = 2.0_8 @@ -96,5 +105,16 @@ program testmath cq = log ((-1.0_8, -1.0_8)) call dotestc (21, cr, cq, (0.3466, -2.3562)) -end program +end subroutine +program main + implicit none + external testmath + + !$acc serial + !$omp target + call testmath + !$acc end serial + !$omp end target + +end program From a10be075d7b9c547e6d3baf498d31b45b05637f7 Mon Sep 17 00:00:00 2001 From: Tarun Prabhu Date: Thu, 29 Aug 2024 14:42:25 -0600 Subject: [PATCH 3/4] [Fortran/gfortran][NFC] Recategorize tests Move some disabled test to the "unsupported" category since there is no reasonable way for those tests to be fixed. Recategorize other tests so their reasons for being disabled are accurate. --------- Co-authored-by: Tarun Prabhu --- .../gfortran/regression/DisabledFiles.cmake | 39 +++++++++---------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/Fortran/gfortran/regression/DisabledFiles.cmake b/Fortran/gfortran/regression/DisabledFiles.cmake index 95d297fbb..b2c6727bb 100644 --- a/Fortran/gfortran/regression/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/DisabledFiles.cmake @@ -119,6 +119,21 @@ file(GLOB UNSUPPORTED_FILES CONFIGURE_DEPENDS unlimited_polymorphic_14.f90 # Unsupported predefined macro: __TIMESTAMP__ wdate-time.F90 + + # This test checks that two arrays, initialized with random real numbers that + # are converted to integers, are not identical. It is possible, though + # unlikely for such "randomly initialized" arrays to be identical. Because of + # this inherent flakiness, this test will remain unsupported. + random_init_2.f90 + + # Test is not conformant as it writes to a constant argument + # Similar test, that is conformant, added to UnitTests/assign-goto + assign_5.f90 + + # Test is not conformant as it expects different value of cmdstat and cmdmsg + # Similar test added: UnitTests/execute_command_line + execute_command_line_1.f90 + execute_command_line_3.f90 ) # These tests are skipped because they hit a 'not yet implemented' assertion @@ -291,11 +306,6 @@ file(GLOB UNIMPLEMENTED_FILES CONFIGURE_DEPENDS # unimplemented: intrinsic: co_broadcast coarray_collectives_17.f90 - # Test is not conformant as it expects different value of cmdstat and cmdmsg - # Similar test added: UnitTests/execute_command_line - execute_command_line_1.f90 - execute_command_line_3.f90 - # unimplemented: intrinsic: failed_images coarray_failed_images_1.f08 @@ -1008,6 +1018,8 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS widechar_IO_4.f90 zero_sized_1.f90 elemental_function_2.f90 + do_check_1.f90 + random_3.f90 # These tests fail at runtime on AArch64 (but pass on x86). Disable them # anyway so the test-suite passes by default on AArch64. @@ -1015,18 +1027,11 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS findloc_8.f90 pr99210.f90 - # These tests fail on Ubuntu because of a bug in the not utility. At least - # some of these should work once the issue with not has been fixed. - # - # https://github.com/llvm/llvm-test-suite/pull/102#issuecomment-1980674221 - # - do_check_1.f90 + # These tests go into an infinite loop printing "Hello World" pointer_check_1.f90 pointer_check_2.f90 pointer_check_3.f90 pointer_check_4.f90 - random_3.f90 - unpack_bounds_1.f90 # --------------------------------------------------------------------------- # @@ -1050,6 +1055,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS no_unit_error_1.f90 pointer_check_10.f90 pointer_remapping_6.f08 + unpack_bounds_1.f90 # --------------------------------------------------------------------------- # @@ -1408,10 +1414,6 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS directive_unroll_5.f90 # Tests "!GCC$ attributes weak :: x" weak-3.f90 - # Test is not conformant as it writes to a constant argument - # Similar test, that is conformant, added to UnitTests/assign-goto - assign_5.f90 - # Probable bugs # ["a", "ab"] @@ -1793,9 +1795,6 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS # for the buildbot, this is disabled. internal_dummy_2.f08 - # These are flaky tests, which may fail sometimes. - random_init_2.f90 - # The causes of failure of these tests need to be investigated PR113061.f90 allocate_with_source_29.f90 From d6a91b84c1cee34d841cfd5d1e862c8c0f82f39a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Valentin=20Clement=20=28=E3=83=90=E3=83=AC=E3=83=B3?= =?UTF-8?q?=E3=82=BF=E3=82=A4=E3=83=B3=20=E3=82=AF=E3=83=AC=E3=83=A1?= =?UTF-8?q?=E3=83=B3=29?= Date: Thu, 5 Sep 2024 11:43:08 -0700 Subject: [PATCH 4/4] [Fortran] Disable pr32601.f03 (#156) * Update pr32601.f03 * Disable test and restore flags --- Fortran/gfortran/regression/DisabledFiles.cmake | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Fortran/gfortran/regression/DisabledFiles.cmake b/Fortran/gfortran/regression/DisabledFiles.cmake index b2c6727bb..a97def389 100644 --- a/Fortran/gfortran/regression/DisabledFiles.cmake +++ b/Fortran/gfortran/regression/DisabledFiles.cmake @@ -1840,4 +1840,7 @@ file(GLOB FAILING_FILES CONFIGURE_DEPENDS pr111022.f90 pr114304.f90 zero_sized_15.f90 + + # Test needs to add -pedantic to show the error + pr32601.f03 )