diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
34 files changed, 1066 insertions, 106 deletions
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90 b/gcc/testsuite/gfortran.dg/associate_70.f90 index ddb38b8..6f8f5d6a 100644 --- a/gcc/testsuite/gfortran.dg/associate_70.f90 +++ b/gcc/testsuite/gfortran.dg/associate_70.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! ( dg-options "-Wuninitialized" ) +! { dg-options "-Wuninitialized" } ! ! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and ! both normal and scalarized array references did not work correctly. diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 index f4bb701..695a580 100644 --- a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 @@ -20,7 +20,7 @@ end subroutine poobar program test character(len=*), parameter :: foo = 'test' ! Parameters must work. character(len=4) :: bar = foo - character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" } + character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" } print *, bar call poobar () end diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90 index 51e11e9..4191d24 100644 --- a/gcc/testsuite/gfortran.dg/bessel_3.f90 +++ b/gcc/testsuite/gfortran.dg/bessel_3.f90 @@ -6,7 +6,7 @@ ! IMPLICIT NONE print *, SIN (1.0) -print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" }) +print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" } print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" } print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" } print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" } diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 index 45d0955..d8c8039 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 @@ -20,7 +20,7 @@ procedure(sub), pointer :: fsub integer, external :: noCsub procedure(integer), pointer :: fint -cp = c_funloc (sub) ! { dg-error "Cannot convert TYPE.c_funptr. to TYPE.c_ptr." }) +cp = c_funloc (sub) ! { dg-error "Cannot convert TYPE.c_funptr. to TYPE.c_ptr." } cfp = c_loc (int) ! { dg-error "Cannot convert TYPE.c_ptr. to TYPE.c_funptr." } call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." } diff --git a/gcc/testsuite/gfortran.dg/cray_pointers_2.f90 b/gcc/testsuite/gfortran.dg/cray_pointers_2.f90 index 4351874..e646fc8 100644 --- a/gcc/testsuite/gfortran.dg/cray_pointers_2.f90 +++ b/gcc/testsuite/gfortran.dg/cray_pointers_2.f90 @@ -1,6 +1,4 @@ -! Using two spaces between dg-do and run is a hack to keep gfortran-dg-runtest -! from cycling through optimization options for this expensive test. -! { dg-do run } +! { dg-do run } ! { dg-options "-O3 -fcray-pointer -fbounds-check -fno-inline" } ! { dg-timeout-factor 4 } ! diff --git a/gcc/testsuite/gfortran.dg/derived_result_4.f90 b/gcc/testsuite/gfortran.dg/derived_result_4.f90 new file mode 100644 index 0000000..12ab190 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/derived_result_4.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-additional-options "-Wall -Wno-return-type -Wno-unused-variable" } +! +! PR fortran/118796 - bogus recursion with DT default initialization + +module m1 + implicit none + + type :: t1 + type(integer) :: f1 = 0 + end type t1 + + TYPE :: c1 + contains + procedure, public :: z + END TYPE c1 + +contains + ! type-bound procedure z has a default initialization + function z( this ) + type(t1) :: z + class(c1), intent(in) :: this + end function z +end module m1 + +module m2 + use m1, only : c1 +contains + function z() result(field) + end function z +end module m2 + +module m3 + use m1, only : c1 +contains + function z() + end function z +end module m3 diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_11.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_11.f90 new file mode 100644 index 0000000..d4890a3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_11.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +module m +implicit none +contains +subroutine sub(y,str) +integer :: y, x, i +character(len=5) :: str +character(len=5) :: z = "abcde" +logical :: error = .false. + +x = 5 +z = "12345" +do concurrent (i = 1: 3) local_init(x) local_init(z) shared(error)default(none) + if (x /= 5) error = .true. + if (z /= "12345") error = .true. + x = 99 + z = "XXXXX" +end do +if (x /= 5 .or. z /= "12345") stop 1 +if (error) stop 2 + +do concurrent (i = 1: 3) local(y) local(str) shared(error) default(none) + y = 99 + str = "XXXXX" +end do +if (y /= 42 .or. str /= "ABCDE") stop 3 +end +end + +use m +implicit none +character(len=5) :: chars = "ABCDE" +integer :: fourtytwo = 42 +call sub(fourtytwo, chars) +end + + +! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) x;" 2 "original" } } +! { dg-final { scan-tree-dump-times " static character\\(kind=1\\) z\\\[1:5\\\] = .abcde.;" 1 "original" } } +! { dg-final { scan-tree-dump-times " character\\(kind=1\\) z\\\[1:5\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times " integer\\(kind=4\\) y;" 1 "original" } } +! { dg-final { scan-tree-dump-times " character\\(kind=1\\) str\\\[1:5\\\];" 1 "original" } } + +! { dg-final { scan-tree-dump-times " x = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\) &.12345.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " x = x;" 1 "original" } } +! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &z, \\(void \\*\\)\\ &z, 5\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-not " y = y;" "original" } } +! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str, \\(void \\*\\)\\ &.XXXXX.\\\[1\\\]\{lb: 1 sz: 1\}, 5\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __builtin_memmove \\(\\(void \\*\\) &str," 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_12.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_12.f90 new file mode 100644 index 0000000..8a2acfa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_12.f90 @@ -0,0 +1,175 @@ +! { dg-do compile } + +! Fails to compile because default initializers aren't supported. +! cf. do_concurrent_14.f90 and PR fortran/101602 (comment 6) + +module m +implicit none +type t + integer :: y = 44 + integer, pointer :: ptr(:) => null() +end type t + +contains + +subroutine sub(x, y) + integer :: i + type(t) :: x, y(4) + type(t) :: a, b(3) + logical :: error = .false. + integer, target :: tgt(6) + integer, target :: tgt2(7) + + x%y = 100 + x%ptr => tgt + y(1)%y = 101 + y(2)%y = 102 + y(3)%y = 103 + y(4)%y = 104 + y(1)%ptr => tgt + y(2)%ptr => tgt + y(3)%ptr => tgt + y(4)%ptr => tgt + + a%y = 105 + a%ptr => tgt + b(1)%y = 106 + b(2)%y = 107 + b(3)%y = 108 + b(1)%ptr => tgt + b(2)%ptr => tgt + b(3)%ptr => tgt + + do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none) + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + error = .true. + + x%y = 900 + x%ptr => tgt + y(1)%y = 901 + y(2)%y = 902 + y(3)%y = 903 + y(4)%y = 904 + y(1)%ptr => tgt2 + y(2)%ptr => tgt2 + y(3)%ptr => tgt2 + y(4)%ptr => tgt2 + + a%y = 905 + a%ptr => tgt + b(1)%y = 906 + b(2)%y = 907 + b(3)%y = 908 + b(1)%ptr => tgt2 + b(2)%ptr => tgt2 + b(3)%ptr => tgt2 + end do + + if (error) stop 1 + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 2 + + do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2) default(none) +! { dg-error "34: Sorry, LOCAL specifier at .1. for 'x' of derived type with default initializer is not yet supported" "" { target *-*-* } .-1 } +! { dg-error "36: Sorry, LOCAL specifier at .1. for 'y' of derived type with default initializer is not yet supported" "" { target *-*-* } .-2 } +! { dg-error "38: Sorry, LOCAL specifier at .1. for 'a' of derived type with default initializer is not yet supported" "" { target *-*-* } .-3 } +! { dg-error "40: Sorry, LOCAL specifier at .1. for 'b' of derived type with default initializer is not yet supported" "" { target *-*-* } .-4 } + + if (x%y /= 44) error = .true. + if (any(y(:)%y /= 44)) error = .true. + if (a%y /= 44) error = .true. + if (any (b(:)%y /= 44)) error = .true. + + if (associated(x%ptr)) error = .true. + if (associated(y(1)%ptr)) error = .true. + if (associated(y(2)%ptr)) error = .true. + if (associated(y(3)%ptr)) error = .true. + if (associated(y(4)%ptr)) error = .true. + if (associated(a%ptr)) error = .true. + if (associated(b(1)%ptr)) error = .true. + if (associated(b(2)%ptr)) error = .true. + if (associated(b(3)%ptr)) error = .true. + + x%y = 900 + x%ptr => tgt + y(1)%y = 901 + y(2)%y = 902 + y(3)%y = 903 + y(4)%y = 904 + y(1)%ptr => tgt2 + y(2)%ptr => tgt2 + y(3)%ptr => tgt2 + y(4)%ptr => tgt2 + + a%y = 905 + a%ptr => tgt + b(1)%y = 906 + b(2)%y = 907 + b(3)%y = 908 + b(1)%ptr => tgt2 + b(2)%ptr => tgt2 + b(3)%ptr => tgt2 + end do + + if (error) stop 3 + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 4 +end +end + +use m +implicit none +type(t) :: q, r(4) +call sub(q,r) +end diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_13.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_13.f90 new file mode 100644 index 0000000..6545780 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_13.f90 @@ -0,0 +1,211 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +module m +implicit none +type t + integer :: y = 44 + integer, pointer :: ptr(:) => null() +end type t + +contains + +subroutine sub(x, y) + integer :: i + type(t), pointer :: x, y(:) + type(t), pointer :: a, b(:) + logical :: error = .false. + integer, target :: tgt(6) + integer, target :: tgt2(7) + + type(t), pointer :: x_saved + type(t), pointer :: y_saved(:) + type(t), pointer :: a_saved + type(t), pointer :: b_saved(:) + + allocate(a, b(3)) + + x_saved => x + y_saved => y + a_saved => a + b_saved => b + + x%y = 100 + x%ptr => tgt + y(1)%y = 101 + y(2)%y = 102 + y(3)%y = 103 + y(4)%y = 104 + y(1)%ptr => tgt + y(2)%ptr => tgt + y(3)%ptr => tgt + y(4)%ptr => tgt + + a%y = 105 + a%ptr => tgt + b(1)%y = 106 + b(2)%y = 107 + b(3)%y = 108 + b(1)%ptr => tgt + b(2)%ptr => tgt + b(3)%ptr => tgt + + do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none) + if (.not.associated(x,x_saved)) error = .true. + if (.not.associated(y,y_saved)) error = .true. + if (.not.associated(a,a_saved)) error = .true. + if (.not.associated(b,b_saved)) error = .true. + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + error = .true. + + if (i == 3) then + ! This is a hack - assuming no concurrency! + x%y = 900 + y(1)%y = 901 + a%y = 905 + b(1)%y = 906 + endif + x => null() + y => null() + a => null() + b => null() + end do + + if (error) stop 1 + if (.not.associated(x,x_saved)) stop 2 + if (.not.associated(y,y_saved)) stop 3 + if (.not.associated(a,a_saved)) stop 4 + if (.not.associated(b,b_saved)) stop 5 + ! Value a bit changed because of the hack above! + if (x%y /= 900 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 901 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 905 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 906 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 6 + + ! Reset + x%y = 100 + y(1)%y = 101 + a%y = 105 + b(1)%y = 106 + + do concurrent (i = 1: 3) local(x,y,a,b) shared(error) default(none) + x => null() + y => null() + a => null() + b => null() + end do + + if (.not.associated(x,x_saved)) stop 7 + if (.not.associated(y,y_saved)) stop 8 + if (.not.associated(a,a_saved)) stop 9 + if (.not.associated(b,b_saved)) stop 10 + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 11 + + do concurrent (i = 1: 3) local(x,y,a,b) shared(error,tgt,tgt2,x_saved,y_saved,a_saved,b_saved) default(none) + x => a_saved + y => b_saved + a => x_saved + b => y_saved + if (a%y /= 100 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 101 & + .or. b(2)%y /= 102 & + .or. b(3)%y /= 103 & + .or. b(4)%y /= 104 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt) & + .or. .not.associated (b(4)%ptr, tgt) & + .or. x%y /= 105 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 106 & + .or. y(2)%y /= 107 & + .or. y(3)%y /= 108 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt)) & + error = .true. + end do + + if (.not.associated(x,x_saved)) stop 12 + if (.not.associated(y,y_saved)) stop 13 + if (.not.associated(a,a_saved)) stop 14 + if (.not.associated(b,b_saved)) stop 15 + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 16 +end +end + +use m +implicit none +type(t), pointer :: q, r(:) +allocate(q, r(4)) +call sub(q,r) +end diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_14.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_14.f90 new file mode 100644 index 0000000..c0a90ff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_14.f90 @@ -0,0 +1,176 @@ +! { dg-do run } + +module m +implicit none +type t + integer :: y = 44 + integer, pointer :: ptr(:) => null() +end type t + +! No default initializers, cf. do_concurrent_12.f90 +! and PR fortran/101602 (comment 6) +type t2 + integer :: y + integer, pointer :: ptr(:) +end type t2 + +contains + +subroutine sub(x, y) + integer :: i + type(t) :: x, y(4) + type(t) :: a, b(3) + type(t2) :: x2, y2(4) + type(t2) :: a2, b2(3) + logical :: error = .false. + integer, target :: tgt(6) + integer, target :: tgt2(7) + + x%y = 100 + x%ptr => tgt + y(1)%y = 101 + y(2)%y = 102 + y(3)%y = 103 + y(4)%y = 104 + y(1)%ptr => tgt + y(2)%ptr => tgt + y(3)%ptr => tgt + y(4)%ptr => tgt + + a%y = 105 + a%ptr => tgt + b(1)%y = 106 + b(2)%y = 107 + b(3)%y = 108 + b(1)%ptr => tgt + b(2)%ptr => tgt + b(3)%ptr => tgt + + ! Copy values from 't' to associated 't2' variables + x2%y = x%y + x2%ptr => x%ptr + a2%y = a%y + a2%ptr => a%ptr + y2(:)%y = y(:)%y + do i = 1, size(y) + y2(i)%ptr => y(i)%ptr + end do + b2(:)%y = b(:)%y + do i = 1, size(b) + b2(i)%ptr => b(i)%ptr + end do + + do concurrent (i = 1: 3) local_init(x,y,a,b) shared(error,tgt,tgt2) default(none) + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + error = .true. + + x%y = 900 + x%ptr => tgt + y(1)%y = 901 + y(2)%y = 902 + y(3)%y = 903 + y(4)%y = 904 + y(1)%ptr => tgt2 + y(2)%ptr => tgt2 + y(3)%ptr => tgt2 + y(4)%ptr => tgt2 + + a%y = 905 + a%ptr => tgt + b(1)%y = 906 + b(2)%y = 907 + b(3)%y = 908 + b(1)%ptr => tgt2 + b(2)%ptr => tgt2 + b(3)%ptr => tgt2 + end do + + if (error) stop 1 + if (x%y /= 100 & + .or. .not.associated (x%ptr, tgt) & + .or. y(1)%y /= 101 & + .or. y(2)%y /= 102 & + .or. y(3)%y /= 103 & + .or. y(4)%y /= 104 & + .or. .not.associated (y(1)%ptr, tgt) & + .or. .not.associated (y(2)%ptr, tgt) & + .or. .not.associated (y(3)%ptr, tgt) & + .or. .not.associated (y(4)%ptr, tgt) & + .or. a%y /= 105 & + .or. .not.associated (a%ptr, tgt) & + .or. b(1)%y /= 106 & + .or. b(2)%y /= 107 & + .or. b(3)%y /= 108 & + .or. .not.associated (b(1)%ptr, tgt) & + .or. .not.associated (b(2)%ptr, tgt) & + .or. .not.associated (b(3)%ptr, tgt)) & + stop 2 + + ! Use version without default initializers + do concurrent (i = 1: 3) local(x2,y2,a2,b2) shared(error,tgt,tgt2) default(none) + x2%y = 900 + x2%ptr => tgt + y2(1)%y = 901 + y2(2)%y = 902 + y2(3)%y = 903 + y2(4)%y = 904 + y2(1)%ptr => tgt2 + y2(2)%ptr => tgt2 + y2(3)%ptr => tgt2 + y2(4)%ptr => tgt2 + + a2%y = 905 + a2%ptr => tgt + b2(1)%y = 906 + b2(2)%y = 907 + b2(3)%y = 908 + b2(1)%ptr => tgt2 + b2(2)%ptr => tgt2 + b2(3)%ptr => tgt2 + end do + + if (error) stop 3 + if (x2%y /= 100 & + .or. .not.associated (x2%ptr, tgt) & + .or. y2(1)%y /= 101 & + .or. y2(2)%y /= 102 & + .or. y2(3)%y /= 103 & + .or. y2(4)%y /= 104 & + .or. .not.associated (y2(1)%ptr, tgt) & + .or. .not.associated (y2(2)%ptr, tgt) & + .or. .not.associated (y2(3)%ptr, tgt) & + .or. .not.associated (y2(4)%ptr, tgt) & + .or. a2%y /= 105 & + .or. .not.associated (a2%ptr, tgt) & + .or. b2(1)%y /= 106 & + .or. b2(2)%y /= 107 & + .or. b2(3)%y /= 108 & + .or. .not.associated (b2(1)%ptr, tgt) & + .or. .not.associated (b2(2)%ptr, tgt) & + .or. .not.associated (b2(3)%ptr, tgt)) & + stop 4 +end +end + +use m +implicit none +type(t) :: q, r(4) +call sub(q,r) +end diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_15.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_15.f90 new file mode 100644 index 0000000..f0003c8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_15.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +! Fails to compile because assumed-size arrays are not yet +! handled with LOCAL / LOCAL_INIT, cf. PR fortran/101602 (comment 6) + +subroutine test_it(xx, yy) + implicit none + integer :: xx(:), yy(:,:) + integer :: i, sz1, sz2 + + sz1 = size(xx) + do , concurrent (i = 1 : sz1) local(xx) ! { dg-error "39: Sorry, LOCAL specifier at .1. for assumed-size array 'xx' is not yet supported" } + xx(i) = 1 + end do + + sz2 = size(yy,dim=1) + do , concurrent (i=1:sz2) local_init(yy) ! { dg-error "40: Sorry, LOCAL_INIT specifier at .1. for assumed-size array 'yy' is not yet supported" } + yy(i,:) = 1 + end do +end diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 index a99d81e..55eb97b 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_8_f2023.f90 @@ -8,10 +8,8 @@ program do_concurrent_complex product = 1 do concurrent (i = 1:10) local(j) shared(sum) reduce(+:sum) ! { dg-error "Variable .sum. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 } - ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 } do concurrent (j = 1:10) local(k) shared(product) reduce(*:product) ! { dg-error "Variable .product. at .1. has already been specified in a locality-spec" "" { target *-*-* } .-1 } - ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-2 } do concurrent (k = 1:10) array(i,j,k) = i * j * k sum = sum + array(i,j,k) @@ -20,4 +18,4 @@ program do_concurrent_complex end do end do print *, sum, product -end program do_concurrent_complex
\ No newline at end of file +end program do_concurrent_complex diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 index 98cef3e..9c1bca6 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_9.f90 @@ -6,7 +6,7 @@ program do_concurrent_default_none x = 0 y = 0 z = 0 - do concurrent (i = 1:10) default(none) shared(x) local(y) ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported" } + do concurrent (i = 1:10) default(none) shared(x) local(y) ! { dg-error "Variable 'z' .* not specified in a locality spec .* but required due to DEFAULT \\(NONE\\)" "" { target *-*-* } .-1 } x = x + i y = i * 2 diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 index 2e1c18c..0c8a6ad 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 @@ -11,7 +11,6 @@ program do_concurrent_all_clauses shared(arr, squared, sum, max_val) & reduce(+:sum) & ! { dg-error "Variable 'sum' at \\(1\\) has already been specified in a locality-spec" } reduce(max:max_val) ! { dg-error "Variable 'max_val' at \\(1\\) has already been specified in a locality-spec" } - ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported*" "" { target *-*-* } .-1 } block integer :: temp2 temp = i * 2 diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 index 08e1fb9..6c5e87e 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_local_init.f90 @@ -3,9 +3,9 @@ program do_concurrent_local_init implicit none integer :: i, arr(10), temp - do concurrent (i = 1:10) local_init(temp) ! { dg-error "LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" } + do concurrent (i = 1:10) local_init(temp) temp = i arr(i) = temp end do print *, arr -end program do_concurrent_local_init
\ No newline at end of file +end program do_concurrent_local_init diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 index 0ee7a7e..ed3504e 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_locality_specs.f90 @@ -6,9 +6,8 @@ do , concurrent (i = 1:5) shared(j,jj) local(k,kk) local_init(ll,lll) ! { dg-warning "Variable 'kk' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-1 } ! { dg-warning "Variable 'll' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-2 } ! { dg-warning "Variable 'jj' in locality-spec at \\(1\\) is not used \\\[-Wunused-variable\\\]" "" { target *-*-* } .-3 } - ! { dg-error "Sorry, LOCAL and LOCAL_INIT are not yet supported for 'do concurrent' constructs" "" { target *-*-* } .-4 } j = 5 k = 7 lll = 8 end do -end
\ No newline at end of file +end diff --git a/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 b/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 new file mode 100644 index 0000000..540079a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +! Test that interop objects are implicitly created/destroyed when a dispatch +! construct doesn't provide enough of them to satisfy the declare variant +! append_args clause. + +module m + use iso_c_binding, only: c_intptr_t + integer, parameter :: omp_interop_kind = c_intptr_t +contains +subroutine g(x,y,z) + integer(omp_interop_kind) :: x, y, z + value :: y +end +subroutine f() + !$omp declare variant(f: g) append_args(interop(target), interop(prefer_type("cuda","hip"), targetsync), interop(target,targetsync,prefer_type({attr("ompx_foo")}))) match(construct={dispatch}) +end +end + +use m +!$omp dispatch device(99) + call f() +end + +! { dg-final { scan-tree-dump "__builtin_GOMP_interop \\(99, 3, &interopobjs\.\[0-9\]+, &tgt_tgtsync\.\[0-9\]+, &pref_type\.\[0-9\]+, " "gimple" } } +! { dg-final { scan-tree-dump "__builtin_GOMP_interop \\(99, 0, 0B, 0B, 0B, 0, 0B, 3, &interopobjs\.\[0-9\]+," "gimple" } } +! { dg-final { scan-tree-dump "g \\(&interop\.\[0-9\]+, interop\.\[0-9\]+, &interop\.\[0-9\]+\\)" "gimple" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 index c994b55..7e4f74d 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 @@ -49,7 +49,7 @@ contains end subroutine subroutine f2a () - !$omp declare variant (f1b) append_args ( interop ( prefer_type ( "cuda", "hip" ) ) , interop(target)) & + !$omp declare variant (f1b) append_args ( interop ( target, prefer_type ( "cuda", "hip" ) ) , interop(target)) & !$omp& append_args ( interop ( target , targetsync) ) match(construct={dispatch}) ! { dg-error "'append_args' clause at .1. specified more than once" } end subroutine @@ -60,17 +60,17 @@ contains end subroutine subroutine f2c (x,y) - !$omp declare variant (fop) , append_args ( interop ( prefer_type ( "cuda", "hip" ) ) , interop(target)) , & + !$omp declare variant (fop) , append_args ( interop ( target, prefer_type ( "cuda", "hip" ) ) , interop(target)) , & !$omp& adjust_args (need_device_ptr : x, y ) ! { dg-error "the 'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } type(c_ptr) :: x, y value :: y end subroutine subroutine f2d () - !$omp declare variant (f1d) append_args ( interop ( prefer_type ( "cuda", "hip" ) ) , interop(target)) , ! { dg-error "111: expected 'match', 'adjust_args' or 'append_args' at .1." } + !$omp declare variant (f1d) append_args ( interop ( target, prefer_type ( "cuda", "hip" ) ) , interop(target)) , ! { dg-error "119: expected 'match', 'adjust_args' or 'append_args' at .1." } end subroutine subroutine f2e () - !$omp declare variant (f1e) append_args ( interop ( prefer_type ( "cuda", "hip" ) ) , interop(target) interop(targetsync)) ! { dg-error "Expected ',' or '\\)' at .1." } + !$omp declare variant (f1e) append_args ( interop ( target, prefer_type ( "cuda", "hip" ) ) , interop(target) interop(targetsync)) ! { dg-error "Expected ',' or '\\)' at .1." } end subroutine end diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-2.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-2.f90 index 7a68977..63a6934 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-2.f90 @@ -56,7 +56,7 @@ contains integer(omp_interop_kind),value :: obj2 end subroutine g1a (obj) - !$omp declare variant (g1 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g1 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) integer(omp_interop_kind),value :: obj end @@ -75,7 +75,7 @@ contains integer(omp_interop_kind) :: obj2 end subroutine g3a (obj) - !$omp declare variant (g3 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g3 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) integer(omp_interop_kind),value :: obj end @@ -84,7 +84,7 @@ contains integer(omp_interop_kind) :: obj2 end subroutine g4a (obj) - !$omp declare variant (g4 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g4 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) integer(omp_interop_kind),value :: obj end @@ -95,7 +95,7 @@ contains optional :: obj3 end subroutine g5a (obj) - !$omp declare variant (g5 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g5 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj3' at .1. with OPTIONAL attribute not support when utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -108,7 +108,7 @@ contains optional :: obj3 end subroutine g5avar (obj) - !$omp declare variant (g5var ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g5var ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj3' at .1. with OPTIONAL attribute not support when utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -120,7 +120,7 @@ contains integer(omp_interop_kind) :: obj2 end subroutine g6a (obj) - !$omp declare variant (g6 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g6 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj3' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -132,7 +132,7 @@ contains integer(omp_interop_kind),allocatable :: obj2 end subroutine g7a (obj) - !$omp declare variant (g7 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g7 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -144,7 +144,7 @@ contains integer(omp_interop_kind) :: obj2(:) end subroutine g8a (obj) - !$omp declare variant (g8 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g8 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -156,7 +156,7 @@ contains integer(omp_interop_kind) :: obj2(2) end subroutine g9a (obj) - !$omp declare variant (g9 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g9 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -168,7 +168,7 @@ contains integer(1) :: obj2 end subroutine g10a (obj) - !$omp declare variant (g10 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g10 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -180,7 +180,7 @@ contains real(omp_interop_kind) :: obj2 ! { dg-warning "C kind type parameter is for type INTEGER but type at .1. is REAL" } end subroutine g11a (obj) - !$omp declare variant (g11 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g11 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end @@ -192,7 +192,7 @@ contains integer(omp_interop_kind) :: obj2[*] end subroutine g12a (obj) - !$omp declare variant (g12 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (g12 ) match(construct={dispatch}) append_args ( interop ( target , targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ! { dg-error "'obj2' at .1. must be a nonpointer, nonallocatable scalar integer dummy argument of 'omp_interop_kind' kind as it utilized with the 'append_args' clause at .2." "" { target *-*-* } .-1 } integer(omp_interop_kind),value :: obj end diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-3.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-3.f90 index 5dbc246..3b5d3f8 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-3.f90 @@ -33,7 +33,7 @@ contains integer(omp_interop_kind), value :: o_value end subroutine sub_no_arg () - !$omp declare variant (vsub_no_arg ) match(construct={dispatch}) append_args (interop(targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (vsub_no_arg ) match(construct={dispatch}) append_args (interop(targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) end integer(c_int) function vfun_cbind(arg2_int, arg2_str, o2_dummy, o2_value) bind(C) diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-4.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-4.f90 index 6f55084..f07e3ab 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-4.f90 @@ -40,7 +40,7 @@ contains character(len=*) :: str integer, optional, value :: int_opt character(len=:), allocatable :: alloc_str - !$omp declare variant (vifun ) match(construct={dispatch}) append_args (interop(targetsync), interop( prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) + !$omp declare variant (vifun ) match(construct={dispatch}) append_args (interop(targetsync), interop( target, prefer_type ( {fr("cuda"), attr("ompx_xx")}, {attr("ompx_yy")} ))) ifun = 0 end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90 index f75b49c..ab44050 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90 @@ -9,12 +9,6 @@ ! { dg-error "'x' at .1. is specified more than once" "" { target *-*-* } 17 } -! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f1', except when specifying all 1 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 } -! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 33 } -! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f2', except when specifying all 2 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 } -! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 37 } -! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f3', except when specifying all 3 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 } -! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 43 } ! Check that module-file handling works for declare_variant ! and its match/adjust_args/append_args clauses diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 index a16c384..eae0cb3 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 @@ -33,12 +33,12 @@ integer(omp_interop_fr_kind), parameter :: ifr_array(2) = [omp_ifr_cuda, omp_ifr integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 integer :: x -!$omp interop init(obj1) init(target,targetsync : obj2, obj3) nowait ! OK -!$omp interop init(obj1) init (targetsync : obj2, obj3) nowait ! OK -!$omp interop init(obj1) init (targetsync , target : obj2, obj3) nowait ! OK +!$omp interop init(target: obj1) init(target,targetsync : obj2, obj3) nowait ! OK +!$omp interop init(target: obj1) init (targetsync : obj2, obj3) nowait ! OK +!$omp interop init(target: obj1) init (targetsync , target : obj2, obj3) nowait ! OK -!$omp interop init(obj1) init(target,targetsync,target: obj2, obj3) nowait ! { dg-error "Duplicate 'target'" } -!$omp interop init(obj1) init(target,targetsync, targetsync : obj2, obj3) nowait ! { dg-error "Duplicate 'targetsync'" } +!$omp interop init(target: obj1) init(target,targetsync,target: obj2, obj3) nowait ! { dg-error "Duplicate 'target'" } +!$omp interop init(target: obj1) init(target,targetsync, targetsync : obj2, obj3) nowait ! { dg-error "Duplicate 'targetsync'" } !$omp interop init(prefer_type("cuda", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) & !$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0) @@ -47,7 +47,7 @@ integer :: x ! { dg-warning "Unknown foreign runtime identifier 'cu' at \\(1\\) \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } !$omp assume contains(interop) - !$omp interop init(prefer_type("cuða") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\[^'\]*a'" } + !$omp interop init(target, prefer_type("cuða") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\[^'\]*a'" } !$omp end assume !$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "36: Expected ',' or '\\)'" } @@ -63,35 +63,35 @@ integer :: x !$omp interop init ( target , prefer_type( { fr("hsa"), attr("ompx_nothing") , fr("hsa" ) }) :obj1) ! { dg-error "Duplicated 'fr' preference-selector-name" } -!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } -!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(4 ) }) : obj1) ! OK -!$omp interop init ( prefer_type( {fr(4_"cuda" ) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(c_char_"cuda") }) : obj1) ! OK -!$omp interop init ( prefer_type( {fr(1_"cuda" ) }) : obj1) ! OK -!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero ) }, {fr(omp_ifr_hip)}) : obj1) ! OK -!$omp interop init ( prefer_type( {fr("cuda" // "_driver") }) : obj1) ! { dg-error "46: Expected '\\)'" } -!$omp interop init ( prefer_type( {fr(trim("cuda" // "_driver")) }) : obj1) ! { dg-error "38: Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr("hello" }) : obj1) ! { dg-error "47: Expected '\\)'" } +!$omp interop init ( target, prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } +!$omp interop init ( target, prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(4 ) }) : obj1) ! OK +!$omp interop init ( target, prefer_type( {fr(4_"cuda" ) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(c_char_"cuda") }) : obj1) ! OK +!$omp interop init ( target, prefer_type( {fr(1_"cuda" ) }) : obj1) ! OK +!$omp interop init ( target, prefer_type( {fr(omp_ifr_level_zero ) }, {fr(omp_ifr_hip)}) : obj1) ! OK +!$omp interop init ( target, prefer_type( {fr("cuda" // "_driver") }) : obj1) ! { dg-error "54: Expected '\\)'" } +!$omp interop init ( target, prefer_type( {fr(trim("cuda" // "_driver")) }) : obj1) ! { dg-error "46: Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr("hello" }) : obj1) ! { dg-error "55: Expected '\\)'" } ! { dg-warning "Unknown foreign runtime identifier 'hello' at \\(1\\) \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } -!$omp interop init ( prefer_type( {fr(x) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(ifr_array ) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(ifr_array(1) ) }) : obj1) +!$omp interop init ( target, prefer_type( {fr(x) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(ifr_array ) }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(ifr_array(1) ) }) : obj1) -!$omp interop init ( prefer_type( omp_ifr_level_zero, omp_ifr_hip ) : obj1) ! OK -!$omp interop init ( prefer_type( omp_ifr_level_zero +1 ) : obj1) ! OK -!$omp interop init ( prefer_type( x ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( ifr_array ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( ifr_array(2) ) : obj1) ! OK +!$omp interop init ( target, prefer_type( omp_ifr_level_zero, omp_ifr_hip ) : obj1) ! OK +!$omp interop init ( target, prefer_type( omp_ifr_level_zero +1 ) : obj1) ! OK +!$omp interop init ( target, prefer_type( x ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( ifr_array ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( ifr_array(2) ) : obj1) ! OK -!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } -!$omp interop init ( prefer_type( 4, 1, 3) : obj1) +!$omp interop init ( target, prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" } +!$omp interop init ( target, prefer_type( 4, 1, 3) : obj1) -!$omp interop init ( prefer_type( {fr("cuda") }, {fr(omp_ifr_hsa)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) -!$omp interop init ( prefer_type( {fr("cuda") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) ! { dg-error "65: Expected '\\)'" } -!$omp interop init ( prefer_type( {fr("cuda",5) }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) ! { dg-error "45: Expected '\\)' at" } -!$omp interop init ( prefer_type( {fr("sycl"), attr("ompx_1", "ompx_2"), attr("ompx_3") }, {attr("ompx_4", "ompx_5"),fr(omp_ifr_level_zero)} ) : obj1) -!$omp interop init ( prefer_type( { fr(5), attr("ompx_1") }, {fr(omp_ifr_hsa)} , {attr("ompx_a") } ) : obj1) +!$omp interop init ( target, prefer_type( {fr("cuda") }, {fr(omp_ifr_hsa)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) +!$omp interop init ( target, prefer_type( {fr("cuda") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) ! { dg-error "73: Expected '\\)'" } +!$omp interop init ( target, prefer_type( {fr("cuda",5) }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1) ! { dg-error "53: Expected '\\)' at" } +!$omp interop init ( target, prefer_type( {fr("sycl"), attr("ompx_1", "ompx_2"), attr("ompx_3") }, {attr("ompx_4", "ompx_5"),fr(omp_ifr_level_zero)} ) : obj1) +!$omp interop init ( target, prefer_type( { fr(5), attr("ompx_1") }, {fr(omp_ifr_hsa)} , {attr("ompx_a") } ) : obj1) end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 index b313011..a8fc920 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 @@ -27,13 +27,13 @@ integer(1) :: o1 integer, parameter :: mykind = mod (omp_interop_kind, 100) ! remove saving the 'comes from c_int' info real(mykind) :: or -!$omp interop init (op) ! { dg-error "'op' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } +!$omp interop init (target : op) ! { dg-error "'op' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } ! { dg-error "Object 'op' is not a variable at \\(1\\)" "" { target *-*-* } .-1 } -!$omp interop init (ointent) ! { dg-error "'ointent' at \\(1\\) in 'INIT' clause must be definable" } -!$omp interop init (od) ! { dg-error "'od' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } -!$omp interop init (od(1)) ! { dg-error "Syntax error in OpenMP variable list" } -!$omp interop init (o1) ! { dg-error "'o1' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } -!$omp interop init (or) ! { dg-error "'or' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } +!$omp interop init (target : ointent) ! { dg-error "'ointent' at \\(1\\) in 'INIT' clause must be definable" } +!$omp interop init (target : od) ! { dg-error "'od' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } +!$omp interop init (target : od(1)) ! { dg-error "Syntax error in OpenMP variable list" } +!$omp interop init (target: o1) ! { dg-error "'o1' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } +!$omp interop init (target: or) ! { dg-error "'or' at \\(1\\) in 'INIT' clause must be a scalar integer variable of 'omp_interop_kind' kind" } !$omp interop use (op) ! { dg-error "'op' at \\(1\\) in 'USE' clause must be a scalar integer variable of 'omp_interop_kind' kind" } ! { dg-error "Object 'op' is not a variable at \\(1\\)" "" { target *-*-* } .-1 } @@ -60,21 +60,21 @@ implicit none integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 integer :: x -!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } -!$omp interop init ( prefer_type( {fr(1_"hip") , attr(omp_ifr_cuda) }) : obj1) ! { dg-error "Expected default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" } +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr(omp_ifr_cuda) }) : obj1) ! { dg-error "Expected default-kind character literal" } -!$omp interop init ( prefer_type( {fr(1_"hip") , attr("myooption") }) : obj1) ! { dg-error "Character literal at .1. must start with 'ompx_'" } -!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") , attr("ompx_") } ) : obj1) -!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") }, { attr("ompx_") } ) : obj1) -!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") } { attr("ompx_") } ) : obj1) ! { dg-error "Expected ',' or '\\)'" } -!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr("myooption") }) : obj1) ! { dg-error "Character literal at .1. must start with 'ompx_'" } +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr("ompx_option") , attr("ompx_") } ) : obj1) +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr("ompx_option") }, { attr("ompx_") } ) : obj1) +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr("ompx_option") } { attr("ompx_") } ) : obj1) ! { dg-error "Expected ',' or '\\)'" } +!$omp interop init ( target, prefer_type( {fr(1_"hip") , attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } -!$omp interop init ( prefer_type( {fr(1_"hip") attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } -!$omp interop init ( prefer_type( {fr(1_"hip")}), prefer_type("cuda") : obj1) ! { dg-error "Duplicate 'prefer_type' modifier" } +!$omp interop init ( target, prefer_type( {fr(1_"hip") attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" } +!$omp interop init ( target, prefer_type( {fr(1_"hip")}), prefer_type("cuda") : obj1) ! { dg-error "Duplicate 'prefer_type' modifier" } -!$omp interop init ( prefer_type( {attr("ompx_option1,ompx_option2") ) : obj1) ! { dg-error "Unexpected null or ',' character in character literal" } +!$omp interop init ( target, prefer_type( {attr("ompx_option1,ompx_option2") ) : obj1) ! { dg-error "Unexpected null or ',' character in character literal" } !$omp interop init ( targetsync other ) : obj1) ! { dg-error "Expected ',' or ':'" } -!$omp interop init ( prefer_type( {fr(1_"cuda") } ), other : obj1) ! { dg-error "Expected 'target' or 'targetsync'" } -!$omp interop init ( prefer_type( {fr(1_"cuda") } ), obj1) ! { dg-error "Expected 'target' or 'targetsync'" } +!$omp interop init ( target, prefer_type( {fr(1_"cuda") } ), other : obj1) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } +!$omp interop init ( target, prefer_type( {fr(1_"cuda") } ), obj1) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 index a3bbfca..04015de 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 @@ -25,16 +25,16 @@ integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5 integer(omp_interop_kind) :: target, targetsync,prefer_type integer :: x -!$omp interop init(obj1) init(target,targetsync : obj2, obj3) nowait +!$omp interop init(target: obj1) init(target,targetsync : obj2, obj3) nowait !$omp interop init(prefer_type(1_"cuda", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) & !$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0) !$omp assume contains(interop) - !$omp interop init(prefer_type("cu da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu da'" } + !$omp interop init(target, prefer_type("cu da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu da'" } !$omp end assume -!$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4) +!$omp interop init(target: obj1, obj2, obj1), use(obj4) destroy(obj4) ! { dg-error "Symbol 'obj1' present on multiple clauses" "" { target *-*-* } .-1 } ! { dg-error "Symbol 'obj4' present on multiple clauses" "" { target *-*-* } .-2 } @@ -44,13 +44,13 @@ integer :: x !$omp interop depend(inout: x) use(obj2), destroy(obj3) ! Likewise -!$omp interop depend(inout: x) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } +!$omp interop depend(inout: x) use(obj2), destroy(obj3) init(target: obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } -!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } +!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(target: obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." } !$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(prefer_type("cuda"), targetsync : obj4) ! OK -!$omp interop init(target, targetsync, prefer_type, obj1) -!$omp interop init(prefer_type, obj1, target, targetsync) +!$omp interop init(target, targetsync, prefer_type, obj1) ! { dg-error "51: Expected '\\(' after 'prefer_type'" } +!$omp interop init(target, prefer_type, obj1, targetsync) ! { dg-error "39: Expected '\\(' after 'prefer_type'" } ! Duplicated variable name or duplicated modifier: !$omp interop init(target, targetsync,target : obj1) ! { dg-error "Duplicate 'target' at \\(1\\)" } @@ -62,5 +62,5 @@ integer :: x !$omp interop init(target : target, targetsync,targetsync) ! { dg-error "Symbol 'targetsync' present on multiple clauses" } -!$omp interop init(, targetsync, prefer_type, obj1, target) ! { dg-error "Syntax error in OpenMP variable list" } +!$omp interop init(, targetsync, prefer_type, obj1, target) ! { dg-error "20: Expected 'prefer_type', 'target', or 'targetsync'" } end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-4.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-4.f90 index 43c28d6..7422881 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-4.f90 @@ -26,14 +26,14 @@ implicit none integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5, obj6, obj7 integer :: x(6) -!$omp interop init ( obj1, obj2) use (obj3) destroy(obj4) init(obj5) destroy(obj6) use(obj7) -! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(obj1\\) init\\(obj2\\) init\\(obj5\\) use\\(obj3\\) use\\(obj7\\) destroy\\(obj4\\) destroy\\(obj6\\)\[\r\n\]" 1 "original" } } +!$omp interop init ( target: obj1, obj2) use (obj3) destroy(obj4) init(target: obj5) destroy(obj6) use(obj7) +! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(target: obj1\\) init\\(target: obj2\\) init\\(target: obj5\\) use\\(obj3\\) use\\(obj7\\) destroy\\(obj4\\) destroy\\(obj6\\)\[\r\n\]" 1 "original" } } !$omp interop nowait init (targetsync : obj1, obj2) use (obj3) destroy(obj4) init(target, targetsync : obj5) destroy(obj6) use(obj7) depend(inout: x) ! { dg-final { scan-tree-dump-times "#pragma omp interop depend\\(inout:x\\) init\\(targetsync: obj1\\) init\\(targetsync: obj2\\) init\\(target, targetsync: obj5\\) use\\(obj3\\) use\\(obj7\\) destroy\\(obj4\\) destroy\\(obj6\\) nowait\[\r\n\]" 1 "original" } } -!$omp interop init ( obj1, obj2) init (target: obj3) init(targetsync : obj4) init(target,targetsync: obj5) -! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(obj1\\) init\\(obj2\\) init\\(target: obj3\\) init\\(targetsync: obj4\\) init\\(target, targetsync: obj5\\)\[\r\n\]" 1 "original" } } +!$omp interop init ( target: obj1, obj2) init (target: obj3) init(targetsync : obj4) init(target,targetsync: obj5) +! { dg-final { scan-tree-dump-times "#pragma omp interop init\\(target: obj1\\) init\\(target: obj2\\) init\\(target: obj3\\) init\\(targetsync: obj4\\) init\\(target, targetsync: obj5\\)\[\r\n\]" 1 "original" } } ! -------------------------------------------- diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-5.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-5.f90 index a6a2d71..a08eeb8 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-5.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-5.f90 @@ -1,7 +1,13 @@ ! { dg-additional-options "-fdump-tree-omplower" } subroutine sub1 (a1, a2, a3, a4) - use omp_lib, only: omp_interop_kind + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer(omp_interop_kind) :: a1 ! by ref integer(omp_interop_kind), optional :: a2 ! as pointer integer(omp_interop_kind), allocatable :: a3 ! ref to pointer @@ -9,13 +15,13 @@ subroutine sub1 (a1, a2, a3, a4) integer(omp_interop_kind) :: b !$omp interop init(target : a1, a2, a3, a4, b) - ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=4\\) tgt_tgtsync\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=8\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[0\\\] = 1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[1\\\] = 1;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[2\\\] = 1;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[3\\\] = 1;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[4\\\] = 1;\[\r\n ]*__builtin_GOMP_interop \\(-5, 5, &interopobjs\.\[0-9\]+, &tgt_tgtsync\.\[0-9\]+, 0B, 0, 0B, 0, 0B, 0, 0B\\);" 1 "omplower" } } + ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=4\\) tgt_tgtsync\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[0\\\] = 1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[1\\\] = 1;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[2\\\] = 1;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[3\\\] = 1;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*tgt_tgtsync\.\[0-9\]+\\\[4\\\] = 1;\[\r\n ]*__builtin_GOMP_interop \\(-5, 5, &interopobjs\.\[0-9\]+, &tgt_tgtsync\.\[0-9\]+, 0B, 0, 0B, 0, 0B, 0, 0B\\);" 1 "omplower" } } !$omp interop use(a1, a2, a3, a4, b) - ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=8\\) b\.\[0-9\]+;\[\r\n ]*void \\* b\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) a4\.\[0-9\]+;\[\r\n ]*void \\* a4\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) & a1\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*b\.\[0-9\]+ = b;\[\r\n ]*b\.\[0-9\]+ = \\(void \\*\\) b\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = b\.\[0-9\]+;\[\r\n ]*a4\.\[0-9\]+ = a4;\[\r\n ]*a4\.\[0-9\]+ = \\(void \\*\\) a4\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = a4\.\[0-9\]+;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\*D\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*D\.\[0-9\]+ = \\*a2\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = D\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*D\.\[0-9\]+ = \\*a1\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = D\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B, 0, 0B\\);" 1 "omplower" } } + ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) b\.\[0-9\]+;\[\r\n ]*void \\* b\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) a4\.\[0-9\]+;\[\r\n ]*void \\* a4\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) D\.\[0-9\]+;\[\r\n ]*void \\* D\.\[0-9\]+;\[\r\n ]*b\.\[0-9\]+ = b;\[\r\n ]*b\.\[0-9\]+ = \\(void \\*\\) b\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = b\.\[0-9\]+;\[\r\n ]*a4\.\[0-9\]+ = a4;\[\r\n ]*a4\.\[0-9\]+ = \\(void \\*\\) a4\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = a4\.\[0-9\]+;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\*D\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*D\.\[0-9\]+ = \\*a2\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = D\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*D\.\[0-9\]+ = \\*a1\.\[0-9\]+;\[\r\n ]*D\.\[0-9\]+ = \\(void \\*\\) D\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = D\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B, 0, 0B\\);" 1 "omplower" } } !$omp interop destroy(a1, a2, a3, a4, b) - ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=8\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=8\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 0, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B\\);" 1 "omplower" } } + ! { dg-final { scan-tree-dump-times "void \\* interopobjs\.\[0-9\]+\\\[5\\\];\[\r\n ]*integer\\(kind=\[48\]\\) \\* & a3\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* D\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) \\* a2\.\[0-9\]+;\[\r\n ]*integer\\(kind=\[48\]\\) & a1\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[0\\\] = &b;\[\r\n ]*interopobjs\.\[0-9\]+\\\[1\\\] = &a4;\[\r\n ]*a3\.\[0-9\]+ = a3;\[\r\n ]*D\.\[0-9\]+ = \\*a3\.\[0-9\]+;\[\r\n ]*interopobjs\.\[0-9\]+\\\[2\\\] = D\.\[0-9\]+;\[\r\n ]*a2\.\[0-9\]+ = a2;\[\r\n ]*interopobjs\.\[0-9\]+\\\[3\\\] = a2\.\[0-9\]+;\[\r\n ]*a1\.\[0-9\]+ = a1;\[\r\n ]*interopobjs\.\[0-9\]+\\\[4\\\] = a1\.\[0-9\]+;\[\r\n ]*__builtin_GOMP_interop \\(-5, 0, 0B, 0B, 0B, 0, 0B, 5, &interopobjs\.\[0-9\]+, 0, 0B\\);" 1 "omplower" } } end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/pr118965-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr118965-1.f90 new file mode 100644 index 0000000..c9b1eca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr118965-1.f90 @@ -0,0 +1,48 @@ +! At least one of the target and/or targetsync modifiers must be provided. +! This implies that there are always modifiers required, and the parser +! should reject e.g. "init (var1, var2)"; the first thing in the list is +! always an init_modifier in valid code. + +module m + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer, parameter :: omp_interop_fr_kind = c_int + + integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1 + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2 + integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3 + integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5 + integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7 +end module m + +program main +use m +implicit none +integer(omp_interop_kind) :: obj1, obj2 + + !$omp interop init (obj1) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (obj1, obj2) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (obj1, target) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (target, obj1) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (obj1, targetsync) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (targetsync, obj1) ! { dg-error "Expected 'prefer_type', 'target', or 'targetsync'" } + !$omp interop init (targetsync, target) ! { dg-error "Expected ',' or ':'" } + + !$omp interop init (target, prefer_type( {fr(4 ) }) : obj1) ! OK + !$omp interop init (targetsync, prefer_type( {fr(4 ) }) : obj1) ! OK + !$omp interop init (prefer_type( {fr(4 ) }), target : obj1) ! OK + + !$omp interop init (prefer_type( {fr(4 ) }) : obj1) ! { dg-error "Missing required 'target' and/or 'targetsync' modifier" } + + ! This does not complain about foobar not being declared because + ! Fortran parser error handling eats the whole rest of the statement. + !$omp interop init (prefer_type( {fr(4 ) }) : foobar) ! { dg-error "Missing required 'target' and/or 'targetsync' modifier" } + +end
\ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/gomp/pr118965-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr118965-2.f90 new file mode 100644 index 0000000..0b3015a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr118965-2.f90 @@ -0,0 +1,57 @@ +! At least one of the target and/or targetsync modifiers must be provided. + +module my_omp_lib + use iso_c_binding + implicit none + + ! The following definitions are in omp_lib, which cannot be included + ! in gcc/testsuite/ + integer, parameter :: omp_interop_kind = c_intptr_t + integer, parameter :: omp_interop_fr_kind = c_int + + integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1 + integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2 + integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3 + integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5 + integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6 + integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7 +end module my_omp_lib + +module m + use my_omp_lib + implicit none + logical, parameter :: flag = .true. +contains + + subroutine f1 (i) + integer(omp_interop_kind) :: i + end + + subroutine g1 () + !$omp declare variant (f1) match(user={condition(flag)}) & + !$omp& append_args(interop(prefer_type({attr("ompx_fun")}))) + ! { dg-error "Missing required 'target' and/or 'targetsync' modifier" "" { target *-*-* } .-1 } + end + + function f2 (a1, a2) + integer(omp_interop_kind) :: a1 + integer(omp_interop_kind) :: a2 + integer :: f2 + f2 = 0 + end + + function g2 () + !$omp declare variant(f2) & + !$omp& append_args(interop(prefer_type("cuda")), & + !$omp& interop(prefer_type({fr("hsa")}))) & + !$omp& match(construct={dispatch}) + ! { dg-error "Missing required 'target' and/or 'targetsync' modifier" "" { target *-*-* } .-3 } + ! There is no diagnostic for the second interop arg because Fortran + ! error recovery skips to the end of the statement after diagnosing the + ! first one. + integer :: g2 + g2 = 5 + end +end diff --git a/gcc/testsuite/gfortran.dg/optional_absent_13.f90 b/gcc/testsuite/gfortran.dg/optional_absent_13.f90 new file mode 100644 index 0000000..9c2039b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_13.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! PR fortran/119656 - wrong code with impure elemental subroutine and interface +! +! Derived from testcase at: +! https://fortran-lang.discourse.group/t/ +! problem-with-impure-elemental-subroutine-in-interface-with-gfortran/9545 + +module m2 + implicit none + interface foo + module procedure foo_mat + module procedure foo_df + module procedure foo_cmat + end interface foo +contains + + subroutine foo_mat(x, nacf, label) + real, intent(in) :: x(:,:) + integer, intent(in) :: nacf + character(len=*), intent(in), optional :: label + end subroutine foo_mat + + impure elemental subroutine foo_df(nacf, outu, xstr) + integer , intent(in) :: nacf + integer , intent(in), optional :: outu + character(len=*), intent(in), optional :: xstr + if (present(xstr)) then + if (len (xstr) /= 2) then + print *,"nacf, len(xstr) =", nacf, len(xstr) + stop nacf + end if + end if + end subroutine foo_df + + subroutine foo_cmat(x, nacf, label) + complex, intent(in) :: x(:,:) + integer, intent(in) :: nacf + character(len=*), intent(in), optional :: label + end subroutine foo_cmat + +end module m2 + +program main + use m2, only: foo, foo_df + implicit none + call foo_df(nacf = 1, xstr="ab") + call foo (nacf = 2, xstr="ab") +end program main diff --git a/gcc/testsuite/gfortran.dg/parity_2.f90 b/gcc/testsuite/gfortran.dg/parity_2.f90 index 5ff11da..9a8e035 100644 --- a/gcc/testsuite/gfortran.dg/parity_2.f90 +++ b/gcc/testsuite/gfortran.dg/parity_2.f90 @@ -6,7 +6,7 @@ ! Check implementation of PARITY ! implicit none -print *, parity([real ::]) ! { dg-error "must be LOGICAL" }) +print *, parity([real ::]) ! { dg-error "must be LOGICAL" } print *, parity([integer ::]) ! { dg-error "must be LOGICAL" } print *, parity([logical ::]) print *, parity(.true.) ! { dg-error "must be an array" } diff --git a/gcc/testsuite/gfortran.dg/reduce_2.f90 b/gcc/testsuite/gfortran.dg/reduce_2.f90 index 52d7c68..cacd54a 100644 --- a/gcc/testsuite/gfortran.dg/reduce_2.f90 +++ b/gcc/testsuite/gfortran.dg/reduce_2.f90 @@ -8,6 +8,10 @@ integer, allocatable :: i(:,:,:) integer :: n(2,2) Logical :: l1(4), l2(2,3), l3(2,2) + type :: string_t + character(:), allocatable :: chr(:) + end type + type(string_t) :: str ! The ARRAY argument at (1) of REDUCE shall not be polymorphic print *, reduce (cstar, add) ! { dg-error "shall not be polymorphic" } @@ -54,6 +58,10 @@ ! (2) shall be the same print *, reduce ([character(4) :: 'abcd','efgh'], char_three) ! { dg-error "arguments of the OPERATION" } +! The character length of the ARRAY argument at (1) and of the arguments of the OPERATION at (2) +! shall be the same + str = reduce ([character(4) :: 'abcd','efgh'], char_one) ! { dg-error "character length of the ARRAY" } + ! The DIM argument at (1), if present, must be an integer scalar print *, reduce (i, add, dim = 2.0) ! { dg-error "must be an integer scalar" } diff --git a/gcc/testsuite/gfortran.dg/reduce_3.f90 b/gcc/testsuite/gfortran.dg/reduce_3.f90 new file mode 100644 index 0000000..c0ed062 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reduce_3.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! PR119460: Scalar reduce was failing with ARRAY elements larger than +! an address size. +! +! Contributed by Rainer Orth <ro@gcc.gnu.org> +! +program test_reduce + implicit none + integer :: i + integer, parameter :: dp = kind(1.0_8), extent = 4 + + real(dp) :: rarray(extent,extent,extent), rmat(extent,extent), & + rvec (extent), rscl + + type :: t + real(dp) :: field(extent) + end type t + + type (t) :: tmat(extent, extent), tarray(extent), tscalar + + rarray = reshape ([(real(i, kind = dp), i = 1, size(rarray))], & + shape (rarray)) + + rmat = reduce (rarray, add, dim = 1) + if (any (rmat /= sum (rarray, 1))) stop 1 + + rmat = reduce (rarray, add, dim = 2) + if (any (rmat /= sum (rarray, 2))) stop 2 + + rmat = reduce (rarray, add, dim = 3) + if (any (rmat /= sum (rarray, 3))) stop 3 + + rscl = reduce (rarray, add) + if (rscl /= sum (rarray)) stop 4 + + tmat%field(1) = rmat + tarray = reduce (tmat, t_add, dim =1) + rvec = reduce (rmat, add, dim = 1) + if (any (tarray%field(1) /= rvec)) stop 5 + + tscalar = reduce (tmat, t_add) + if (tscalar%field(1) /= sum (tmat%field(1))) stop 6 +contains + + pure real(dp) function add (i, j) + real(dp), intent(in) :: i, j + add = i + j + end function add + + pure type(t) function t_add (i, j) + type(t), intent(in) :: i, j + t_add%field(1) = i%field(1) + j%field(1) + end function t_add + +end diff --git a/gcc/testsuite/gfortran.dg/reduce_4.f90 b/gcc/testsuite/gfortran.dg/reduce_4.f90 new file mode 100644 index 0000000..edea931 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/reduce_4.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! PR119540 comment2: REDUCE was getting the shape wrong. This testcase also +! verifies that the longest possible name for the OPERATION wrapper function +! is catered for. +! +! Contributed by Harald Anlauf <anlauf@gcc.gnu.org> +! +program p2345678901234567890123456789012345678901234567890123456789_123 + implicit none + integer, parameter :: n = 3 + integer, parameter :: vec(n) = [2, 5, 10] + integer, parameter :: mat(n,2) = reshape([vec,2*vec],[n,2]) + integer :: mat_shape(2), reduce_shape(1), r + integer, dimension(:), allocatable :: res1 + + mat_shape = shape (mat) + reduce_shape = shape (reduce (mat, add, 1), 1) + if (reduce_shape(1) /= mat_shape(2)) stop 1 + + reduce_shape = shape (reduce (mat, add, 1), 1) + if (reduce_shape(1) /= mat_shape(2)) stop 2 + + res1 = reduce (mat, add, 1) + if (any (res1 /= [17, 34])) stop 3 + + res1 = reduce (mat, add, 2) + if (any (res1 /= [6, 15, 30])) stop 4 + + r = reduce (vec, & + o2345678901234567890123456789012345678901234567890123456789_123) + if (r /= 17) stop 5 + + deallocate (res1) +contains + pure function add(i,j) result(sum_ij) + integer, intent(in) :: i, j + integer :: sum_ij + sum_ij = i + j + end function add + + pure function o2345678901234567890123456789012345678901234567890123456789_123 (i, j) & + result (sum) + integer, intent(in) :: i, j + integer :: sum + sum = i + j + end function +end |