diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
136 files changed, 5112 insertions, 281 deletions
diff --git a/gcc/testsuite/gfortran.dg/actual_array_subref.f90 b/gcc/testsuite/gfortran.dg/actual_array_subref.f90 new file mode 100644 index 0000000..932d7ab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_array_subref.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! { dg-additional-options "-O2 -fcheck=bounds" } +! +! PR fortran/119986 +! +! Check passing of inquiry references of complex arrays and substring +! references of character arrays when these are components of derived types. +! +! Extended version of report by Neil Carlson. + +program main + implicit none + integer :: j + + complex, parameter :: z0(*) = [(cmplx(j,-j),j=1,4)] + type :: cx + real :: re + real :: im + end type cx + type(cx), parameter :: c0(*) = [(cx (j,-j),j=1,4)] + + type :: my_type + complex :: z(4) = z0 + type(cx) :: c(4) = c0 + end type my_type + type(my_type) :: x + + character(*), parameter :: s0(*) = ["abcd","efgh","ijkl","mnop"] + character(*), parameter :: expect(*) = s0(:)(2:3) + character(len(s0)) :: s1(4) = s0 + + type :: str1 + character(len(s0)) :: s(4) = s0 + end type str1 + type(str1) :: string1 + + type :: str2 + character(:), allocatable :: s(:) + end type str2 + type(str2) :: string2 + + integer :: stopcode = 0 + + if (len(expect) /= 2) stop 1 + if (expect(4) /= "no") stop 2 + if (any(c0 %re /= [ 1, 2, 3, 4])) stop 3 + if (any(c0 %im /= [-1,-2,-3,-4])) stop 4 + + stopcode = 10 + call fubar ( x%z %re, x%z %im) + call fubar ( x%c %re, x%c %im) + + stopcode = 20 + call fubar ((x%z %re), (x%z %im)) + call fubar ((x%c %re), (x%c %im)) + + stopcode = 30 + call fubar ([x%z %re], [x%z %im]) + call fubar ([x%c %re], [x%c %im]) + + stopcode = 50 + call chk ( s0(:)(2:3) ) + call chk ((s0(:)(2:3))) + call chk ([s0(:)(2:3)]) + + stopcode = 60 + call chk ( s1(:)(2:3) ) + call chk ((s1(:)(2:3))) + call chk ([s1(:)(2:3)]) + + stopcode = 70 + call chk ( string1%s(:)(2:3) ) + call chk ((string1%s(:)(2:3))) + call chk ([string1%s(:)(2:3)]) + + string2% s = s0 + if (len(string2%s) /= 4) stop 99 + stopcode = 80 + call chk ( string2%s(:)(2:3) ) + call chk ((string2%s(:)(2:3))) + call chk ([string2%s(:)(2:3)]) + deallocate (string2% s) + +contains + + subroutine fubar(u, v) + real, intent(in) :: u(:), v(:) + if (any (u /= z0%re)) stop stopcode + 1 + if (any (v /= z0%im)) stop stopcode + 2 + if (any (u /= c0%re)) stop stopcode + 3 + if (any (v /= c0%im)) stop stopcode + 4 + stopcode = stopcode + 4 + end subroutine + + subroutine chk (s) + character(*), intent(in) :: s(:) + if (size(s) /= 4) stop stopcode + 1 + if (len (s) /= 2) stop stopcode + 2 + if (any (s /= expect)) stop stopcode + 3 + stopcode = stopcode + 3 + end subroutine chk + +end program diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 index 2af089e..d0751f3 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 @@ -25,6 +25,6 @@ contains allocate (array(1)%bigarr) end function end -! { dg-final { scan-tree-dump-times "builtin_malloc" 3 "original" } } +! { dg-final { scan-tree-dump-times "builtin_malloc" 4 "original" } } ! { dg-final { scan-tree-dump-times "builtin_free" 3 "original" } } -! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "while \\(1\\)" 5 "original" } } diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 index 0753e33..8202d78 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 @@ -45,11 +45,10 @@ contains type(c), value :: d end subroutine - type(c) function c_init() ! { dg-warning "not set" } + type(c) function c_init() end function subroutine sub(d) type(u), value :: d end subroutine end program test_pr58586 - diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 index 4a55d73..9ff38e3 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 @@ -51,14 +51,14 @@ contains type(t), value :: d end subroutine - type(c) function c_init() ! { dg-warning "not set" } + type(c) function c_init() end function class(c) function c_init2() ! { dg-warning "not set" } allocatable :: c_init2 end function - type(c) function d_init(this) ! { dg-warning "not set" } + type(c) function d_init(this) class(d) :: this end function @@ -102,4 +102,3 @@ program test_pr58586 call add_c(oe%init()) deallocate(oe) end program - diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90 new file mode 100644 index 0000000..f5e2fc9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-additional-options "-Wsurprising" } +! +! PR fortran/51961 - fix checking of MOLD= in ALLOCATE statements +! +! Contributed by Tobias Burnus + +program p + implicit none + type t + end type t + type u + class(t), allocatable :: a(:), b(:,:), c + end type u + class(T), allocatable :: a(:), b(:,:), c + type(u) :: z + + allocate (b(2,2)) + allocate (z% b(2,2)) + + allocate (a(2), mold=b(:,1)) + allocate (a(1:2), mold=b(1,:)) + allocate (a(2), mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (a(1:2), mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (z% a(2), mold=b(:,1)) + allocate (z% a(1:2), mold=b(1,:)) + allocate (z% a(2), mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (z% a(1:2), mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (z% a(2), mold=z% b(:,1)) + allocate (z% a(1:2), mold=z% b(1,:)) + allocate (z% a(2), mold=z% b) ! { dg-warning "but MOLD= expression at" } + allocate (z% a(1:2), mold=z% b) ! { dg-warning "but MOLD= expression at" } + + allocate (c, mold=b(1,1)) + allocate (c, mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (z% c, mold=b(1,1)) + allocate (z% c, mold=b) ! { dg-warning "but MOLD= expression at" } + allocate (z% c, mold=z% b(1,1)) + allocate (z% c, mold=z% b) ! { dg-warning "but MOLD= expression at" } + + allocate (a, mold=b(:,1)) + allocate (a, mold=b(1,:)) + allocate (z% a, mold=b(:,1)) + allocate (z% a, mold=b(1,:)) + allocate (z% a, mold=z% b(:,1)) + allocate (z% a, mold=z% b(1,:)) + + allocate (a, mold=b) ! { dg-error "or have the same rank" } + allocate (z% a, mold=b) ! { dg-error "or have the same rank" } + allocate (z% a, mold=z% b) ! { dg-error "or have the same rank" } +end diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 index fd2db74..36c1245 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 @@ -210,5 +210,5 @@ program main call v%free() deallocate(av) end program -! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } } diff --git a/gcc/testsuite/gfortran.dg/asan/array_constructor_1.f90 b/gcc/testsuite/gfortran.dg/asan/array_constructor_1.f90 new file mode 100644 index 0000000..a0c5507 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/array_constructor_1.f90 @@ -0,0 +1,25 @@ +!{ dg-do run } + +! Contributed by Christopher Albert <albert@tugraz.at> + +program grow_type_array + type :: container + integer, allocatable :: arr(:) + end type container + + type(container), allocatable :: list(:) + + allocate(list(0)) + + list = [list, new_elem(5)] + + deallocate(list) + +contains + + type(container) function new_elem(s) result(out) + integer :: s + allocate(out%arr(s)) + end function new_elem + +end program grow_type_array diff --git a/gcc/testsuite/gfortran.dg/asan/finalize_1.f90 b/gcc/testsuite/gfortran.dg/asan/finalize_1.f90 new file mode 100644 index 0000000..ab53a9e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/finalize_1.f90 @@ -0,0 +1,67 @@ +!{ dg-do run } + +! PR fortran/120637 + +! Contributed by Antony Lewis <antony@cosmologist.info> +! The unused module is needed to trigger the issue of not freeing the +! memory of second module. + + module MiscUtils + implicit none + + contains + + logical function isFloat0(R) + class(*), intent(in) :: R + + select type(R) + type is (real) + isFloat0 = .true. + end select + end function isFloat0 + + end module MiscUtils + + module results3 + implicit none + public + + Type ClTransferData2 + real, dimension(:,:,:), allocatable :: Delta_p_l_k + end type ClTransferData2 + + type TCLdata2 + Type(ClTransferData2) :: CTransScal, CTransTens, CTransVec + end type TCLdata2 + + type :: CAMBdata2 + Type(TClData2) :: CLdata2 + end type + + end module results3 + +program driver + use results3 + integer i + do i=1, 2 + call test() + end do + + contains + + subroutine test + implicit none + class(CAMBdata2), pointer :: Data + + allocate(CAMBdata2::Data) + + allocate(Data%ClData2%CTransScal%Delta_p_l_k(3, 1000, 1000)) + allocate(Data%ClData2%CTransVec%Delta_p_l_k(3, 1000, 1000)) + deallocate(Data) + + end subroutine test + + end program driver + +!{ dg-final { cleanup-modules "miscutils results3" } } + diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 index 23ca88b..bc2206d 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 @@ -38,6 +38,6 @@ contains type(my_c_ptr_0) :: my_ptr2 type(c_funptr) :: myfun print *,c_associated(my_ptr,my_ptr2) - print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of TYPE.c_funptr." } + print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1, found TYPE.c_funptr. instead of TYPE.c_ptr." } end subroutine end 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/coindexed_6.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_6.f90 new file mode 100644 index 0000000..d566c504 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_6.f90 @@ -0,0 +1,24 @@ +!{ dg-do compile } + +! Check PR120843 is fixed + +program p + implicit none + + type T + integer, allocatable :: arr(:,:) [:,:] + end type + + type(T) :: o + integer, allocatable :: vec(:)[:,:] + integer :: c[*] + + c = 7 + + allocate(o%arr(4,3)[2,*], source=6) + allocate(vec(10)[1,*], source=7) + + if (vec(3) * c /= 49) stop 1 + if (o%arr(2,2)* c /= 42) stop 2 + +end program p diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_7.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_7.f90 new file mode 100644 index 0000000..0663970 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_7.f90 @@ -0,0 +1,24 @@ +!{ dg-do compile } + +! Check PR120847 is fixed. + +program p + implicit none + + type T + integer, allocatable :: i(:, :) [:] + end type T + + type(T) :: o + integer, allocatable :: c[:] + integer :: i + + c = 7 + + allocate(o%i(4, 5)[*], source=6) + + do i = 1, 4 + c = o%i(mod(i, 2), mod(i, 3))[1] + end do + +end program p 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_data_2.f90 b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 new file mode 100644 index 0000000..bda57f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=lib -Warray-temporaries" } +! +! PR fortran/99838 - ICE due to missing locus with data statement for coarray +! +! Contributed by Gerhard Steinmetz + +program p + type t + integer :: a + end type + type(t) :: x(3)[*] + data x%a /1, 2, 3/ ! { dg-warning "Creating array temporary" } +end 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/comma_format_extension_1.f b/gcc/testsuite/gfortran.dg/comma_format_extension_1.f index a3a5a98..c4b43f0 100644 --- a/gcc/testsuite/gfortran.dg/comma_format_extension_1.f +++ b/gcc/testsuite/gfortran.dg/comma_format_extension_1.f @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "" } +! { dg-options "-std=legacy" } ! test that the extension for a missing comma is accepted subroutine mysub diff --git a/gcc/testsuite/gfortran.dg/comma_format_extension_3.f b/gcc/testsuite/gfortran.dg/comma_format_extension_3.f index 0b00224..9d974d6 100644 --- a/gcc/testsuite/gfortran.dg/comma_format_extension_3.f +++ b/gcc/testsuite/gfortran.dg/comma_format_extension_3.f @@ -3,7 +3,7 @@ ! did do the correct thing at runtime. ! Note the missing , before i1 in the format. ! { dg-do run } -! { dg-options "" } +! { dg-options "-std=legacy" } character*12 c write (c,100) 0, 1 diff --git a/gcc/testsuite/gfortran.dg/continuation_13.f90 b/gcc/testsuite/gfortran.dg/continuation_13.f90 index 9799b59e..475c896 100644 --- a/gcc/testsuite/gfortran.dg/continuation_13.f90 +++ b/gcc/testsuite/gfortran.dg/continuation_13.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-options "-std=gnu" } +! { dg-options "-std=legacy" } ! PR64506 character(25) :: astring diff --git a/gcc/testsuite/gfortran.dg/dec_math.f90 b/gcc/testsuite/gfortran.dg/dec_math.f90 index 393e7de..79c1807 100644 --- a/gcc/testsuite/gfortran.dg/dec_math.f90 +++ b/gcc/testsuite/gfortran.dg/dec_math.f90 @@ -5,6 +5,12 @@ ! Test extra math intrinsics formerly offered by -fdec-math, ! now included with -std=gnu or -std=legacy. ! +! Since Fortran 2023, the degree trigonometric functions (sind, cosd, ...) +! are part of the standard; additionally, Fortran 2023 added a two-argument +! version of atand as alias for atan2d. +! +! Note that cotan and cotand are not part of Fortran 2023; hence, this file +! still requires -std=gnu and cannot be compiled with -std=f2023. module dec_math @@ -522,6 +528,69 @@ call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qatand") #endif ! Input +f_i1 = 1.0_4 +f_i2 = 2.0_4 +d_i1 = 1.0_8 +d_i2 = 2.0_8 +#ifdef __GFC_REAL_10__ +l_i1 = 1.0_10 +l_i2 = 2.0_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 1.0_16 +q_i2 = 2.0_16 +#endif + +! Expected +f_oe = r2d_f * atan2 (f_i1, f_i2) +f_oxe = r2d_f * atan2 (xf * f_i1, f_i2) +d_oe = r2d_d * atan2 (d_i1, d_i2) +d_oxe = r2d_d * atan2 (xd * d_i1, d_i2) +#ifdef __GFC_REAL_10__ +l_oe = r2d_l * atan2 (l_i1, l_i2) +l_oxe = r2d_l * atan2 (xl * l_i1, l_i2) +#endif +#ifdef __GFC_REAL_16__ +q_oe = r2d_q * atan2 (q_i1, q_i2) +q_oxe = r2d_q * atan2 (xq * q_i1, q_i2) +#endif + +! Actual +f_oa = atand (f_i1, f_i2) +f_oc = atand (1.0_4, 2.0_4) +f_ox = atand (xf * f_i1, f_i2) +d_oa = atand (d_i1, d_i2) +d_oc = atand (1.0_8, 2.0_8) +d_ox = atand (xd * d_i1, d_i2) +#ifdef __GFC_REAL_10__ +l_oa = atand (l_i1, l_i2) +l_oc = atand (1.0_10, 2.0_10) +l_ox = atand (xl * l_i1, l_i2) +#endif +#ifdef __GFC_REAL_16__ +q_oa = atand (q_i1, q_i2) +q_oc = atand (1.0_16, 2.0_16) +q_ox = atand (xq * q_i1, q_i2) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fatand") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fatand") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fatand") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) datand") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) datand") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) atand") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) latand") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) latand") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) latand") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qatand") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qatand") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qatand") +#endif + +! Input f_i1 = 34.3775_4 d_i1 = 34.3774677078494_8 #ifdef __GFC_REAL_10__ diff --git a/gcc/testsuite/gfortran.dg/dec_math_3.f90 b/gcc/testsuite/gfortran.dg/dec_math_3.f90 index 5bf4398..d2f57e2 100644 --- a/gcc/testsuite/gfortran.dg/dec_math_3.f90 +++ b/gcc/testsuite/gfortran.dg/dec_math_3.f90 @@ -1,8 +1,17 @@ ! { dg-options "-std=gnu" } ! { dg-do compile } -! Former ICE when simplifying asind, plus wrong function name in error message -real, parameter :: d = asind(1.1) ! { dg-error "Argument of ASIND at.*must be between -1 and 1" } -print *, d +real, parameter :: dacos = acosd(1.1) ! { dg-error "Argument of ACOSD at .1. must be within the closed interval \\\[-1, 1\\\]" } +print *, dacos +real, parameter :: dasin = asind(-1.1) ! { dg-error "Argument of ASIND at .1. must be within the closed interval \\\[-1, 1\\\]" } +print *, dasin +real, parameter :: datan2 = atan2d(0.0, 0.0) ! { dg-error "If the first argument of ATAN2D at .1. is zero, then the second argument must not be zero" } +print *, datan2 +real, parameter :: piacos = acospi(-1.1) ! { dg-error "Argument of ACOSPI at .1. must be within the closed interval \\\[-1, 1\\\]" } +print *, piacos +real, parameter :: piasin = asinpi(1.1) ! { dg-error "Argument of ASINPI at .1. must be within the closed interval \\\[-1, 1\\\]" } +print *, piasin +real, parameter :: piatan2 = atan2pi(0.0, 0.0) ! { dg-error "If the first argument of ATAN2PI at .1. is zero, then the second argument must not be zero" } +print *, piatan2 end diff --git a/gcc/testsuite/gfortran.dg/dec_math_5.f90 b/gcc/testsuite/gfortran.dg/dec_math_5.f90 index dee2de4..a7ff327 100644 --- a/gcc/testsuite/gfortran.dg/dec_math_5.f90 +++ b/gcc/testsuite/gfortran.dg/dec_math_5.f90 @@ -101,4 +101,67 @@ program p if (abs(b1 - 0.5) > e2) stop 38 if (abs(c1 - 0.5) > e3) stop 39 if (abs(d1 - 0.5) > e4) stop 40 + + a1 = acospi(0.5) + b1 = acospi(-0.5) + c1 = acospi(0.5) + d1 = acospi(-0.5) + if (abs(a1 - 1.0 / 3) > e1) stop 41 + if (abs(b1 - 2.0 / 3) > e2) stop 42 + if (abs(c1 - 1.0 / 3) > e3) stop 43 + if (abs(d1 - 2.0 / 3) > e4) stop 44 + + a1 = asinpi(0.5) + b1 = asinpi(-0.5) + c1 = asinpi(0.5) + d1 = asinpi(-0.5) + if (abs(a1 - 1.0 / 6) > e1) stop 45 + if (abs(b1 + 1.0 / 6) > e2) stop 46 + if (abs(c1 - 1.0 / 6) > e3) stop 47 + if (abs(d1 + 1.0 / 6) > e4) stop 48 + + a1 = atanpi(1.0) + b1 = atanpi(-1.0) + c1 = atanpi(1.0) + d1 = atanpi(-1.0) + if (abs(a1 - 0.25) > e1) stop 49 + if (abs(b1 + 0.25) > e2) stop 50 + if (abs(c1 - 0.25) > e3) stop 51 + if (abs(d1 + 0.25) > e4) stop 52 + + a1 = atan2pi(1.0, 1.0) + b1 = atan2pi(1.0, 1.0) + c1 = atan2pi(1.0, 1.0) + d1 = atan2pi(1.0, 1.0) + if (abs(a1 - 0.25) > e1) stop 53 + if (abs(b1 - 0.25) > e2) stop 54 + if (abs(c1 - 0.25) > e3) stop 55 + if (abs(d1 - 0.25) > e4) stop 56 + + a1 = cospi(1._4 / 3) + b1 = cospi(-1._8 / 3) + c1 = cospi(4._ep / 3) + d1 = cospi(-4._16 / 3) + if (abs(a1 - 0.5) > e1) stop 57 + if (abs(b1 - 0.5) > e2) stop 58 + if (abs(c1 + 0.5) > e3) stop 59 + if (abs(d1 + 0.5) > e4) stop 60 + + a1 = sinpi(1._4 / 6) + b1 = sinpi(-1._8 / 6) + c1 = sinpi(5._ep / 6) + d1 = sinpi(-7._16 / 6) + if (abs(a1 - 0.5) > e1) stop 61 + if (abs(b1 + 0.5) > e2) stop 62 + if (abs(c1 - 0.5) > e3) stop 63 + if (abs(d1 - 0.5) > e4) stop 64 + + a1 = tanpi(0.25) + b1 = tanpi(-0.25) + c1 = tanpi(1.25) + d1 = tanpi(-1.25) + if (abs(a1 - 1.0) > e1) stop 65 + if (abs(b1 + 1.0) > e2) stop 66 + if (abs(c1 - 1.0) > e3) stop 67 + if (abs(d1 + 1.0) > e4) stop 68 end program p diff --git a/gcc/testsuite/gfortran.dg/dec_math_6.f90 b/gcc/testsuite/gfortran.dg/dec_math_6.f90 new file mode 100644 index 0000000..dfb8b06 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dec_math_6.f90 @@ -0,0 +1,12 @@ +! { dg-options "-std=f2018" } +! { dg-do compile } + +intrinsic :: acospi ! { dg-error "The intrinsic 'acospi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: asinpi ! { dg-error "The intrinsic 'asinpi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: atanpi ! { dg-error "The intrinsic 'atanpi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: atan2pi ! { dg-error "The intrinsic 'atan2pi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: cospi ! { dg-error "The intrinsic 'cospi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: sinpi ! { dg-error "The intrinsic 'sinpi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } +intrinsic :: tanpi ! { dg-error "The intrinsic 'tanpi' declared INTRINSIC at .1. is not available in the current standard settings but new in Fortran 2023. Use an appropriate '-std=\\*' option or enable '-fall-intrinsics' in order to use it" } + +end diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 index bdfa47b..406e031 100644 --- a/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 +++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 @@ -129,5 +129,5 @@ contains prt_spec = name end function new_prt_spec3 end program main -! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 16 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } } diff --git a/gcc/testsuite/gfortran.dg/derived_result_5.f90 b/gcc/testsuite/gfortran.dg/derived_result_5.f90 new file mode 100644 index 0000000..1ba4d19 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/derived_result_5.f90 @@ -0,0 +1,123 @@ +! { dg-do run } +! { dg-additional-options "-O2 -Wreturn-type" } +! +! PR fortran/85750 - default-initialization and functions returning derived type + +module bar + implicit none + type ilist + integer :: count = 42 + integer, pointer :: ptr(:) => null() + end type ilist + + type jlist + real, allocatable :: a(:) + integer :: count = 23 + end type jlist + +contains + + function make_list(i) + integer, intent(in) :: i + type(ilist), dimension(2) :: make_list + make_list(i)%count = i + end function make_list + + function make_list_res(i) result(list) + integer, intent(in) :: i + type(ilist), dimension(2) :: list + list(i)%count = i + end function make_list_res + + function make_jlist(i) + integer, intent(in) :: i + type(jlist), dimension(2) :: make_jlist + make_jlist(i)%count = i + end function make_jlist + + function make_jlist_res(i) result(list) + integer, intent(in) :: i + type(jlist), dimension(2) :: list + list(i)%count = i + end function make_jlist_res + + function empty_ilist() + type(ilist), dimension(2) :: empty_ilist + end function + + function empty_jlist() + type(jlist), dimension(2) :: empty_jlist + end function + + function empty_ilist_res() result (res) + type(ilist), dimension(2) :: res + end function + + function empty_jlist_res() result (res) + type(jlist), dimension(2) :: res + end function + +end module bar + +program foo + use bar + implicit none + type(ilist) :: mylist(2) = ilist(count=-2) + type(jlist), allocatable :: yourlist(:) + + mylist = ilist(count=-1) + if (any (mylist%count /= [-1,-1])) stop 1 + mylist = empty_ilist() + if (any (mylist%count /= [42,42])) stop 2 + mylist = ilist(count=-1) + mylist = empty_ilist_res() + if (any (mylist%count /= [42,42])) stop 3 + + allocate(yourlist(1:2)) + if (any (yourlist%count /= [23,23])) stop 4 + yourlist = jlist(count=-1) + if (any (yourlist%count /= [-1,-1])) stop 5 + yourlist = empty_jlist() + if (any (yourlist%count /= [23,23])) stop 6 + yourlist = jlist(count=-1) + yourlist = empty_jlist_res() + if (any (yourlist%count /= [23,23])) stop 7 + + mylist = make_list(1) + if (any (mylist%count /= [1,42])) stop 11 + mylist = make_list(2) + if (any (mylist%count /= [42,2])) stop 12 + mylist = (make_list(1)) + if (any (mylist%count /= [1,42])) stop 13 + mylist = [make_list(2)] + if (any (mylist%count /= [42,2])) stop 14 + + mylist = make_list_res(1) + if (any (mylist%count /= [1,42])) stop 21 + mylist = make_list_res(2) + if (any (mylist%count /= [42,2])) stop 22 + mylist = (make_list_res(1)) + if (any (mylist%count /= [1,42])) stop 23 + mylist = [make_list_res(2)] + if (any (mylist%count /= [42,2])) stop 24 + + yourlist = make_jlist(1) + if (any (yourlist%count /= [1,23])) stop 31 + yourlist = make_jlist(2) + if (any (yourlist%count /= [23,2])) stop 32 + yourlist = (make_jlist(1)) + if (any (yourlist%count /= [1,23])) stop 33 + yourlist = [make_jlist(2)] + if (any (yourlist%count /= [23,2])) stop 34 + + yourlist = make_jlist_res(1) + if (any (yourlist%count /= [1,23])) stop 41 + yourlist = make_jlist_res(2) + if (any (yourlist%count /= [23,2])) stop 42 + yourlist = (make_jlist_res(1)) + if (any (yourlist%count /= [1,23])) stop 43 + yourlist = [make_jlist_res(2)] + if (any (yourlist%count /= [23,2])) stop 44 + + deallocate (yourlist) +end program foo diff --git a/gcc/testsuite/gfortran.dg/diagnostic-format-json-1.F90 b/gcc/testsuite/gfortran.dg/diagnostic-format-json-1.F90 deleted file mode 100644 index b8cd61c..0000000 --- a/gcc/testsuite/gfortran.dg/diagnostic-format-json-1.F90 +++ /dev/null @@ -1,24 +0,0 @@ -! { dg-do compile } -! { dg-options "-fdiagnostics-format=json" } - -#error message - -#if 0 -{ dg-begin-multiline-output "" } -[{"kind": "error", - "message": "#error message", - "children": [], - "column-origin": 1, - "locations": [{"caret": {"file": - "line": 4, - "display-column": 2, - "byte-column": 2, - "column": 2}, - "finish": {"file": - "line": 4, - "display-column": 6, - "byte-column": 6, - "column": 6}}], - "escape-source": false}] -{ dg-end-multiline-output "" } -#endif diff --git a/gcc/testsuite/gfortran.dg/diagnostic-format-json-2.F90 b/gcc/testsuite/gfortran.dg/diagnostic-format-json-2.F90 deleted file mode 100644 index 9ff1ef5..0000000 --- a/gcc/testsuite/gfortran.dg/diagnostic-format-json-2.F90 +++ /dev/null @@ -1,26 +0,0 @@ -! { dg-do compile } -! { dg-options "-fdiagnostics-format=json" } - -#warning message - -#if 0 -{ dg-begin-multiline-output "" } -[{"kind": "warning", - "message": "#warning message", - "option": "-Wcpp", - "option_url": - "children": [], - "column-origin": 1, - "locations": [{"caret": {"file": - "line": 4, - "display-column": 2, - "byte-column": 2, - "column": 2}, - "finish": {"file": - "line": 4, - "display-column": 8, - "byte-column": 8, - "column": 8}}], - "escape-source": false}] -{ dg-end-multiline-output "" } -#endif diff --git a/gcc/testsuite/gfortran.dg/diagnostic-format-json-3.F90 b/gcc/testsuite/gfortran.dg/diagnostic-format-json-3.F90 deleted file mode 100644 index 750e186..0000000 --- a/gcc/testsuite/gfortran.dg/diagnostic-format-json-3.F90 +++ /dev/null @@ -1,26 +0,0 @@ -! { dg-do compile } -! { dg-options "-fdiagnostics-format=json -Werror" } - -#warning message - -#if 0 -{ dg-begin-multiline-output "" } -[{"kind": "error", - "message": "#warning message", - "option": "-Werror=cpp", - "option_url": - "children": [], - "column-origin": 1, - "locations": [{"caret": {"file": - "line": 4, - "display-column": 2, - "byte-column": 2, - "column": 2}, - "finish": {"file": - "line": 4, - "display-column": 8, - "byte-column": 8, - "column": 8}}], - "escape-source": false}] -{ dg-end-multiline-output "" } -#endif diff --git a/gcc/testsuite/gfortran.dg/diagnostic-format-json-pr105916.F90 b/gcc/testsuite/gfortran.dg/diagnostic-format-json-pr105916.F90 deleted file mode 100644 index bf22a86..0000000 --- a/gcc/testsuite/gfortran.dg/diagnostic-format-json-pr105916.F90 +++ /dev/null @@ -1,14 +0,0 @@ -! { dg-do compile } -! { dg-options "-fdiagnostics-format=json-stderr -fmax-errors=1 -Wfatal-errors" } - -program main - implicit none - print*, "Hello World!" -end program main - -! We expect an empty array as the JSON output. -#if 0 -{ dg-begin-multiline-output "" } -[] -{ dg-end-multiline-output "" } -#endif 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_basic.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 index fe8723d..bdb6e0e 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_basic.f90 @@ -1,4 +1,4 @@ -! { dg-do run } +! { dg-do compile } program basic_do_concurrent implicit none integer :: i, arr(10) @@ -7,5 +7,8 @@ program basic_do_concurrent arr(i) = i end do + do concurrent (i=1:10);enddo + do,concurrent (i=1:10);arr(i)=i;enddo + print *, arr -end program basic_do_concurrent
\ No newline at end of file +end program basic_do_concurrent 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/g77/980310-3.f b/gcc/testsuite/gfortran.dg/g77/980310-3.f index 39bd86c..4bf4d91 100644 --- a/gcc/testsuite/gfortran.dg/g77/980310-3.f +++ b/gcc/testsuite/gfortran.dg/g77/980310-3.f @@ -12,7 +12,7 @@ C Date: Wed, 17 Dec 1997 23:20:29 +0000 C From: Joao Cardoso <jcardoso@inescn.pt> C To: egcs-bugs@cygnus.com C Subject: egcs-1.0 f77 bug on OSR5 -C When trying to compile the Fortran file that I enclose bellow, +C When trying to compile the Fortran file that I enclose below, C I got an assembler error: C C ./g77 -B./ -fpic -O -c scaleg.f diff --git a/gcc/testsuite/gfortran.dg/goacc/acc-wait-1.f90 b/gcc/testsuite/gfortran.dg/goacc/acc-wait-1.f90 new file mode 100644 index 0000000..dd19b41 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/acc-wait-1.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine f0(x) + implicit none + integer, value :: x + !$acc wait(x) if(.false.) async +end + +subroutine f1(y, ia) + implicit none + integer, value :: y, ia + !$acc wait(y) if(.true.) async(ia) +end + +subroutine fl(z, ll) + implicit none + integer, value :: z + logical, value :: ll + !$acc wait(z) if(ll) async(3) +end + +subroutine a0(a) + implicit none + integer, value :: a + !$acc wait(a) if(.false.) +end + +subroutine a1(b) + implicit none + integer, value :: b + !$acc wait(b) if(.true.) +end + +subroutine al(c, qq) + implicit none + integer, value :: c + logical, value :: qq + !$acc wait(c) if(qq) +end + +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = x;\[\\n\\r\]+ *if \\(0\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(-1, 1, D\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = ia;\[\\n\\r\]+ *D\.\[0-9\]+ = y;\[\\n\\r\]+ *if \\(1\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(D\.\[0-9\]+, 1, D\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = z;\[\\n\\r\]+ *D\.\[0-9\]+ = ll;\[\\n\\r\]+ *if \\(D\.\[0-9\]+\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(3, 1, D\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = a;\[\\n\\r\]+ *if \\(0\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(-2, 1, D\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = b;\[\\n\\r\]+ *if \\(1\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(-2, 1, D\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\.\[0-9\]+ = c;\[\\n\\r\]+ *D\.\[0-9\]+ = qq;\[\\n\\r\]+ *if \\(D\.\[0-9\]+\\)\[\\n\\r\]+ *\{\[\\n\\r\]+ *__builtin_GOACC_wait \\(-2, 1, D\.\[0-9\]+\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/goacc/parameter-3.f90 b/gcc/testsuite/gfortran.dg/goacc/parameter-3.f90 new file mode 100644 index 0000000..2c8aa61 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/parameter-3.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +subroutine x + integer :: var + integer, parameter :: ilog = 0 + integer, parameter :: array(*) = [11,22,33] + !$ACC DECLARE COPYIN(ilog, array, var, array) ! { dg-error "Symbol 'array' present on multiple clauses" } +end subroutine x + +integer :: a +integer, parameter :: b = 4 +integer, parameter :: c(*) = [1,2,3] + +!$acc parallel copy(a,c,b,c) ! { dg-error "Symbol 'c' present on multiple clauses" } +!$acc end parallel +end diff --git a/gcc/testsuite/gfortran.dg/goacc/parameter-4.f90 b/gcc/testsuite/gfortran.dg/goacc/parameter-4.f90 new file mode 100644 index 0000000..aadd7cf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/parameter-4.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine x + integer :: var + integer, parameter :: ilog = 0 + integer, parameter :: array(*) = [11,22,33] + !$ACC DECLARE COPYIN(ilog, array, var) +end subroutine x + +integer :: a +integer, parameter :: b = 4 +integer, parameter :: c(*) = [1,2,3] + +!$acc parallel copy(a,c,b) + a = c(2) + b +!$acc end parallel + +!$acc parallel firstprivate(a,c,b) + a = c(2) + b +!$acc end parallel +end + +! { dg-final { scan-tree-dump-times "#pragma acc data map\\(to:var\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma acc parallel map\\(tofrom:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma acc parallel firstprivate\\(a\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/goacc/parameter.f95 b/gcc/testsuite/gfortran.dg/goacc/parameter.f95 index b581338..a9bde4a 100644 --- a/gcc/testsuite/gfortran.dg/goacc/parameter.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/parameter.f95 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-additional-options "-Wsurprising" } module test contains @@ -6,37 +7,37 @@ contains implicit none integer :: i integer, parameter :: a = 1 - !$acc declare device_resident (a) ! { dg-error "is not a variable" } - !$acc data copy (a) ! { dg-error "not a variable" } + !$acc declare device_resident (a) ! (no warning here - for semi-good reasons) + !$acc data copy (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as parameters need not be copied \\\[-Wsurprising\\\]" } !$acc end data - !$acc data deviceptr (a) ! { dg-error "not a variable" } + !$acc data deviceptr (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as parameters need not be copied \\\[-Wsurprising\\\]" } !$acc end data - !$acc parallel private (a) ! { dg-error "not a variable" } + !$acc parallel private (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } !$acc end parallel - !$acc serial private (a) ! { dg-error "not a variable" } + !$acc serial private (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } !$acc end serial - !$acc host_data use_device (a) ! { dg-error "not a variable" } + !$acc host_data use_device (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } !$acc end host_data - !$acc parallel loop reduction(+:a) ! { dg-error "not a variable" } + !$acc parallel loop reduction(+:a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } do i = 1,5 enddo !$acc end parallel loop - !$acc serial loop reduction(+:a) ! { dg-error "not a variable" } + !$acc serial loop reduction(+:a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } do i = 1,5 enddo !$acc end serial loop !$acc parallel loop do i = 1,5 - !$acc cache (a) ! { dg-error "not a variable" } + !$acc cache (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } enddo !$acc end parallel loop !$acc serial loop do i = 1,5 - !$acc cache (a) ! { dg-error "not a variable" } + !$acc cache (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as it is a parameter \\\[-Wsurprising\\\]" } enddo !$acc end serial loop - !$acc update device (a) ! { dg-error "not a variable" } - !$acc update host (a) ! { dg-error "not a variable" } - !$acc update self (a) ! { dg-error "not a variable" } + !$acc update device (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as parameters need not be copied \\\[-Wsurprising\\\]" } + !$acc update host (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as parameters need not be copied \\\[-Wsurprising\\\]" } + !$acc update self (a) ! { dg-warning "Clause for object 'a' at .1. is ignored as parameters need not be copied \\\[-Wsurprising\\\]" } end subroutine oacc1 end module test 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/omp_get_num_devices_initial_device-2.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90 new file mode 100644 index 0000000..18613d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-O1 -fdump-tree-optimized -fno-builtin-omp_get_num_devices -fno-builtin-omp_get_initial_device" } +integer function f() result(ret) + interface + integer function omp_get_initial_device (); end + integer function omp_get_num_devices (); end + end interface + + if (omp_get_initial_device () /= omp_get_num_devices ()) error stop + + if (omp_get_num_devices () /= omp_get_num_devices ()) error stop + + if (omp_get_initial_device () /= omp_get_initial_device ()) error stop + + ret = omp_get_num_devices () +end + +! { dg-final { scan-tree-dump-times "error_stop" 3 "optimized" } } + +! { dg-final { scan-tree-dump-times "omp_get_num_devices" 4 "optimized" } } +! { dg-final { scan-tree-dump-times "omp_get_initial_device" 3 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 new file mode 100644 index 0000000..279656b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-O1 -fdump-tree-optimized" } +integer function f() result(ret) + interface + integer function omp_get_initial_device (); end + integer function omp_get_num_devices (); end + end interface + + if (omp_get_initial_device () /= omp_get_num_devices ()) error stop + + if (omp_get_num_devices () /= omp_get_num_devices ()) error stop + + if (omp_get_initial_device () /= omp_get_initial_device ()) error stop + + ret = omp_get_num_devices () +end + +! { dg-final { scan-tree-dump-not "error_stop" "optimized" } } + +! { dg-final { scan-tree-dump-not "omp_get_num_devices" "optimized" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump "return 0;" "optimized" { target { ! offloading_enabled } } } } + +! { dg-final { scan-tree-dump-times "omp_get_num_devices" 1 "optimized" { target offloading_enabled } } } +! { dg-final { scan-tree-dump "_1 = __builtin_omp_get_num_devices \\(\\);\[\\r\\n\]+\[ \]+return _1;" "optimized" { target offloading_enabled } } } 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/guality/arg1.f90 b/gcc/testsuite/gfortran.dg/guality/arg1.f90 index 332a4ed..775b7bb 100644 --- a/gcc/testsuite/gfortran.dg/guality/arg1.f90 +++ b/gcc/testsuite/gfortran.dg/guality/arg1.f90 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-options "-g" } +! { dg-options "-fno-shrink-wrap -g" } integer :: a(10), b(12) call sub (a, 10) call sub (b, 12) diff --git a/gcc/testsuite/gfortran.dg/guality/pr120193.f90 b/gcc/testsuite/gfortran.dg/guality/pr120193.f90 new file mode 100644 index 0000000..e65febf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/guality/pr120193.f90 @@ -0,0 +1,26 @@ +! PR fortran/120193 +! { dg-do run } +! { dg-options "-g -funsigned" } +! { dg-skip-if "" { *-*-* } { "*" } { "-O0" } } + +program foo + unsigned(kind=1) :: a(2), e + unsigned(kind=2) :: b(2), f + unsigned(kind=4) :: c(2), g + unsigned(kind=8) :: d(2), h + character(kind=1, len=1) :: i(2), j + character(kind=4, len=1) :: k(2), l + a = 97u_1 ! { dg-final { gdb-test 24 "a" "d" } } + b = 97u_2 ! { dg-final { gdb-test 24 "b" "c" } } + c = 97u_4 ! { dg-final { gdb-test 24 "c" "b" } } + d = 97u_8 ! { dg-final { gdb-test 24 "d" "a" } } + e = 97u_1 ! { dg-final { gdb-test 24 "e" "97" } } + f = 97u_2 ! { dg-final { gdb-test 24 "f" "97" } } + g = 97u_4 ! { dg-final { gdb-test 24 "g" "97" } } + h = 97u_8 ! { dg-final { gdb-test 24 "h" "97" } } + i = 'a' ! { dg-final { gdb-test 24 "i" "('a', 'a')" } } + j = 'b' ! { dg-final { gdb-test 24 "j" "'b'" } } + k = 'c' + l = 'd' + print *, a +end program diff --git a/gcc/testsuite/gfortran.dg/import12.f90 b/gcc/testsuite/gfortran.dg/import12.f90 new file mode 100644 index 0000000..df1aae6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/import12.f90 @@ -0,0 +1,302 @@ +! { dg-do compile } +! +! Tests the variants of IMPORT introduced in F2018 +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! +MODULE M + import, none ! { dg-error "F2018: C897 IMPORT statement" } + IMPLICIT NONE + integer :: z +end module + +MODULE N + IMPLICIT NONE + integer :: z +end module + +! Taken from gfortran.dg/pr103312.f90. These F2008-style invocations should +! be accepted. +module example + type, abstract :: foo + integer :: i + contains + procedure(foo_size), deferred :: size + procedure(foo_func), deferred :: func + end type + abstract interface + pure integer function foo_size (this) + import :: foo + class(foo), intent(in) :: this + end function + function foo_func (this) result (string) + import :: foo + class(foo) :: this + character(this%size()) :: string + end function + end interface +end module + +block data blk + import, all ! { dg-error "F2018: C897 IMPORT statement" } + integer a(2) + common /my_common/a + data a/1,2/ +end + +subroutine extern_sub1 + import ! { dg-error "F2018: C897 IMPORT statement" } +end + +subroutine extern_sub2 (arg1, arg2, arg3) + implicit none + integer :: arg1, arg2, arg3 + arg1 = int_fcn () +contains + integer function int_fcn () + import, only : arg2, arg3 + int_fcn = arg2 * arg3 + end +end + +program p + import, all ! { dg-error "F2018: C897 IMPORT statement" } + implicit none + integer :: x, y + type :: t + integer :: i + end type + type(t) :: progtype + type, extends(t) :: s + integer :: j + end type + class(t), allocatable :: progclass +contains + +! OK because arg is just that and x is declared in scope of sub1. + subroutine sub1 (arg) + import, none + implicit none + real :: arg, x + end + +! IMPORT, ALL must be the only IMPORT statement in the scope. + subroutine sub2 (arg) + import, none + import, all ! { dg-error "F2018: C8100 IMPORT statement" } + implicit none + real :: arg, x + end + +! Error message says it all. + subroutine sub3 (arg) + import, none + implicit none + integer :: arg + print *, arg + x = 1 ! { dg-error "F2018: C8102" } + end + +! Error messages say it all. + subroutine sub4 (arg) + import, only : y + implicit none + integer :: arg + print *, arg + x = 1 ! { dg-error "F2018: C8102" } + y = 2 + print *, x ! { dg-error "F2018: C8102" } + end + +! IMPORT eos and IMPORT, ALL must be unique in the scope. + subroutine sub5a (arg) + import, all + import ! { dg-error "F2018: C8100" } + implicit none + real :: arg + real :: x ! { dg-error "F2018: C8102" } + end + + subroutine sub5b (arg) + import, only : x + implicit none + real :: arg + real :: x ! { dg-error "F2018: C8102" } + end + +! Error message says it all. + integer function func1 () + import, only : x + func1 = x * y ! { dg-error "F2018: C8102" } + end + +! Error messages say it all. + subroutine sub6 (arg) + import, only : func1 + import, only : func2 + import, only : foobar ! { dg-error "has no IMPLICIT type" } + implicit none + integer :: arg + arg = func1 () * func2 () * func3 () ! { dg-error "F2018: C8102" } + end + +! Error message says it all. + integer function func2 () + use N + import, none + implicit none + func2 = y ! { dg-error "F2018: C8102" } + end + +! OK + integer function func3 () + func3 = 42 + end + + subroutine sub7 (arg) + implicit none + integer :: arg +! OK + block + import, only : arg, func1, func2, func3 + arg = func1 () * func2 () * func3 () + end block + block + arg = func1 () + import, only : arg, func1 ! { dg-error "Unexpected IMPORT statement" } + end block + end + +! Error messages say it all. + subroutine sub8 (arg) + implicit none + integer :: arg + block + import, only : func1 + import, only : func2 + import, only : foobar ! { dg-error "has no IMPLICIT type" } + arg = func1 () * func2 () * func3 () ! { dg-error "F2018: C8102" } + end block + end + +! ASSOCIATE does not have a specification part so IMPORT cannot appear. + subroutine sub9 (arg) + implicit none + integer :: arg + associate (f3 => func3 ()) ! { dg-error "F2018: C8102" } + import, only : arg, func1 ! { dg-error "Unexpected IMPORT statement" } + arg = func1 () * func2 () * f3 ! { dg-error "F2018: C8102" } + end associate + end + +! OK + subroutine sub10 (arg) + import, only : t + implicit none + type(t) :: arg, mytype + mytype%i = 1 + arg = mytype + end + +! TYPE t does not appear in the IMPORT list + subroutine sub11 (arg) + import, only : progtype + implicit none + type(t) :: arg + progtype%i = 1 ! { dg-error "F2018: C8102" } + arg = progtype ! { dg-error "F2018: C8102" } + end + +! TYPE t is excluded by IMPORT, NONE + subroutine sub12 (arg) + import, none + implicit none + type(t) :: arg, mytype + mytype%i = 1 ! { dg-error "F2018: C8102" } + arg = mytype ! { dg-error "F2018: C8102" } + end + +! TYPE t does not appear in the IMPORT list + subroutine sub13 (arg) + import, only : progclass + implicit none + class(t) :: arg + type(t) :: ca(2) = [t(1), t(2)] ! { dg-error "F2018: C8102" } + progclass%i = t(1) ! { dg-error "F2018: C8102" } + arg = progclass ! { dg-error "F2018: C8102" } + ca = [t(1), t(2)] ! { dg-error "has no IMPLICIT type|F2018: C8102" } + arg = ca(2) ! Note: The preceeding line catches 'ca' having no implicit type. + end + +! TYPE t is excluded by IMPORT, NONE + subroutine sub14 (arg) + import, none + implicit none + class(t) :: arg + class(t), allocatable :: myclass + myclass%i = t(1) ! { dg-error "F2018: C8102" } + arg%i = myclass%i ! { dg-error "F2018: C8102" } + select type (arg) ! { dg-error "F2018: C8102" } + type is (t) + arg%i = arg%i + 1 + type is (s) + arg%j = -1 + end select + end + +! TYPE s does not appear in the IMPORT, ONLY list + subroutine sub15 (arg) + import, only : t + implicit none + class(t) :: arg + class(t), allocatable :: myclass + myclass = t(1) + arg%i = myclass%i + select type (arg) ! { dg-error "F2018: C8102" } + type is (t) + arg%i = arg%i + 1 + type is (s) + arg%j = -1 ! s is caught at the SELECT TYPE statement + end select + end + +! This is OK + subroutine sub16 (arg) + import, only : t, s + implicit none + class(t) :: arg + class(t), allocatable :: myclass + myclass = t(1) + arg%i = myclass%i + select type (arg) + type is (t) + arg%i = arg%i + 1 + type is (s) + arg%j = -1 + end select + end + + subroutine sub17 (arg) + import, only : t + implicit none + class(t) :: arg + call sub16 (arg) ! { dg-error "F2018: C8102" } + end + +! Make sure that recursive procedures do not require the procedure itself to be imported. + recursive subroutine sub18 (arg) + import, none + implicit none + integer :: arg + if (arg <= 0) call sub18 (arg) + arg = 1 + end + + recursive integer function func4 (arg) result (res) + import, none + implicit none + integer :: arg + if (arg <= 0) arg = func4 (arg) + res = 1 + end +end diff --git a/gcc/testsuite/gfortran.dg/import3.f90 b/gcc/testsuite/gfortran.dg/import3.f90 index 74cd527..9288c6b 100644 --- a/gcc/testsuite/gfortran.dg/import3.f90 +++ b/gcc/testsuite/gfortran.dg/import3.f90 @@ -1,6 +1,8 @@ ! { dg-do compile } +! { dg-options "-std=f2008" } ! { dg-shouldfail "Invalid use of IMPORT" } ! Test invalid uses of import +! Wording of some error messages change for -std>=F2018 but all are caught. ! PR fortran/29601 subroutine test() diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 index 580cb1a..bb1a3cb 100644 --- a/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 +++ b/gcc/testsuite/gfortran.dg/inline_matmul_16.f90 @@ -58,4 +58,4 @@ program main end do end do end program main -! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } +! { dg-final { scan-tree-dump-not "_gfortran_matmul" "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 new file mode 100644 index 0000000..0876941 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_matmul_26.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs -finline-matmul-limit=1000 -O" } +! PR 66094: Check functionality for MATMUL(TRANSPOSE(A),B)) for two-dimensional arrays +program main + implicit none + integer :: in, im, icnt + integer, volatile :: ten + + ten = 10 + ! cycle through a few test cases... + do in = 2,ten + do im = 2,ten + do icnt = 2,ten + block + real, dimension(icnt,in) :: a2 + real, dimension(icnt,im) :: b2 + real, dimension(in,im) :: c2,cr + integer :: i,j,k + call random_number(a2) + call random_number(b2) + c2 = 0 + do i=1,size(a2,2) + do j=1, size(b2,2) + do k=1, size(a2,1) + c2(i,j) = c2(i,j) + a2(k,i) * b2(k,j) + end do + end do + end do + cr = matmul(transpose(a2), b2) + if (any(abs(c2-cr) > 1e-4)) STOP 7 + end block + end do + end do + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 new file mode 100644 index 0000000..534225a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/101735 - substrings and parsing of type parameter inquiries + +program p + implicit none + integer, parameter :: ck = 4 + character(len=5) :: str = "" + character(len=5) :: str2(4) + character(len=5,kind=ck) :: str4 = ck_"" + type t + character(len=5) :: str(4) + end type t + type(t) :: var + integer :: x, y + + integer, parameter :: i1 = kind (str(1:3)) + integer, parameter :: j1 = str (1:3) % kind + integer, parameter :: k1 = (str(1:3) % kind) + integer, parameter :: kk = str (1:3) % kind % kind + + integer, parameter :: i4 = kind (str4(1:3)) + integer, parameter :: j4 = str4 (1:3) % kind + integer, parameter :: ll = str4 (1:3) % len + + integer, parameter :: i2 = len (str(1:3)) + integer, parameter :: j2 = str (1:3) % len + integer, parameter :: k2 = (str(1:3) % len) + integer, parameter :: lk = str (1:3) % len % kind + + integer, parameter :: l4 = str2 (:) (2:3) % len + integer, parameter :: l5 = var % str (:) (2:4) % len + integer, parameter :: k4 = str2 (:) (2:3) % kind + integer, parameter :: k5 = var % str (:) (2:4) % kind + integer, parameter :: k6 = str2 (:) (2:3) % len % kind + integer, parameter :: k7 = var % str (:) (2:4) % len % kind + + if (i1 /= 1) stop 1 + if (j1 /= 1) stop 2 + if (k1 /= 1) stop 3 + + if (i4 /= ck) stop 4 + if (j4 /= ck) stop 5 + if (ll /= 3) stop 6 + + if (kk /= 4) stop 7 + if (lk /= 4) stop 8 + + if (i2 /= 3) stop 9 + if (j2 /= 3) stop 10 + if (k2 /= 3) stop 11 + + if (l4 /= 2) stop 12 + if (l5 /= 3) stop 13 + if (k4 /= 1) stop 14 + if (k5 /= 1) stop 15 + if (k6 /= 4) stop 16 + if (k7 /= 4) stop 17 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 new file mode 100644 index 0000000..70ef621 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-additional-options "-O0 -fdump-tree-original -std=f2018" } +! +! PR fortran/102599 - type parameter inquiries and constant complex arrays +! PR fortran/114022 - likewise +! +! Everything below shall be simplified at compile time. + +module mod + implicit none + public :: wp, c0, z0, y, test1 + private + + integer :: j + integer, parameter :: n = 5 + integer, parameter :: wp = 8 + type :: cx + real(wp) :: re + real(wp) :: im + end type cx + type(cx), parameter :: c0(*) = [(cx (j,-j), j=1,n)] + complex(wp), parameter :: z0(*) = [(cmplx(j,-j,wp),j=1,n)] + + type :: my_type + complex(wp) :: z(n) = z0 + type(cx) :: c(n) = c0 + end type my_type + type(my_type), parameter :: y = my_type() + +contains + + ! Check simplification for inquiries of host-associated variables + subroutine test1 () + ! Inquiries and full arrays + real(wp), parameter :: r0(*) = real (z0) + real(wp), parameter :: i0(*) = aimag (z0) + real(wp), parameter :: r1(*) = c0 % re + real(wp), parameter :: i1(*) = c0 % im + real(wp), parameter :: r2(*) = z0 % re + real(wp), parameter :: i2(*) = z0 % im + real(wp), parameter :: r3(*) = y % c % re + real(wp), parameter :: i3(*) = y % c % im + real(wp), parameter :: r4(*) = y % z % re + real(wp), parameter :: i4(*) = y % z % im + + logical, parameter :: l1 = all (r1 == r0) + logical, parameter :: l2 = all (i1 == i0) + logical, parameter :: l3 = all (r1 == r2) + logical, parameter :: l4 = all (i1 == i2) + logical, parameter :: l5 = all (r3 == r4) + logical, parameter :: l6 = all (i3 == i4) + logical, parameter :: l7 = all (r1 == r3) + logical, parameter :: l8 = all (i1 == i3) + + ! Inquiries and array sections + real(wp), parameter :: p0(*) = real (z0(::2)) + real(wp), parameter :: q0(*) = aimag (z0(::2)) + real(wp), parameter :: p1(*) = c0(::2) % re + real(wp), parameter :: q1(*) = c0(::2) % im + real(wp), parameter :: p2(*) = z0(::2) % re + real(wp), parameter :: q2(*) = z0(::2) % im + real(wp), parameter :: p3(*) = y % c(::2) % re + real(wp), parameter :: q3(*) = y % c(::2) % im + real(wp), parameter :: p4(*) = y % z(::2) % re + real(wp), parameter :: q4(*) = y % z(::2) % im + + logical, parameter :: m1 = all (p1 == p0) + logical, parameter :: m2 = all (q1 == q0) + logical, parameter :: m3 = all (p1 == p2) + logical, parameter :: m4 = all (q1 == q2) + logical, parameter :: m5 = all (p3 == p4) + logical, parameter :: m6 = all (q3 == q4) + logical, parameter :: m7 = all (p1 == p3) + logical, parameter :: m8 = all (q1 == q3) + + ! Inquiries and vector subscripts + real(wp), parameter :: v0(*) = real (z0([3,2])) + real(wp), parameter :: w0(*) = aimag (z0([3,2])) + real(wp), parameter :: v1(*) = c0([3,2]) % re + real(wp), parameter :: w1(*) = c0([3,2]) % im + real(wp), parameter :: v2(*) = z0([3,2]) % re + real(wp), parameter :: w2(*) = z0([3,2]) % im + real(wp), parameter :: v3(*) = y % c([3,2]) % re + real(wp), parameter :: w3(*) = y % c([3,2]) % im + real(wp), parameter :: v4(*) = y % z([3,2]) % re + real(wp), parameter :: w4(*) = y % z([3,2]) % im + + logical, parameter :: o1 = all (v1 == v0) + logical, parameter :: o2 = all (w1 == w0) + logical, parameter :: o3 = all (v1 == v2) + logical, parameter :: o4 = all (w1 == w2) + logical, parameter :: o5 = all (v3 == v4) + logical, parameter :: o6 = all (w3 == w4) + logical, parameter :: o7 = all (v1 == v3) + logical, parameter :: o8 = all (w1 == w3) + + ! Miscellaneous + complex(wp), parameter :: x(-1:*) = cmplx (r1,i1,kind=wp) + real(x%re%kind), parameter :: r(*) = x % re + real(x%im%kind), parameter :: i(*) = x % im + real(x%re%kind), parameter :: s(*) = [ x(:) % re ] + real(x%im%kind), parameter :: t(*) = [ x(:) % im ] + + integer, parameter :: kr = x % re % kind + integer, parameter :: ki = x % im % kind + integer, parameter :: kx = x % kind + + if (kr /= wp .or. ki /= wp .or. kx /= wp) stop 1 + if (any (r /= r1)) stop 2 + if (any (i /= i1)) stop 3 + if (any (s /= r1)) stop 4 + if (any (t /= i1)) stop 5 + + if (.not. all ([l1,l2,l3,l4,l5,l6,l7,l8])) stop 6 + if (.not. all ([m1,m2,m3,m4,m5,m6,m7,m8])) stop 7 + if (.not. all ([o1,o2,o3,o4,o5,o6,o7,o8])) stop 8 + end subroutine test1 +end + +program p + use mod, only: wp, c0, z0, y, test1 + implicit none + call test1 () + call test2 () +contains + ! Check simplification for inquiries of use-associated variables + subroutine test2 () + ! Inquiries and full arrays + real(wp), parameter :: r0(*) = real (z0) + real(wp), parameter :: i0(*) = aimag (z0) + real(wp), parameter :: r1(*) = c0 % re + real(wp), parameter :: i1(*) = c0 % im + real(wp), parameter :: r2(*) = z0 % re + real(wp), parameter :: i2(*) = z0 % im + real(wp), parameter :: r3(*) = y % c % re + real(wp), parameter :: i3(*) = y % c % im + real(wp), parameter :: r4(*) = y % z % re + real(wp), parameter :: i4(*) = y % z % im + + logical, parameter :: l1 = all (r1 == r0) + logical, parameter :: l2 = all (i1 == i0) + logical, parameter :: l3 = all (r1 == r2) + logical, parameter :: l4 = all (i1 == i2) + logical, parameter :: l5 = all (r3 == r4) + logical, parameter :: l6 = all (i3 == i4) + logical, parameter :: l7 = all (r1 == r3) + logical, parameter :: l8 = all (i1 == i3) + + ! Inquiries and array sections + real(wp), parameter :: p0(*) = real (z0(::2)) + real(wp), parameter :: q0(*) = aimag (z0(::2)) + real(wp), parameter :: p1(*) = c0(::2) % re + real(wp), parameter :: q1(*) = c0(::2) % im + real(wp), parameter :: p2(*) = z0(::2) % re + real(wp), parameter :: q2(*) = z0(::2) % im + real(wp), parameter :: p3(*) = y % c(::2) % re + real(wp), parameter :: q3(*) = y % c(::2) % im + real(wp), parameter :: p4(*) = y % z(::2) % re + real(wp), parameter :: q4(*) = y % z(::2) % im + + logical, parameter :: m1 = all (p1 == p0) + logical, parameter :: m2 = all (q1 == q0) + logical, parameter :: m3 = all (p1 == p2) + logical, parameter :: m4 = all (q1 == q2) + logical, parameter :: m5 = all (p3 == p4) + logical, parameter :: m6 = all (q3 == q4) + logical, parameter :: m7 = all (p1 == p3) + logical, parameter :: m8 = all (q1 == q3) + + ! Inquiries and vector subscripts + real(wp), parameter :: v0(*) = real (z0([3,2])) + real(wp), parameter :: w0(*) = aimag (z0([3,2])) + real(wp), parameter :: v1(*) = c0([3,2]) % re + real(wp), parameter :: w1(*) = c0([3,2]) % im + real(wp), parameter :: v2(*) = z0([3,2]) % re + real(wp), parameter :: w2(*) = z0([3,2]) % im + real(wp), parameter :: v3(*) = y % c([3,2]) % re + real(wp), parameter :: w3(*) = y % c([3,2]) % im + real(wp), parameter :: v4(*) = y % z([3,2]) % re + real(wp), parameter :: w4(*) = y % z([3,2]) % im + + logical, parameter :: o1 = all (v1 == v0) + logical, parameter :: o2 = all (w1 == w0) + logical, parameter :: o3 = all (v1 == v2) + logical, parameter :: o4 = all (w1 == w2) + logical, parameter :: o5 = all (v3 == v4) + logical, parameter :: o6 = all (w3 == w4) + logical, parameter :: o7 = all (v1 == v3) + logical, parameter :: o8 = all (w1 == w3) + + ! Miscellaneous + complex(wp), parameter :: x(-1:*) = cmplx (r1,i1,kind=wp) + real(x%re%kind), parameter :: r(*) = x % re + real(x%im%kind), parameter :: i(*) = x % im + real(x%re%kind), parameter :: s(*) = [ x(:) % re ] + real(x%im%kind), parameter :: t(*) = [ x(:) % im ] + + integer, parameter :: kr = x % re % kind + integer, parameter :: ki = x % im % kind + integer, parameter :: kx = x % kind + + if (kr /= wp .or. ki /= wp .or. kx /= wp) stop 11 + if (any (r /= r1)) stop 12 + if (any (i /= i1)) stop 13 + if (any (s /= r1)) stop 14 + if (any (t /= i1)) stop 15 + + if (.not. all ([l1,l2,l3,l4,l5,l6,l7,l8])) stop 16 + if (.not. all ([m1,m2,m3,m4,m5,m6,m7,m8])) stop 17 + if (.not. all ([o1,o2,o3,o4,o5,o6,o7,o8])) stop 18 + end subroutine test2 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } 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/interface_60.f90 b/gcc/testsuite/gfortran.dg/interface_60.f90 new file mode 100644 index 0000000..a7701f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_60.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-Wexternal-argument-mismatch" } +! Originally proc_ptr_52.f90, this gave an error with the warning above. + +module cs + +implicit none + +integer, target :: integer_target + +abstract interface + function classStar_map_ifc(x) result(y) + class(*), pointer :: y + class(*), target, intent(in) :: x + end function classStar_map_ifc +end interface + +contains + + function fun(x) result(y) + class(*), pointer :: y + class(*), target, intent(in) :: x + select type (x) + type is (integer) + integer_target = x ! Deals with dangling target. + y => integer_target + class default + y => null() + end select + end function fun + + function apply(fap, x) result(y) + procedure(classStar_map_ifc) :: fap + integer, intent(in) :: x + integer :: y + class(*), pointer :: p + y = 0 ! Get rid of 'y' undefined warning + p => fap (x) + select type (p) + type is (integer) + y = p + end select + end function apply + + function selector() result(fsel) + procedure(classStar_map_ifc), pointer :: fsel + fsel => fun + end function selector + +end module cs + + +program classStar_map + +use cs +implicit none + +integer :: x, y +procedure(classStar_map_ifc), pointer :: fm + +x = 123654 +fm => selector () ! Fixed by second chunk in patch +y = apply (fm, x) ! Fixed by first chunk in patch +if (x .ne. y) stop 1 + +x = 2 * x +y = apply (fun, x) ! PR93925; fixed as above +if (x .ne. y) stop 2 + +end program classStar_map diff --git a/gcc/testsuite/gfortran.dg/interface_61.f90 b/gcc/testsuite/gfortran.dg/interface_61.f90 new file mode 100644 index 0000000..15db3b8a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_61.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options -Wexternal-argument-mismatch } +! PR fortran/120163 - this used to cause an error. +! Original test case by Bálint Aradi +module mod1 + implicit none + + abstract interface + pure subroutine callback_interface(a) + real, intent(in) :: a + end subroutine callback_interface + end interface + +contains + + subroutine caller(callback) + procedure(callback_interface) :: callback + real :: a + call callback(a) + end subroutine caller + +end module mod1 + + +module mod2 + use mod1 +end module mod2 diff --git a/gcc/testsuite/gfortran.dg/interface_62.f90 b/gcc/testsuite/gfortran.dg/interface_62.f90 new file mode 100644 index 0000000..19d4325 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_62.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! PR fortran/120355 - this was rejected because the typespec from +! the RESULT clause was not picked up. +! Test case jsberg@bnl.gov. + +program p + implicit none + integer :: i,j + interface + function s(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + end function s + end interface + i = 0 + call t(s,i,j) +contains + subroutine t(f,x,y) + implicit none + integer, intent(in) :: x + integer, intent(out) :: y + interface + function f(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + end function f + end interface + y = f(x) + end subroutine t +end program p + +function s(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + y = 1 - x +end function s diff --git a/gcc/testsuite/gfortran.dg/interface_63.f90 b/gcc/testsuite/gfortran.dg/interface_63.f90 new file mode 100644 index 0000000..56c1644 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_63.f90 @@ -0,0 +1,97 @@ +! { dg-do compile } +! PR fortran/120784 - fix checking of renamed-on-use interface name +! +! Contributed by Matt Thompson <matthew.thompson at nasa dot gov> + +module A_mod + implicit none + + interface Get + procedure :: get_1 + procedure :: get_2 + end interface Get + +contains + + subroutine get_1(i) + integer :: i + i = 5 + end subroutine get_1 + + subroutine get_2(x) + real :: x + x = 4 + end subroutine get_2 +end module A_mod + +module B_mod + use A_mod, only : MyGet => Get + implicit none + + interface MyGet + procedure :: other_get + end interface MyGet + +contains + + subroutine other_get(c) + character(1) :: c + c = 'a' + end subroutine other_get + + subroutine check_get () + character :: c + integer :: i + real :: r + call myget (c) + call myget (i) + call myget (r) + end subroutine check_get + +end module B_MOD + +program p + use b_mod, only: myget + implicit none + character :: c + integer :: i + real :: r + call myget (c) + call myget (i) + call myget (r) +end + +! Check that we do not regress on the following: + +module mod1 + implicit none + + interface local + module procedure local_data + end interface local + +contains + + logical function local_data (data) result (local) + real, intent(in) :: data + local = .true. + end function local_data + +end module mod1 + +module mod2 + use mod1, only: local + implicit none + + interface local + module procedure local_invt + end interface local + +contains + + logical function local_invt (invt) result (local) + integer, intent(in) :: invt + local = .true. + end function local_invt + +end module mod2 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/move_alloc_20.f03 b/gcc/testsuite/gfortran.dg/move_alloc_20.f03 new file mode 100644 index 0000000..20403c3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_20.f03 @@ -0,0 +1,151 @@ +! { dg-do run } +! +! Check the presence of the pre and post code of the FROM and TO arguments +! of the MOVE_ALLOC intrinsic subroutine. + +module m + implicit none + type :: t + integer, allocatable :: a(:) + end type +end module + +module pre + use m + implicit none + private + public :: check_pre + +contains + + subroutine check_pre + integer, parameter :: n = 5 + type(t) :: x(n) + integer, allocatable :: tmp(:) + integer :: array(4) = [ -1, 0, 1, 2 ] + integer :: i + + if (allocated(tmp)) error stop 1 + + tmp = [17] + + if (.not. allocated(tmp)) error stop 11 + if (any(shape(tmp) /= [1])) error stop 12 + if (any(tmp /= [17])) error stop 13 + do i=1,n + if (allocated(x(i)%a)) error stop 14 + end do + + ! Check that the index of X is properly computed for the evaluation of TO. + call move_alloc(tmp, x(sum(array))%a) + + do i=1,n + if (i == 2) cycle + if (allocated(x(i)%a)) error stop 21 + end do + if (.not. allocated(x(2)%a)) error stop 22 + if (any(shape(x(2)%a) /= [1])) error stop 23 + if (any(x(2)%a /= [17])) error stop 24 + if (allocated(tmp)) error stop 25 + + ! Check that the index of X is properly computed for the evaluation of FROM. + call move_alloc(x(sum(array))%a, tmp) + + if (.not. allocated(tmp)) error stop 31 + if (any(shape(tmp) /= [1])) error stop 32 + if (any(tmp /= [17])) error stop 33 + do i=1,n + if (allocated(x(i)%a)) error stop 34 + end do + end subroutine + +end module + +module post + use m + implicit none + private + public :: check_post + integer, parameter :: n = 5 + type(t), target :: x(n) + type :: u + integer :: a + contains + final :: finalize + end type + integer :: finalization_count = 0 + +contains + + function idx(arg) + type(u) :: arg + integer :: idx + idx = mod(arg%a, n) + end function + + subroutine check_post + type(u) :: y + integer, allocatable :: tmp(:) + integer, target :: array(4) = [ -1, 0, 1, 2 ] + integer :: i + + y%a = 12 + + if (allocated(tmp)) error stop 1 + + tmp = [37] + + if (.not. allocated(tmp)) error stop 11 + if (any(shape(tmp) /= [1])) error stop 12 + if (any(tmp /= [37])) error stop 13 + if (finalization_count /= 0) error stop 14 + do i=1,n + if (allocated(x(i)%a)) error stop 15 + end do + + ! Check that the cleanup code for the evaluation of TO is properly + ! executed after MOVE_ALLOC: the result of GET_U should be finalized. + call move_alloc(tmp, x(idx(get_u(y)))%a) + + do i=1,n + if (i == 2) cycle + if (allocated(x(i)%a)) error stop 21 + end do + if (.not. allocated(x(2)%a)) error stop 22 + if (any(shape(x(2)%a) /= [1])) error stop 23 + if (any(x(2)%a /= [37])) error stop 24 + if (allocated(tmp)) error stop 25 + if (finalization_count /= 1) error stop 26 + + ! Check that the cleanup code for the evaluation of FROM is properly + ! executed after MOVE_ALLOC: the result of GET_U should be finalized. + call move_alloc(x(idx(get_u(y)))%a, tmp) + + if (.not. allocated(tmp)) error stop 31 + if (any(shape(tmp) /= [1])) error stop 32 + if (any(tmp /= [37])) error stop 33 + if (finalization_count /= 2) error stop 34 + do i=1,n + if (allocated(x(i)%a)) error stop 35 + end do + end subroutine + + function get_u(arg) + type(u) :: arg, get_u + get_u = arg + end function get_u + + subroutine finalize(obj) + type(u) :: obj + finalization_count = finalization_count + 1 + end subroutine + +end module + +program p + use pre + use post + implicit none + call check_pre + call check_post +end program diff --git a/gcc/testsuite/gfortran.dg/non_lvalue_1.f90 b/gcc/testsuite/gfortran.dg/non_lvalue_1.f90 new file mode 100644 index 0000000..61dad5a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/non_lvalue_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! Check the generation of NON_LVALUE_EXPR expressions in cases where a unary +! operator expression would simplify to a bare data reference. + +! A NON_LVALUE_EXPR is generated for a double negation that would simplify to +! a bare data reference. +function f1 (f1_arg1) + integer, value :: f1_arg1 + integer :: f1 + f1 = -(-f1_arg1) +end function +! { dg-final { scan-tree-dump "__result_f1 = NON_LVALUE_EXPR <f1_arg1>;" "original" } } + +! A NON_LVALUE_EXPR is generated for a double complement that would simplify to +! a bare data reference. +function f2 (f2_arg1) + integer, value :: f2_arg1 + integer :: f2 + f2 = not(not(f2_arg1)) +end function +! { dg-final { scan-tree-dump "__result_f2 = NON_LVALUE_EXPR <f2_arg1>;" "original" } } + +! A NON_LVALUE_EXPR is generated for a double complex conjugate that would +! simplify to a bare data reference. +function f3 (f3_arg1) + complex, value :: f3_arg1 + complex :: f3 + f3 = conjg(conjg(f3_arg1)) +end function +! { dg-final { scan-tree-dump "__result_f3 = NON_LVALUE_EXPR <f3_arg1>;" "original" } } 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/pr112877-1.f90 b/gcc/testsuite/gfortran.dg/pr112877-1.f90 new file mode 100644 index 0000000..f5596f0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr112877-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Os" } + +program test + use iso_c_binding, only: c_short + interface + subroutine foo(a) bind(c) + import c_short + integer(kind=c_short), intent(in), value :: a + end subroutine foo + end interface + integer(kind=c_short) a(5); + call foo (a(3)) +end + +! { dg-final { scan-assembler "movswl\t10\\(%rsp\\), %edi" { target { { i?86-*-linux* i?86-*-gnu* x86_64-*-linux* x86_64-*-gnu* } && { ! ia32 } } } } } +! { dg-final { scan-assembler "movswl\t-14\\(%ebp\\), %eax" { target { { i?86-*-linux* i?86-*-gnu* x86_64-*-linux* x86_64-*-gnu* } && { ia32 } } } } } 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/pr119856.f90 b/gcc/testsuite/gfortran.dg/pr119856.f90 new file mode 100644 index 0000000..60ada0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119856.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR119856, the error should occur in both write statements. +program badfmt + implicit none + + character(10):: fmt = "(AI5)" ! Not a PARAMETER so not examined + ! at compile time + integer :: ioerr + ioerr = 0 + write (*, fmt, iostat=ioerr) 'value =', 42 + if (ioerr /= 5006) stop 10 +! + write (*, fmt, iostat=ioerr) 'value =', 43 + if (ioerr /= 5006) stop 13 +end program badfmt diff --git a/gcc/testsuite/gfortran.dg/pr119948.f90 b/gcc/testsuite/gfortran.dg/pr119948.f90 new file mode 100644 index 0000000..2e36fae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119948.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! Test the fix for PR119948, which used to fail as indicated below with: +! (1) "Error: Bad allocate-object at (1) for a PURE procedure" +! (2) "Error: ‘construct_test2 at (1) is not a variable" +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module test_m + implicit none + + type test_t + integer, allocatable :: i + end type + + interface + pure module function construct_test(arg) result(test) + implicit none + type(test_t) :: test + type(test_t), intent(in) :: arg + end function + + pure module function construct_test2(arg) + implicit none + type(test_t) construct_test2 + type(test_t), intent(in) :: arg + end function + + pure module function construct_test_3(arg) result(test) + implicit none + type(test_t) :: test + type(test_t), intent(in) :: arg + end function + + pure module function construct_test_4(arg) + implicit none + type(test_t) :: construct_test_4 + type(test_t), intent(in) :: arg + end function + end interface + +contains + module procedure construct_test + allocate(test%i, source = arg%i) ! Fail #1 + end procedure + + module procedure construct_test2 + allocate(construct_test2%i, source = arg%i) ! Fail #2 + end procedure +end module + +submodule (test_m)test_s +contains + module procedure construct_test_3 + allocate(test%i, source = arg%i) ! This was OK. + end procedure + + module procedure construct_test_4 + allocate(construct_test_4%i, source = arg%i) ! This was OK. + end procedure +end submodule + + use test_m + type(test_t) :: res, dummy +! + dummy%i = int (rand () * 1e6) + res = construct_test (dummy) + if (res%i /= dummy%i) stop 1 +! + dummy%i = int (rand () * 1e6) + res = construct_test2 (dummy) + if (res%i /= dummy%i) stop 2 +! + dummy%i = int (rand () * 1e6) + res = construct_test_3 (dummy) + if (res%i /= dummy%i) stop 3 + + dummy%i = int (rand () * 1e6) + res = construct_test_4 (dummy) + if (res%i /= dummy%i) stop 4 + + deallocate (res%i, dummy%i) +end diff --git a/gcc/testsuite/gfortran.dg/pr120049_2.f90 b/gcc/testsuite/gfortran.dg/pr120049_2.f90 new file mode 100644 index 0000000..1f91e06 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120049_2.f90 @@ -0,0 +1,62 @@ +! Compiled with pr120049_b.f90 +! { dg-options -O0 } +! { dg-do compile } +! { dg-compile-aux-modules "pr120049_b.f90" } +! +! Test the fix for PR120049 +program tests_gtk_sup + use gtk_sup + implicit none + + type mytype + integer :: myint + end type mytype + type(mytype) :: ijkl = mytype(42) + logical :: truth + real :: var1 + type(c_ptr), target :: val + type(c_funptr), target :: fptr + character(15) :: stringy + complex :: certainly + truth = .true. + var1 = 86. + stringy = "what the hay!" + certainly = (3.14,-4.13) + if (c_associated(val, c_loc(val))) then + stop 1 + endif + if (c_associated(c_loc(val), val)) then + stop 2 + endif + print *, c_associated(fptr, C_NULL_FUNPTR) + print *, c_associated(c_loc(val), C_NULL_PTR) + print *, c_associated(C_NULL_PTR, c_loc(val)) + print *, c_associated(c_loc(val), 42) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), .42) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), truth) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), .false.) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), var1) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), stringy) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), certainly) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(42) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(truth) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(.false.) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(var1) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(stringy) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(certainly) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(val, testit(val)) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(testit(val), val) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(testit(val)) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(c_loc(val), C_NULL_FUNPTR) ! { dg-error "C_ASSOCIATED shall have the" } + print *, c_associated(C_NULL_FUNPTR, c_loc(val)) ! { dg-error "C_ASSOCIATED shall have the" } +contains + + function testit (avalue) result(res) + type(c_ptr) :: avalue + type(mytype) :: res + res%myint = 42 + end function + +end program tests_gtk_sup diff --git a/gcc/testsuite/gfortran.dg/pr120049_a.f90 b/gcc/testsuite/gfortran.dg/pr120049_a.f90 new file mode 100644 index 0000000..7095314 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120049_a.f90 @@ -0,0 +1,18 @@ +! Compiled with pr120049_b.f90 +! { dg-options -O0 } +! { dg-do run } +! { dg-compile-aux-modules "pr120049_b.f90" } +! { dg-additional-sources pr120049_b.f90 } +! +! Test the fix for PR86248 +program tests_gtk_sup + use gtk_sup + implicit none + type(c_ptr), target :: val + if (c_associated(val, c_loc(val))) then + stop 1 + endif + if (c_associated(c_loc(val), val)) then + stop 2 + endif +end program tests_gtk_sup diff --git a/gcc/testsuite/gfortran.dg/pr120049_b.f90 b/gcc/testsuite/gfortran.dg/pr120049_b.f90 new file mode 100644 index 0000000..28a2783 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120049_b.f90 @@ -0,0 +1,6 @@ +! +! Module for pr120049.f90 +! +module gtk_sup + use, intrinsic :: iso_c_binding +end module gtk_sup diff --git a/gcc/testsuite/gfortran.dg/pr120152_1.f90 b/gcc/testsuite/gfortran.dg/pr120152_1.f90 new file mode 100644 index 0000000..c49197d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120152_1.f90 @@ -0,0 +1,52 @@ +! PR libfortran/120152 +! { dg-do run } + +subroutine f1 + integer(kind=8) :: a (10, 10, 10), b (10, 10) + logical :: c (10, 10, 10) + a = 0 + c = .true. + b = maxloc (a, 2, c, 8, .true.) +end +subroutine f2 + integer(kind=8) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + logical :: c (10, 10, 10) + a = 0 + c = .true. + b = maxloc (a, 2, c, 4, .true.) +end +subroutine f3 + integer(kind=8) :: a (10, 10, 10), b (10, 10) + a = 0 + b = maxloc (a, 2, kind=8, back=.true.) +end +subroutine f4 + integer(kind=8) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + a = 0 + b = maxloc (a, 2, kind=4, back=.true.) +end +subroutine f5 + integer(kind=8) :: a (10, 10, 10), b (10, 10) + logical :: c + a = 0 + c = .false. + b = maxloc (a, 2, c, 8, .true.) +end +subroutine f6 + integer(kind=8) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + logical :: c + a = 0 + c = .false. + b = maxloc (a, 2, c, 4, .true.) +end +program pr120152 + call f1 + call f2 + call f3 + call f4 + call f5 + call f6 +end diff --git a/gcc/testsuite/gfortran.dg/pr120152_2.f90 b/gcc/testsuite/gfortran.dg/pr120152_2.f90 new file mode 100644 index 0000000..39cfb28 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120152_2.f90 @@ -0,0 +1,80 @@ +! PR libfortran/120152 +! { dg-do run { target fortran_large_int } } + +subroutine f1 + integer(kind=16) :: a (10, 10, 10) + integer(kind=8) :: b (10, 10) + logical :: c (10, 10, 10) + a = 0 + c = .true. + b = maxloc (a, 2, c, 8, .true.) +end +subroutine f2 + integer(kind=16) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + logical :: c (10, 10, 10) + a = 0 + c = .true. + b = maxloc (a, 2, c, 4, .true.) +end +subroutine f3 + integer(kind=16) :: a (10, 10, 10) + integer(kind=8) :: b (10, 10) + a = 0 + b = maxloc (a, 2, kind=8, back=.true.) +end +subroutine f4 + integer(kind=16) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + a = 0 + b = maxloc (a, 2, kind=4, back=.true.) +end +subroutine f5 + integer(kind=16) :: a (10, 10, 10) + integer(kind=8) :: b (10, 10) + logical :: c + a = 0 + c = .false. + b = maxloc (a, 2, c, 8, .true.) +end +subroutine f6 + integer(kind=16) :: a (10, 10, 10) + integer(kind=4) :: b (10, 10) + logical :: c + a = 0 + c = .false. + b = maxloc (a, 2, c, 4, .true.) +end +subroutine f7 + integer(kind=8) :: a (10, 10, 10) + integer(kind=16) :: b (10, 10) + logical :: c (10, 10, 10) + a = 0 + c = .true. + b = maxloc (a, 2, c, 16, .true.) +end +subroutine f8 + integer(kind=8) :: a (10, 10, 10) + integer(kind=16) :: b (10, 10) + a = 0 + b = maxloc (a, 2, kind=16, back=.true.) +end +subroutine f9 + integer(kind=8) :: a (10, 10, 10) + integer(kind=16) :: b (10, 10) + logical :: c + a = 0 + c = .false. + b = maxloc (a, 2, c, 16, .true.) +end +program pr120152 + call f1 + call f2 + call f3 + call f4 + call f5 + call f6 + call f7 + call f8 + call f9 +end diff --git a/gcc/testsuite/gfortran.dg/pr120153.f90 b/gcc/testsuite/gfortran.dg/pr120153.f90 new file mode 100644 index 0000000..22a7849 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120153.f90 @@ -0,0 +1,36 @@ +! PR libfortran/120153 +! { dg-do run { target fortran_large_int } } +! { dg-additional-options "-funsigned" } + +subroutine f1 + unsigned(kind=16) :: a (10, 10, 10) + integer(kind=16) :: b (10, 10) + logical :: c (10, 10, 10) + a = 0u_16 + c = .true. + b = maxloc (a, 2, c, 16, .true.) +end +subroutine f2 + unsigned(kind=16) :: a (10, 10, 10) + integer(kind=16) :: b (10, 10) + a = 0u_16 + b = maxloc (a, 2, kind=16, back=.true.) +end +subroutine f3 + unsigned(kind=16) :: a (10, 10, 10) + integer(kind=8) :: b (10, 10) + logical :: c + a = 0u_16 + c = .false. + b = maxloc (a, 2, c, 16, .true.) +end +subroutine f4 + unsigned(kind=16) :: a (5, 5, 5) + call random_number (a) +end +program pr120153 + call f1 + call f2 + call f3 + call f4 +end diff --git a/gcc/testsuite/gfortran.dg/pr120158.f90 b/gcc/testsuite/gfortran.dg/pr120158.f90 new file mode 100644 index 0000000..593f4bc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120158.f90 @@ -0,0 +1,15 @@ +! PR libfortran/120158 +! { dg-do run { target fortran_large_int } } +! { dg-additional-options "-funsigned" } + + unsigned(kind=8) :: a(10, 10, 10), b(10, 10) + integer(kind=8) :: c(10, 10), d(10, 10) + a = 0u_8 + if (maxval (a) .ne. 0u_8) stop 1 + b = maxval (a, 1) + if (any (b .ne. 0u_8)) stop 2 + c = maxloc (a, 1) + d = maxloc (a, 2, back=.true.) + if (any (c .ne. 1)) stop 3 + if (any (d .ne. 10)) stop 4 +end diff --git a/gcc/testsuite/gfortran.dg/pr120191_1.f90 b/gcc/testsuite/gfortran.dg/pr120191_1.f90 new file mode 100644 index 0000000..13a787d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120191_1.f90 @@ -0,0 +1,614 @@ +! PR fortran/120191 +! { dg-do run } + + integer(kind=1) :: a1(10, 10, 10), b1(10) + integer(kind=2) :: a2(10, 10, 10), b2(10) + integer(kind=4) :: a4(10, 10, 10), b4(10) + integer(kind=8) :: a8(10, 10, 10), b8(10) + real(kind=4) :: r4(10, 10, 10), s4(10) + real(kind=8) :: r8(10, 10, 10), s8(10) + logical :: l1(10, 10, 10), l2(10), l3 + l1 = .true. + l2 = .true. + l3 = .true. + a1 = 0 + if (any (maxloc (a1) .ne. 1)) stop 1 + if (any (maxloc (a1, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (a1, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (a1, kind=2) .ne. 1)) stop 4 + if (any (maxloc (a1, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (a1, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (a1, 1) .ne. 1)) stop 7 + if (any (maxloc (a1, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (a1, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (a1, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (a1, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (a1, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (a1, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (a1, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (a1, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (a1, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (a1, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (a1, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (a1, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (a1, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (a1, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (a1, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (a1, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (a1, 1, l3, 2, .true.) .ne. 10)) stop 24 + b1 = 0 + if (any (maxloc (b1) .ne. 1)) stop 1 + if (any (maxloc (b1, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (b1, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (b1, kind=2) .ne. 1)) stop 4 + if (any (maxloc (b1, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (b1, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (b1, 1) .ne. 1) stop 7 + if (maxloc (b1, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (b1, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (b1, 1, kind=1) .ne. 1) stop 10 + if (maxloc (b1, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (b1, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (b1, 1, l2) .ne. 1) stop 13 + if (maxloc (b1, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (b1, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (b1, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (b1, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (b1, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (b1, 1, l3) .ne. 1) stop 19 + if (maxloc (b1, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (b1, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (b1, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (b1, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (b1, 1, l3, 2, .true.) .ne. 10) stop 24 + a2 = 0 + if (any (maxloc (a2) .ne. 1)) stop 1 + if (any (maxloc (a2, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (a2, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (a2, kind=2) .ne. 1)) stop 4 + if (any (maxloc (a2, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (a2, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (a2, 1) .ne. 1)) stop 7 + if (any (maxloc (a2, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (a2, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (a2, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (a2, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (a2, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (a2, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (a2, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (a2, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (a2, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (a2, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (a2, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (a2, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (a2, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (a2, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (a2, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (a2, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (a2, 1, l3, 2, .true.) .ne. 10)) stop 24 + b2 = 0 + if (any (maxloc (b2) .ne. 1)) stop 1 + if (any (maxloc (b2, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (b2, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (b2, kind=2) .ne. 1)) stop 4 + if (any (maxloc (b2, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (b2, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (b2, 1) .ne. 1) stop 7 + if (maxloc (b2, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (b2, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (b2, 1, kind=1) .ne. 1) stop 10 + if (maxloc (b2, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (b2, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (b2, 1, l2) .ne. 1) stop 13 + if (maxloc (b2, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (b2, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (b2, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (b2, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (b2, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (b2, 1, l3) .ne. 1) stop 19 + if (maxloc (b2, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (b2, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (b2, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (b2, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (b2, 1, l3, 2, .true.) .ne. 10) stop 24 + a4 = 0 + if (any (maxloc (a4) .ne. 1)) stop 1 + if (any (maxloc (a4, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (a4, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (a4, kind=2) .ne. 1)) stop 4 + if (any (maxloc (a4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (a4, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (a4, 1) .ne. 1)) stop 7 + if (any (maxloc (a4, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (a4, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (a4, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (a4, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (a4, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (a4, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (a4, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (a4, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (a4, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (a4, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (a4, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (a4, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (a4, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (a4, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (a4, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (a4, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (a4, 1, l3, 2, .true.) .ne. 10)) stop 24 + b4 = 0 + if (any (maxloc (b4) .ne. 1)) stop 1 + if (any (maxloc (b4, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (b4, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (b4, kind=2) .ne. 1)) stop 4 + if (any (maxloc (b4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (b4, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (b4, 1) .ne. 1) stop 7 + if (maxloc (b4, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (b4, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (b4, 1, kind=1) .ne. 1) stop 10 + if (maxloc (b4, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (b4, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (b4, 1, l2) .ne. 1) stop 13 + if (maxloc (b4, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (b4, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (b4, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (b4, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (b4, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (b4, 1, l3) .ne. 1) stop 19 + if (maxloc (b4, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (b4, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (b4, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (b4, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (b4, 1, l3, 2, .true.) .ne. 10) stop 24 + a8 = 0 + if (any (maxloc (a8) .ne. 1)) stop 1 + if (any (maxloc (a8, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (a8, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (a8, kind=2) .ne. 1)) stop 4 + if (any (maxloc (a8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (a8, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (a8, 1) .ne. 1)) stop 7 + if (any (maxloc (a8, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (a8, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (a8, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (a8, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (a8, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (a8, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (a8, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (a8, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (a8, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (a8, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (a8, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (a8, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (a8, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (a8, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (a8, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (a8, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (a8, 1, l3, 2, .true.) .ne. 10)) stop 24 + b8 = 0 + if (any (maxloc (b8) .ne. 1)) stop 1 + if (any (maxloc (b8, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (b8, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (b8, kind=2) .ne. 1)) stop 4 + if (any (maxloc (b8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (b8, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (b8, 1) .ne. 1) stop 7 + if (maxloc (b8, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (b8, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (b8, 1, kind=1) .ne. 1) stop 10 + if (maxloc (b8, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (b8, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (b8, 1, l2) .ne. 1) stop 13 + if (maxloc (b8, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (b8, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (b8, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (b8, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (b8, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (b8, 1, l3) .ne. 1) stop 19 + if (maxloc (b8, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (b8, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (b8, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (b8, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (b8, 1, l3, 2, .true.) .ne. 10) stop 24 + r4 = 0.0 + if (any (maxloc (r4) .ne. 1)) stop 1 + if (any (maxloc (r4, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (r4, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (r4, kind=2) .ne. 1)) stop 4 + if (any (maxloc (r4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (r4, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (r4, 1) .ne. 1)) stop 7 + if (any (maxloc (r4, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (r4, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (r4, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (r4, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (r4, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (r4, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (r4, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (r4, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (r4, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (r4, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (r4, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (r4, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (r4, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (r4, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (r4, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (r4, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (r4, 1, l3, 2, .true.) .ne. 10)) stop 24 + s4 = 0.0 + if (any (maxloc (s4) .ne. 1)) stop 1 + if (any (maxloc (s4, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (s4, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (s4, kind=2) .ne. 1)) stop 4 + if (any (maxloc (s4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (s4, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (s4, 1) .ne. 1) stop 7 + if (maxloc (s4, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (s4, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (s4, 1, kind=1) .ne. 1) stop 10 + if (maxloc (s4, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (s4, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (s4, 1, l2) .ne. 1) stop 13 + if (maxloc (s4, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (s4, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (s4, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (s4, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (s4, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (s4, 1, l3) .ne. 1) stop 19 + if (maxloc (s4, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (s4, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (s4, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (s4, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (s4, 1, l3, 2, .true.) .ne. 10) stop 24 + r8 = 0.0 + if (any (maxloc (r8) .ne. 1)) stop 1 + if (any (maxloc (r8, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (r8, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (r8, kind=2) .ne. 1)) stop 4 + if (any (maxloc (r8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (r8, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (maxloc (r8, 1) .ne. 1)) stop 7 + if (any (maxloc (r8, 1, back=.false.) .ne. 1)) stop 8 + if (any (maxloc (r8, 1, back=.true.) .ne. 10)) stop 9 + if (any (maxloc (r8, 1, kind=1) .ne. 1)) stop 10 + if (any (maxloc (r8, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (maxloc (r8, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (maxloc (r8, 1, l1) .ne. 1)) stop 13 + if (any (maxloc (r8, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (maxloc (r8, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (maxloc (r8, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (maxloc (r8, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (maxloc (r8, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (maxloc (r8, 1, l3) .ne. 1)) stop 19 + if (any (maxloc (r8, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (maxloc (r8, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (maxloc (r8, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (maxloc (r8, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (maxloc (r8, 1, l3, 2, .true.) .ne. 10)) stop 24 + s8 = 0.0 + if (any (maxloc (s8) .ne. 1)) stop 1 + if (any (maxloc (s8, back=.false.) .ne. 1)) stop 2 + if (any (maxloc (s8, back=.true.) .ne. 10)) stop 3 + if (any (maxloc (s8, kind=2) .ne. 1)) stop 4 + if (any (maxloc (s8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (maxloc (s8, kind=8, back=.true.) .ne. 10)) stop 6 + if (maxloc (s8, 1) .ne. 1) stop 7 + if (maxloc (s8, 1, back=.false.) .ne. 1) stop 8 + if (maxloc (s8, 1, back=.true.) .ne. 10) stop 9 + if (maxloc (s8, 1, kind=1) .ne. 1) stop 10 + if (maxloc (s8, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (maxloc (s8, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (maxloc (s8, 1, l2) .ne. 1) stop 13 + if (maxloc (s8, 1, l2, back=.false.) .ne. 1) stop 14 + if (maxloc (s8, 1, l2, back=.true.) .ne. 10) stop 15 + if (maxloc (s8, 1, l2, kind=8) .ne. 1) stop 16 + if (maxloc (s8, 1, l2, 4, .false.) .ne. 1) stop 17 + if (maxloc (s8, 1, l2, 2, .true.) .ne. 10) stop 18 + if (maxloc (s8, 1, l3) .ne. 1) stop 19 + if (maxloc (s8, 1, l3, back=.false.) .ne. 1) stop 20 + if (maxloc (s8, 1, l3, back=.true.) .ne. 10) stop 21 + if (maxloc (s8, 1, l3, kind=8) .ne. 1) stop 22 + if (maxloc (s8, 1, l3, 4, .false.) .ne. 1) stop 23 + if (maxloc (s8, 1, l3, 2, .true.) .ne. 10) stop 24 + a1 = 0 + if (any (minloc (a1) .ne. 1)) stop 1 + if (any (minloc (a1, back=.false.) .ne. 1)) stop 2 + if (any (minloc (a1, back=.true.) .ne. 10)) stop 3 + if (any (minloc (a1, kind=2) .ne. 1)) stop 4 + if (any (minloc (a1, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (a1, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (a1, 1) .ne. 1)) stop 7 + if (any (minloc (a1, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (a1, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (a1, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (a1, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (a1, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (a1, 1, l1) .ne. 1)) stop 13 + if (any (minloc (a1, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (a1, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (a1, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (a1, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (a1, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (a1, 1, l3) .ne. 1)) stop 19 + if (any (minloc (a1, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (a1, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (a1, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (a1, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (a1, 1, l3, 2, .true.) .ne. 10)) stop 24 + b1 = 0 + if (any (minloc (b1) .ne. 1)) stop 1 + if (any (minloc (b1, back=.false.) .ne. 1)) stop 2 + if (any (minloc (b1, back=.true.) .ne. 10)) stop 3 + if (any (minloc (b1, kind=2) .ne. 1)) stop 4 + if (any (minloc (b1, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (b1, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (b1, 1) .ne. 1) stop 7 + if (minloc (b1, 1, back=.false.) .ne. 1) stop 8 + if (minloc (b1, 1, back=.true.) .ne. 10) stop 9 + if (minloc (b1, 1, kind=1) .ne. 1) stop 10 + if (minloc (b1, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (b1, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (b1, 1, l2) .ne. 1) stop 13 + if (minloc (b1, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (b1, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (b1, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (b1, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (b1, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (b1, 1, l3) .ne. 1) stop 19 + if (minloc (b1, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (b1, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (b1, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (b1, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (b1, 1, l3, 2, .true.) .ne. 10) stop 24 + a2 = 0 + if (any (minloc (a2) .ne. 1)) stop 1 + if (any (minloc (a2, back=.false.) .ne. 1)) stop 2 + if (any (minloc (a2, back=.true.) .ne. 10)) stop 3 + if (any (minloc (a2, kind=2) .ne. 1)) stop 4 + if (any (minloc (a2, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (a2, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (a2, 1) .ne. 1)) stop 7 + if (any (minloc (a2, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (a2, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (a2, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (a2, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (a2, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (a2, 1, l1) .ne. 1)) stop 13 + if (any (minloc (a2, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (a2, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (a2, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (a2, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (a2, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (a2, 1, l3) .ne. 1)) stop 19 + if (any (minloc (a2, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (a2, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (a2, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (a2, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (a2, 1, l3, 2, .true.) .ne. 10)) stop 24 + b2 = 0 + if (any (minloc (b2) .ne. 1)) stop 1 + if (any (minloc (b2, back=.false.) .ne. 1)) stop 2 + if (any (minloc (b2, back=.true.) .ne. 10)) stop 3 + if (any (minloc (b2, kind=2) .ne. 1)) stop 4 + if (any (minloc (b2, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (b2, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (b2, 1) .ne. 1) stop 7 + if (minloc (b2, 1, back=.false.) .ne. 1) stop 8 + if (minloc (b2, 1, back=.true.) .ne. 10) stop 9 + if (minloc (b2, 1, kind=1) .ne. 1) stop 10 + if (minloc (b2, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (b2, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (b2, 1, l2) .ne. 1) stop 13 + if (minloc (b2, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (b2, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (b2, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (b2, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (b2, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (b2, 1, l3) .ne. 1) stop 19 + if (minloc (b2, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (b2, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (b2, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (b2, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (b2, 1, l3, 2, .true.) .ne. 10) stop 24 + a4 = 0 + if (any (minloc (a4) .ne. 1)) stop 1 + if (any (minloc (a4, back=.false.) .ne. 1)) stop 2 + if (any (minloc (a4, back=.true.) .ne. 10)) stop 3 + if (any (minloc (a4, kind=2) .ne. 1)) stop 4 + if (any (minloc (a4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (a4, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (a4, 1) .ne. 1)) stop 7 + if (any (minloc (a4, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (a4, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (a4, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (a4, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (a4, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (a4, 1, l1) .ne. 1)) stop 13 + if (any (minloc (a4, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (a4, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (a4, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (a4, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (a4, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (a4, 1, l3) .ne. 1)) stop 19 + if (any (minloc (a4, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (a4, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (a4, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (a4, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (a4, 1, l3, 2, .true.) .ne. 10)) stop 24 + b4 = 0 + if (any (minloc (b4) .ne. 1)) stop 1 + if (any (minloc (b4, back=.false.) .ne. 1)) stop 2 + if (any (minloc (b4, back=.true.) .ne. 10)) stop 3 + if (any (minloc (b4, kind=2) .ne. 1)) stop 4 + if (any (minloc (b4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (b4, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (b4, 1) .ne. 1) stop 7 + if (minloc (b4, 1, back=.false.) .ne. 1) stop 8 + if (minloc (b4, 1, back=.true.) .ne. 10) stop 9 + if (minloc (b4, 1, kind=1) .ne. 1) stop 10 + if (minloc (b4, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (b4, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (b4, 1, l2) .ne. 1) stop 13 + if (minloc (b4, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (b4, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (b4, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (b4, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (b4, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (b4, 1, l3) .ne. 1) stop 19 + if (minloc (b4, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (b4, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (b4, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (b4, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (b4, 1, l3, 2, .true.) .ne. 10) stop 24 + a8 = 0 + if (any (minloc (a8) .ne. 1)) stop 1 + if (any (minloc (a8, back=.false.) .ne. 1)) stop 2 + if (any (minloc (a8, back=.true.) .ne. 10)) stop 3 + if (any (minloc (a8, kind=2) .ne. 1)) stop 4 + if (any (minloc (a8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (a8, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (a8, 1) .ne. 1)) stop 7 + if (any (minloc (a8, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (a8, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (a8, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (a8, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (a8, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (a8, 1, l1) .ne. 1)) stop 13 + if (any (minloc (a8, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (a8, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (a8, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (a8, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (a8, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (a8, 1, l3) .ne. 1)) stop 19 + if (any (minloc (a8, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (a8, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (a8, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (a8, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (a8, 1, l3, 2, .true.) .ne. 10)) stop 24 + b8 = 0 + if (any (minloc (b8) .ne. 1)) stop 1 + if (any (minloc (b8, back=.false.) .ne. 1)) stop 2 + if (any (minloc (b8, back=.true.) .ne. 10)) stop 3 + if (any (minloc (b8, kind=2) .ne. 1)) stop 4 + if (any (minloc (b8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (b8, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (b8, 1) .ne. 1) stop 7 + if (minloc (b8, 1, back=.false.) .ne. 1) stop 8 + if (minloc (b8, 1, back=.true.) .ne. 10) stop 9 + if (minloc (b8, 1, kind=1) .ne. 1) stop 10 + if (minloc (b8, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (b8, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (b8, 1, l2) .ne. 1) stop 13 + if (minloc (b8, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (b8, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (b8, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (b8, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (b8, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (b8, 1, l3) .ne. 1) stop 19 + if (minloc (b8, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (b8, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (b8, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (b8, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (b8, 1, l3, 2, .true.) .ne. 10) stop 24 + r4 = 0.0 + if (any (minloc (r4) .ne. 1)) stop 1 + if (any (minloc (r4, back=.false.) .ne. 1)) stop 2 + if (any (minloc (r4, back=.true.) .ne. 10)) stop 3 + if (any (minloc (r4, kind=2) .ne. 1)) stop 4 + if (any (minloc (r4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (r4, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (r4, 1) .ne. 1)) stop 7 + if (any (minloc (r4, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (r4, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (r4, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (r4, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (r4, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (r4, 1, l1) .ne. 1)) stop 13 + if (any (minloc (r4, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (r4, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (r4, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (r4, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (r4, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (r4, 1, l3) .ne. 1)) stop 19 + if (any (minloc (r4, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (r4, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (r4, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (r4, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (r4, 1, l3, 2, .true.) .ne. 10)) stop 24 + s4 = 0.0 + if (any (minloc (s4) .ne. 1)) stop 1 + if (any (minloc (s4, back=.false.) .ne. 1)) stop 2 + if (any (minloc (s4, back=.true.) .ne. 10)) stop 3 + if (any (minloc (s4, kind=2) .ne. 1)) stop 4 + if (any (minloc (s4, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (s4, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (s4, 1) .ne. 1) stop 7 + if (minloc (s4, 1, back=.false.) .ne. 1) stop 8 + if (minloc (s4, 1, back=.true.) .ne. 10) stop 9 + if (minloc (s4, 1, kind=1) .ne. 1) stop 10 + if (minloc (s4, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (s4, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (s4, 1, l2) .ne. 1) stop 13 + if (minloc (s4, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (s4, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (s4, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (s4, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (s4, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (s4, 1, l3) .ne. 1) stop 19 + if (minloc (s4, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (s4, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (s4, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (s4, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (s4, 1, l3, 2, .true.) .ne. 10) stop 24 + r8 = 0.0 + if (any (minloc (r8) .ne. 1)) stop 1 + if (any (minloc (r8, back=.false.) .ne. 1)) stop 2 + if (any (minloc (r8, back=.true.) .ne. 10)) stop 3 + if (any (minloc (r8, kind=2) .ne. 1)) stop 4 + if (any (minloc (r8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (r8, kind=8, back=.true.) .ne. 10)) stop 6 + if (any (minloc (r8, 1) .ne. 1)) stop 7 + if (any (minloc (r8, 1, back=.false.) .ne. 1)) stop 8 + if (any (minloc (r8, 1, back=.true.) .ne. 10)) stop 9 + if (any (minloc (r8, 1, kind=1) .ne. 1)) stop 10 + if (any (minloc (r8, 1, kind=2, back=.false.) .ne. 1)) stop 11 + if (any (minloc (r8, 1, kind=4, back=.true.) .ne. 10)) stop 12 + if (any (minloc (r8, 1, l1) .ne. 1)) stop 13 + if (any (minloc (r8, 1, l1, back=.false.) .ne. 1)) stop 14 + if (any (minloc (r8, 1, l1, back=.true.) .ne. 10)) stop 15 + if (any (minloc (r8, 1, l1, kind=8) .ne. 1)) stop 16 + if (any (minloc (r8, 1, l1, 4, .false.) .ne. 1)) stop 17 + if (any (minloc (r8, 1, l1, 2, .true.) .ne. 10)) stop 18 + if (any (minloc (r8, 1, l3) .ne. 1)) stop 19 + if (any (minloc (r8, 1, l3, back=.false.) .ne. 1)) stop 20 + if (any (minloc (r8, 1, l3, back=.true.) .ne. 10)) stop 21 + if (any (minloc (r8, 1, l3, kind=8) .ne. 1)) stop 22 + if (any (minloc (r8, 1, l3, 4, .false.) .ne. 1)) stop 23 + if (any (minloc (r8, 1, l3, 2, .true.) .ne. 10)) stop 24 + s8 = 0.0 + if (any (minloc (s8) .ne. 1)) stop 1 + if (any (minloc (s8, back=.false.) .ne. 1)) stop 2 + if (any (minloc (s8, back=.true.) .ne. 10)) stop 3 + if (any (minloc (s8, kind=2) .ne. 1)) stop 4 + if (any (minloc (s8, kind=4, back=.false.) .ne. 1)) stop 5 + if (any (minloc (s8, kind=8, back=.true.) .ne. 10)) stop 6 + if (minloc (s8, 1) .ne. 1) stop 7 + if (minloc (s8, 1, back=.false.) .ne. 1) stop 8 + if (minloc (s8, 1, back=.true.) .ne. 10) stop 9 + if (minloc (s8, 1, kind=1) .ne. 1) stop 10 + if (minloc (s8, 1, kind=2, back=.false.) .ne. 1) stop 11 + if (minloc (s8, 1, kind=4, back=.true.) .ne. 10) stop 12 + if (minloc (s8, 1, l2) .ne. 1) stop 13 + if (minloc (s8, 1, l2, back=.false.) .ne. 1) stop 14 + if (minloc (s8, 1, l2, back=.true.) .ne. 10) stop 15 + if (minloc (s8, 1, l2, kind=8) .ne. 1) stop 16 + if (minloc (s8, 1, l2, 4, .false.) .ne. 1) stop 17 + if (minloc (s8, 1, l2, 2, .true.) .ne. 10) stop 18 + if (minloc (s8, 1, l3) .ne. 1) stop 19 + if (minloc (s8, 1, l3, back=.false.) .ne. 1) stop 20 + if (minloc (s8, 1, l3, back=.true.) .ne. 10) stop 21 + if (minloc (s8, 1, l3, kind=8) .ne. 1) stop 22 + if (minloc (s8, 1, l3, 4, .false.) .ne. 1) stop 23 + if (minloc (s8, 1, l3, 2, .true.) .ne. 10) stop 24 +end diff --git a/gcc/testsuite/gfortran.dg/pr120191_2.f90 b/gcc/testsuite/gfortran.dg/pr120191_2.f90 new file mode 100644 index 0000000..6334286 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120191_2.f90 @@ -0,0 +1,84 @@ +! PR fortran/120191 +! { dg-do run } + + character(kind=1, len=2) :: a(4, 4, 4), b(4) + logical :: l(4, 4, 4), m, n(4) + a = 'aa' + b = 'aa' + l = .true. + m = .true. + n = .true. + if (any (maxloc (a) .ne. 1)) stop 1 + if (any (maxloc (a, dim=1) .ne. 1)) stop 2 + if (any (maxloc (a, 1) .ne. 1)) stop 3 + if (any (maxloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 1)) stop 4 + if (any (maxloc (a, 1, l, 4, .false.) .ne. 1)) stop 5 + if (any (maxloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 1)) stop 6 + if (any (maxloc (a, 1, m, 4, .false.) .ne. 1)) stop 7 + if (any (maxloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 4)) stop 8 + if (any (maxloc (a, 1, l, 4, .true.) .ne. 4)) stop 9 + if (any (maxloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 4)) stop 10 + if (any (maxloc (a, 1, m, 4, .true.) .ne. 4)) stop 11 + if (any (maxloc (b) .ne. 1)) stop 12 + if (maxloc (b, dim=1) .ne. 1) stop 13 + if (maxloc (b, 1) .ne. 1) stop 14 + if (maxloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 1) stop 15 + if (maxloc (b, 1, n, 4, .false.) .ne. 1) stop 16 + if (maxloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 1) stop 17 + if (maxloc (b, 1, m, 4, .false.) .ne. 1) stop 18 + if (maxloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 4) stop 19 + if (maxloc (b, 1, n, 4, .true.) .ne. 4) stop 20 + if (maxloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 4) stop 21 + if (maxloc (b, 1, m, 4, .true.) .ne. 4) stop 22 + l = .false. + m = .false. + n = .false. + if (any (maxloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 0)) stop 23 + if (any (maxloc (a, 1, l, 4, .false.) .ne. 0)) stop 24 + if (maxloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 0) stop 25 + if (maxloc (b, 1, n, 4, .false.) .ne. 0) stop 26 + if (maxloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 0) stop 27 + if (maxloc (b, 1, m, 4, .false.) .ne. 0) stop 28 + if (maxloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 0) stop 29 + if (maxloc (b, 1, n, 4, .true.) .ne. 0) stop 30 + if (maxloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 0) stop 31 + if (maxloc (b, 1, m, 4, .true.) .ne. 0) stop 32 + l = .true. + m = .true. + n = .true. + if (any (minloc (a) .ne. 1)) stop 1 + if (any (minloc (a, dim=1) .ne. 1)) stop 2 + if (any (minloc (a, 1) .ne. 1)) stop 3 + if (any (minloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 1)) stop 4 + if (any (minloc (a, 1, l, 4, .false.) .ne. 1)) stop 5 + if (any (minloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 1)) stop 6 + if (any (minloc (a, 1, m, 4, .false.) .ne. 1)) stop 7 + if (any (minloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 4)) stop 8 + if (any (minloc (a, 1, l, 4, .true.) .ne. 4)) stop 9 + if (any (minloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 4)) stop 10 + if (any (minloc (a, 1, m, 4, .true.) .ne. 4)) stop 11 + if (any (minloc (b) .ne. 1)) stop 12 + if (minloc (b, dim=1) .ne. 1) stop 13 + if (minloc (b, 1) .ne. 1) stop 14 + if (minloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 1) stop 15 + if (minloc (b, 1, n, 4, .false.) .ne. 1) stop 16 + if (minloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 1) stop 17 + if (minloc (b, 1, m, 4, .false.) .ne. 1) stop 18 + if (minloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 4) stop 19 + if (minloc (b, 1, n, 4, .true.) .ne. 4) stop 20 + if (minloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 4) stop 21 + if (minloc (b, 1, m, 4, .true.) .ne. 4) stop 22 + l = .false. + m = .false. + n = .false. + if (any (minloc (a, dim=1, mask=l, kind=4, back=.false.) .ne. 0)) stop 23 + if (any (minloc (a, 1, l, 4, .false.) .ne. 0)) stop 24 + if (minloc (b, dim=1, mask=n, kind=4, back=.false.) .ne. 0) stop 25 + if (minloc (b, 1, n, 4, .false.) .ne. 0) stop 26 + if (minloc (b, dim=1, mask=m, kind=4, back=.false.) .ne. 0) stop 27 + if (minloc (b, 1, m, 4, .false.) .ne. 0) stop 28 + if (minloc (b, dim=1, mask=n, kind=4, back=.true.) .ne. 0) stop 29 + if (minloc (b, 1, n, 4, .true.) .ne. 0) stop 30 + if (minloc (b, dim=1, mask=m, kind=4, back=.true.) .ne. 0) stop 31 + if (minloc (b, 1, m, 4, .true.) .ne. 0) stop 32 +end diff --git a/gcc/testsuite/gfortran.dg/pr120191_3.f90 b/gcc/testsuite/gfortran.dg/pr120191_3.f90 new file mode 100644 index 0000000..26e4095 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120191_3.f90 @@ -0,0 +1,23 @@ +! PR fortran/120191 +! { dg-do run } + + character(kind=1, len=2) :: a(4, 4, 4), b(4) + logical :: l(4, 4, 4), m, n(4) + a = 'aa' + b = 'aa' + l = .false. + m = .false. + n = .false. + if (any (maxloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 0)) stop 1 + if (any (maxloc (a, 1, m, 4, .false.) .ne. 0)) stop 2 + if (any (maxloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 0)) stop 3 + if (any (maxloc (a, 1, l, 4, .true.) .ne. 0)) stop 4 + if (any (maxloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 0)) stop 5 + if (any (maxloc (a, 1, m, 4, .true.) .ne. 0)) stop 6 + if (any (minloc (a, dim=1, mask=m, kind=4, back=.false.) .ne. 0)) stop 7 + if (any (minloc (a, 1, m, 4, .false.) .ne. 0)) stop 8 + if (any (minloc (a, dim=1, mask=l, kind=4, back=.true.) .ne. 0)) stop 9 + if (any (minloc (a, 1, l, 4, .true.) .ne. 0)) stop 10 + if (any (minloc (a, dim=1, mask=m, kind=4, back=.true.) .ne. 0)) stop 11 + if (any (minloc (a, 1, m, 4, .true.) .ne. 0)) stop 12 +end diff --git a/gcc/testsuite/gfortran.dg/pr120196.f90 b/gcc/testsuite/gfortran.dg/pr120196.f90 new file mode 100644 index 0000000..368c43a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120196.f90 @@ -0,0 +1,26 @@ +! PR libfortran/120196 +! { dg-do run } + +program pr120196 + character(len=:, kind=1), allocatable :: a(:), s + character(len=:, kind=4), allocatable :: b(:), t + logical, allocatable :: l(:) + logical :: m + allocate (character(len=16, kind=1) :: a(10), s) + allocate (l(10)) + a(:) = "" + s = "*" + l = .true. + m = .true. + if (findloc (a, s, dim=1, back=.true.) .ne. 0) stop 1 + if (findloc (a, s, mask=l, dim=1, back=.true.) .ne. 0) stop 2 + if (findloc (a, s, mask=m, dim=1, back=.true.) .ne. 0) stop 3 + deallocate (a, s) + allocate (character(len=16, kind=4) :: b(10), t) + b(:) = "" + t = "*" + if (findloc (b, t, dim=1, back=.true.) .ne. 0) stop 4 + if (findloc (b, t, mask=l, dim=1, back=.true.) .ne. 0) stop 5 + if (findloc (b, t, mask=m, dim=1, back=.true.) .ne. 0) stop 6 + deallocate (b, t, l) +end program pr120196 diff --git a/gcc/testsuite/gfortran.dg/pr120743.f90 b/gcc/testsuite/gfortran.dg/pr120743.f90 new file mode 100644 index 0000000..8682d0c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr120743.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! PR fortran/120743 - ICE in verify_gimple_in_seq with substrings +! +! Testcase as reduced by Jerry DeLisle + +module what + implicit none + CHARACTER(LEN=:), ALLOCATABLE :: attrlist +contains + SUBROUTINE get_c_attr ( attrname, attrval_c ) + ! + ! returns attrval_c='' if not found + ! + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: attrname + CHARACTER(LEN=*), INTENT(OUT) :: attrval_c + ! + CHARACTER(LEN=1) :: quote + INTEGER :: j0, j1 + LOGICAL :: found + ! + ! search for attribute name in attrlist: attr1="val1" attr2="val2" ... + ! + attrval_c = '' + if ( .not. allocated(attrlist) ) return + if ( len_trim(attrlist) < 1 ) return + ! + j0 = 1 + do while ( j0 < len_trim(attrlist) ) + ! locate = and first quote + j1 = index ( attrlist(j0:), '=' ) + quote = attrlist(j0+j1:j0+j1) + ! next line: something is not right + if ( quote /= '"' .and. quote /= "'" ) return + end do + ! + END SUBROUTINE get_c_attr +end module what diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 index cb7cf70..421d247 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_52.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-additional-options "-fcheck=pointer" } ! ! Test the fix for PRs93924 & 93925. ! diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_57.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_57.f90 new file mode 100644 index 0000000..7ecb88f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_57.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-additional-options "-fcheck=pointer" } +! +! PR fortran/102900 + +module cs + implicit none + interface + function classStar_map_ifc() result(y) + import + class(*), pointer :: y + end function classStar_map_ifc + end interface + +contains + + function selector() + procedure(classStar_map_ifc), pointer :: selector + selector => NULL() + end function selector + + function selector_result() result(f) + procedure(classStar_map_ifc), pointer :: f + f => NULL() + end function selector_result + + function fun(x) result(y) + class(*), pointer :: y + class(*), target, intent(in) :: x + select type (x) + class default + y => null() + end select + end function fun + +end module cs 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/save_8.f90 b/gcc/testsuite/gfortran.dg/save_8.f90 new file mode 100644 index 0000000..8e9198c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/save_8.f90 @@ -0,0 +1,13 @@ +!{ dg-do run } + +! Check PR120483 is fixed. +! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> +! and Peter Güntert <peter@guentert.com> + +program save_8 + implicit none + character(len=:), allocatable, save :: s1 + s1 = 'ABC' + if (s1(3:3) /= 'C') stop 1 +end program save_8 + diff --git a/gcc/testsuite/gfortran.dg/save_alloc_character_1.f90 b/gcc/testsuite/gfortran.dg/save_alloc_character_1.f90 new file mode 100644 index 0000000..e26919f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/save_alloc_character_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR fortran/120713 +! Check that the length variable of SAVEd allocatable character arrays are +! not initialized at function entry. + +program p + implicit none + call s(1) + call s(2) +contains + subroutine s(i) + integer, intent(in) :: i + character(len=:), allocatable, save :: a(:) + integer :: j + if (i == 1) then + allocate(a, source= [ ('x' // achar(ichar('0') + j), j=1,7) ]) + else + if (len(a) /= 2) error stop 1 + if (any(a /= ['x1','x2','x3','x4','x5','x6','x7'])) error stop 2 + end if + end subroutine s +end program p diff --git a/gcc/testsuite/gfortran.dg/select_type_51.f90 b/gcc/testsuite/gfortran.dg/select_type_51.f90 new file mode 100644 index 0000000..6099be1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_51.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! Check the support by the compiler of very long symbol names in SELECT TYPE +! and TYPE IS statements. +! +! Original testcase by Harald Anlauf. + +module m + implicit none + type t2345678901234567890123456789012345678901234567890123456789_123 + integer :: i + end type t2345678901234567890123456789012345678901234567890123456789_123 + class(*), allocatable :: a, & + c2345678901234567890123456789012345678901234567890123456789_123 +contains + subroutine check_type_is_intrinsic() + select type (s2345678901234567890123456789012345678901234567890123456789_123 & + => c2345678901234567890123456789012345678901234567890123456789_123) + type is (integer(kind=4)) + print *, s2345678901234567890123456789012345678901234567890123456789_123 + end select + end subroutine + subroutine check_type_is_derived() + select type (s2345678901234567890123456789012345678901234567890123456789_123 & + => c2345678901234567890123456789012345678901234567890123456789_123) + type is (t2345678901234567890123456789012345678901234567890123456789_123) + print *, s2345678901234567890123456789012345678901234567890123456789_123%i + end select + end subroutine + subroutine check_type_is_class() + select type (s2345678901234567890123456789012345678901234567890123456789_123 & + => c2345678901234567890123456789012345678901234567890123456789_123) + class is (t2345678901234567890123456789012345678901234567890123456789_123) + print *, s2345678901234567890123456789012345678901234567890123456789_123%i + end select + end subroutine +end module m diff --git a/gcc/testsuite/gfortran.dg/stat_3.f90 b/gcc/testsuite/gfortran.dg/stat_3.f90 new file mode 100644 index 0000000..93ec183 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stat_3.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! PR fortran/82480 - checking of arguments to STAT/LSTAT/FSTAT + +subroutine sub1 () + integer, parameter :: ik = kind(1) + integer(ik) :: buff12(12) + integer(ik) :: buff13(13) + integer(ik) :: unit = 10 + integer(ik) :: ierr + character(len=64) :: name = "/etc/passwd" + ierr = stat (name, values= buff12) ! { dg-error "too small" } + ierr = stat (name, values= buff13) + ierr = lstat (name, values= buff12) ! { dg-error "too small" } + ierr = lstat (name, values= buff13) + ierr = fstat (unit, values= buff12) ! { dg-error "too small" } + ierr = fstat (unit, values= buff13) + ierr = stat (name, values=(buff13)) ! { dg-error "must be a variable" } + ierr = lstat (name, values=(buff13)) ! { dg-error "must be a variable" } + ierr = fstat (unit, values=(buff13)) ! { dg-error "must be a variable" } +end + +subroutine sub2 () + integer, parameter :: ik = kind(1) + integer(ik) :: buff12(12) + integer(ik), target :: buff13(13) = 0 + integer(ik) :: unit = 10 + integer(ik), target :: ierr = 0 + character(len=64) :: name = "/etc/passwd" + integer(ik),pointer :: pbuf(:) => buff13 + integer(ik),pointer :: perr => ierr + call stat (name, status=ierr, values= buff12) ! { dg-error "too small" } + call stat (name, status=ierr, values= buff13) + call lstat (name, status=ierr, values= buff12) ! { dg-error "too small" } + call lstat (name, status=ierr, values= buff13) + call fstat (unit, status=ierr, values= buff12) ! { dg-error "too small" } + call fstat (unit, status=ierr, values= buff13) + call stat (name, status=ierr, values=(buff13)) ! { dg-error "must be a variable" } + call lstat (name, status=ierr, values=(buff13)) ! { dg-error "must be a variable" } + call fstat (unit, status=ierr, values=(buff13)) ! { dg-error "must be a variable" } + call stat (name, status=(ierr),values=buff13) ! { dg-error "must be a variable" } + call lstat (name, status=(ierr),values=buff13) ! { dg-error "must be a variable" } + call fstat (unit, status=(ierr),values=buff13) ! { dg-error "must be a variable" } + call stat (name, status=perr, values= pbuf) + call lstat (name, status=perr, values= pbuf) + call fstat (unit, status=perr, values= pbuf) +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" } } diff --git a/gcc/testsuite/gfortran.dg/transfer_array_subref.f90 b/gcc/testsuite/gfortran.dg/transfer_array_subref.f90 new file mode 100644 index 0000000..b480dff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_array_subref.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-additional-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/102891 - passing of inquiry ref of complex array to TRANSFER + +program main + implicit none + integer, parameter :: dp = 8 + + type complex_wrap1 + complex(dp) :: z(2) + end type complex_wrap1 + + type complex_wrap2 + complex(dp), dimension(:), allocatable :: z + end type complex_wrap2 + + type(complex_wrap1) :: x = complex_wrap1([ (1, 2), (3, 4) ]) + type(complex_wrap2) :: w + + w%z = x%z + + ! The following statements should get optimized away... + if (size (transfer ( x%z%re ,[1.0_dp])) /= 2) error stop 1 + if (size (transfer ((x%z%re),[1.0_dp])) /= 2) error stop 2 + if (size (transfer ([x%z%re],[1.0_dp])) /= 2) error stop 3 + if (size (transfer ( x%z%im ,[1.0_dp])) /= 2) error stop 4 + if (size (transfer ((x%z%im),[1.0_dp])) /= 2) error stop 5 + if (size (transfer ([x%z%im],[1.0_dp])) /= 2) error stop 6 + + ! ... while the following may not: + if (any (transfer ( x%z%re ,[1.0_dp]) /= x%z%re)) stop 7 + if (any (transfer ( x%z%im ,[1.0_dp]) /= x%z%im)) stop 8 + + if (size (transfer ( w%z%re ,[1.0_dp])) /= 2) stop 11 + if (size (transfer ((w%z%re),[1.0_dp])) /= 2) stop 12 + if (size (transfer ([w%z%re],[1.0_dp])) /= 2) stop 13 + if (size (transfer ( w%z%im ,[1.0_dp])) /= 2) stop 14 + if (size (transfer ((w%z%im),[1.0_dp])) /= 2) stop 15 + if (size (transfer ([w%z%im],[1.0_dp])) /= 2) stop 16 + + if (any (transfer ( w%z%re ,[1.0_dp]) /= x%z%re)) stop 17 + if (any (transfer ( w%z%im ,[1.0_dp]) /= x%z%im)) stop 18 + + deallocate (w%z) +end program main + +! { dg-final { scan-tree-dump-not "_gfortran_error_stop_numeric" "optimized" } } |