diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
67 files changed, 1927 insertions, 157 deletions
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 index 29c2b3a..7fd2085 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 @@ -9,6 +9,7 @@ program pr98903 integer :: a[*] type(team_type) :: team + team = get_team() me = this_image() n = num_images() a = 42 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 new file mode 100644 index 0000000..c35ec10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -0,0 +1,80 @@ +!{ dg-do run } + +! Check coindexes with team= or team_number= are working. + +program coindexed_5 + use, intrinsic :: iso_fortran_env + + type(team_type) :: parentteam, team, formed_team + integer :: t_num= 42, stat = 42, lhs + integer(kind=2) :: st_num=42 + integer :: caf(2)[*] + + parentteam = get_team() + + caf = [23, 32] + form team(t_num, team, new_index=1) + form team(t_num, formed_team) + + change team(team, cell[*] => caf(2)) + ! for get_from_remote + ! Checking against caf_single is very limitted. + if (cell[1, team_number=t_num] /= 32) stop 1 + if (cell[1, team_number=st_num] /= 32) stop 2 + if (cell[1, team=parentteam] /= 32) stop 3 + + ! Check that team_number is validated + lhs = cell[1, team_number=5, stat=stat] + if (stat /= 1) stop 4 + + ! Check that only access to active teams is valid + stat = 42 + lhs = cell[1, team=formed_team, stat=stat] + if (stat /= 1) stop 5 + + ! for send_to_remote + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = 45 + if (cell /= 45) stop 11 + cell[1, team_number=st_num] = 46 + if (cell /= 46) stop 12 + cell[1, team=parentteam] = 47 + if (cell /= 47) stop 13 + + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = 0 + if (stat /= 1) stop 14 + + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = -1 + if (stat /= 1) stop 15 + + ! for transfer_between_remotes + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = caf(1)[1, team_number=-1] + if (cell /= 23) stop 21 + cell[1, team_number=st_num] = caf(2)[1, team_number=-1] + ! cell is an alias for caf(2) and has been overwritten by caf(1)! + if (cell /= 23) stop 22 + cell[1, team=parentteam] = caf(1)[1, team= team] + if (cell /= 23) stop 23 + + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1] + if (stat /= 1) stop 24 + stat = -1 + cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat] + if (stat /= 1) stop 25 + + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = caf(1)[1] + if (stat /= 1) stop 26 + stat = 42 + cell[1] = caf(1)[1, team=formed_team, stat=stat] + if (stat /= 1) stop 27 + end team +end program coindexed_5 diff --git a/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 new file mode 100644 index 0000000..f37d1c7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 @@ -0,0 +1,29 @@ +!{ dg-do compile } + +! PR 97210 +! Tests get_team syntax + + use iso_fortran_env + implicit none + type(team_type) :: team, ret + integer :: level + + ret = get_team() + ret = get_team('abc') !{ dg-error "must be INTEGER" } + ret = get_team(level, 'abc') !{ dg-error "Too many arguments" } + ret = get_team([1,2]) !{ dg-error "must be a scalar" } + ret = get_team(team) !{ dg-error "must be INTEGER" } + + ret = get_team(INITIAL_TEAM) + ret = get_team(CURRENT_TEAM) + ret = get_team(PARENT_TEAM) + ret = get_team(INITIAL_TEAM, CURRENT_TEAM) !{ dg-error "Too many arguments" } + + level = INITIAL_TEAM + ret = get_team(level) + ret = get_team(99) !{ dg-error "specify one of the INITIAL_TEAM, PARENT_TEAM" } + level = 99 + ret = get_team(level) + level = get_team() !{ dg-error "Cannot convert TYPE\\(team_type\\)" } +end + diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index 098a2bb..b7ec5a6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 @@ -18,7 +18,7 @@ program test_image_status_1 isv = image_status(k2) ! Ok isv = image_status(k4) ! Ok isv = image_status(k8) ! Ok - isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" } + isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" } isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 53917b5..6f453d5 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -21,7 +21,7 @@ subroutine this_image_check() integer,save :: z(4)[*], i j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" } - j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" } + j = this_image(dim=3) ! { dg-error "'dim' argument without 'coarray' argument" } i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" } i = image_index(z, 2) ! { dg-error "must be a rank one array" } end subroutine this_image_check diff --git a/gcc/testsuite/gfortran.dg/coarray_49.f90 b/gcc/testsuite/gfortran.dg/coarray_49.f90 index 370e3fd..fd8549b 100644 --- a/gcc/testsuite/gfortran.dg/coarray_49.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_49.f90 @@ -5,5 +5,5 @@ program p integer :: x[*] - print *, image_index (x, [1.0]) ! { dg-error "shall be INTEGER" } + print *, image_index (x, [1.0]) ! { dg-error "must be INTEGER" } end diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 index 299ea62..2d8a39a 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 @@ -20,6 +20,6 @@ program test call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3) end program test -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 6\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 index 8419cf9..05a1350 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 @@ -33,6 +33,6 @@ contains end function hc end program test -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 new file mode 100644 index 0000000..702611c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 @@ -0,0 +1,30 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! Test critical syntax errors with stat= and errmsg= specifiers + + implicit none + integer :: istat + character(len=30) :: err + integer(kind=1) :: too_small_stat + + critical (stat=err) !{ dg-error "must be a scalar INTEGER" } + continue + end critical + + critical (stat=istat, stat=istat) !{ dg-error "Duplicate STAT" } + continue + end critical !{ dg-error "Expecting END PROGRAM" } + + critical (stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" } + continue + end critical + + critical (stat=istat, errmsg=err, errmsg=err) !{ dg-error "Duplicate ERRMSG" } + continue + end critical !{ dg-error "Expecting END PROGRAM" } + + critical (stat=too_small_stat) !{ dg-error "scalar INTEGER variable of at least kind 2" } + continue + end critical +end diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 new file mode 100644 index 0000000..cd609bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Test critical construct with stat= and errmsg= specifiers +! + use, intrinsic :: iso_fortran_env, only: int16 + implicit none + integer :: istat = 42 + integer(kind=int16) :: istat16 = 42 + character(len=30) :: err = 'unchanged' + integer :: fail = 0 + + critical (stat=istat, errmsg=err) + if (istat /= 0) fail = 1 + if (trim(err) /= 'unchanged') fail = 2 + end critical + + if (fail /= 0) stop fail + + critical (stat=istat16, errmsg=err) + if (istat16 /= 0) fail = 3 + if (trim(err) /= 'unchanged') fail = 4 + end critical + + if (fail /= 0) stop fail +end + +! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &istat, &err, 30\\);" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &stat\\.\[0-9\]+, &err, 30\\);" "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token\\.\[0-9\]+, 0, 1, &stat\\.\[0-9\]+, 0B, 0\\);" 2 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 index 63cca3e..7939a79 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 @@ -19,8 +19,8 @@ end ! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 index a27d740..31a7677 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 @@ -19,8 +19,8 @@ end ! { dg-final { scan-tree-dump-times "bar \\(struct array02_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 index 1fe2318..5a609d8 100644 --- a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 @@ -1,19 +1,52 @@ -! { dg-do compile } -! { dg-options "-fdump-tree-original -fcoarray=single" } +!{ dg-do run } +!{ dg-options "-fdump-tree-original -fcoarray=single" } ! -j1 = this_image(distance=4) -j2 = this_image(5) + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[2,*] +integer, allocatable :: res(:) +type(team_type) :: team + +form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1) +j1 = this_image() +if (j1 /= 1) then + print *, me, ":", j1 + stop 1 +endif +res = this_image(caf) +if (any (res /= [1, 1])) then + print *, me, ":", res + stop 2 +endif +j2 = this_image(caf, 1) +if (j2 /= 1) then + print *, me, ":", j2 + stop 3 +endif +j3 = this_image(team) +if (j3 /= MOD(this_image() + 43, num_images()) +1) then + print *, me, ":", j3 + stop 4 +endif +res = this_image(caf, team) +if (any(res /= [1, 1])) then + print *, me, ":", res + stop 5 +endif +j4 = this_image(caf, 1, team) +if (j4 /= 1) then + print *, me, ":", j4 + stop 6 +endif +associate(me => this_image()) +end associate k1 = num_images() -k2 = num_images(6) -k3 = num_images(distance=7) -k4 = num_images(distance=8, failed=.true.) -k5 = num_images(failed=.false.) +k2 = num_images(team) +k3 = num_images(-1) end -! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k4 = 0;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k5 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j\[1-4\] = 1;" 4 "original" } } +! { dg-final { scan-tree-dump-times "A\\.\[0-9\]+\\\[2\\\] = \\\{1, 1\\\};" 4 "original" } } +! { dg-final { scan-tree-dump "k1 = 1;" "original" } } +! { dg-final { scan-tree-dump "k2 = 1;" "original" } } +! { dg-final { scan-tree-dump "k3 = 1;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 index 002c897..9713e3d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 @@ -1,19 +1,57 @@ -! { dg-do compile } -! { dg-options "-fdump-tree-original -fcoarray=lib" } +!{ dg-do run } +!{ dg-additional-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } ! -j1 = this_image(distance=4) -j2 = this_image(5) + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[2,*] +integer, allocatable :: res(:) +type(team_type) :: team + +form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1) + +associate(me => this_image()) +j1 = this_image() +if (j1 /= 1) then + print *, me, ":", j1 + stop 1 +endif +res = this_image(caf) +if (any (res /= [1, 1])) then + print *, me, ":", res + stop 2 +endif +j2 = this_image(caf, 1) +if (j2 /= 1) then + print *, me, ":", j2 + stop 3 +endif +j3 = this_image(team) +if (j3 /= MOD(this_image() + 43, num_images()) +1) then + print *, me, ":", j3 + stop 4 +endif +res = this_image(caf, team) +if (any(res /= [1, 1])) then + print *, me, ":", res + stop 5 +endif +j4 = this_image(caf, 1, team) +if (j4 /= 1) then + print *, me, ":", j4 + stop 6 +endif +end associate k1 = num_images() -k2 = num_images(6) -k3 = num_images(distance=7) -k4 = num_images(distance=8, failed=.true.) -k5 = num_images(failed=.false.) +k2 = num_images(team) +k3 = num_images(-1) +k4 = num_images(1) end -! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k4 = _gfortran_caf_num_images \\(8, 1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k5 = _gfortran_caf_num_images \\(0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump "j1 = _gfortran_caf_this_image \\(0B\\);" "original" } } +! { dg-final { scan-tree-dump "j3 = _gfortran_caf_this_image \\(team\\);" "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(team\\) \\+ -1;" 2 "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(0B\\) \\+ -1;" 2 "original" } } +! { dg-final { scan-tree-dump "k1 = _gfortran_caf_num_images \\(0B, 0B\\);" "original" } } +! { dg-final { scan-tree-dump "k2 = _gfortran_caf_num_images \\(team, 0B\\);" "original" } } +! { dg-final { scan-tree-dump "k3 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } } +! { dg-final { scan-tree-dump "k4 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 new file mode 100644 index 0000000..b8433b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } + + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[*] +integer, allocatable :: res(:) +type(team_type) :: team + +j1 = this_image() ! ok +j1 = this_image('bar') !{ dg-error "First argument of 'this_image'" } +res = this_image(caf) ! ok +res = this_image(caf, caf) !{ dg-error "Second argument of 'this_image'" } +j2 = this_image(caf, 1) ! ok +j3 = this_image(caf, 'foo') !{ dg-error "Second argument of 'this_image'" } +j4 = this_image(caf, [1, 2]) !{ dg-error "Second argument of 'this_image'" } +j5 = this_image(team) ! ok +j6 = this_image(team, caf) !{ dg-error "Second argument of 'this_image'" } +res = this_image(caf, team) ! ok +res = this_image(caf, team, 'foo') !{ dg-error "shall be of type 'team_type'" } +j4 = this_image(caf, 1, team) ! ok +j5 = this_image(caf, 1, team, 'baz') !{ dg-error "Too many arguments in call" } +j6 = this_image(dim=1, team=team, coarray=caf) + +k1 = num_images() ! ok +k2 = num_images(team) ! ok +k3 = num_images(team, 2) !{ dg-error "Too many arguments in call to" } +k4 = num_images(1) ! ok +k5 = num_images('abc') !{ dg-error "'team/team_number' argument of 'num_images' intrinsic" } +k6 = num_images(1, team) !{ dg-error "Too many arguments in call to" } +end 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..a7fa7c3 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 @@ -19,7 +18,7 @@ program do_concurrent_all_clauses squared = i * i arr(i) = temp2 + squared sum = sum + arr(i) - max_val = max(max_val, arr(i)) ! { dg-error "Reference to impure function" } + max_val = max(max_val, arr(i)) end block end do print *, arr, sum, max_val 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 index f2c4d97..540079a 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append-args-interop.f90 @@ -23,6 +23,6 @@ use m 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 "__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/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/map-alloc-comp-1.f90 b/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 index 0c44296..f48addc 100644 --- a/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 @@ -10,5 +10,5 @@ type sct end type type(sct) var -!$omp target enter data map(to:var) ! { dg-error "allocatable components is not permitted in map clause" } +!$omp target enter data map(to:var) end diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-1.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-1.f90 new file mode 100644 index 0000000..750cec9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-1.f90 @@ -0,0 +1,30 @@ +type t + integer :: t +end type t +class(t), target, allocatable :: c, ca(:) +class(t), pointer :: p, pa(:) +integer :: x +allocate( t :: c, ca(5)) +p => c +pa => ca + +! 11111111112222222222333333333344 +!2345678901234567890123456789012345678901 +!$omp target enter data map(c, ca, p, pa) +! { dg-warning "29:Mapping of polymorphic list item 'c' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } +! { dg-warning "32:Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 } +! { dg-warning "36:Mapping of polymorphic list item 'p' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 } +! { dg-warning "39:Mapping of polymorphic list item 'pa' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 } + +! 11111111112222222222333333333344 +!2345678901234567890123456789012345678901 + +! 11111111112222222222333333333344 +!2345678901234567890123456789012345678901 +!$omp target update from(c,ca), to(p,pa) +! { dg-warning "26:Mapping of polymorphic list item 'c' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } +! { dg-warning "28:Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 } +! { dg-warning "36:Mapping of polymorphic list item 'p' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 } +! { dg-warning "38:Mapping of polymorphic list item 'pa' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 } + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-2.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-2.f90 index e25db68..3bedc9b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-2.f90 @@ -9,7 +9,7 @@ allocate( t :: c, ca(5)) p => c pa => ca -!$omp target ! { dg-warning "Implicit mapping of polymorphic variable 'ca' is unspecified behavior \\\[-Wopenmp\\\]" } +!$omp target ! { dg-warning "Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" } ll = allocated(ca) !$omp end target diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-3.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-3.f90 new file mode 100644 index 0000000..9777ecf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-3.f90 @@ -0,0 +1,23 @@ +subroutine sub(var, var2) +type t + integer :: x +end type t + +type t2 + integer :: x + integer, allocatable :: y +end type + +class(t) var, var2 +type(t2) :: var3, var4 +!$omp target firstprivate(var) & ! { dg-error "Polymorphic list item 'var' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" } +!$omp& private(var2) ! { dg-error "Polymorphic list item 'var2' at .1. in PRIVATE clause has unspecified behavior and unsupported" } + var%x = 5 + var2%x = 5 +!$omp end target +!$omp target firstprivate(var3) & ! { dg-error "Sorry, list item 'var3' at .1. with allocatable components is not yet supported in FIRSTPRIVATE clause" } +!$omp& private(var4) ! { dg-error "Sorry, list item 'var4' at .1. with allocatable components is not yet supported in PRIVATE clause" } + var3%x = 5 + var4%x = 5 +!$omp end target +end diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-4.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-4.f90 new file mode 100644 index 0000000..5a1a70a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-4.f90 @@ -0,0 +1,9 @@ +subroutine one +implicit none +type t + class(*), allocatable :: ul +end type + +type(t) :: var +!$omp target enter data map(to:var) ! { dg-error "Mapping of unlimited polymorphic list item 'var.ul' is unspecified behavior and unsupported" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-5.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-5.f90 new file mode 100644 index 0000000..4b5814e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping-5.f90 @@ -0,0 +1,9 @@ +subroutine one +implicit none +type t + class(*), allocatable :: ul +end type + +class(*), allocatable :: ul_var +!$omp target enter data map(to: ul_var) ! { dg-error "Mapping of unlimited polymorphic list item 'ul_var' is unspecified behavior and unsupported" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping.f90 b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping.f90 index dd7eb31..752cca2 100644 --- a/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/polymorphic-mapping.f90 @@ -10,37 +10,21 @@ pa => ca ! 11111111112222222222333333333344 !2345678901234567890123456789012345678901 -!$omp target enter data map(c, ca, p, pa) -! { dg-warning "29:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } -! { dg-warning "32:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 } -! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 } -! { dg-warning "39:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 } - -! 11111111112222222222333333333344 -!2345678901234567890123456789012345678901 -!$omp target firstprivate(ca) ! { dg-warning "27:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" } +!$omp target firstprivate(ca) ! { dg-error "27:Polymorphic list item 'ca' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" } !$omp end target -!$omp target parallel do firstprivate(ca) ! { dg-warning "39:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" } +!$omp target parallel do firstprivate(ca) ! { dg-error "39:Polymorphic list item 'ca' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" } do x = 0, 5 end do -!$omp target parallel do private(ca) ! OK; should map declared type +!$omp target parallel do private(ca) ! { dg-error "34:Polymorphic list item 'ca' at .1. in PRIVATE clause has unspecified behavior and unsupported" } do x = 0, 5 end do -!$omp target private(ca) ! OK; should map declared type +!$omp target private(ca) ! { dg-error "22:Polymorphic list item 'ca' at .1. in PRIVATE clause has unspecified behavior and unsupported" } block end block -! 11111111112222222222333333333344 -!2345678901234567890123456789012345678901 -!$omp target update from(c,ca), to(p,pa) -! { dg-warning "26:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 } -! { dg-warning "28:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 } -! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 } -! { dg-warning "38:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 } - ! ------------------------- !$omp target parallel map(release: x) ! { dg-error "36:TARGET with map-type other than TO, FROM, TOFROM, or ALLOC on MAP clause" } 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/interface_59.f90 b/gcc/testsuite/gfortran.dg/interface_59.f90 new file mode 100644 index 0000000..c9ccd67 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_59.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/119669 - this used to generate an ICE. + +program a + implicit real(a-h,o-z) + external abstract_caller, caller, func +! real func + call abstract_caller (caller, func, 1.5) + call abstract_caller (caller, func, 1.5) +end program a + +function func (x) + real func, x + func = x * x - 1. +end diff --git a/gcc/testsuite/gfortran.dg/move_alloc_11.f90 b/gcc/testsuite/gfortran.dg/move_alloc_11.f90 new file mode 100644 index 0000000..d33e0ce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_11.f90 @@ -0,0 +1,23 @@ +!{ dg-do compile } + +! General error checking for move_alloc parameter list. + +integer, allocatable :: i, o +integer :: st, s2 +character(30) :: e, e2 + + call move_alloc(i, o, STAT=st) + call move_alloc(i, o, STAT=st, STAT=s2) !{ dg-error "Keyword 'stat' at \\(1\\) has already appeared in the current argument list" } + call move_alloc(i, o, STAT=e) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + call move_alloc(i, o, STAT=[st, s2]) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + call move_alloc(i, o, STAT=.TRUE.) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + + call move_alloc(i, o, STAT=st, ERRMSG=e) + call move_alloc(i, o, ERRMSG=e) + call move_alloc(i, o, ERRMSG=e, ERRMSG=e2) !{ dg-error "Keyword 'errmsg' at \\(1\\) has already appeared in the current argument list" } + call move_alloc(i, o, ERRMSG=st) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" } + call move_alloc(i, o, ERRMSG=.TRUE.) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" } + + +end + diff --git a/gcc/testsuite/gfortran.dg/num_images_1.f90 b/gcc/testsuite/gfortran.dg/num_images_1.f90 index dac34ba..e03857c 100644 --- a/gcc/testsuite/gfortran.dg/num_images_1.f90 +++ b/gcc/testsuite/gfortran.dg/num_images_1.f90 @@ -5,5 +5,5 @@ program foo implicit none integer k5 - k5 = num_images(failed=.false.) ! { dg-error "argument to NUM_IMAGES" } + k5 = num_images(failed=.false.) ! { dg-error "Cannot find keyword named 'failed' in call to 'num_images'" } end program foo 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/pr102458.f90 b/gcc/testsuite/gfortran.dg/pr102458.f90 index 555e497..7c13084 100644 --- a/gcc/testsuite/gfortran.dg/pr102458.f90 +++ b/gcc/testsuite/gfortran.dg/pr102458.f90 @@ -9,7 +9,7 @@ end program p block - integer :: a(get_team()) = 1 ! { dg-error "Automatic array" } + integer :: a(get_team()) = 1 ! { dg-error "Automatic array | ISO_FORTRAN_ENV | must be of INTEGER" } print *, a end block end diff --git a/gcc/testsuite/gfortran.dg/pr119502.f90 b/gcc/testsuite/gfortran.dg/pr119502.f90 new file mode 100644 index 0000000..80d7c61 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119502.f90 @@ -0,0 +1,15 @@ +! { dg-do run } + +! PR119502, negative unit numbers are not allowed without using NEWUNIT + +program foo + integer :: iun = -1 + integer :: ios + open (iun, iostat=ios) + if (ios == 0) stop 1 + write(iun,*, iostat=ios) "This is a test." + if (ios == 0) stop 2 + close (iun, iostat=ios) + if (ios == 0) stop 3 +end + diff --git a/gcc/testsuite/gfortran.dg/pr119836_1.f90 b/gcc/testsuite/gfortran.dg/pr119836_1.f90 new file mode 100644 index 0000000..984e2d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_1.f90 @@ -0,0 +1,18 @@ +! +! { dg-do run } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + do concurrent (i=1:n) + x(i) = shiftl (i,1) ! accepted + block + y(i) = shiftl (i,1) ! wrongly rejected + end block + end do + if (any(x /= y)) stop 1 +end program p diff --git a/gcc/testsuite/gfortran.dg/pr119836_2.f90 b/gcc/testsuite/gfortran.dg/pr119836_2.f90 new file mode 100644 index 0000000..5e2d0c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_2.f90 @@ -0,0 +1,21 @@ +! +! { dg-do compile } +! +! PR fortran/119836 +! +! Although intrinsic functions contained within the Fortran standard +! are pure procedures, many of the additional intrinsic functions +! supplied in libgfortran are impure. RAND() is one such function. +! +program foo + implicit none + integer i + real x(4) + do concurrent (i=1:4) + x = rand() ! { dg-error "Reference to impure function" } + block + x = rand() ! { dg-error "Reference to impure function" } + end block + end do + print *, x +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr119836_3.f90 b/gcc/testsuite/gfortran.dg/pr119836_3.f90 new file mode 100644 index 0000000..69a5fcf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_3.f90 @@ -0,0 +1,30 @@ +! +! { dg-do run } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + x = [(i,i=1,n)] + do concurrent (i=1:n) + call bar(x, y) + end do + if (any(x /= y)) stop 1 + x = 2 * x + do concurrent (i=1:n) + block + call bar(x, y) + end block + end do + if (any(x /= y)) stop 1 + + contains + elemental subroutine bar(x, y) + integer, intent(in) :: x + integer, intent(out) :: y + y = x + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/pr119836_4.f90 b/gcc/testsuite/gfortran.dg/pr119836_4.f90 new file mode 100644 index 0000000..dc6f72b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_4.f90 @@ -0,0 +1,30 @@ +! +! { dg-do compile } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + x = [(i,i=1,n)] + do concurrent (i=1:n) + call bar(x, y) ! { dg-error "Subroutine call" } + end do + if (any(x /= y)) stop 1 + x = 2 * x + do concurrent (i=1:n) + block + call bar(x, y) ! { dg-error "Subroutine call" } + end block + end do + if (any(x /= y)) stop 1 + + contains + subroutine bar(x, y) + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + y = x + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 b/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 new file mode 100644 index 0000000..92640e2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pure_formal_proc_4.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! PR fortran/106948 - check that passing of PURE procedures works +! +! Contributed by Jim Feng + +module a + implicit none + + interface new + pure module subroutine b(x, f) + integer, intent(inout) :: x + interface + pure function f(x) result(r) + real, intent(in) :: x + real :: r + end function f + end interface + end subroutine b + end interface new +end module a + +submodule(a) a_b + implicit none + +contains + module procedure b + x = int(f(real(x)) * 0.15) + end procedure b +end submodule a_b + +program test + use a + implicit none + + integer :: x + + x = 100 + call new(x, g) + print *, x + +contains + + pure function g(y) result(r) + real, intent(in) :: y + real :: r + + r = sqrt(y) + end function g +end program test 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 diff --git a/gcc/testsuite/gfortran.dg/team_change_2.f90 b/gcc/testsuite/gfortran.dg/team_change_2.f90 new file mode 100644 index 0000000..66fe63c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_change_2.f90 @@ -0,0 +1,93 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests change team syntax + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat + character(len=30) :: err + integer :: caf[*], caf2[*] + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team !{ dg-error "Syntax error in CHANGE TEAM statement" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (err) !{ dg-error "must be a scalar expression of type TEAM_TYPE" } + continue + end team + + change team (team, stat=err) !{ dg-error "must be a scalar INTEGER" } + continue + end team + + change team (team, stat=istat, stat=istat) !{ dg-error "Duplicate STAT" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" } + continue + end team + + change team (team, stat=istat, errmsg=str, errmsg=str) !{ dg-error "Duplicate ERRMSG" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + +1234 if (istat /= 0) stop 1 !{ dg-error "leaves CHANGE TEAM" } + + change team (team) + go to 1234 !{ dg-error "leaves CHANGE TEAM" } + end team + + call foo(team) + + ! F2018, C1113 + change team (team, caf[3,*] => caf) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, c[3,*] => caf, c => caf2) !{ dg-error "Duplicate name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, c[3,*] => caf, caf => caf2) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, caf2[3,*] => caf, c => caf2) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + ! F2018, C1114 + change team (team, c => [caf, caf2]) !{ dg-error "a named coarray" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + ! F2018, C1115 + change team (team, c => caf, c2 => caf) !{ dg-error "duplicates selector at" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + t: change team(team) + exit t + end team t + + change team(team) + exit t !{ dg-error "EXIT statement at \\(1\\) is not within construct 't'" } + end team +contains + subroutine foo(team) + type(team_type) :: team + + change team (team) + return !{ dg-error "Image control statement" } + end team + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/team_change_3.f90 b/gcc/testsuite/gfortran.dg/team_change_3.f90 new file mode 100644 index 0000000..bc30c40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_change_3.f90 @@ -0,0 +1,29 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests change team stat= and errmsg= specifiers + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat = 42 + character(len=30) :: err = 'unchanged' + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team, stat=istat) + if (istat /= 0) stop 1 + end team + + change team (team, stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + end team + +end + +! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_end_2.f90 b/gcc/testsuite/gfortran.dg/team_end_2.f90 new file mode 100644 index 0000000..c27b59d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_end_2.f90 @@ -0,0 +1,42 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests change team syntax + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat + character(len=30) :: err + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team) + continue + end team (stat=err) ! { dg-error "must be a scalar INTEGER" } + + change team (team) + continue + end team (stat=istat, stat=istat) ! { dg-error "Duplicate STAT" } + + change team (team) + continue + end team (stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + + change team (team) + continue + end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" } + + t: change team (team) + continue + end team (stat=istat) t ! ok + + t2: change team (team) + continue + end team ! { dg-error "Expected block name of 't2' in END TEAM" } + end team t2 ! close the team correctly to catch other errors +end + diff --git a/gcc/testsuite/gfortran.dg/team_end_3.f90 b/gcc/testsuite/gfortran.dg/team_end_3.f90 new file mode 100644 index 0000000..9cd7d4c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_end_3.f90 @@ -0,0 +1,41 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests end team stat= and errmsg= specifiers + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat = 42 + character(len=30) :: err = 'unchanged' + integer, allocatable :: sample(:)[:] + integer, allocatable :: scal_caf[:] + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team) + allocate(sample(5)[*], scal_caf[*]) + if (.NOT. allocated(sample)) stop 1 + if (.NOT. allocated(scal_caf)) stop 2 + end team (stat=istat) + if (istat /= 0) stop 3 + if (allocated(sample)) stop 4 + if (allocated(scal_caf)) stop 5 + + deallocate(sample, stat=istat) + if (istat == 0) stop 6 + + istat = 42 + t: change team (team) + continue + end team (stat=istat, errmsg=err) t + if (istat /= 0) stop 7 + if (trim(err) /= 'unchanged') stop 8 +end + +! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_form_2.f90 b/gcc/testsuite/gfortran.dg/team_form_2.f90 new file mode 100644 index 0000000..5c6d81f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_form_2.f90 @@ -0,0 +1,27 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests form team syntax errors + + use iso_fortran_env, only : team_type + implicit none + integer :: istat, new_team + character(len=30) :: err + type(team_type) :: team + + new_team = mod(this_image(),2)+1 + + form team ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team) ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team,err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" } + form team (new_team,team,istat) ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team,team,stat=istat,stat=istat) ! { dg-error "Duplicate STAT" } + form team (new_team,team,stat=istat,errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + form team (new_team,team,stat=istat,errmsg=err,errmsg=err) ! { dg-error "Duplicate ERRMSG" } + form team (new_team,team,new_index=1,new_index=1) ! { dg-error "Duplicate NEW_INDEX" } + form team (new_team,team,new_index=err) ! { dg-error "must be a scalar INTEGER" } + form team (new_team,team,new_index=1,new_index=1,stat=istat,errmsg=err) ! { dg-error "Duplicate NEW_INDEX" } + form team (new_team,team,new_index=1,stat=istat,errmsg=err,new_index=9) ! { dg-error "Duplicate NEW_INDEX" } + +end diff --git a/gcc/testsuite/gfortran.dg/team_form_3.f90 b/gcc/testsuite/gfortran.dg/team_form_3.f90 new file mode 100644 index 0000000..d9aae33 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_form_3.f90 @@ -0,0 +1,34 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests form team with stat= and errmsg= + + use iso_fortran_env, only : team_type + implicit none + integer :: istat = 42, new_team + character(len=30) :: err = "unchanged" + type(team_type) :: team + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + form team (new_team,team,stat=istat) + if (istat /= 0) stop 1 + form team (new_team,team,stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + form team (new_team,team,new_index=1) + istat = 42 + form team (new_team,team,new_index=1,stat=istat) + if (istat /= 0) stop 3 + form team (new_team,team,new_index=1,stat=istat,errmsg=err) + if (trim(err) /= 'unchanged') stop 4 +end + +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, &err, 30\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_get_1.f90 b/gcc/testsuite/gfortran.dg/team_get_1.f90 new file mode 100644 index 0000000..fe00ce8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_get_1.f90 @@ -0,0 +1,27 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original" } + +! PR 87939 +! Tests get_team + + use iso_fortran_env + implicit none + type(team_type) :: team, ret + integer :: new_team, level + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + ret = get_team() + ret = get_team(INITIAL_TEAM) + ret = get_team(PARENT_TEAM) + ret = get_team(CURRENT_TEAM) + level = INITIAL_TEAM + ret = get_team(level) + +end + +! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(0B\\)" "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_team \\(&C\.\[0-9\]+\\)" 3 "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(&level\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_number_1.f90 b/gcc/testsuite/gfortran.dg/team_number_1.f90 index e44e17b..f0ee7d1 100644 --- a/gcc/testsuite/gfortran.dg/team_number_1.f90 +++ b/gcc/testsuite/gfortran.dg/team_number_1.f90 @@ -1,13 +1,13 @@ ! { dg-do run } ! { dg-options "-fcoarray=single" } ! -! Tests if team_number intrinsic fucntion works +! Tests if team_number intrinsic function works ! use iso_fortran_env, only : team_type implicit none - type(team_type) team + type(team_type) :: team integer, parameter :: standard_initial_value=-1 - integer new_team + integer :: new_team if (team_number()/=standard_initial_value) STOP 1 diff --git a/gcc/testsuite/gfortran.dg/team_sync_1.f90 b/gcc/testsuite/gfortran.dg/team_sync_1.f90 new file mode 100644 index 0000000..5b28651 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_sync_1.f90 @@ -0,0 +1,24 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Test sync team syntax errors + + use iso_fortran_env, only : team_type + implicit none + integer :: istat + character(len=30) :: err + type(team_type) :: team + + form team (mod(this_image(),2)+1, team) + + change team (team) + sync team ! { dg-error "Syntax error in SYNC TEAM statement" } + sync team (err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" } + sync team (team, istat) ! { dg-error "Syntax error in SYNC TEAM statement" } + sync team (team, stat=err) ! { dg-error "must be a scalar INTEGER" } + sync team (team, stat=istat, stat=istat) ! { dg-error "Duplicate STAT" } + sync team (team, stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + sync team (team, stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" } + end team +end diff --git a/gcc/testsuite/gfortran.dg/team_sync_2.f90 b/gcc/testsuite/gfortran.dg/team_sync_2.f90 new file mode 100644 index 0000000..947f65d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_sync_2.f90 @@ -0,0 +1,27 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Test sync team statement +! + use iso_fortran_env, only : team_type + implicit none + integer :: istat = 42 + type(team_type) :: team + character(len=30) :: err = "unchanged" + + form team (mod(this_image(),2)+1, team) + + change team (team) + sync team (team) + sync team (team, stat=istat) + if (istat /= 0) stop 1 + sync team (team, stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + end team +end + +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, &err, 30\\)" "original" } } |