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 f498b4c7c..a97def389 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 @@ -165,6 +180,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 @@ -284,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 @@ -351,6 +368,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 +559,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 +872,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. @@ -968,24 +1018,20 @@ 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. 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. - # - # 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 # --------------------------------------------------------------------------- # @@ -1009,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 # --------------------------------------------------------------------------- # @@ -1367,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"] @@ -1438,6 +1481,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 +1776,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 @@ -1748,4 +1794,53 @@ 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 + + # 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 + + # Test needs to add -pedantic to show the error + pr32601.f03 ) 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