diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
288 files changed, 9868 insertions, 423 deletions
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 index c399e71..43a0115 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-additional-sources ISO_Fortran_binding_17.c } ! { dg-options "-fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! PR fortran/92470 ! diff --git a/gcc/testsuite/gfortran.dg/actual_procedure_2.f b/gcc/testsuite/gfortran.dg/actual_procedure_2.f new file mode 100644 index 0000000..247ebc1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_procedure_2.f @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/50377 +! +! Reject procedures passed as actual argument if there is no explicit +! interface and they are not declared EXTERNAL +! +! Contributed by Vittorio Zecca + +! external sub ! Required for valid code +! external fun ! Required for valid code + call sub(sub) ! { dg-error "used as actual argument" } + z = fun(fun) ! { dg-error "used as actual argument" } + end + + subroutine sub(y) + external y + end + + real function fun(z) + external z + f = 1. + end diff --git a/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 b/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 index dcc2d7c..a231a4d 100644 --- a/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 +++ b/gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90 @@ -48,19 +48,19 @@ contains subroutine foo1 (slist, i) character(*), dimension(*) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo1 subroutine foo2 (slist, i) character(5), dimension(:) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo2 subroutine foo3 (slist, i) character(5), dimension(:,:) :: slist integer i - write (slist(1,1), '(2hi=,i3)') i + write (slist(1,1), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo3 end program test_lex diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 new file mode 100644 index 0000000..7a659f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_17.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! PR fortran/121616 +! +! Test fix for intrinsic assignment to allocatable scalar polymorphic component + +program p + call pr121616 () + call test_ts () +end + +! Derived from original PR (contributed by Jean Vézina) +subroutine pr121616 () + implicit none + integer :: i + type general + class(*), allocatable :: x + end type general + type(general) :: a(4), b(4) + ! Intrinsic assignment to a variable of unlimited polymorphic type + a(1)%x = 1 + a(2)%x = 3.14 + a(3)%x = .true. + a(4)%x = 'abc' + ! The workaround was to use a structure constructor + b(1) = general(1) + b(2) = general(3.14) + b(3) = general(.true.) + b(4) = general('abc') + do i = 1, 4 + if (.not. allocated (a(i)%x)) stop 10+i + if (.not. allocated (b(i)%x)) stop 20+i + call prt (a(i)%x, b(i)%x) + end do + do i = 1, 4 + deallocate (a(i)%x, b(i)%x) + end do +contains + subroutine prt (x, y) + class(*), intent(in) :: x, y + select type (v=>x) + type is (integer) + print *,v + type is (real) + print *,v + type is (logical) + print *,v + type is (character(*)) + print *,v + class default + error stop 99 + end select + if (.not. same_type_as (x, y)) stop 30+i + end subroutine prt +end + +! Contributed by a friend (private communication) +subroutine test_ts () + implicit none + + type :: t_inner + integer :: i + end type + + type :: t_outer + class(t_inner), allocatable :: inner + end type + + class(t_inner), allocatable :: inner + type(t_outer), allocatable :: outer(:) + integer :: i + + allocate(t_inner :: inner) + inner% i = 0 + + !------------------------------------------------ + ! Size of outer must be > 1 for the bug to appear + !------------------------------------------------ + allocate(outer(2)) + + !------------------------------ + ! Loop is necessary for the bug + !------------------------------ + do i = 1, size(outer) + write(*,*) i + !---------------------------------------------------- + ! Expect intrinsic assignment to polymorphic variable + !---------------------------------------------------- + outer(i)% inner = inner + deallocate (outer(i)% inner) + end do + + write(*,*) 'Loop DONE' + deallocate(outer) + deallocate(inner) + write(*,*) 'Dellocation DONE' +end 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/alloc_comp_deep_copy_5.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_5.f90 new file mode 100644 index 0000000..c0b305e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_5.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-additional-options "-Wa,--noexecstack" { target gas } } +! { dg-additional-options "-Wl,-z,noexecstack" { target gld } } +! +! PR fortran/121628 +! Test deep copy of recursive allocatable array components with multi-level +! nesting and repeated circular assignments. This test ensures: +! 1. Deep copy works correctly for grandchildren (multi-level recursion) +! 2. Repeated circular assignments don't cause memory corruption/double-free +! 3. No trampolines are generated (verified by noexecstack flags) +! +! Contributed by Christopher Albert <albert@tugraz.at> +! and Harald Anlauf <anlauf@gcc.gnu.org> +! +program alloc_comp_deep_copy_5 + implicit none + + type :: nested_t + character(len=10) :: name + type(nested_t), allocatable :: children(:) + end type nested_t + + type(nested_t) :: a, b + + ! Build a tree with grandchildren + b%name = "root" + allocate (b%children(2)) + b%children(1)%name = "child1" + b%children(2)%name = "child2" + allocate (b%children(1)%children(1)) + b%children(1)%children(1)%name = "grandchild" + + ! Test 1: Initial assignment + a = b + if (.not. allocated(a%children)) stop 1 + if (.not. allocated(a%children(1)%children)) stop 2 + if (a%children(1)%children(1)%name /= "grandchild") stop 3 + + ! Verify deep copy by modifying a + a%children(1)%children(1)%name = "modified" + if (b%children(1)%children(1)%name /= "grandchild") stop 4 + if (a%children(1)%children(1)%name /= "modified") stop 5 + + ! Test 2: Circular assignment b=a (should not corrupt memory) + b = a + if (.not. allocated(a%children)) stop 6 + if (.not. allocated(a%children(1)%children)) stop 7 + if (.not. allocated(b%children)) stop 8 + if (.not. allocated(b%children(1)%children)) stop 9 + + ! Test 3: Circular assignment a=b (stress test) + a = b + if (.not. allocated(a%children)) stop 10 + if (.not. allocated(a%children(1)%children)) stop 11 + + ! Test 4: Another circular assignment (triggered double-free in buggy code) + b = a + if (.not. allocated(b%children)) stop 12 + if (.not. allocated(b%children(1)%children)) stop 13 + + ! Verify final state + if (b%children(1)%children(1)%name /= "modified") stop 14 +end program alloc_comp_deep_copy_5 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_6.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_6.f90 new file mode 100644 index 0000000..ae20d5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_6.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! { dg-additional-options "-Wa,--noexecstack" { target gas } } +! { dg-additional-options "-Wl,-z,noexecstack" { target gld } } +! +! PR fortran/121628 +! Test deep copy of recursive allocatable components with both data arrays +! and recursive children. This is a comprehensive test combining: +! 1. Allocatable data arrays (values) +! 2. Recursive allocatable arrays (children) +! 3. Multi-level tree structure +! 4. Complete data integrity verification after deep copy +! 5. No trampolines (noexecstack flags) +! +! Contributed by Christopher Albert <albert@tugraz.at> +! +program alloc_comp_deep_copy_6 + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + + type :: nested_t + real(dp), allocatable :: values(:) + type(nested_t), allocatable :: children(:) + end type nested_t + + type(nested_t) :: a, b + + ! Build nested structure with both values and children + allocate (b%values(3)) + b%values = [1.0_dp, 2.0_dp, 3.0_dp] + + allocate (b%children(2)) + allocate (b%children(1)%values(2)) + b%children(1)%values = [4.0_dp, 5.0_dp] + + allocate (b%children(2)%values(1)) + b%children(2)%values = [6.0_dp] + + ! Deeper nesting + allocate (b%children(1)%children(1)) + allocate (b%children(1)%children(1)%values(2)) + b%children(1)%children(1)%values = [7.0_dp, 8.0_dp] + + ! Deep copy + a = b + + ! Verify allocation status + if (.not. allocated(a%values)) stop 1 + if (.not. allocated(a%children)) stop 2 + if (.not. allocated(a%children(1)%values)) stop 3 + if (.not. allocated(a%children(2)%values)) stop 4 + if (.not. allocated(a%children(1)%children)) stop 5 + if (.not. allocated(a%children(1)%children(1)%values)) stop 6 + + ! Verify data integrity + if (any(a%values /= [1.0_dp, 2.0_dp, 3.0_dp])) stop 7 + if (any(a%children(1)%values /= [4.0_dp, 5.0_dp])) stop 8 + if (any(a%children(2)%values /= [6.0_dp])) stop 9 + if (any(a%children(1)%children(1)%values /= [7.0_dp, 8.0_dp])) stop 10 + + ! Verify deep copy: modify a and ensure b is unchanged + a%values(1) = -1.0_dp + a%children(1)%values(1) = -2.0_dp + a%children(2)%values(1) = -3.0_dp + a%children(1)%children(1)%values(1) = -4.0_dp + + if (any(b%values /= [1.0_dp, 2.0_dp, 3.0_dp])) stop 11 + if (any(b%children(1)%values /= [4.0_dp, 5.0_dp])) stop 12 + if (any(b%children(2)%values /= [6.0_dp])) stop 13 + if (any(b%children(1)%children(1)%values /= [7.0_dp, 8.0_dp])) stop 14 + + if (any(a%values /= [-1.0_dp, 2.0_dp, 3.0_dp])) stop 15 + if (any(a%children(1)%values /= [-2.0_dp, 5.0_dp])) stop 16 + if (any(a%children(2)%values /= [-3.0_dp])) stop 17 + if (any(a%children(1)%children(1)%values /= [-4.0_dp, 8.0_dp])) stop 18 +end program alloc_comp_deep_copy_6 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_7.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_7.f90 new file mode 100644 index 0000000..749a712 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_7.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/121628 +! Test that derived types with multiple recursive allocatable array +! components compile without ICE. This was broken by the initial deep-copy +! patch which caused infinite compile-time recursion due to seen_derived_types +! persisting across wrapper generation. +! +! The fix saves and restores seen_derived_types when generating element +! copy wrappers to prevent inheriting parent context state. +! + +program alloc_comp_deep_copy_7 + implicit none + + type :: nested_t + type(nested_t), allocatable :: children(:) + type(nested_t), allocatable :: relatives(:) + end type nested_t + + type(nested_t) :: a + +end program alloc_comp_deep_copy_7 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/argument_checking_15.f90 b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 index e79541f..63931a2 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_15.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 @@ -45,8 +45,8 @@ subroutine test() implicit none character(len=5), pointer :: c character(len=5) :: str(5) -call foo(c) ! { dg-warning "Character length mismatch" } -call bar(str) ! { dg-warning "Character length mismatch" } +call foo(c) ! { dg-error "Character length mismatch" } +call bar(str) ! { dg-error "Character length mismatch" } contains subroutine foo(a) character(len=3), pointer :: a diff --git a/gcc/testsuite/gfortran.dg/argument_checking_27.f90 b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 new file mode 100644 index 0000000..06dd187 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 @@ -0,0 +1,240 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018 -Wcharacter-truncation" } +! PR fortran/93330 +! +! Exercise compile-time checking of character length of dummy vs. +! actual arguments. Based on original testcase by Tobias Burnus + +module m + use iso_c_binding, only: c_char + implicit none +contains + ! scalar dummy + ! character(kind=1): + subroutine zero(x, y) + character(kind=1,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero >', x, '< >', y, '<' + end + subroutine one(x, y) + character(kind=1,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one >', x, '< >', y, '<' + end + subroutine two(x, y) + character(kind=1,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two >', x, '< >', y, '<' + end + subroutine cbind(x, y) bind(C) + character(kind=c_char,len=1), value :: x + character(kind=c_char,len=1), value :: y + print '(5a)','cbind >', x, '< >', y, '<' + end + + ! character(kind=4): + subroutine zero4(x, y) + character(kind=4,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero4 >', x, '< >', y, '<' + end + subroutine one4(x, y) + character(kind=4,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one4 >', x, '< >', y, '<' + end + subroutine two4(x, y) + character(kind=4,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two4 >', x, '< >', y, '<' + end + + ! character(kind=1): + ! array dummy, assumed size + subroutine zero_0(x, y) + character(kind=1,len=0) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_0 >', x(1), '< >', y, '<' + end + subroutine one_0(x, y) + character(kind=1,len=1) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','one_0 >', x(1), '< >', y, '<' + end + subroutine two_0(x, y) + character(kind=1,len=2) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','two_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero_1(x, y) + character(kind=1,len=0) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_1 >', x(1), '< >', y, '<' + end + subroutine one_1(x, y) + character(kind=1,len=1) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','one_1 >', x(1), '< >', y, '<' + end + subroutine two_1(x, y) + character(kind=1,len=2) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','two_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero_a(x, y) + character(kind=1,len=0) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero_a >', x(1), '< >', y, '<' + end + subroutine one_a(x, y) + character(kind=1,len=1) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one_a >', x(1), '< >', y, '<' + end + subroutine two_a(x, y) + character(kind=1,len=2) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two_a >', x(1), '< >', y, '<' + end + + ! character(kind=4): + ! array dummy, assumed size + subroutine zero4_0(x, y) + character(kind=4,len=0) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_0 >', x(1), '< >', y, '<' + end + subroutine one4_0(x, y) + character(kind=4,len=1) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','one4_0 >', x(1), '< >', y, '<' + end + subroutine two4_0(x, y) + character(kind=4,len=2) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','two4_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero4_1(x, y) + character(kind=4,len=0) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_1 >', x(1), '< >', y, '<' + end + subroutine one4_1(x, y) + character(kind=4,len=1) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','one4_1 >', x(1), '< >', y, '<' + end + subroutine two4_1(x, y) + character(kind=4,len=2) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','two4_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero4_a(x, y) + character(kind=4,len=0) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero4_a >', x(1), '< >', y, '<' + end + subroutine one4_a(x, y) + character(kind=4,len=1) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one4_a >', x(1), '< >', y, '<' + end + subroutine two4_a(x, y) + character(kind=4,len=2) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two4_a >', x(1), '< >', y, '<' + end +end + +program p + use m + implicit none + call zero('', '1') + call one ('', '2') ! { dg-error "length of actual argument shorter" } + call one ('b'(3:2),'3') ! { dg-error "length of actual argument shorter" } + call two ('', '4') ! { dg-error "length of actual argument shorter" } + call two ('f','5') ! { dg-error "length of actual argument shorter" } + + call cbind('', '6') ! { dg-error "length of actual argument shorter" } + call cbind('ABC','7') ! { dg-warning "length of actual argument longer" } + + ! character(kind=4): + call zero4(4_'', '8') + call zero4(4_'3','9') ! { dg-warning "length of actual argument longer" } + call one4 (4_'', 'A') ! { dg-error "length of actual argument shorter" } + call one4 (4_'b'(3:2),'B') ! { dg-error "length of actual argument shorter" } + call one4 (4_'bbcd'(3:3),'C') + call one4 (4_'cd','D') ! { dg-warning "length of actual argument longer" } + call two4 (4_'', 'E') ! { dg-error "length of actual argument shorter" } + call two4 (4_'f', 'F') ! { dg-error "length of actual argument shorter" } + call two4 (4_'fgh','G') ! { dg-warning "length of actual argument longer" } + + ! array dummy, assumed size + call zero_0([''],'a') + call zero_0(['a'],'b') + call one_0 ([''],'c') + call one_0 (['b'],'d') + call one_0 (['cd'],'e') + call two_0 ([''],'f') + call two_0 (['fg'],'g') + + ! array dummy, explicit size + call zero_1([''],'a') + call zero_1(['a'],'b') ! { dg-warning "actual argument longer" } + call one_1 ([''],'c') ! { dg-error "too few elements for dummy" } + call one_1 (['b'],'d') + call one_1 (['cd'],'e') ! { dg-warning "actual argument longer" } + call two_1 ([''],'f') ! { dg-error "too few elements for dummy" } + call two_1 (['fg'],'h') + + ! array dummy, assumed shape + call zero_a([''],'a') + call zero_a(['a'],'b') ! { dg-error "Character length mismatch" } + call one_a ([''],'c') ! { dg-error "Character length mismatch" } + call one_a (['b'],'d') + call one_a (['cd'],'e') ! { dg-error "Character length mismatch" } + call two_a ([''],'f') ! { dg-error "Character length mismatch" } + call two_a (['fg'],'h') + + ! character(kind=4): + ! array dummy, assumed size + call zero4_0([4_''],4_'a') + call zero4_0([4_'a'],4_'b') + call one4_0 ([4_''],4_'c') + call one4_0 ([4_'b'],4_'d') + call one4_0 ([4_'cd'],4_'e') + call two4_0 ([4_''],4_'f') + call two4_0 ([4_'fg'],4_'g') + + ! array dummy, explicit size + call zero4_1([4_''],4_'a') + call zero4_1([4_'a'],4_'b') ! { dg-warning "actual argument longer" } + call one4_1 ([4_''],4_'c') ! { dg-error "too few elements for dummy" } + call one4_1 ([4_'b'],4_'d') + call one4_1 ([4_'cd'],4_'e') ! { dg-warning "actual argument longer" } + call two4_1 ([4_''],4_'f') ! { dg-error "too few elements for dummy" } + call two4_1 ([4_'fg'],4_'h') + + ! array dummy, assumed shape + call zero4_a([4_''],4_'a') + call zero4_a([4_'a'],4_'b') ! { dg-error "Character length mismatch" } + call one4_a ([4_''],4_'c') ! { dg-error "Character length mismatch" } + call one4_a ([4_'b'],4_'d') + call one4_a ([4_'cd'],4_'e') ! { dg-error "Character length mismatch" } + call two4_a ([4_''],4_'f') ! { dg-error "Character length mismatch" } + call two4_a ([4_'fg'],4_'h') +end diff --git a/gcc/testsuite/gfortran.dg/array_constructor_58.f90 b/gcc/testsuite/gfortran.dg/array_constructor_58.f90 new file mode 100644 index 0000000..1473be0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_constructor_58.f90 @@ -0,0 +1,17 @@ +!{ dg-do run } + +! Contributed by Federico Perini <federico.perini@gmail.com> +! Check that PR fortran/119106 is fixed. + +program char_param_array +implicit none +character, parameter :: p(5) = ['1','2','3','4','5'] +character, save :: n(5) = ['1','2','3','4','5'] +integer :: i(10), j + +i = 4 +if (any([(n(i(j)),j=1,10)] /= '4')) stop 1 ! OK +if (any([(p(i(j)),j=1,10)] /= '4')) stop 2 ! used to runtime out-of-bounds error + +end program char_param_array + diff --git a/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 b/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 new file mode 100644 index 0000000..1e5989f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 @@ -0,0 +1,326 @@ +! { dg-do run } +! PR fortran/107721 - array constructor type-spec lost with parentheses +! PR fortran/102417 - character array constructor type-spec lost +! +! Tests type-spec preservation in array constructors with parentheses, +! nested constructors, and CLASS(*) type verification for all intrinsic types. + +program array_constructor_typespec_1 + implicit none + integer :: i, iscalar + integer, dimension(2) :: iarr + real, dimension(2) :: rarr + real :: rscalar + complex, dimension(2) :: carr + complex :: cscalar + logical, dimension(2) :: larr + character(4), dimension(3) :: charr + character(8), dimension(2) :: charr8 + character(16), dimension(3) :: charr16 + character(16), dimension(2) :: charr16_2 + character(:), allocatable :: charr17(:) + character :: x = 'a', y = 'b' + class(*), allocatable :: res(:) + character(10), dimension(1) :: charr10 + character(4), dimension(1) :: charr4_1 + character(:), allocatable :: charr0(:) + character(4), dimension(0) :: empty4 + + ! INTEGER - runtime value checks + iarr = [integer :: [1.0], [2.0]] + if (any(iarr /= [1, 2])) stop 1 + iarr = [integer :: ([1.0]), ([2.0])] + if (any(iarr /= [1, 2])) stop 2 + iarr = [integer :: ((([1.0]))), [2.0]] + if (any(iarr /= [1, 2])) stop 3 + + ! REAL - runtime value checks + rarr = [real :: [2], [3]] + if (any(rarr /= [2.0, 3.0])) stop 4 + rarr = [real :: ([2]), ([3])] + if (any(rarr /= [2.0, 3.0])) stop 5 + rarr = [real :: ((([2]))), [3]] + if (any(rarr /= [2.0, 3.0])) stop 6 + + ! COMPLEX - runtime value checks + carr = [complex :: [3], [4]] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 7 + carr = [complex :: ([3]), ([4])] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 8 + carr = [complex :: ((([3]))), [4]] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 9 + + ! LOGICAL - runtime value checks + larr = [logical :: [.true.], [.false.]] + if (any(larr .neqv. [.true., .false.])) stop 10 + larr = [logical :: ([.true.]), ([.false.])] + if (any(larr .neqv. [.true., .false.])) stop 11 + + ! CHARACTER - runtime value checks (PR 102417) + charr = [character(4) :: 'a', 'b', 'c'] + if (any(charr /= ['a ', 'b ', 'c '])) stop 12 + charr = [character(4) :: ('a'), 'b', 'c'] + if (any(charr /= ['a ', 'b ', 'c '])) stop 13 + charr = [[character(4) :: 'a', 'b', 'c']] + if (any(charr /= ['a ', 'b ', 'c '])) stop 14 + + ! CHARACTER with nested constructors - length 8 + charr8 = [character(8) :: 'x', 'y'] + if (charr8(1) /= 'x ') stop 15 + if (charr8(2) /= 'y ') stop 16 + + charr8 = [character(8) :: ['a', 'b']] + if (charr8(1) /= 'a ') stop 17 + if (charr8(2) /= 'b ') stop 18 + + ! Outer constructor without type-spec, inner with type-spec. + ! With proper type-spec propagation, no length mismatch warning is needed. + charr8 = [[character(8) :: ['a', 'b']]] + if (charr8(1) /= 'a ') stop 19 + if (charr8(2) /= 'b ') stop 20 + + ! Triple-nested constructor with type-spec in middle. + charr8 = [[[character(8) :: ['a', 'b']]]] + if (charr8(1) /= 'a ') stop 21 + if (charr8(2) /= 'b ') stop 22 + + charr8 = [character(8) :: (x), (y)] + if (charr8(1) /= 'a ') stop 23 + if (charr8(2) /= 'b ') stop 24 + + charr8 = [[character(8) :: (x), (y)]] + if (charr8(1) /= 'a ') stop 25 + if (charr8(2) /= 'b ') stop 26 + + ! CHARACTER concatenation with parentheses (PR 107721 comment 14) + charr16_2 = [character(16) :: 'a' // 'c', 'b' // 'de'] + if (charr16_2(1) /= 'ac ') stop 101 + if (charr16_2(2) /= 'bde ') stop 102 + + charr16_2 = [character(16) :: 'a' // 'c', ('b' // 'de')] + if (charr16_2(1) /= 'ac ') stop 103 + if (charr16_2(2) /= 'bde ') stop 104 + + charr16_2 = [character(16) :: ('a' // 'c'), 'b' // 'de'] + if (charr16_2(1) /= 'ac ') stop 105 + if (charr16_2(2) /= 'bde ') stop 106 + + ! CHARACTER concatenation after constructor - verify length 17 + charr17 = [character(16) :: 'a' // 'c', 'b' // 'de'] // '|' + if (len(charr17) /= 17) stop 107 + if (charr17(1) /= 'ac |') stop 108 + if (charr17(2) /= 'bde |') stop 109 + + charr17 = [character(16) :: 'a' // 'c', ('b' // 'de')] // '|' + if (len(charr17) /= 17) stop 110 + if (charr17(1) /= 'ac |') stop 111 + if (charr17(2) /= 'bde |') stop 112 + + charr17 = [character(16) :: ('a' // 'c'), 'b' // 'de'] // '|' + if (len(charr17) /= 17) stop 113 + if (charr17(1) /= 'ac |') stop 114 + if (charr17(2) /= 'bde |') stop 115 + + ! CHARACTER - longer length 16 + charr16 = [character(16) :: 'a', 'b', 'c'] + if (charr16(1) /= 'a ') stop 27 + if (charr16(2) /= 'b ') stop 28 + if (charr16(3) /= 'c ') stop 29 + + charr16 = [[character(16) :: 'a', 'b', 'c']] + if (charr16(1) /= 'a ') stop 30 + if (charr16(2) /= 'b ') stop 31 + if (charr16(3) /= 'c ') stop 32 + + ! CHARACTER - truncation cases + charr8 = [character(8) :: 'abcdefghij', 'klmnopqrst'] + if (charr8(1) /= 'abcdefgh') stop 33 + if (charr8(2) /= 'klmnopqr') stop 34 + + charr8 = [[character(8) :: 'abcdefghij', 'klmnopqrst']] + if (charr8(1) /= 'abcdefgh') stop 35 + if (charr8(2) /= 'klmnopqr') stop 36 + + ! Implied-do with parentheses + iarr = [integer :: (/(1.0*i, i=1, 2)/)] + if (any(iarr /= [1, 2])) stop 37 + iarr = [integer :: ((/(1.0*i, i=1, 2)/))] + if (any(iarr /= [1, 2])) stop 38 + + ! Type verification with CLASS(*) - ensure types are actually converted + res = [integer :: ([1.0])] + call verify_integer (res, 42) + deallocate (res) + + res = [integer :: ([1.0]), ([2.0])] + call verify_integer (res, 43) + deallocate (res) + + res = [real :: ([2]), [3]] + call verify_real (res, 44) + deallocate (res) + + res = [complex :: ([3])] + call verify_complex (res, 45) + deallocate (res) + + res = [logical :: ([.true.]), [.false.]] + call verify_logical (res, 46) + deallocate (res) + + ! Parenthesized constructors - verify result TYPE not just value + res = [integer :: ([1.0])] ** 2 + call verify_integer (res, 47) + deallocate (res) + + res = [real :: ([2]), [3]] ** 2 + call verify_real (res, 48) + deallocate (res) + + res = [complex :: ([3])] ** 2 + call verify_complex (res, 49) + deallocate (res) + + ! Harald's test cases from Comment #17 - scalar // constructor patterns + charr17 = '|' // [character(16) :: 'a' // 'c', 'b' // 'de'] + if (len(charr17) /= 17) stop 116 + if (charr17(1) /= '|ac ') stop 117 + if (charr17(2) /= '|bde ') stop 118 + + charr17 = '|' // [character(16) :: 'a' // 'c', ('b' // 'de')] + if (len(charr17) /= 17) stop 119 + if (charr17(1) /= '|ac ') stop 120 + if (charr17(2) /= '|bde ') stop 121 + + charr17 = '|' // [character(16) :: ('a' // 'c'), 'b' // 'de'] + if (len(charr17) /= 17) stop 122 + if (charr17(1) /= '|ac ') stop 123 + if (charr17(2) /= '|bde ') stop 124 + + ! Comment #11: Nested array constructor with concatenation + ! The inner ['a','b'] must be padded to length 16 before concat + charr17 = [character(16) :: ['a', 'b']] // '|' + if (len(charr17) /= 17) stop 125 + if (charr17(1) /= 'a |') stop 126 + if (charr17(2) /= 'b |') stop 127 + + ! Comment #18: Outer constructor without type-spec wrapping inner with + ! type-spec. The type-spec must be propagated when flattening. + charr17 = [[character(16) :: ['a', 'b']]] // '|' + if (len(charr17) /= 17) stop 128 + if (charr17(1) /= 'a |') stop 129 + if (charr17(2) /= 'b |') stop 130 + + charr17 = '|' // [[character(16) :: ['a', 'b']]] + if (len(charr17) /= 17) stop 131 + if (charr17(1) /= '|a ') stop 132 + if (charr17(2) /= '|b ') stop 133 + + ! Harald's new test cases from Comment #22 - nested truncation and padding + ! [ character(2) :: ['abcd','efgh'] ] should truncate to 'ab', 'ef' + ! Then [ character(16) :: ... ] should pad to 'ab ', 'ef ' + + charr16_2 = [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] + if (charr16_2(1) /= 'ab ') stop 134 + if (charr16_2(2) /= 'ef ') stop 135 + + charr17 = [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] // "|" + if (len(charr17) /= 17) stop 136 + if (charr17(1) /= 'ab |') stop 137 + if (charr17(2) /= 'ef |') stop 138 + + charr17 = "|" // [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] + if (len(charr17) /= 17) stop 139 + if (charr17(1) /= '|ab ') stop 140 + if (charr17(2) /= '|ef ') stop 141 + + charr16_2 = [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] + if (charr16_2(1) /= 'ab ') stop 142 + if (charr16_2(2) /= 'ef ') stop 143 + + charr17 = [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] // "|" + if (len(charr17) /= 17) stop 144 + if (charr17(1) /= 'ab |') stop 145 + if (charr17(2) /= 'ef |') stop 146 + + charr17 = "|" // [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] + if (len(charr17) /= 17) stop 147 + if (charr17(1) /= '|ab ') stop 148 + if (charr17(2) /= '|ef ') stop 149 + deallocate (charr17) + + ! Additional torture tests + ! Triple nesting with explicit types: 'abcde'(5) -> 'ab'(2) -> 'ab '(10) + charr10 = [character(10) :: [character(2) :: [character(5) :: 'abcde']]] + if (charr10(1) /= 'ab ') stop 150 + + ! Concatenation of constructors + ! 'a'(2) // 'b'(3) -> 'a b '(5) -> 'a b '(4) + charr4_1 = [character(4) :: [character(2) :: 'a'] // [character(3) :: 'b']] + if (charr4_1(1) /= 'a b ') stop 151 + + ! Zero length strings + ! Inner zero length: 'abc' -> ''(0) -> ' '(4) + charr4_1 = [character(4) :: [character(0) :: 'abc']] + if (charr4_1(1) /= ' ') stop 152 + + ! Outer zero length: 'abc' -> 'abc '(4) -> ''(0) + charr0 = [character(0) :: [character(4) :: 'abc']] + if (len(charr0) /= 0) stop 153 + if (charr0(1) /= '') stop 154 + deallocate (charr0) + + ! Empty array constructors + empty4 = [character(4) :: ] + if (size(empty4) /= 0) stop 155 + + empty4 = [character(4) :: [character(2) :: ]] + if (size(empty4) /= 0) stop 156 + +contains + + subroutine verify_integer (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (integer) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_integer + + subroutine verify_real (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (real) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_real + + subroutine verify_complex (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (complex) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_complex + + subroutine verify_logical (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (logical) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_logical + +end program array_constructor_typespec_1 diff --git a/gcc/testsuite/gfortran.dg/array_memcpy_2.f90 b/gcc/testsuite/gfortran.dg/array_memcpy_2.f90 index 5f54bf1..a95908c 100644 --- a/gcc/testsuite/gfortran.dg/array_memcpy_2.f90 +++ b/gcc/testsuite/gfortran.dg/array_memcpy_2.f90 @@ -1,9 +1,12 @@ ! This checks that the "z = y" assignment is not considered copyable, as the ! array is of a derived type containing allocatable components. Hence, we -! we should expand the scalarized loop, which contains *two* memcpy calls. +! we should expand the scalarized loop, which contains *two* memcpy calls +! for the assignment itself, plus one for initialization. ! { dg-do compile } ! { dg-options "-O2 -fdump-tree-original" } - +! +! PR 121628 +! type :: a integer, allocatable :: i(:) end type a @@ -13,7 +16,14 @@ end type b type(b) :: y(2), z(2) + integer :: j + + do j = 1, 2 + allocate(y(j)%at(1)) + allocate(y(j)%at(1)%i(1)) + y(j)%at(1)%i(1) = j + end do z = y end -! { dg-final { scan-tree-dump-times "memcpy" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy" 4 "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/assign_13.f90 b/gcc/testsuite/gfortran.dg/assign_13.f90 new file mode 100644 index 0000000..262ade0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assign_13.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR fortran/121185 +! The assignment to Y%X in CHECK_T was using a polymorphic array access on the +! left hand side, using the virtual table of Y. + +program p + implicit none + type t + complex, allocatable :: x(:) + end type t + real :: trace = 2. + type(t) :: z + z%x = [1,2] * trace + call check_t (z) +contains + subroutine check_t (y) + class(t) :: y + ! print *, y% x + if (any(y%x /= [2., 4.])) error stop 11 + y%x = y%x / trace + ! print *, y% x + if (any(y%x /= [1., 2.])) error stop 12 + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/assign_14.f90 b/gcc/testsuite/gfortran.dg/assign_14.f90 new file mode 100644 index 0000000..33b46b9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assign_14.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options {-fdump-tree-original} } +! +! PR fortran/121185 +! Check that an intermediary variable is used to reference component a. +! { dg-final { scan-tree-dump-not {->b->a} original } } + +program p + implicit none + type t + integer, allocatable :: a(:) + end type t + type u + type(t), allocatable :: b + end type u + type v + type(u), allocatable :: c + end type v + type(v) :: z + z%c = u() + z%c%b = t() + z%c%b%a = [1,2] + z%c%b%a = z%c%b%a * 2 +end diff --git a/gcc/testsuite/gfortran.dg/associate_75.f90 b/gcc/testsuite/gfortran.dg/associate_75.f90 new file mode 100644 index 0000000..c7c461a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_75.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Test fix for PR121060. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module subdomain_m + implicit none + + type subdomain_t + real :: s_ = 99. + contains + generic :: operator(.laplacian.) => laplacian + procedure laplacian + end type + +contains + + function laplacian(rhs) + class(subdomain_t), intent(in) :: rhs + type(subdomain_t) laplacian + laplacian%s_ = rhs%s_ + 42 + end function + +end module + + use subdomain_m + implicit none + + type operands_t + real :: s_ + end type + + type(subdomain_t) phi + type(operands_t) operands + + associate(laplacian_phi => .laplacian. phi) ! ICE because specific not found. + operands = approximates(laplacian_phi%s_) + end associate + + if (int (operands%s_) /= 42) stop 1 +contains + + function approximates(actual) + real actual + type(operands_t) approximates + approximates%s_ = actual - 99 + end function + +end diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_dummy.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_dummy.f90 index 04f0b9f..2e0e77c 100644 --- a/gcc/testsuite/gfortran.dg/assumed_charlen_dummy.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_charlen_dummy.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options " " } ! Test the fix for PR fortran/39893. ! Original testcase provided by Deji Akingunola. ! Reduced testcase provided by Dominique d'Humieres. diff --git a/gcc/testsuite/gfortran.dg/automatic_char_len_1.f90 b/gcc/testsuite/gfortran.dg/automatic_char_len_1.f90 index 3ccfcb7..7f102b7 100644 --- a/gcc/testsuite/gfortran.dg/automatic_char_len_1.f90 +++ b/gcc/testsuite/gfortran.dg/automatic_char_len_1.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options " " } ! PR18082 - Compiler would get stuck in loop, whilst treating ! the assignments. ! Test is one of PR cases. diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_35.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_35.f90 new file mode 100644 index 0000000..ae3973f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_35.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! PR fortran/49111 +! +! Do not warn for interface declarations with C binding declared PRIVATE + +module mod1 + use iso_c_binding + implicit none + save + + interface + function strerror(errnum) bind(C, NAME = 'strerror') + import + type(C_PTR) :: strerror + integer(C_INT), value :: errnum + end function strerror + end interface + + private strerror +end module mod1 diff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 index bb61cbf..81d74af 100644 --- a/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 +++ b/gcc/testsuite/gfortran.dg/binding_label_tests_9.f03 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-Wsurprising" } module x use iso_c_binding implicit none @@ -7,13 +8,13 @@ module x private :: my_private_sub_2 public :: my_public_sub contains - subroutine bar() bind(c,name="foo") ! { dg-warning "PRIVATE but has been given the binding label" } + subroutine bar() bind(c,name="foo") end subroutine bar subroutine my_private_sub() bind(c, name="") end subroutine my_private_sub - subroutine my_private_sub_2() bind(c) ! { dg-warning "PRIVATE but has been given the binding label" } + subroutine my_private_sub_2() bind(c) ! { dg-warning "is marked PRIVATE" } end subroutine my_private_sub_2 subroutine my_public_sub() bind(c, name="my_sub") diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 index 99a0d86..d8bb8cf 100644 --- a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 +++ b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 @@ -18,7 +18,8 @@ END MODULE m PROGRAM main USE m IMPLICIT NONE - CALL test ('') ! 0 length, but not absent argument. + ! 0 length, but not absent argument. + CALL test ('') ! { dg-warning "Character length of actual argument" } END PROGRAM main ! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" } diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 index a58d05a..57bc709 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-additional-sources "allocate-errors-c.c dump-descriptors.c" } ! { dg-additional-options "-Wno-error -fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! This program tests that the CFI_allocate and CFI_deallocate functions ! properly detect invalid arguments. All the interesting things happen diff --git a/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 index 307a266..9dc8889 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 @@ -2,7 +2,7 @@ ! { dg-do run } ! { dg-additional-sources "establish-errors-c.c dump-descriptors.c" } ! { dg-additional-options "-Wno-error -fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! This program tests that the CFI_establish function properly detects ! invalid arguments. All the interesting things happen in the diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c b/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c new file mode 100644 index 0000000..21a6b7a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c @@ -0,0 +1,10 @@ +/* PR fortran/113338. */ + +#include <ISO_Fortran_binding.h> + +extern void f_proc(CFI_cdesc_t* x); + +extern void c_proc(CFI_cdesc_t* x) +{ + f_proc(x); +} diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90 new file mode 100644 index 0000000..6da3378 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! { dg-additional-sources pr113338-c.c } +! { dg-additional-options "-Wno-error -O2 -std=f2018" } +! { dg-warning "command-line option '-std=f2018' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } +! +! PR fortran/113338 - F2018 extensions to interoperability of procedures + +program example + use iso_c_binding + implicit none + + type :: t + integer :: i + end type + + interface + subroutine c_proc(x) bind(c) + import t + type(t), pointer, intent(in) :: x + end subroutine c_proc + end interface + + type(t), target :: x + + x%i = 42 + call c_proc(x) +end program + +! pointer +subroutine f_proc(x) bind(c) + type :: t + integer :: i + end type t + type(t), pointer, intent(in) :: x + if (.not. associated (x)) stop 1 +! print *, x%i + if (x%i /= 42) stop 2 +end subroutine f_proc + +!----------------------------------------------------------------------- +! Further cases some of which are also tested elsewhere in the testsuite +!----------------------------------------------------------------------- + +! character: length 1 or assumed character length -> *CFI_cdesc_t +subroutine f_char(c, s) bind(c) + character :: c(:) + character(*) :: s(:) +end subroutine f_char + +! allocatable: scalar, assumed-shape, assumed-rank -> *CFI_cdesc_t +subroutine f_a(x, y, z) bind(c) + type :: t + integer :: i + end type t + type(t), allocatable :: x + type(t), allocatable :: y(:) + type(t), allocatable :: z(..) +end subroutine f_a + +! pointer: scalar, assumed-shape, assumed-rank -> *CFI_cdesc_t +subroutine f_p(x, y, z) bind(c) + type :: t + integer :: i + end type t + type(t), pointer :: x + type(t), pointer :: y(:) + type(t), pointer :: z(..) +end subroutine f_p + +! assumed-type: assumed shape, assumed rank -> *CFI_cdesc_t +subroutine f_at_cfi(z, w) bind(c) + type(*) :: z(:) + type(*) :: w(..) +end subroutine f_at_cfi + +! assumed-type: scalar, assumed-size -> *void +subroutine f_at_void(x, y) bind(c) + type(*) :: x + type(*) :: y(*) +end subroutine f_at_void diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 index 28328b7..bc52917 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-additional-sources "section-errors-c.c dump-descriptors.c" } ! { dg-additional-options "-Wno-error -fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! This program tests that the CFI_section function properly detects ! invalid arguments. All the interesting things happen in the diff --git a/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 index b719c9e..584a302 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! { dg-additional-sources "select-errors-c.c dump-descriptors.c" } ! { dg-additional-options "-Wno-error -fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! This program tests that the CFI_select_part function properly detects ! invalid arguments. All the interesting things happen in the diff --git a/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 index 84a01ce..15ea7ba 100644 --- a/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 +++ b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 @@ -2,7 +2,7 @@ ! { dg-do run } ! { dg-additional-sources "setpointer-errors-c.c dump-descriptors.c" } ! { dg-additional-options "-Wno-error -fcheck=all" } -! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! { dg-warning "command-line option '-fcheck=all' is valid for (\[a-zA-Z0-9]+/)*Fortran(/\[a-zA-Z0-9]+)* but not for C" "" { target *-*-* } 0 } ! ! This program tests that the CFI_setpointer function properly detects ! invalid arguments. All the interesting things happen in the diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 index 79cf2c1..da20835 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! { dg-additional-sources c_f_pointer_shape_tests_driver.c } ! Verify that the optional SHAPE parameter to c_f_pointer can be of any ! valid integer kind. We don't test all kinds here since it would be ! difficult to know what kinds are valid for the architecture we're running on. diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c deleted file mode 100644 index 1282beb..0000000 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c +++ /dev/null @@ -1,46 +0,0 @@ -#define NUM_ELEMS 10 -#define NUM_ROWS 2 -#define NUM_COLS 3 - -void test_long_long_1d(int *array, int num_elems); -void test_long_long_2d(int *array, int num_rows, int num_cols); -void test_long_1d(int *array, int num_elems); -void test_int_1d(int *array, int num_elems); -void test_short_1d(int *array, int num_elems); -void test_mixed(int *array, int num_elems); - -int main(int argc, char **argv) -{ - int my_array[NUM_ELEMS]; - int my_2d_array[NUM_ROWS][NUM_COLS]; - int i, j; - - for(i = 0; i < NUM_ELEMS; i++) - my_array[i] = i; - - for(i = 0; i < NUM_ROWS; i++) - for(j = 0; j < NUM_COLS; j++) - my_2d_array[i][j] = (i*NUM_COLS) + j; - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ - test_long_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. - The indices are transposed for Fortran. */ - test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ - test_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ - test_int_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ - test_short_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and - kind=c_long_long. */ - test_mixed(my_array, NUM_ELEMS); - - return 0; -} diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 index 3f60f17..519087a 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4.f03 @@ -1,5 +1,5 @@ ! { dg-do run } -! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! { dg-additional-sources c_f_pointer_shape_tests_driver.c } ! Verify that the optional SHAPE parameter to c_f_pointer can be of any ! valid integer kind. We don't test all kinds here since it would be ! difficult to know what kinds are valid for the architecture we're running on. diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c deleted file mode 100644 index 1282beb..0000000 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_4_driver.c +++ /dev/null @@ -1,46 +0,0 @@ -#define NUM_ELEMS 10 -#define NUM_ROWS 2 -#define NUM_COLS 3 - -void test_long_long_1d(int *array, int num_elems); -void test_long_long_2d(int *array, int num_rows, int num_cols); -void test_long_1d(int *array, int num_elems); -void test_int_1d(int *array, int num_elems); -void test_short_1d(int *array, int num_elems); -void test_mixed(int *array, int num_elems); - -int main(int argc, char **argv) -{ - int my_array[NUM_ELEMS]; - int my_2d_array[NUM_ROWS][NUM_COLS]; - int i, j; - - for(i = 0; i < NUM_ELEMS; i++) - my_array[i] = i; - - for(i = 0; i < NUM_ROWS; i++) - for(j = 0; j < NUM_COLS; j++) - my_2d_array[i][j] = (i*NUM_COLS) + j; - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ - test_long_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. - The indices are transposed for Fortran. */ - test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ - test_long_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ - test_int_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ - test_short_1d(my_array, NUM_ELEMS); - - /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and - kind=c_long_long. */ - test_mixed(my_array, NUM_ELEMS); - - return 0; -} diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 new file mode 100644 index 0000000..3504e68 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_7.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program lower + use iso_c_binding + type(c_ptr) :: x + integer, target :: array_2d(12), array_3d(24) + integer, pointer :: ptr_2d(:, :), ptr_3d(:, :, :) + integer :: myshape_2d(2), myshape_3d(3) + integer :: mylower_2d(2), mylower_3d(3) + + array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12] + x = c_loc(array_2d) + myshape_2d = [3, 4] + mylower_2d = [2, 2] + + call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d) + if (any(lbound(ptr_2d) /= [2, 2])) stop 1 + if (any(ubound(ptr_2d) /= [4, 5])) stop 2 + if (any(shape(ptr_2d) /= [3, 4])) stop 3 + if (ptr_2d(2, 2) /= 1) stop 4 + if (ptr_2d(3, 4) /= 8) stop 5 + if (ptr_2d(4, 5) /= 12) stop 6 + + array_3d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24] + x = c_loc(array_3d) + myshape_3d = [2, 3, 4] + mylower_3d = [-1, -2, -3] + + call c_f_pointer(x, ptr_3d, shape=myshape_3d, lower=mylower_3d) + if (any(lbound(ptr_3d) /= [-1, -2, -3])) stop 7 + if (any(ubound(ptr_3d) /= [0, 0, 0])) stop 8 + if (any(shape(ptr_3d) /= [2, 3, 4])) stop 9 + if (ptr_3d(0, 0, 0) /= 24) stop 10 + +end program lower diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 new file mode 100644 index 0000000..b9b851a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +! Verify that the type and rank of the LOWER argument are enforced. +module c_f_pointer_shape_tests_8 + use, intrinsic :: iso_c_binding + +contains + subroutine sub2(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(kind=c_int), dimension(:), pointer :: my_array_ptr + + call c_f_pointer(my_c_array, my_array_ptr, (/ 10 /), (/ 10.0 /)) ! { dg-error "must be INTEGER" } + end subroutine sub2 + + subroutine sub3(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(kind=c_int), dimension(:), pointer :: my_array_ptr + integer(kind=c_int), dimension(1) :: shape + integer(kind=c_int), dimension(1, 1) :: lower + + lower(1, 1) = 10 + call c_f_pointer(my_c_array, my_array_ptr, shape, lower) ! { dg-error "must be of rank 1" } + end subroutine sub3 +end module c_f_pointer_shape_tests_8 diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 new file mode 100644 index 0000000..e501e3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_9.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +program lower + use iso_c_binding + type(c_ptr) :: x + integer, target :: array_2d(12) + integer, pointer :: ptr_2d(:, :) + integer :: myshape_2d(2) + integer :: mylower_2d(2) + + array_2d = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12] + x = c_loc(array_2d) + myshape_2d = [3, 4] + mylower_2d = [2, 2] + + call c_f_pointer(x, ptr_2d, shape=myshape_2d, lower=mylower_2d) ! { dg-error "Fortran 2023: LOWER argument at" } +end program lower diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c new file mode 100644 index 0000000..70e7d56 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_driver.c @@ -0,0 +1,47 @@ +#define NUM_ELEMS 10 +#define NUM_ROWS 2 +#define NUM_COLS 3 + +void test_long_long_1d (int *array, int num_elems); +void test_long_long_2d (int *array, int num_rows, int num_cols); +void test_long_1d (int *array, int num_elems); +void test_int_1d (int *array, int num_elems); +void test_short_1d (int *array, int num_elems); +void test_mixed (int *array, int num_elems); + +int +main (int argc, char **argv) +{ + int my_array[NUM_ELEMS]; + int my_2d_array[NUM_ROWS][NUM_COLS]; + int i, j; + + for (i = 0; i < NUM_ELEMS; i++) + my_array[i] = i; + + for (i = 0; i < NUM_ROWS; i++) + for (j = 0; j < NUM_COLS; j++) + my_2d_array[i][j] = (i * NUM_COLS) + j; + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ + test_long_long_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. + The indices are transposed for Fortran. */ + test_long_long_2d (my_2d_array[0], NUM_COLS, NUM_ROWS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ + test_long_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ + test_int_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ + test_short_1d (my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and + kind=c_long_long. */ + test_mixed (my_array, NUM_ELEMS); + + return 0; +} 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/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90 index 6529a77..75cb438 100644 --- a/gcc/testsuite/gfortran.dg/char_length_3.f90 +++ b/gcc/testsuite/gfortran.dg/char_length_3.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=legacy" } ! PR fortran/25071 ! Check if actual argument is too short ! diff --git a/gcc/testsuite/gfortran.dg/class_elemental_1.f90 b/gcc/testsuite/gfortran.dg/class_elemental_1.f90 new file mode 100644 index 0000000..547ae98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_elemental_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/121342 +! The polymorphic function result as actual argument used to force the loop +! bounds around the elemental call, altering access to the other arrays. + +program p + implicit none + type :: t + integer :: i + end type + type :: u + integer :: i, a + end type + type(u) :: accum(5) + integer :: a(3:7), k + a = [ (k*k, k=1,5) ] + call s(accum, f(), a) + ! print *, accum%i + ! print *, accum%a + if (any(accum%i /= accum%a)) error stop 1 +contains + elemental subroutine s(l, c, a) + type(u) , intent(out) :: l + class(t) , intent(in) :: c + integer , intent(in) :: a + l%i = c%i + l%a = a + end subroutine + function f() + class(t), allocatable :: f(:) + allocate(f(-1:3)) + f%i = [ (k*k, k=1,5) ] + end function +end program 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_atomic_5.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 index 70c3d2f..8ddfa8d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 @@ -19,7 +19,7 @@ program atomic write(*,*) me end program -! { dg-final { scan-tree-dump-times "value.. = 0;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_define \\(caf_token.., 0, 1, &value.., 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_define \\(caf_token.., 0, 1, &D\\.\[0-9\]+, 0B, 1, 4\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_op \\(1, caf_token.., 0, 1, &me, 0B, 0B, 1, 4\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_ref \\(caf_token.., 0, 1, &me, 0B, 1, 4\\);" 1 "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/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/common_22.f90 b/gcc/testsuite/gfortran.dg/common_22.f90 index e225409..f92319b 100644 --- a/gcc/testsuite/gfortran.dg/common_22.f90 +++ b/gcc/testsuite/gfortran.dg/common_22.f90 @@ -7,18 +7,18 @@ ! Contributed by Bud Davis <jmdavis@link.com> CALL RCCFL (NVE,IR,NU3,VE (1,1,1,I)) - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } ! the PR only contained the two above. ! success is no segfaults or infinite loops. ! let's check some combinations CALL ABC (INTG) - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } CALL DEF (NT1) - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } CALL GHI (NRESL) - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } - COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } END diff --git a/gcc/testsuite/gfortran.dg/common_24.f b/gcc/testsuite/gfortran.dg/common_24.f index ea37c2a..1f35a40 100644 --- a/gcc/testsuite/gfortran.dg/common_24.f +++ b/gcc/testsuite/gfortran.dg/common_24.f @@ -7,5 +7,5 @@ c Contributed by Ilya Enkovich <ienkovich@gcc.gnu.org> COMMON /FMCOM / X(80 000 000) CALL T(XX(A)) - COMMON /FMCOM / XX(80 000 000) ! { dg-error "Unexpected COMMON" } + COMMON /FMCOM / XX(80 000 000) ! { dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } END diff --git a/gcc/testsuite/gfortran.dg/conditional_1.f90 b/gcc/testsuite/gfortran.dg/conditional_1.f90 new file mode 100644 index 0000000..9fd442a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program conditional_simple + implicit none + integer :: i = 42 + logical :: l = .true. + real(4) :: r1 = 1.e-4, r2 = 1.e-5 + complex :: z = (3.0, 4.0) + character(kind=1, len=5) :: c1 = "hello", c2 = "world" + character(len=:), allocatable :: c3 + + i = (i > 0 ? 1 : -1) + if (i /= 1) stop 1 + + i = 0 + i = (i > 0 ? 1 : i < 0 ? -1 : 0) + if (i /= 0) stop 2 + + i = 0 + i = (i > 0 ? 1 : (i < 0 ? -1 : 0)) + if (i /= 0) stop 3 + + i = 0 + i = (l .eqv. .false. ? 1 : 0) + if (i /= 0) stop 4 + + i = 0 + i = (r1 /= r2 ? 0 : 1) + if (i /= 0) stop 5 + + i = 0 + z = (i /= 0 ? z : (-3.0, -4.0)) + if (z /= (-3.0, -4.0)) stop 6 + + i = 0 + c1 = (i /= 0 ? c1 : c2) + if (c1 /= "world") stop 7 + + i = 0 + c1 = (i /= 0 ? "abcde" : "bcdef") + if (c1 /= "bcdef") stop 8 + + i = 0 + c3 = (i /= 0 ? "abcde" : c2(1:3)) + if (c3 /= "wor") stop 9 +end program conditional_simple diff --git a/gcc/testsuite/gfortran.dg/conditional_2.f90 b/gcc/testsuite/gfortran.dg/conditional_2.f90 new file mode 100644 index 0000000..c45b065 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program conditional_constant + implicit none + integer :: i = 42 + + print *, (.true. ? 1 : -1) + print *, (.false. ? "hello" : "world") + i = (.true. ? 1 : -1) + if (i /= 1) stop 1 + + i = 0 + i = (i > 0 ? 1 : .false. ? -1 : 0) + if (i /= 0) stop 2 +end program conditional_constant diff --git a/gcc/testsuite/gfortran.dg/conditional_3.f90 b/gcc/testsuite/gfortran.dg/conditional_3.f90 new file mode 100644 index 0000000..5596cf5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +program conditional_syntax + implicit none + integer :: i = 42 + + i = i > 0 ? 1 : -1 ! { dg-error "Unclassifiable statement at" } + i = (i > 0 ? 1 -1) ! { dg-error "Expected ':' in conditional expression" } +end program conditional_syntax diff --git a/gcc/testsuite/gfortran.dg/conditional_4.f90 b/gcc/testsuite/gfortran.dg/conditional_4.f90 new file mode 100644 index 0000000..5ecf9e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_4.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +program conditional_resolve + implicit none + integer :: i = 42 + integer, parameter :: ucs4 = selected_char_kind('ISO_10646') + character(kind=1) :: k1 = "k1" + character(kind=ucs4) :: k4 = "k4" + integer, dimension(1) :: a_1d + integer, dimension(1, 1) :: a_2d + logical :: l1(2) + integer :: i1(2) + type :: Point + real :: x = 0.0 + end type Point + type(Point) :: p1, p2 + + i = (l1 ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar logical" } + i = (i ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar logical" } + i = (i /= 0 ? 1 : "oh no") ! { dg-error "must have the same declared type" } + i = (i /= 0 ? k1 : k4) ! { dg-error "must have the same kind parameter" } + i = (i /= 0 ? a_1d : a_2d) ! { dg-error "must have the same rank" } + p1 = (i /= 0 ? p1 : p2) ! { dg-error "Sorry, only integer, logical, real, complex and character types are currently supported for conditional expressions" } + i1 = (i /= 0 ? i1 : i1 + 1) ! { dg-error "Sorry, array is currently unsupported for conditional expressions" } +end program conditional_resolve diff --git a/gcc/testsuite/gfortran.dg/conditional_5.f90 b/gcc/testsuite/gfortran.dg/conditional_5.f90 new file mode 100644 index 0000000..98b479d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_5.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +program conditional_std + implicit none + integer :: i = 42 + i = (i > 0 ? 1 : -1) ! { dg-error "Fortran 2023: Conditional expression at" } +end program conditional_std diff --git a/gcc/testsuite/gfortran.dg/conditional_6.f90 b/gcc/testsuite/gfortran.dg/conditional_6.f90 new file mode 100644 index 0000000..931f11c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_6.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program conditional_arg + implicit none + integer :: a = 4 + integer :: b = 5 + character(kind=1, len=4) :: c4 = "abcd" + character(kind=1, len=5) :: c5 = "bcdef" + + call five((a < 5 ? a : b)) + if (a /= 5) stop 1 + + if (my_trim_len((b == 5 ? c4 : c5)) /= 4) stop 2 + if (my_trim_len((b == 5 ? "abcd" : "abcde")) /= 4) stop 3 + if (my_trim_len((b /= 5 ? c4 : c5)) /= 5) stop 4 + if (my_trim_len((b /= 5 ? "abcd" : "abcde")) /= 5) stop 5 + + call five_c((b == 5 ? c4 : c5)) + if (c4 /= "bcde") stop 6 +contains + subroutine five(x) + integer, optional :: x + if (present(x)) then + x = 5 + end if + end subroutine five + + integer function my_trim_len(s) + character(len=*), intent(in) :: s + my_trim_len = len_trim(s) + end function my_trim_len + + subroutine five_c(x) + character(len=*), optional :: x + if (present(x)) then + x = c5 + end if + end subroutine five_c +end program conditional_arg diff --git a/gcc/testsuite/gfortran.dg/conditional_7.f90 b/gcc/testsuite/gfortran.dg/conditional_7.f90 new file mode 100644 index 0000000..87e621a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +module m + contains + function f(n) result(str) + integer, value :: n + character(len=(n > 5 ? n : 5)) :: str + str = "" + str(1:5) = "abcde" + end +end diff --git a/gcc/testsuite/gfortran.dg/conditional_8.f90 b/gcc/testsuite/gfortran.dg/conditional_8.f90 new file mode 100644 index 0000000..913acc7f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_8.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +implicit none +integer :: aa(2) +aa = [1, 2] + +print *, (aa(1) > 0 ? aa(2) : g()) +contains +integer function g() + allocatable :: g + error stop "should not be called" + g = 3 +end +end diff --git a/gcc/testsuite/gfortran.dg/conditional_9.f90 b/gcc/testsuite/gfortran.dg/conditional_9.f90 new file mode 100644 index 0000000..d1bb15e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_9.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +implicit none +integer :: i, j +do concurrent (i=(j > 1 ? 0 : 1) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" } +end do +do concurrent (i=(.true. ? j : 1) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" } +end do +do concurrent (i=(.false. ? 1 : j) : 5) local(j) ! { dg-error "must not appear in LOCAL locality-spec at" } +end do +end diff --git a/gcc/testsuite/gfortran.dg/contiguous_16.f90 b/gcc/testsuite/gfortran.dg/contiguous_16.f90 new file mode 100644 index 0000000..ae1ba26 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/contiguous_16.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-O2 -fdump-tree-original" } +! +! PR fortran/122977 - associate to a contiguous pointer + +program foo + integer, dimension(:), pointer, contiguous :: a + integer, dimension(:), allocatable :: u + allocate (a(4), u(4)) + if (.not. is_contiguous(a)) error stop 1 ! optimized + if (.not. is_contiguous(u)) error stop 2 ! optimized + + associate (b => a) + if (.not. is_contiguous(b)) error stop 3 ! optimized + associate (c => b) + if (.not. is_contiguous(c)) error stop 4 ! optimized + end associate + associate (c => b(1::2)) + if (is_contiguous(c)) stop 11 ! runtime check + end associate + end associate + + associate (v => u) + if (.not. is_contiguous(v)) error stop 5 ! optimized + associate (w => v) + if (.not. is_contiguous(w)) error stop 6 ! optimized + end associate + associate (w => v(1::2)) + if (is_contiguous(w)) stop 12 ! runtime check + end associate + end associate + + associate (b => a(1::2)) + if (is_contiguous(b)) stop 13 ! runtime check + associate (c => b) + if (is_contiguous(c)) stop 14 ! runtime check + end associate + end associate + + associate (v => u(1::2)) + if (is_contiguous(v)) stop 15 ! runtime check + associate (w => v) + if (is_contiguous(w)) stop 16 ! runtime check + end associate + end associate + + deallocate (a, u) +end program foo + +! { dg-final { scan-tree-dump-not "_gfortran_error_stop_numeric" "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 6 "original" } } 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/deferred_character_39.f90 b/gcc/testsuite/gfortran.dg/deferred_character_39.f90 new file mode 100644 index 0000000..38ec431 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_39.f90 @@ -0,0 +1,241 @@ +! { dg-do run } +! PR fortran/108581 - issues with rank-2 deferred-length character arrays +! PR fortran/121939 - ICE in gfc_conv_string_parameter + +program p + call pr108581 + call test2 +end + +! Derived from original testcase +subroutine pr108581 + integer, parameter :: xmin = 0, xmax = 0 + integer, parameter :: ymin = 0, ymax = 1 + integer, parameter :: l = 2 + integer :: x, y + character(8) :: line1, line2, line3 + character(*), parameter :: expect(ymin:ymax) = ['A.','B*'] + character(len=:), pointer :: a(:,:) => NULL() + + allocate (character(len=l) :: a(xmin:xmax, ymin:ymax)) + a(xmin:xmax, ymin) = expect(ymin) + a(xmin:xmax, ymax) = expect(ymax) + + do y = ymin, ymax + write(line1,'(4A)') (a(x, y), x = xmin, xmax) + write(line2,'(4A)') a(xmin:xmax, y) + write(line3,'(4A)') a( : , y) + if (line1 /= expect(y) .or. & + line2 /= expect(y) .or. & + line3 /= expect(y) ) then + write(*,*) (a(x, y), x = xmin, xmax) + write(*,*) a(xmin:xmax, y) + write(*,*) a( : , y) + stop 1 + y + end if + enddo + call chk (a) + deallocate (a) +contains + subroutine chk (z) + character(len=:), pointer :: z(:,:) + integer :: y + do y = lbound(z,2), ubound (z,2) + write(line2,'(4A)') z(xmin:xmax, y) + write(line3,'(4A)') z( : , y) + if (line2 /= expect(y) .or. & + line3 /= expect(y) ) then + write(*,*) z(xmin:xmax, y) + write(*,*) z( : , y) + stop 5 + y + end if + enddo + end subroutine chk +end + +! Exercise character kinds, strides, ... +subroutine test2 + implicit none + integer, parameter :: l = 3 + integer :: i + + character(len=l,kind=1), parameter :: str1(*) = & + [ "123", "456", "789", "0AB" ] + character(len=l,kind=4), parameter :: str4(*) = & + [ 4_"123", 4_"456", 4_"789", 4_"0AB" ] + + character(len=l,kind=1), parameter :: str2(*,*) = & + reshape ([(str1(i),str1(5-i),i=1,4)], shape=[2,4]) + character(len=l,kind=4), parameter :: str5(*,*) = & + reshape ([(str4(i),str4(5-i),i=1,4)], shape=[2,4]) + + character(len=l,kind=1), pointer :: a(:,:) => NULL(), e(:,:) => NULL() + character(len=:,kind=1), pointer :: b(:,:) => NULL(), f(:,:) => NULL() + character(len=l,kind=4), pointer :: c(:,:) => NULL(), g(:,:) => NULL() + character(len=:,kind=4), pointer :: d(:,:) => NULL(), h(:,:) => NULL() + + character(len=16) :: s0, s1, s2, s3, s4 + + ! Simple case: shape=[1,4] + allocate (a, source = reshape (str1,[1,size(str1)])) + allocate (b, source = reshape (str1,[1,size(str1)])) + allocate (c, source = reshape (str4,[1,size(str4)])) + allocate (d, source = c) ! fixed with pr121939 +! d => c + ! Positive non-unit stride + s0 = concat (str1(1::2)) + write(s1,'(4A)') a(1,1::2) + write(s2,'(4A)') b(1,1::2) + write(s3,'(4A)') c(1,1::2) + write(s4,'(4A)') d(1,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 11 + if (s2 /= s0) stop 12 + if (s3 /= s0) stop 13 + if (s4 /= s0) stop 14 + s0 = concat (str1(2::2)) + write(s1,'(4A)') a(1,2::2) + write(s2,'(4A)') b(1,2::2) + write(s3,'(4A)') c(1,2::2) + write(s4,'(4A)') d(1,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 15 + if (s2 /= s0) stop 16 + if (s3 /= s0) stop 17 + if (s4 /= s0) stop 18 + + ! Negative non-unit stride + s0 = concat (str1(3:1:-2)) + write(s1,'(4A)') a(1,3:1:-2) + write(s2,'(4A)') b(1,3:1:-2) + write(s3,'(4A)') c(1,3:1:-2) + write(s4,'(4A)') d(1,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 21 + if (s2 /= s0) stop 22 + if (s3 /= s0) stop 23 + if (s4 /= s0) stop 24 + s0 = concat (str1(4:1:-2)) + write(s1,'(4A)') a(1,4:1:-2) + write(s2,'(4A)') b(1,4:1:-2) + write(s3,'(4A)') c(1,4:1:-2) + write(s4,'(4A)') d(1,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 25 + if (s2 /= s0) stop 26 + if (s3 /= s0) stop 27 + if (s4 /= s0) stop 28 + deallocate (a,b,c,d) + + ! More complex cases with shape=[2,4] + allocate (e, source = reshape (str2,[2,size(str2,2)])) + allocate (f, source = reshape (str2,[2,size(str2,2)])) + allocate (g, source = reshape (str5,[2,size(str5,2)])) + allocate (h, source = reshape (str5,[2,size(str5,2)])) ! fixed with pr121939 +! h => g + s0 = concat (str2(1,3:1:-2)) + write(s1,'(4A)') e(1,3:1:-2) + write(s2,'(4A)') f(1,3:1:-2) + write(s3,'(4A)') g(1,3:1:-2) + write(s4,'(4A)') h(1,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 31 + if (s2 /= s0) stop 32 + if (s3 /= s0) stop 33 + if (s4 /= s0) stop 34 + s0 = concat (str2(1,4:1:-2)) + write(s1,'(4A)') e(1,4:1:-2) + write(s2,'(4A)') f(1,4:1:-2) + write(s3,'(4A)') g(1,4:1:-2) + write(s4,'(4A)') h(1,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 35 + if (s2 /= s0) stop 36 + if (s3 /= s0) stop 37 + if (s4 /= s0) stop 38 + + s0 = concat (str2(2,3:1:-2)) + write(s1,'(4A)') e(2,3:1:-2) + write(s2,'(4A)') f(2,3:1:-2) + write(s3,'(4A)') g(2,3:1:-2) + write(s4,'(4A)') h(2,3:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 41 + if (s2 /= s0) stop 42 + if (s3 /= s0) stop 43 + if (s4 /= s0) stop 44 + s0 = concat (str2(2,4:1:-2)) + write(s1,'(4A)') e(2,4:1:-2) + write(s2,'(4A)') f(2,4:1:-2) + write(s3,'(4A)') g(2,4:1:-2) + write(s4,'(4A)') h(2,4:1:-2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 45 + if (s2 /= s0) stop 46 + if (s3 /= s0) stop 47 + if (s4 /= s0) stop 48 + + ! Check pointer association with negative stride + a => e(2:1:-1,4:1:-1) + b => f(2:1:-1,4:1:-1) + c => g(2:1:-1,4:1:-1) + d => h(2:1:-1,4:1:-1) + + s0 = concat (str2(2,4:1:-2)) + write(s1,'(4A)') a(1,1::2) + write(s2,'(4A)') b(1,1::2) + write(s3,'(4A)') c(1,1::2) + write(s4,'(4A)') d(1,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 51 + if (s2 /= s0) stop 52 + if (s3 /= s0) stop 53 + if (s4 /= s0) stop 54 + s0 = concat (str2(2,3:1:-2)) + write(s1,'(4A)') a(1,2::2) + write(s2,'(4A)') b(1,2::2) + write(s3,'(4A)') c(1,2::2) + write(s4,'(4A)') d(1,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 55 + if (s2 /= s0) stop 56 + if (s3 /= s0) stop 57 + if (s4 /= s0) stop 58 + + s0 = concat (str2(1,4:1:-2)) + write(s1,'(4A)') a(2,1::2) + write(s2,'(4A)') b(2,1::2) + write(s3,'(4A)') c(2,1::2) + write(s4,'(4A)') d(2,1::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 61 + if (s2 /= s0) stop 62 + if (s3 /= s0) stop 63 + if (s4 /= s0) stop 64 + s0 = concat (str2(1,3:1:-2)) + write(s1,'(4A)') a(2,2::2) + write(s2,'(4A)') b(2,2::2) + write(s3,'(4A)') c(2,2::2) + write(s4,'(4A)') d(2,2::2) +! print *, s0, s1, s2, s3, s4 + if (s1 /= s0) stop 65 + if (s2 /= s0) stop 66 + if (s3 /= s0) stop 67 + if (s4 /= s0) stop 68 + deallocate (e,f,g,h) + +contains + + ! Helper function to concatenate string array to scalar string + function concat (s) + character(len=:), allocatable :: concat + character(len=*), intent(in) :: s(:) + integer :: i, l, n + n = size (s) + l = len (s) + allocate (character(len=l*n) :: concat) + do i = 1, n + concat(1+(i-1)*l:i*l) = s(i) + end do + end function concat +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_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_typespec_1.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_typespec_1.f90 new file mode 100644 index 0000000..5a25739 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_typespec_1.f90 @@ -0,0 +1,111 @@ +! { dg-do run } +! { dg-options "-std=f2008 -Wall" } +! +! PR fortran/96255 +! Test DO CONCURRENT with optional type specification +! Covers all shadowing scenarios per F2018 19.4(6) + +program test_do_concurrent_typespec + implicit none + integer :: test_count + test_count = 0 + + ! Test 1: Type-spec with no outer scope variable (BT_UNKNOWN) + ! Should just set the type, no shadow needed + call test_no_outer_var() + test_count = test_count + 1 + + ! Test 2: Type-spec shadows outer variable with same kind + ! Must create shadow per F2018 19.4(6) + call test_shadow_same_kind() + test_count = test_count + 1 + + ! Test 3: Type-spec shadows outer variable with different kind + ! Must create shadow per F2018 19.4(6) + call test_shadow_different_kind() + test_count = test_count + 1 + + ! Test 4: Multiple iterators with mixed scenarios + call test_multiple_iterators() + test_count = test_count + 1 + +contains + + subroutine test_no_outer_var() + implicit none + integer :: sum_val + + ! 'j' is not declared in outer scope + sum_val = 0 + do concurrent (integer :: j = 1:5) + sum_val = sum_val + j + end do + + if (sum_val /= 15) stop 1 ! 1+2+3+4+5 = 15 + end subroutine test_no_outer_var + + subroutine test_shadow_same_kind() + implicit none + integer :: i + integer :: outer_val, inner_sum + + ! Set outer 'i' to a specific value + i = 99 + outer_val = i + + ! DO CONCURRENT with type-spec should shadow 'i' + ! even though kind is the same + inner_sum = 0 + do concurrent (integer :: i = 1:3) + inner_sum = inner_sum + i + end do + + ! After loop, outer 'i' should be unchanged + if (i /= outer_val) stop 2 + if (i /= 99) stop 3 + if (inner_sum /= 6) stop 4 ! 1+2+3 = 6 + end subroutine test_shadow_same_kind + + subroutine test_shadow_different_kind() + implicit none + integer(kind=4) :: k + integer :: result + + ! Set outer 'k' to a value + k = 77 + + ! DO CONCURRENT with different kind should shadow + result = 0 + do concurrent (integer(kind=2) :: k = 1:4) + result = result + int(k, kind=4) + end do + + ! Outer 'k' should be unchanged + if (k /= 77) stop 5 + if (result /= 10) stop 6 ! 1+2+3+4 = 10 + end subroutine test_shadow_different_kind + + subroutine test_multiple_iterators() + implicit none + integer :: i, j + integer :: sum_val + + ! Set outer variables + i = 100 + j = 200 + + ! Multiple iterators: i shadows (same kind), m is new (BT_UNKNOWN) + ! Per F2018 R1125, ONE type-spec applies to ALL iterators + sum_val = 0 + do concurrent (integer :: i = 1:2, m = 1:2) + sum_val = sum_val + i * 10 + m + end do + + ! Outer i should be unchanged, j should be unchanged + if (i /= 100) stop 7 + if (j /= 200) stop 8 + ! sum = (1*10+1) + (1*10+2) + (2*10+1) + (2*10+2) = 11+12+21+22 = 66 + if (sum_val /= 66) stop 9 + end subroutine test_multiple_iterators + +end program test_do_concurrent_typespec diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 index b9b1b1a..0f807ba 100644 --- a/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 @@ -1,6 +1,6 @@ ! { dg-do run } ! -! [OOP] Ensure that different specifc interfaces are +! [OOP] Ensure that different specific interfaces are ! handled properly by dynamic dispatch. ! ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> diff --git a/gcc/testsuite/gfortran.dg/entry_23.f b/gcc/testsuite/gfortran.dg/entry_23.f index ebc5f66..d10ea92 100644 --- a/gcc/testsuite/gfortran.dg/entry_23.f +++ b/gcc/testsuite/gfortran.dg/entry_23.f @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options " " } ! PR 97799 - this used to segfault intermittently. ! Test case by George Hockney. PROGRAM MAIN diff --git a/gcc/testsuite/gfortran.dg/eoshift_8.f90 b/gcc/testsuite/gfortran.dg/eoshift_8.f90 index 0930638..f63a987 100644 --- a/gcc/testsuite/gfortran.dg/eoshift_8.f90 +++ b/gcc/testsuite/gfortran.dg/eoshift_8.f90 @@ -14,5 +14,5 @@ program main f2 = eoshift(e,shift=n,boundary=bnd2) ! { dg-error "has invalid shape" } f2 = eoshift(e,shift=1,boundary="x") ! { dg-error "must be of same type and kind" } - print '(*(1H",A,1H",:","))',f2 + !print '(*(1H",A,1H",:","))',f2 end program main diff --git a/gcc/testsuite/gfortran.dg/finalize_59.f90 b/gcc/testsuite/gfortran.dg/finalize_59.f90 index 8be5f71..e9e68d4 100644 --- a/gcc/testsuite/gfortran.dg/finalize_59.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_59.f90 @@ -187,7 +187,7 @@ Program Cds_Principal Type(Uef_Vector) :: Cds_Mod_Les_materiaux Type (Cds_Materiau_Acier_EC) :: acier_ec Class (Cds_Materiau), pointer :: pt_materiau - Character *(8) :: nom_materiau + Character(len=8) :: nom_materiau !------------------------------------------------------------------------------------------------- CaLL Cds_Mod_Les_materiaux%Add (acier_ec) nom_materiau = "12345678" @@ -199,7 +199,7 @@ Function Get_Pt_Materiau_nom (vecteur, nom_materiau) ! Fonction : !-------------------- ! Parametres en entree - Character *(8), Intent (in) :: nom_materiau + Character(len=8), Intent (in) :: nom_materiau Type (Uef_Vector) , Intent (inout) :: vecteur ! Parametres en sortie diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 new file mode 100644 index 0000000..8fe2001 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/90519 + +module pr90519_finalizer_mod + implicit none + type :: t + type(t), allocatable :: child + contains + final :: finalize_t + end type t +contains + subroutine finalize_t(self) + type(t), intent(inout) :: self + end subroutine finalize_t +end module pr90519_finalizer_mod diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 new file mode 100644 index 0000000..6e9edff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-output " finalizing id\\s+0\\n finalizing id\\s+1\\n finalizer count =\\s+2\\n" } +! PR fortran/90519 + +module pr90519_finalizer_run_mod + implicit none + integer :: finalizer_count = 0 + type :: tree_t + integer :: id = -1 + type(tree_t), allocatable :: child + contains + final :: finalize_tree + end type tree_t +contains + subroutine finalize_tree(self) + type(tree_t), intent(inout) :: self + finalizer_count = finalizer_count + 1 + print *, 'finalizing id', self%id + end subroutine finalize_tree +end module pr90519_finalizer_run_mod + +program test_finalizer + use pr90519_finalizer_run_mod + implicit none + block + type(tree_t) :: root + root%id = 0 + allocate(root%child) + root%child%id = 1 + end block + print *, 'finalizer count =', finalizer_count +end program test_finalizer diff --git a/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 new file mode 100644 index 0000000..4e5b807d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 @@ -0,0 +1,101 @@ +! { dg-do run } +! Test self-assignment with recursive allocatable and finalizer +! This should preserve allocatable components after a = a and a = (a) + +module self_assign_mod + implicit none + type :: node_t + integer :: value = 0 + type(node_t), allocatable :: next + contains + final :: finalize_node + end type node_t +contains + subroutine finalize_node(self) + type(node_t), intent(inout) :: self + end subroutine finalize_node +end module self_assign_mod + +program test_self_assign + use self_assign_mod + implicit none + + call test_simple_self_assign() + call test_parenthesized_self_assign() + call test_triple_parenthesized_self_assign() + call test_array_bounds() + +contains + + subroutine test_simple_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Simple self-assignment should preserve all components + a = a + + if (a%value /= 100) stop 1 + if (.not. allocated(a%next)) stop 2 + if (a%next%value /= 200) stop 3 + end subroutine test_simple_self_assign + + subroutine test_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Parenthesized self-assignment should also preserve all components + a = (a) + + if (a%value /= 100) stop 4 + if (.not. allocated(a%next)) stop 5 + if (a%next%value /= 200) stop 6 + end subroutine test_parenthesized_self_assign + + subroutine test_triple_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Triple-nested parentheses should also work correctly + a = (((a))) + + if (a%value /= 100) stop 7 + if (.not. allocated(a%next)) stop 8 + if (a%next%value /= 200) stop 9 + end subroutine test_triple_parenthesized_self_assign + + subroutine test_array_bounds() + type(node_t), allocatable :: b(:), c(:) + + ! Test array bounds behavior with parentheses. + ! Per F2023:10.2.1.3, lbound((b),1) = 1 even if lbound(b,1) = 5. + ! However, for b = (b) where b is already allocated with the right shape, + ! NO reallocation occurs, so bounds are preserved. + ! For c = (b) where c is unallocated, c gets allocated with default bounds. + allocate(b(5:5)) + b(5)%value = 500 + + ! Self-assignment with parentheses: no reallocation (same shape), bounds preserved + b = (b) + if (.not. allocated(b)) stop 10 + if (lbound(b, 1) /= 5) stop 11 ! Bounds preserved (no realloc) + if (ubound(b, 1) /= 5) stop 12 + if (b(5)%value /= 500) stop 13 + + ! Assignment to unallocated array: gets default (1-based) bounds + c = (b) + if (.not. allocated(c)) stop 14 + if (lbound(c, 1) /= 1) stop 15 ! Default bounds (new allocation) + if (ubound(c, 1) /= 1) stop 16 + if (c(1)%value /= 500) stop 17 + end subroutine test_array_bounds + +end program test_self_assign diff --git a/gcc/testsuite/gfortran.dg/fmt_error_10.f b/gcc/testsuite/gfortran.dg/fmt_error_10.f index fc6620a..9ae2f32 100644 --- a/gcc/testsuite/gfortran.dg/fmt_error_10.f +++ b/gcc/testsuite/gfortran.dg/fmt_error_10.f @@ -14,12 +14,13 @@ write (line,'(1pd24.15e6)',iostat=istat, iomsg=msg) 1.0d0, 1.234 ! { dg-warning "Period required" } if (istat.ne.0) STOP 3 - if (line.ne." 1.000000000000000D+001.E+00") STOP 4 + if (line.ne." 1.000000000000000D+001.E+00") STOP 2 str = '(1pd0.15)' write (line,str,iostat=istat, iomsg=msg) 1.0d0 - if (line.ne."1.000000000000000D+0") STOP 5 + if (line.ne."1.000000000000000D+000") STOP 4 read (*,str,iostat=istat, iomsg=msg) x + if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 6 if (x.ne.555.25) STOP 7 diff --git a/gcc/testsuite/gfortran.dg/fmt_g0_4.f08 b/gcc/testsuite/gfortran.dg/fmt_g0_4.f08 index fff6580..e93ed7f 100644 --- a/gcc/testsuite/gfortran.dg/fmt_g0_4.f08 +++ b/gcc/testsuite/gfortran.dg/fmt_g0_4.f08 @@ -1,15 +1,16 @@ -! { dg-do compile } +! { dg-do run } ! { dg-options "-std=f2008" } ! PR36725 Compile time error for g0 edit descriptor character(30) :: line write(line, '(g0.3)') 0.1 -if (line.ne." 1.000E-01") STOP 1 +if (line.ne."0.100") STOP 1 write(line, '(g0.9)') 1.0 -if (line.ne."1.000000000E+00") STOP 2 +if (line.ne."1.00000000") STOP 2 write(line, '(g0.5)') 29.23 -if (line.ne." 2.92300E+01") STOP 3 +if (line.ne."29.230") STOP 3 write(line, '(g0.8)') -28.4 -if (line.ne."-2.83999996E+01") STOP 4 +if (line.ne."-28.400000") STOP 4 write(line, '(g0.8)') -0.0001 -if (line.ne."-9.99999975E-05") STOP 5 +if (line.ne."-0.99999997E-04") STOP 5 end + diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 index db2cca6..3ba897c 100644 --- a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 @@ -9,32 +9,32 @@ program pr90374 rn = 0.00314_4 afmt = "(D0.3)" write (aresult,fmt=afmt) rn - if (aresult /= "0.314D-2") stop 12 + if (aresult /= "0.314D-02") stop 12 afmt = "(E0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "0.3139999928E-2") stop 15 + if (aresult /= "0.3139999928E-02") stop 15 afmt = "(ES0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "3.1399999280E-3") stop 18 + if (aresult /= "3.1399999280E-03") stop 18 afmt = "(EN0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "3.1399999280E-3") stop 21 + if (aresult /= "3.1399999280E-03") stop 21 afmt = "(G0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "0.3139999928E-2") stop 24 + if (aresult /= "0.3139999928E-02") stop 24 afmt = "(E0.10e0)" write (aresult,fmt=afmt) rn if (aresult /= "0.3139999928E-2") stop 27 write (aresult,fmt="(D0.3)") rn - if (aresult /= "0.314D-2") stop 29 + if (aresult /= "0.314D-02") stop 29 write (aresult,fmt="(E0.10)") rn - if (aresult /= "0.3139999928E-2") stop 31 + if (aresult /= "0.3139999928E-02") stop 31 write (aresult,fmt="(ES0.10)") rn - if (aresult /= "3.1399999280E-3") stop 33 + if (aresult /= "3.1399999280E-03") stop 33 write (aresult,fmt="(EN0.10)") rn - if (aresult /= "3.1399999280E-3") stop 35 + if (aresult /= "3.1399999280E-03") stop 35 write (aresult,fmt="(G0.10)") rn - if (aresult /= "0.3139999928E-2") stop 37 + if (aresult /= "0.3139999928E-02") stop 37 write (aresult,fmt="(E0.10e0)") rn if (aresult /= "0.3139999928E-2") stop 39 write (aresult,fmt="(E0.10e3)") rn diff --git a/gcc/testsuite/gfortran.dg/function_charlen_4.f90 b/gcc/testsuite/gfortran.dg/function_charlen_4.f90 new file mode 100644 index 0000000..ed39aca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_charlen_4.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-O2 -std=legacy -fdump-tree-optimized" } +! +! PR fortran/121203 - fix passing of character length of function to procedure + +program p + character(10), external :: f + call eval (f,"abc") + call eval2(f,"abc") +contains + subroutine eval2(func,c_arg) + character(*) c_arg + character(*) func + external func + ! These tests should get optimized: + if (len (c_arg) /= 3) stop 1 + if (len (func(c_arg)) /= 10) stop 2 + end subroutine +end + +character(10) function f(arg) + character(*) arg + f=arg +end + +subroutine eval(func,c_arg) + character(*) c_arg + character(*) func + external func + if (len (c_arg) /= 3) error stop 3 + if (len (func(c_arg)) /= 10) error stop 4 +end subroutine + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } } 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/g77/f77-edit-h-out.f b/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f index f92b39f..a0e35c8 100644 --- a/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f +++ b/gcc/testsuite/gfortran.dg/g77/f77-edit-h-out.f @@ -5,10 +5,12 @@ C Origin: David Billinghurst <David.Billinghurst@riotinto.com> C C { dg-do run } C { dg-output "^" } - 10 format(1H1) - 20 format(6H 6) +C { dg-options "-std=legacy" + 10 format(1H1) ! { dg-warning "H format specifier" } + 20 format(6H 6) ! { dg-warning "H format specifier" } write(*,10) ! { dg-output "1(\r*\n+)" } write(*,20) ! { dg-output " 6(\r*\n+)" } - write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\r*\n+)" } + write(*,'(16H''apostrophe'' fun)') ! { dg-warning "H format specifier" } + ! { dg-output "'apostrophe' fun(\r*\n+)" } C { dg-output "\$" } end diff --git a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f index 0ce45de..2f03db1 100644 --- a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f +++ b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f @@ -1,4 +1,5 @@ c { dg-do run } +c { dg-options " " } c f90-intrinsic-bit.f c c Test Fortran 90 diff --git a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f index d151fd0..f07336e 100644 --- a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f +++ b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-mathematical.f @@ -1,4 +1,5 @@ c { dg-do run } +c { dg-options " " } c f90-intrinsic-mathematical.f c c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and diff --git a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f index c8d7c56..c01efe6 100644 --- a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f +++ b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-numeric.f @@ -1,4 +1,5 @@ c { dg-do run } +c { dg-options " " } c f90-intrinsic-numeric.f c c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13 diff --git a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f index b388806..406a8e4 100644 --- a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f +++ b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f @@ -1,4 +1,5 @@ c { dg-do run } +c { dg-options " " } c intrinsic-unix-bessel.f c c Test Bessel function intrinsics. diff --git a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f index 250519a..6ed9590 100644 --- a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f +++ b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f @@ -1,4 +1,5 @@ c { dg-do run } +c { dg-options " " } c intrinsic-unix-erf.f c c Test Bessel function intrinsics. diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 new file mode 100644 index 0000000..57d0aba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_1.f90 @@ -0,0 +1,194 @@ +! { dg-do run } +! +! Test the F2018 generic statement +! +function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + cg = arg1 + arg2 +end + +module m + implicit none + + type :: t + integer :: i + end type + integer :: tsum = 0 + + public g + interface g ! Check generic statement + generic interface works + module procedure tg + end interface g + + generic :: g => ig, rg + generic :: operator(.plus.) => ig, rg + generic, private :: h => ig, rg + generic :: WRITE(FORMATTED) => wtarray + + interface g ! Check generic statement + generic interface works + function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + end + end interface g + +! Subroutines + generic, public :: sg => sig, srg + +! Check that we can mix with submodule procedures + interface + real module function realg (arg1, arg2) + real, intent(in) :: arg1, arg2 + end function + end interface + generic, public :: subg => ig, realg + +contains + + function rg (arg1, arg2) + real :: rg + real, intent(in) :: arg1, arg2 + rg = arg1 + arg2 + end + function ig (arg1, arg2) + integer :: ig + integer, intent(in) :: arg1, arg2 + ig = arg1 + arg2 + end + function tg (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i + arg2%i + end + subroutine srg (arg1, arg2, arg3) + real :: arg3 + real, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine sig (arg1, arg2, arg3) + integer :: arg3 + integer, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + + SUBROUTINE wtarray (dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list (:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + WRITE (unit, FMT=*, iostat=iostat, iomsg=iomsg) dtv%i + END SUBROUTINE wtarray + + subroutine foo + real :: a = 1.0, b = 2.0, r + integer :: c = 3, d = 4 + type(t) :: tres + generic :: operator(+) => tg +! private in foo + r = h(a,b) + if (r /= rg(a,b)) stop 1 + if (h(c,d) /= ig(c,d)) stop 2 +! operator in foo + r = a.plus.b + if (r /= rg(a,b)) stop 3 + if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4 +! check intrinsic operator + tres = t(21) + t(21) + if (tres%i /= 42) stop 5 + end +end module m + +submodule (m) subm +contains + real module function realg (arg1, arg2) + real, intent(in) :: arg1, arg2 + realg = arg1 + arg2 + end +end + +program p + use m + implicit none + integer :: i, rv + + generic :: operator(.minus.) => pig, prg + generic :: operator(*) => times + generic :: j => ig, rg + generic :: j => mg + + real :: a = 1.0, b = 2.0, s3 + integer :: c = 3, d = 4, si + type(t) :: t1 = t(2), t2 = t(3), tres + type(t) :: tarray(5) = [t(5), t(4), t(3), t(2), t(1)] + +! module generic in p + if (g(2.0*a,2.0*b) /= rg(2.0*a,2.0*b)) stop 6 + if (g(c,d) /= ig(c,d)) stop 7 +! local generic in p + if (j(a,b) /= rg(a,b)) stop 8 + if (j(c,d) /= ig (c,d)) stop 9 +! local generic in p with different number of arguments + if (j(c,d,-1) /= mg(c,d,-1)) stop 10 +! module operator in p + if (7*int(a.plus.b) /= 3*(c.plus.d)) stop 11 +! local operator in p + if ((a.minus.b) /= prg(a,b)) stop 12 + if ((c.minus.d) /= pig(c,d)) stop 13 +! local operator in block + block + generic :: operator(.bminus.) => pig, prg + if ((a.bminus.b) /= prg(a,b)) stop 14 + if ((c.bminus.d) /= pig(c,d)) stop 15 + end block +! intrinsic operator in p + tres = t1 * t2 + if (tres%i /= 6) stop 16 +! test private interface in module + call foo +! test mixture of GENERIC statement and generic INTERFACE + if (g((1.0,1.0),(2.0,2.0)) /= cg((1.0,1.0),(2.0,2.0))) stop 17 + tres = g(t1,t2) + if (tres%i /= 5) stop 18 +! subroutines + call sg(10.0*a, b, s3) + if (int(s3) /= 12) stop 19 + call sg(5*c, d, si) + if (si /= 19) stop 20 +! submodule procedures + if (subg(20.0*a,2.0*b) /= realg(20.0*a,2.0*b)) stop 21 +! check DTIO + open (10,status='scratch') + WRITE(10, '(DT)') tarray + rewind(10) + do i = 1,5 + read(10, *) rv + tsum = tsum + rv + end do + close(10) + if (tsum /= 15) stop 22 +contains + + function pig (arg1, arg2) + integer :: pig + integer, intent(in) :: arg1, arg2 + pig = arg1 - arg2 + end + function prg (arg1, arg2) + real :: prg + real, intent(in) :: arg1, arg2 + prg = arg1 - arg2 + end + function times (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i * arg2%i + end + function mg (arg1, arg2, arg3) + integer :: mg + integer, intent(in) :: arg1, arg2, arg3 + mg = arg1 - arg2 * arg3 + end +end diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 new file mode 100644 index 0000000..f698012 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_2.f90 @@ -0,0 +1,87 @@ +! { dg-do compile } +! +! Test the F2018 generic statement error reporting using the module from +! generic_stmt_1.f90 +! +function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + cg = arg1 + arg2 +end + +module m1 + implicit none + + type :: t + integer :: i + end type + + public g + interface g ! Check generic statement + generic interface works + module procedure tg + end interface g + + generic, public :: g => ig ! { dg-error "repeats that already given" } + generic, private :: g => rg ! { dg-error "conflicts with that already" } + generic :: operator(.plus.) => ig, rg, gg ! { dg-error "did you mean|must be a FUNCTION" } + generic, private :: h => ig, rg + generic :: => ig, rg ! { dg-error "Malformed GENERIC statement" } + generic :: wron ng => ig, rg ! { dg-error "Expected .=>." } + generic :: #!& => ig, rg ! { dg-error "Malformed GENERIC statement" } + generic, private :: operator(.plusplus.) => ig + generic, private :: operator(.plusplus.) => rg ! { dg-error "repeats the access specification" } + generic, PUBLIC :: operator(.plusplus.) => tg ! { dg-error "must have the same access" } + + interface g ! Check generic statement + generic interface works + function cg (arg1, arg2) + complex :: cg + complex, intent(in) :: arg1, arg2 + end + end interface g + + generic, public :: sg => sig, srg + generic, public :: sg2 => sig, srg, rg ! Error appears at 'srg' declaration + + +contains + + function rg (arg1, arg2) + real :: rg + real, intent(in) :: arg1, arg2 + rg = arg1 + arg2 + end + function ig (arg1, arg2) + integer :: ig + integer, intent(in) :: arg1, arg2 + ig = arg1 + arg2 + end + function tg (arg1, arg2) result(res) + type(t) :: res + type(t), intent(in) :: arg1, arg2 + res%i = arg1%i + arg2%i + end + subroutine srg (arg1, arg2, arg3) ! { dg-error "procedures must be either all SUBROUTINEs" } + real :: arg3 + real, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine sig (arg1, arg2, arg3) + integer :: arg3 + integer, intent(in) :: arg1, arg2 + arg3 = arg1 + arg2 + end + subroutine foo + real :: a = 1.0, b = 2.0, r + integer :: c = 3, d = 4 + generic, public :: sg => sig, srg ! { dg-error "not in a module" } + generic :: operator(+) => rg ! { dg-error "conflicts with intrinsic interface" } + r = h(a,d) ! { dg-error "There is no specific function" } + if (r /= rg(a,b)) stop 1 + if (h(c,d) /= ig(c,d)) stop 2 + generic :: wrong => ig, rg ! { dg-error "Unexpected GENERIC statement" } +! operator in foo + r = c.plus.b ! { dg-error "Unknown operator" } + if (r /= rg(a,b)) stop 3 + if ((c.plus.(2*d)) /= ig(c,2*d)) stop 4 + end +end module m1 diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 new file mode 100644 index 0000000..543c63f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_3.f90 @@ -0,0 +1,96 @@ +! { dg-do compile } +! +! Test the F2018 generic statement error reporting of access and name conflicts. +! +! Contributed by Steven Kargl <kargls@comcast.net> +! + module foo1 + + implicit none + private + + public bah + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + + public bar + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo1 + + module foo2 + + implicit none + private + + generic :: bah => bah, bak ! { dg-error "conflicts with that" } + public bah + + generic :: bar => bah, bak ! OK - checked that 'bar' is not a procedure + public bar + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo2 + + module foo3 ! { dg-error "clashes with the name of an entity" } + + implicit none + private + + integer :: bar = 10 ! { dg-error "has a type" } + generic :: bar => bah, bak ! { dg-error "has a type" } + + generic :: foo3 => bah, bak ! { dg-error "clashes with the name of an entity" } + + contains + integer function bah(i) + integer, intent(in) :: i + bah = i + end function bah + real function bak(x) + real, intent(in) :: x + bak = 42.5 + end function bak + end module foo3 + + module foo4 + implicit none + private + public bak + + generic :: bak => bar, bah + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah + end module foo4 + + program snooze + use foo4 + print *, bak(42) ! Public statement for 'bak' exposes the + print *, bak(43.5) ! specific procedures 'bar' and 'bah' here. + end program snooze diff --git a/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 new file mode 100644 index 0000000..24e814a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_stmt_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Test the correct processing of public generic statements and verify that they +! behave in the same way as public interfaces. +! +! Contributed by Steven Kargl <kargls@comcast.net> +! +module foo + + implicit none + + private + public bak1, bak2 + + + generic :: bak1 => bar, bah + + ! Should be equivalent to above. + + interface bak2 + module procedure bar + module procedure bah + end interface bak2 + + + contains + function bar(i) + real bar + integer, intent(in) :: i + bar = i + end function bar + function bah(x) + real bah + real, intent(in) :: x + bah = x + end function bah +end module foo + +program snooze + use foo + if (bak1(42) /= bak2(42)) stop 1 + if (bak1(43.5) /= bak2(43.5)) stop 2 +end program snooze 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/goacc/routine-1.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-1.f90 index 67c5f11..14617ad 100644 --- a/gcc/testsuite/gfortran.dg/goacc/routine-1.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/routine-1.f90 @@ -4,7 +4,7 @@ integer :: a(n), i integer, external :: fact i = 1 - !$acc routine (fact) ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + !$acc routine (fact) ! { dg-error "\\!\\\$ACC ROUTINE statement at \\(1\\) cannot appear after executable statements" } !$acc routine () ! { dg-error "Syntax error in \\\!\\\$ACC ROUTINE \\\( NAME \\\)" } !$acc parallel !$acc loop @@ -21,7 +21,7 @@ recursive function fact (x) result (res) integer, intent(in) :: x integer :: res res = 1 - !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + !$acc routine ! { dg-error "\\!\\\$ACC ROUTINE statement at \\(1\\) cannot appear after executable statements" } if (x < 1) then res = 1 else @@ -32,6 +32,6 @@ subroutine incr (x) integer, intent(inout) :: x integer i i = 0 - !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + !$acc routine ! { dg-error "\\!\\\$ACC ROUTINE statement at \\(1\\) cannot appear after executable statements" } x = x + 1 end subroutine incr diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-2.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-2.f90 index 3be3351..6188bd8 100644 --- a/gcc/testsuite/gfortran.dg/goacc/routine-2.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/routine-2.f90 @@ -7,7 +7,7 @@ integer :: res integer i i = 0 - !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + !$acc routine ! { dg-error "\\!\\\$ACC ROUTINE statement at \\(1\\) cannot appear after executable statements" } if (x < 1) then res = 1 else diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 index 39824c2..3a6711b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 @@ -26,7 +26,7 @@ module main integer function f4 (a) import c_ptr type(c_ptr), intent(inout) :: a - !$omp declare variant (f0) adjust_args (nothing: a) ! { 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" } + !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "expected 'match' clause at .1." } end function integer function f5 (i) integer, intent(inout) :: i diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 index e3ef841..55e4a1a 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 @@ -25,7 +25,7 @@ subroutine common use m integer :: a,b,c(5) common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" } - !$omp allocate(/my/) allocator(omp_cgroup_mem_alloc) + !$omp allocate(/my/) allocator(omp_low_lat_mem_alloc) end integer function allocators() result(res) diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 index ab85e32..e919f78 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 @@ -72,9 +72,9 @@ common /com4/ y,z allocatable :: q pointer :: b !$omp allocate (c, d) allocator (omp_pteam_mem_alloc) -!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) +!$omp allocate (/com4/) allocator (omp_low_lat_mem_alloc) !$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" } -!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" } +!$omp allocate (/com4/) allocator (omp_low_lat_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" } !$omp allocate(q,x) ! { dg-error "Unexpected allocatable variable 'q' at .1. in declarative !.OMP ALLOCATE directive" } !$omp allocate(b,e) ! { dg-error "Unexpected pointer variable 'b' at .1. in declarative !.OMP ALLOCATE directive" } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-static-3.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-static-3.f90 new file mode 100644 index 0000000..28a638c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-static-3.f90 @@ -0,0 +1,245 @@ +! { dg-do compile } +! +! PR fortran/122892 +! +! OpenMP 6.0 clarified that the omp_{cgroup,pteam,thread}_mem_alloc +! (i.e. those with access trait != device) may only be used for +! static local variables. +! Check for this! + +module omp_lib_kinds + use iso_c_binding, only: c_int, c_intptr_t + implicit none + private :: c_int, c_intptr_t + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end module + +block data + use omp_lib_kinds + implicit none + integer :: i1,i2,i3,i4,i5,i6,i7,i8 + common /b_i1/ i1 + common /b_i2/ i2 + common /b_i3/ i3 + common /b_i4/ i4 + common /b_i5/ i5 + common /b_i6/ i6 + common /b_i7/ i7 + common /b_i8/ i8 + + data i1 / 1 / + data i2 / 2 / + data i3 / 3 / + data i4 / 4 / + data i5 / 5 / + data i6 / 6 / + data i7 / 7 / + data i8 / 8 / + + !$omp allocate(/b_i1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_i2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_i3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_i4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_i5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_i6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_i6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_i7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_i7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_i8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_i8/' at .2., may only be used for local static variables" } +end block data + +block data my_block_data + use omp_lib_kinds + implicit none + integer :: j1,j2,j3,j4,j5,j6,j7,j8 + common /b_j1/ j1 + common /b_j2/ j2 + common /b_j3/ j3 + common /b_j4/ j4 + common /b_j5/ j5 + common /b_j6/ j6 + common /b_j7/ j7 + common /b_j8/ j8 + + data j1 / 1 / + data j2 / 2 / + data j3 / 3 / + data j4 / 4 / + data j5 / 5 / + data j6 / 6 / + data j7 / 7 / + data j8 / 8 / + + !$omp allocate(/b_j1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_j2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_j3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_j4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_j5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_j6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_j6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_j7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_j7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_j8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_j8/' at .2., may only be used for local static variables" } +end block data my_block_data + +module m + use omp_lib_kinds + implicit none + + integer :: a1,a2,a3,a4,a5,a6,a7,a8 + integer :: b1,b2,b3,b4,b5,b6,b7,b8 + common /b_b1/ b1 + common /b_b2/ b2 + common /b_b3/ b3 + common /b_b4/ b4 + common /b_b5/ b5 + common /b_b6/ b6 + common /b_b7/ b7 + common /b_b8/ b8 + + !$omp allocate(a1) allocator(omp_default_mem_alloc) + !$omp allocate(a2) allocator(omp_large_cap_mem_alloc) + !$omp allocate(a3) allocator(omp_const_mem_alloc) + !$omp allocate(a4) allocator(omp_high_bw_mem_alloc) + !$omp allocate(a5) allocator(omp_low_lat_mem_alloc) + !$omp allocate(a6) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item 'a6' at .2., may only be used for local static variables" } + !$omp allocate(a7) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item 'a7' at .2., may only be used for local static variables" } + !$omp allocate(a8) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item 'a8' at .2., may only be used for local static variables" } + + !$omp allocate(/b_b1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_b2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_b3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_b4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_b5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_b6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_b6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_b7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_b7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_b8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_b8/' at .2., may only be used for local static variables" } +end + +program main + use omp_lib_kinds + implicit none + + integer m1,m2,m3,m4,m5,m6,m7,m8 + integer n1,n2,n3,n4,n5,n6,n7,n8 + common /b_n1/ n1 + common /b_n2/ n2 + common /b_n3/ n3 + common /b_n4/ n4 + common /b_n5/ n5 + common /b_n6/ n6 + common /b_n7/ n7 + common /b_n8/ n8 + + !$omp allocate(m1) allocator(omp_default_mem_alloc) + !$omp allocate(m2) allocator(omp_large_cap_mem_alloc) + !$omp allocate(m3) allocator(omp_const_mem_alloc) + !$omp allocate(m4) allocator(omp_high_bw_mem_alloc) + !$omp allocate(m5) allocator(omp_low_lat_mem_alloc) + !$omp allocate(m6) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item 'm6' at .2., may only be used for local static variables" } + !$omp allocate(m7) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item 'm7' at .2., may only be used for local static variables" } + !$omp allocate(m8) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item 'm8' at .2., may only be used for local static variables" } + + !$omp allocate(/b_n1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_n2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_n3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_n4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_n5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_n6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_n6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_n7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_n7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_n8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_n8/' at .2., may only be used for local static variables" } + + block + integer, save :: o1,o2,o3,o4,o5,o6,o7,o8 + ! NOTE: COMMON statement is not allowed inside of BLOCK + + !$omp allocate(o1) allocator(omp_default_mem_alloc) + !$omp allocate(o2) allocator(omp_large_cap_mem_alloc) + !$omp allocate(o3) allocator(omp_const_mem_alloc) + !$omp allocate(o4) allocator(omp_high_bw_mem_alloc) + !$omp allocate(o5) allocator(omp_low_lat_mem_alloc) + !$omp allocate(o6) allocator(omp_cgroup_mem_alloc) + !$omp allocate(o7) allocator(omp_pteam_mem_alloc) + !$omp allocate(o8) allocator(omp_thread_mem_alloc) + end block +end + +subroutine sub + use omp_lib_kinds + implicit none + + integer, save :: s1,s2,s3,s4,s5,s6,s7,s8 + integer t1,t2,t3,t4,t5,t6,t7,t8 + common /b_t1/ t1 + common /b_t2/ t2 + common /b_t3/ t3 + common /b_t4/ t4 + common /b_t5/ t5 + common /b_t6/ t6 + common /b_t7/ t7 + common /b_t8/ t8 + + !$omp allocate(s1) allocator(omp_default_mem_alloc) + !$omp allocate(s2) allocator(omp_large_cap_mem_alloc) + !$omp allocate(s3) allocator(omp_const_mem_alloc) + !$omp allocate(s4) allocator(omp_high_bw_mem_alloc) + !$omp allocate(s5) allocator(omp_low_lat_mem_alloc) + !$omp allocate(s6) allocator(omp_cgroup_mem_alloc) + !$omp allocate(s7) allocator(omp_pteam_mem_alloc) + !$omp allocate(s8) allocator(omp_thread_mem_alloc) + + !$omp allocate(/b_t1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_t2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_t3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_t4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_t5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_t6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_t6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_t7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_t7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_t8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_t8/' at .2., may only be used for local static variables" } +contains + integer function func() + integer, save :: q1,q2,q3,q4,q5,q6,q7,q8 + integer r1,r2,r3,r4,r5,r6,r7,r8 + common /b_r1/ r1 + common /b_r2/ r2 + common /b_r3/ r3 + common /b_r4/ r4 + common /b_r5/ r5 + common /b_r6/ r6 + common /b_r7/ r7 + common /b_r8/ r8 + + !$omp allocate(q1) allocator(omp_default_mem_alloc) + !$omp allocate(q2) allocator(omp_large_cap_mem_alloc) + !$omp allocate(q3) allocator(omp_const_mem_alloc) + !$omp allocate(q4) allocator(omp_high_bw_mem_alloc) + !$omp allocate(q5) allocator(omp_low_lat_mem_alloc) + !$omp allocate(q6) allocator(omp_cgroup_mem_alloc) + !$omp allocate(q7) allocator(omp_pteam_mem_alloc) + !$omp allocate(q8) allocator(omp_thread_mem_alloc) + + !$omp allocate(/b_r1/) allocator(omp_default_mem_alloc) + !$omp allocate(/b_r2/) allocator(omp_large_cap_mem_alloc) + !$omp allocate(/b_r3/) allocator(omp_const_mem_alloc) + !$omp allocate(/b_r4/) allocator(omp_high_bw_mem_alloc) + !$omp allocate(/b_r5/) allocator(omp_low_lat_mem_alloc) + !$omp allocate(/b_r6/) allocator(omp_cgroup_mem_alloc) ! { dg-error "Predefined allocator 'omp_cgroup_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_r6/' at .2., may only be used for local static variables" } + !$omp allocate(/b_r7/) allocator(omp_pteam_mem_alloc) ! { dg-error "Predefined allocator 'omp_pteam_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_r7/' at .2., may only be used for local static variables" } + !$omp allocate(/b_r8/) allocator(omp_thread_mem_alloc) ! { dg-error "Predefined allocator 'omp_thread_mem_alloc' in ALLOCATOR clause at .1., used for list item '/b_r8/' at .2., may only be used for local static variables" } + end function +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 index 7e4f74d..fdab51f 100644 --- a/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/append_args-1.f90 @@ -56,12 +56,12 @@ contains subroutine f2b () !$omp declare variant (f1c) & - !$omp& append_args ( interop ( target , targetsync) ) ! { dg-error "the 'append_args' clause at .1. can only be specified if the 'dispatch' selector of the construct selector set appears in the 'match' clause" } + !$omp& append_args ( interop ( target , targetsync) ) ! { dg-error "expected 'match'" } end subroutine subroutine f2c (x,y) !$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" } + !$omp& adjust_args (need_device_ptr : x, y ) ! { dg-error "expected 'match' clause at .1." } type(c_ptr) :: x, y value :: y end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 index 476d7b9..06ac604 100644 --- a/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/crayptr2.f90 @@ -3,7 +3,7 @@ ! { dg-require-effective-target tls } module crayptr2 - integer :: e ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } + integer :: e pointer (ip5, e) ! The standard is not very clear about this. @@ -12,6 +12,6 @@ module crayptr2 ! be if they are module variables. But threadprivate pointees don't ! make any sense anyway. -!$omp threadprivate (e) +!$omp threadprivate (e) ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } end module crayptr2 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 index 93075fb..b4f1e52 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-2.f90 @@ -24,7 +24,11 @@ module declare_target_2 end interface end subroutine bar + !$omp declare target enter (q) ! { dg-error "isn.t SAVEd" } + !$omp declare target link (r) ! { dg-error "isn.t SAVEd" } + !$omp declare target local (s) ! { dg-error "isn.t SAVEd" } !$omp declare target link (baz) ! { dg-error "isn.t SAVEd" } + integer :: q, r, s call baz ! { dg-error "attribute conflicts" } end subroutine subroutine foo ! { dg-error "attribute conflicts" } diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 index 55534d8..296c0db 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-4.f90 @@ -42,15 +42,14 @@ module mymod !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(host) !$omp declare target to(c) device_type(any) - ! Fails in ME with "Error: wrong number of arguments specified for 'omp declare target link' attribute" - ! !$omp declare target link(e) device_type(nohost) - ! !$omp declare target link(f) device_type(host) - ! !$omp declare target link(g) device_type(any) + ! !$omp declare target link(e) device_type(nohost) ! -> invalid: only 'any' is permitted + ! !$omp declare target link(f) device_type(host) ! -> invalid: only 'any' is permitted + !$omp declare target link(g) device_type(any) !$omp declare target to(/block1/) device_type(nohost) !$omp declare target to(/block2/) device_type(host) !$omp declare target to(/block3/) device_type(any) - !$omp declare target link(/block4/) device_type(nohost) + ! !$omp declare target link(/block4/) device_type(nohost) ! -> invalid, link requires host or any !$omp declare target link(/block5/) device_type(host) !$omp declare target link(/block6/) device_type(any) contains diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 index 76687d4..0dacb89 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-5.f90 @@ -4,9 +4,15 @@ end subroutine bar() !$omp declare target to(bar) device_type(nohost) - !$omp declare target to(bar) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(bar) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } end +module invalid + implicit none + integer :: d + !$omp declare target link(d) device_type(nohost) ! { dg-error "set with NOHOST specified may not appear in a LINK clause" } +end module + module mymod_one implicit none integer :: a, b, c, d, e ,f @@ -17,24 +23,21 @@ module mymod_one !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(any) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) !$omp declare target link(e) device_type(any) !$omp declare target link(f) device_type(host) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) end module module mtest use mymod_one ! { dg-error "Cannot change attributes of USE-associated symbol" } implicit none - !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(a) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } + !$omp declare target to(b) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp declare target link(e) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target link(f) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } end module module mymod @@ -47,17 +50,15 @@ module mymod !$omp declare target to(a) device_type(nohost) !$omp declare target to(b) device_type(any) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) + !$omp declare target link(d) device_type(nohost) ! { dg-error "set with NOHOST specified may not appear in a LINK clause" } !$omp declare target link(e) device_type(any) !$omp declare target link(f) device_type(host) !$omp declare target to(c) device_type(host) - !$omp declare target link(d) device_type(nohost) - - !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } - !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + + !$omp declare target to(a) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'nohost'" } + !$omp declare target to(b) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp declare target link(e) device_type(host) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'any'" } + !$omp declare target link(f) device_type(any) ! { dg-error "set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 new file mode 100644 index 0000000..21970e6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-6.f90 @@ -0,0 +1,15 @@ +subroutine sub ! { dg-error "SUBROUTINE attribute conflicts with OMP DECLARE TARGET LINK attribute in 'sub'" } + !$omp declare target link(sub) +end subroutine sub + +subroutine sub2 ! { dg-error "SUBROUTINE attribute conflicts with OMP DECLARE TARGET LOCAL attribute in 'sub2'" } + !$omp declare target local(sub2) +end subroutine sub2 + +integer function func() ! { dg-error "PROCEDURE attribute conflicts with OMP DECLARE TARGET LINK attribute in 'func'" } + !$omp declare target link(func) +end + +integer function func2() ! { dg-error "PROCEDURE attribute conflicts with OMP DECLARE TARGET LOCAL attribute in 'func2'" } + !$omp declare target local(func2) +end diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 index f6b3ae1..4345c69 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-target-indirect-2.f90 @@ -11,7 +11,7 @@ contains subroutine sub2 !$omp declare target indirect (.false.) to (sub2) end subroutine - ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub2" "gimple" } } + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target \\(device_type\\(any\\)\\)\\\)\\\)\\\n.*\\\nvoid sub2" "gimple" } } subroutine sub3 !$omp declare target indirect (.true.) to (sub3) @@ -21,5 +21,5 @@ contains subroutine sub4 !$omp declare target indirect (.false.) enter (sub4) end subroutine - ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target\\\)\\\)\\\n.*\\\nvoid sub4" "gimple" } } + ! { dg-final { scan-tree-dump "__attribute__\\\(\\\(omp declare target \\(device_type\\(any\\)\\)\\\)\\\)\\\n.*\\\nvoid sub4" "gimple" } } end module diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 index df57f9c..ae5ca95 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 @@ -7,11 +7,11 @@ program main continue - !$omp declare variant (base: variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." } + !$omp declare variant (base: variant) match (construct={parallel}) ! { dg-error "\\!\\\$OMP DECLARE VARIANT statement at \\(1\\) cannot appear after executable statements" } contains subroutine base () continue - !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." } + !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "\\!\\\$OMP DECLARE VARIANT statement at \\(1\\) cannot appear after executable statements" } end subroutine end program diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 index 11be76e..02bd8623 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 @@ -195,7 +195,7 @@ contains !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." } end subroutine subroutine f77 () - !$omp declare variant (f1) match(user={condition(score(f76):.true.)}) ! { dg-error ".score. argument must be constant integer expression at .1." } + !$omp declare variant (f1) match(user={condition(score(f76):.true.)}) ! { dg-error "Unexpected use of subroutine name 'f76'" } end subroutine subroutine f78 () !$omp declare variant (f1) match(user={condition(score(-130):.true.)}) ! { dg-error ".score. argument must be non-negative" } diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-20.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-20.f90 index 17fdcb7..82b8a52 100644 --- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-20.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-20.f90 @@ -44,6 +44,7 @@ contains !$omp declare variant(variant5) match(target_device={device_num(-4)}) ! OK - omp_invalid_device (will never match) ! OK - but not handled -> PR middle-end/113904 !$omp declare variant(variant5) match(target_device={device_num(my_device)}) ! { dg-error "property must be a constant integer expression" } + ! { dg-error "Symbol 'my_device' at .1. has no IMPLICIT type" "" { target *-*-* } .-1 } !$omp declare variant(variant5) match(target_device={device_num(-2)}) ! { dg-error "property must be a conforming device number" } res = 99 diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 new file mode 100644 index 0000000..a1b2f2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-22.f90 @@ -0,0 +1,6 @@ +! PR118839: Check that error is diagnosed when the variant is the same +! as the base function. + +subroutine f() + !$omp declare variant(f) match(user={condition(.true.)}) ! { dg-error "variant 'f' at .1. is the same as base function" } +end subroutine diff --git a/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 new file mode 100644 index 0000000..a3f8615 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +implicit none + +integer :: N +N = 1024 + +!$omp target dyn_groupprivate(1024) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate (1024 * N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( abort ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( null ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target + +!$omp target dyn_groupprivate ( fallback ( default_mem ) : N) ! { dg-message "sorry, unimplemented: 'dyn_groupprivate' clause" } +!$omp end target +end + +! { dg-final { scan-tree-dump-times "#pragma omp target dyn_groupprivate\\(1024\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target dyn_groupprivate\\(D\\.\[0-9\]+\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target dyn_groupprivate\\(fallback\\(abort\\):n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target dyn_groupprivate\\(fallback\\(null\\):n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target dyn_groupprivate\\(fallback\\(default_mem\\):n\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 new file mode 100644 index 0000000..8410334 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/dyn_groupprivate-2.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } + +implicit none + +integer, parameter :: M = 1024 +integer :: N, A(1) + +N = 1024 + +!$omp target dyn_groupprivate(0) ! OK, zero is permitted +block; end block + +!$omp target dyn_groupprivate(0) dyn_groupprivate(0) ! { dg-error "Duplicated 'dyn_groupprivate' clause" } +block; end block + +!$omp target dyn_groupprivate(-123) ! { dg-warning "INTEGER expression of DYN_GROUPPRIVATE clause at .1. must be non-negative \\\[-Wopenmp\\\]" } +block; end block + +!$omp target dyn_groupprivate (0 * M-1) ! { dg-warning "INTEGER expression of DYN_GROUPPRIVATE clause at .1. must be non-negative \\\[-Wopenmp\\\]" } +block; end block + +!$omp target dyn_groupprivate ( fallback ( other ) : N) ! { dg-error "Failed to match clause" } +block; end block + +!$omp target dyn_groupprivate ( A ) ! { dg-error "DYN_GROUPPRIVATE clause at .1. requires a scalar INTEGER expression" } +block; end block + +!$omp target dyn_groupprivate ( 1024. ) ! { dg-error "DYN_GROUPPRIVATE clause at .1. requires a scalar INTEGER expression" } +block; end block + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 new file mode 100644 index 0000000..f776c08 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-1.f90 @@ -0,0 +1,23 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, u, k ! { dg-warning "Ignoring the 'groupprivate' attribute for 'threadprivate' variable 'k' declared at .1. \\\[-Wopenmp\\\]" } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'x' declared at .1." "" { target *-*-* } .-1 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'y' declared at .1." "" { target *-*-* } .-2 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'z' declared at .1." "" { target *-*-* } .-3 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'v' declared at .1." "" { target *-*-* } .-4 } +! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by 'u' declared at .1." "" { target *-*-* } .-5 } +! +! Note:Error different as 'groupprivate' flag is overwritten by 'threadprivate', cf. warning above. +! { dg-error "Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, used by 'k' declared at .1." "" { target *-*-* } .-8 } + !$omp groupprivate(x, z) device_Type( any ) + !$omp declare target local(x) device_type ( any ) + !$omp declare target enter( ii) ,local(y), device_type ( host ) + !$omp groupprivate(y) device_type( host) + !$omp groupprivate(v) device_type (nohost ) + !$omp groupprivate(u) + + ! See also (currently unresolved) OpenMP Specification Issue 4663. + !$omp groupprivate(k) + !$omp threadprivate(k) +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 new file mode 100644 index 0000000..922d229 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-2.f90 @@ -0,0 +1,37 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, q, r,o, b2,c + + !$omp groupprivate(x, z, o) device_Type( any ) + !$omp declare target enter(x) device_type ( any ) ! { dg-error "List item 'x' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target to(z) device_type ( any ) ! { dg-error "List item 'z' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target link(o) device_type ( any ) ! { dg-error "List item 'o' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target enter( ii) ,local(y,c), link(r), to(q) device_type ( host ) + !$omp groupprivate(r,q) device_type(host) +! { dg-error "List item 'q' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-1 } +! { dg-error "List item 'r' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-2 } + !$omp groupprivate(c) ! { dg-error "List item 'c' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(y) device_type( any) ! { dg-error "List item 'y' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(v) device_type (nohost ) + !$omp groupprivate(v) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + + !$omp declare target link(b2) device_type(nohost) ! { dg-error "List item 'b2' at .1. set with NOHOST specified may not appear in a LINK clause" } +end module + +subroutine sub() + implicit none + integer, save :: x0,x1,x2,x3,x4 + !$omp groupprivate(x0) + !$omp groupprivate(x1) + !$omp groupprivate(x2) device_type ( any) + !$omp groupprivate(x3) device_type (host ) + !$omp groupprivate(x4) device_type( nohost) + + !$omp declare target(x0) ! { dg-error "List item 'x0' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) to(x1) ! { dg-error "List item 'x1' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) enter(x2) ! { dg-error "List item 'x2' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) link(x3) ! { dg-error "List item 'x3' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) local(x4) ! { dg-error "List item 'x4' at .1. set in previous OMP GROUPPRIVATE directive to the different DEVICE_TYPE 'nohost'" } + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 new file mode 100644 index 0000000..d7ccbe2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-3.f90 @@ -0,0 +1,16 @@ +module m +implicit none +integer :: y = 5 ! { dg-error "!.OMP GROUPPRIVATE variable 'y' at .1. must not have an initializer" } +!$omp groupprivate(y) +end + +subroutine sub + integer :: k ! { dg-error "OpenMP groupprivate variable 'k' at .1. must have the SAVE attribute" } + !$omp groupprivate(k) +end + +subroutine sub2 + !$omp groupprivate(q) + integer, save :: q + !$omp groupprivate(q) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 new file mode 100644 index 0000000..2a3a054 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-4.f90 @@ -0,0 +1,25 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, u, k + + common /b_ii/ ii + common /b_x/ x ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_x/' declared at .1." } + common /b_y/ y ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_y/' declared at .1." } + common /b_z/ z ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_z/' declared at .1." } + common /b_v/ v ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_v/' declared at .1." } + common /b_u/ u ! { dg-error "Sorry, OMP GROUPPRIVATE not implemented, used by common block '/b_u/' declared at .1." } + common /b_k/ k ! { dg-warning "Ignoring the 'groupprivate' attribute for 'threadprivate' common block '/b_k/' declared at .1. \\\[-Wopenmp\\\]" } +! { dg-error "Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, used by common block '/b_k/' declared at .1." "" { target *-*-* } .-1 } + + !$omp groupprivate(/b_x/, /b_z/) device_Type( any ) + !$omp declare target local(/b_x/) device_type ( any ) + !$omp declare target enter( /b_ii/) ,local(/b_y/), device_type ( host ) + !$omp groupprivate(/b_y/) device_type( host) + !$omp groupprivate(/b_v/) device_type (nohost ) + !$omp groupprivate(/b_u/) + + ! See also (currently unresolved) OpenMP Specification Issue 4663. + !$omp groupprivate(/b_k/) + !$omp threadprivate(/b_k/) +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 new file mode 100644 index 0000000..c9f89fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-5.f90 @@ -0,0 +1,58 @@ +module m + implicit none + integer :: ii + integer :: x, y(20), z, v, q, r,o, b2,c + + common /b_ii/ ii + common /b_x/ x + common /b_y/ y + common /b_z/ z + common /b_v/ v + common /b_q/ q + common /b_r/ r + common /b_o/ o + common /b_b2/ b2 + common /b_c/ c + + !$omp groupprivate(/b_x/, /b_z/, /b_o/) device_Type( any ) + !$omp declare target enter(/b_x/) device_type ( any ) ! { dg-error "Common block '/b_x/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target to(/b_z/) device_type ( any ) ! { dg-error "Common block '/b_z/' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target link(/b_o/) device_type ( any ) ! { dg-error "Common block '/b_o/' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target enter( / b_ii / ) ,local(/b_y/ , /b_c/), link(/b_r/), to(/b_q/) device_type ( host ) + !$omp groupprivate( /b_r/ ,/b_q/) device_type(host) +! { dg-error "List item '/b_r/' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-1 } +! { dg-error "List item '/b_q/' at .1. implies OMP DECLARE TARGET with the LOCAL clause, but it has been specified with a different clause before" "" { target *-*-* } .-2 } + !$omp groupprivate(/b_c/) ! { dg-error "List item 'b_c' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(/b_y/) device_type( any) ! { dg-error "List item 'b_y' at .1. set in previous OMP DECLARE TARGET directive to the different DEVICE_TYPE 'host'" } + !$omp groupprivate(/b_v/) device_type (nohost ) + !$omp groupprivate(/b_v/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } + + !$omp declare target link(/b_b2/) device_type(nohost) ! { dg-error "Common block '/b_b2/' at .1. set with NOHOST specified may not appear in a LINK clause" } +end module + +subroutine sub() + implicit none + integer, save :: xx + integer :: x0,x1,x2,x3,x4 + + common /b_xx/ xx ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'xx' at .1." } + common /b_x0/ x0 + common /b_x1/ x1 + common /b_x2/ x2 + common /b_x3/ x3 + common /b_x4/ x4 + + !$omp groupprivate(/b_xx/) ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'xx' at .1." } + !$omp groupprivate(/b_x0/) + !$omp groupprivate(/b_x1/) + !$omp groupprivate(/b_x2/) device_type ( any) + !$omp groupprivate(/b_x3/) device_type (host ) + !$omp groupprivate(/b_x4/) device_type( nohost) + + !$omp declare target(/b_x0/) ! { dg-error "Common block '/b_x0/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) to(/b_x1/) ! { dg-error "Common block '/b_x1/' at .1. not appear in the 'to' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(any) enter(/b_x2/) ! { dg-error "Common block '/b_x2/' at .1. not appear in the 'enter' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) link(/b_x3/) ! { dg-error "Common block '/b_x3/' at .1. not appear in the 'link' clause as it was previously specified in a GROUPPRIVATE directive" } + !$omp declare target device_type(host) local(/b_x4/) ! { dg-error "Common block '/b_x4/' at .1. set in previous OMP GROUPPRIVATE directive to the different DEVICE_TYPE 'nohost'" } + +end diff --git a/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 b/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 new file mode 100644 index 0000000..6ae5b3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/groupprivate-6.f90 @@ -0,0 +1,34 @@ +module m +implicit none +integer :: y = 5 ! { dg-error "!.OMP GROUPPRIVATE variable 'y' at .1. must not have an initializer" } +common /b_y/ y +!$omp groupprivate(/b_y/) +end + +subroutine sub + integer, save :: k + common /b_k/ k ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'k' at .1." } + !$omp groupprivate(/b_k/) ! { dg-error "COMMON attribute conflicts with SAVE attribute in 'k' at .1." } +end + +subroutine sub2 + common /b_q/ q + !$omp groupprivate(/b_q/) + integer :: q + !$omp groupprivate(/b_q/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified at .1." } +end + +subroutine dupl + integer :: a,b,c,d + integer :: u,v,w,x + common /b_a/ a + common /b_b/ b + common /b_c/ c + common /b_d/ d + + !$omp groupprivate(/b_a/,u,/b_a/) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + !$omp groupprivate(v,/b_b/,v) ! { dg-error "Duplicate OpenMP GROUPPRIVATE attribute specified" } + + !$omp threadprivate(/b_a/,u,/b_a/) ! { dg-error "Duplicate THREADPRIVATE attribute specified" } + !$omp threadprivate(v,/b_b/,v) ! { dg-error "Duplicate THREADPRIVATE attribute specified" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 index eae0cb3..9dd0470 100644 --- a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 @@ -19,7 +19,7 @@ end module m subroutine sub1 ! { dg-error "Program unit at .1. has OpenMP device constructs/routines but does not set !.OMP REQUIRES REVERSE_OFFLOAD but other program units do" } !$omp interop - integer :: y ! { dg-error "Unexpected data declaration statement" } + integer :: y ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } end subroutine sub1 program main 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/order-2.f90 b/gcc/testsuite/gfortran.dg/gomp/order-2.f90 index 4ee3a82..8938cac 100644 --- a/gcc/testsuite/gfortran.dg/gomp/order-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/order-2.f90 @@ -11,14 +11,14 @@ contains implicit none integer, save :: t t = 1 - !$omp threadprivate (t1) ! { dg-error "Unexpected" } + !$omp threadprivate (t1) ! { dg-error "\\!\\\$OMP THREADPRIVATE statement at \\(1\\) cannot appear after executable statements" } end subroutine f2 subroutine f3 use m implicit none integer :: j j = 1 - !$omp declare reduction (foo:real:omp_out = omp_out + omp_in) ! { dg-error "Unexpected" } + !$omp declare reduction (foo:real:omp_out = omp_out + omp_in) ! { dg-error "\\!\\\$OMP DECLARE REDUCTION statement at \\(1\\) cannot appear after executable statements" } end subroutine f3 subroutine f4 use m @@ -26,12 +26,12 @@ contains !$omp declare target integer, save :: f4_1 f4_1 = 1 - !$omp declare target (f4_1) ! { dg-error "Unexpected" } - !$omp declare target ! { dg-error "Unexpected" } + !$omp declare target (f4_1) ! { dg-error "\\!\\\$OMP DECLARE TARGET statement at \\(1\\) cannot appear after executable statements" } + !$omp declare target ! { dg-error "\\!\\\$OMP DECLARE TARGET statement at \\(1\\) cannot appear after executable statements" } end subroutine f4 integer function f5 (a, b) integer :: a, b a = 1; b = 2 - !$omp declare simd (f5) notinbranch ! { dg-error "Unexpected" } + !$omp declare simd (f5) notinbranch ! { dg-error "\\!\\\$OMP DECLARE SIMD statement at \\(1\\) cannot appear after executable statements" } end function f5 end subroutine f1 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr104428.f90 b/gcc/testsuite/gfortran.dg/gomp/pr104428.f90 new file mode 100644 index 0000000..639b331 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr104428.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +program p + interface + subroutine x + end subroutine x + end interface +contains + subroutine foo + !$omp declare variant(x) match(construct={do}) + end + subroutine bar + !$omp declare variant(y) match(construct={do}) ! { dg-error "Cannot find symbol 'y'" } + end +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 b/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 new file mode 100644 index 0000000..a524db5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr107421.f90 @@ -0,0 +1,19 @@ +! { dg-require-effective-target pie } +! { dg-additional-options "-fdump-ipa-whole-program" } +! Add -fPIE or -mno-direct-extern-access to disable direct access to +! external symbol from executable. +! { dg-additional-options "-fPIE" { target { ! { i?86-*-* x86_64-*-* } } } } +! { dg-additional-options "-mno-direct-extern-access" { target { i?86-*-* x86_64-*-* } } } + +integer :: i + +common /c/ i + +!$omp threadprivate (/c/) + +i = 0 + +end + +! tls_model should be tls-initial-exec due to common block. +! { dg-final { scan-ipa-dump "Varpool flags: tls-initial-exec" "whole-program" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 new file mode 100644 index 0000000..f16a256 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr120180-1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } + +! This test case checks that the inner metadirective is accepted as intervening +! code since it resolves to 'omp nothing'. + +SUBROUTINE test1(x_min, x_max, y_min, y_max, xarea, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: xarea + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp metadirective & + !$omp when(user={condition(.false.)}: & + !$omp target teams distribute parallel do simd collapse(2)) & + !$omp when(user={condition(.false.)}: & + !$omp target teams distribute parallel do) & + !$omp default( & + !$omp target teams loop collapse(2)) + DO k=y_min,y_max + !$omp metadirective when(user={condition(.false.)}: simd) + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*xarea(j,k) + ENDDO + ENDDO + +END SUBROUTINE test1 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 new file mode 100644 index 0000000..ea90ad6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr120180-2.f90 @@ -0,0 +1,90 @@ +! { dg-do compile } + +! This test case checks that a non-executable OpenMP directive is accepted +! as intervening code. + +SUBROUTINE test1(x_min, x_max, y_min, y_max, xarea, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: xarea + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp nothing + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*xarea(j,k) + ENDDO + ENDDO + +END SUBROUTINE test1 + +SUBROUTINE test2(x_min, x_max, y_min, y_max, x, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: x, z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp assume holds(x>1) + z = abs(x-1) + !$omp end assume + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test2 + +SUBROUTINE test3(x_min, x_max, y_min, y_max, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp error at(compilation) ! { dg-error "OMP ERROR encountered at" } + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test3 + +SUBROUTINE test4(x_min, x_max, y_min, y_max, z, vol_flux_x) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: x_min, x_max, y_min, y_max + + REAL(KIND=8) :: z + REAL(KIND=8), DIMENSION(x_min:x_max,y_min:y_max) :: vol_flux_x + + INTEGER :: j,k + + !$omp do collapse(2) + DO k=y_min,y_max + !$omp error at(execution) ! { dg-error "OMP DO cannot contain OpenMP directive in intervening code" } + DO j=x_min,x_max + vol_flux_x(j,k)=0.25_8*z + ENDDO + ENDDO + +END SUBROUTINE test4 diff --git a/gcc/testsuite/gfortran.dg/gomp/pr121452-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr121452-1.f90 new file mode 100644 index 0000000..60697c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr121452-1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +! Check that the front end acccepts a CONTINUE statement +! inside an ordered loop. + +implicit none +integer :: i, j +integer :: A(5,5), B(5,5) = 1 + +!$omp do ordered(2) + do 10 i = 1, 5 + do 20 j = 1, 5 + A(i,j) = B(i,j) +20 continue +10 continue + +if (any(A /= 1)) stop 1 +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr121452-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr121452-2.f90 new file mode 100644 index 0000000..ab020d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr121452-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! Check that the OMP_STRUCTURED_BLOCK that wraps intervening code is accepted by +! the OMP lowering pass. + +implicit none +integer :: i, j, x +integer :: A(5,5), B(5,5) = 1 + +!$omp simd collapse(2) + do i = 1, 5 + do j = 1, 5 + A(i,j) = B(i,j) + end do + x = 1 ! intervening code + end do + +if (any(A /= 1)) stop 1 +end + +! { dg-final { scan-tree-dump "#pragma omp __structured_block" "original" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/pr121452-3.f90 b/gcc/testsuite/gfortran.dg/gomp/pr121452-3.f90 new file mode 100644 index 0000000..605f92c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr121452-3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! Check that the OMP_STRUCTURED_BLOCK that wraps intervening code is accepted by +! the OMP lowering pass. + + +implicit none +integer :: i, j +integer :: A(5,5), B(5,5) = 1 + +!$omp simd collapse(2) + do 10 i = 1, 5 + do 20 j = 1, 5 + A(i,j) = B(i,j) +20 continue +10 continue + +if (any(A /= 1)) stop 1 +end + +! { dg-final { scan-tree-dump "#pragma omp __structured_block" "original" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 new file mode 100644 index 0000000..b7eb44f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122306-1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } + +! This test case checks that a function call in a context selector is accepted. + +module m + implicit none (type, external) +contains + integer function f(n) + integer :: i, n + f = 0 + !$omp metadirective & + !$omp& when(user={condition(use_target())}: target parallel do map(f) reduction(+:f)) & + !$omp& otherwise(parallel do reduction(+:f)) + do i = 1, n + f = f + 1 + end do + end + logical function use_target() + use_target = .false. + end +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 new file mode 100644 index 0000000..799c92b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122306-2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! This test case checks that various user-condition context selectors correctly +! parsed and resolved. + +SUBROUTINE test1(x_min, x_max, vol_flux_x) + IMPLICIT NONE + INTEGER, INTENT(IN) :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: vol_flux_x + integer, parameter :: one = 1 + INTEGER :: j + + !$omp begin metadirective when(user={condition(one < 0)}: parallel) + DO j=x_min,x_max + vol_flux_x(j)=0.25_8 + ENDDO + !$omp end metadirective +END SUBROUTINE test1 + +SUBROUTINE test2(x_min, x_max, vol_flux_x, flag) + IMPLICIT NONE + INTEGER, INTENT(IN) :: x_min, x_max + REAL(KIND=8), DIMENSION(x_min:x_max) :: vol_flux_x + LOGICAL :: flag + INTEGER :: j + + !$omp begin metadirective when(user={condition(flag)}: parallel) + DO j=x_min,x_max + vol_flux_x(j)=0.25_8 + ENDDO + !$omp end metadirective +END SUBROUTINE test2 + diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 new file mode 100644 index 0000000..bf4cbd5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label referenced in the first statement past a +! metadirective body is bound to the outer region. + +!$omp metadirective when(user={condition(.true.)}: target teams & +!$omp& distribute parallel do) + DO JCHECK = 1, MNMIN + END DO + WRITE(6,366) PCHECK, UCHECK, VCHECK + 366 FORMAT(/, ' Vcheck = ',E12.4,/) + END PROGRAM diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 new file mode 100644 index 0000000..041d790 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a statement label that ends a loop in the first statement past a +! metadirective body is bound to the outer region. + +implicit none +integer :: i, j +logical :: cond1, cond2 +integer :: A(0:10,0:5), B(0:10,0:5) + +cond1 = .true. +cond2 = .true. + +!$omp metadirective when(user={condition(cond1)} : parallel do collapse(2)) + do 50 j = 0, 5 +!$omp metadirective when(user={condition(.false.)} : simd) + do 51 i = 0, 10 + A(i,j) = i*10 + j + 51 continue + 50 continue + + do 55 i = 0, 5 + 55 continue + +!$omp begin metadirective when(user={condition(cond2)} : parallel do collapse(2)) + do 60 j = 0, 5 +!$omp metadirective when(user={condition(.false.)} : simd) + do 61 i = 0, 10 + B(i,j) = i*10 + j + 61 continue + 60 continue +!$omp end metadirective + + do 70 j = 0, 5 + 70 continue +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 new file mode 100644 index 0000000..61225db --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a statement label defined in the first statement past a +! metadirective body is bound to the outer region. + + +integer :: cnt, x + +cnt = 0 +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + x = 5 +!$omp end metadirective +1234 format("Hello") +write(*,1234) + +!$omp begin metadirective when(user={condition(x > 0)} : parallel) + x = 5 +!$omp end metadirective +4567 print *, 'hello', cnt +cnt = cnt + 1 +if (cnt < 2) goto 4567 +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 new file mode 100644 index 0000000..ff5b683 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122369-4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label defined in the first statement after a nested +! metadirective body can be referenced correctly. + +integer :: cnt, x +cnt = 0 +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + !$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + x = 5 + !$omp end metadirective + 1234 format("Hello") + write(*,1234) +!$omp end metadirective +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 new file mode 100644 index 0000000..c64a864 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122508-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-label" } + +! Check that a format label defined outside a metadirective body can be +! referenced correctly inside the metadirective body. + +implicit none +integer :: cnt +1345 format("The count is ", g0) + +cnt = 0 +write(*,1345) cnt + +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + write(*,1345) cnt +!$omp end metadirective +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 b/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 new file mode 100644 index 0000000..4528711 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122508-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + +! Check that redefining labels across metadirective regions triggers a +! diagnostic. + +implicit none +integer :: cnt +1345 format("The count is ", g0) + +cnt = 0 +write(*,1345) cnt + +!$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + 6789 format("The count is ", g0) + !$omp begin metadirective when(user={condition(cnt > 0)} : parallel) + 1345 print *, 'nested' ! { dg-error "Label 1345 at .1. already referenced as a format label" } + 6789 print *, 'world' + !$omp end metadirective + write(*,1345) cnt ! { dg-error "Label 1345 at .1. previously used as branch target" } + write(*,6789) cnt ! { dg-error "Label 6789 at .1. previously used as branch target" } +!$omp end metadirective +end diff --git a/gcc/testsuite/gfortran.dg/gomp/pr122570.f b/gcc/testsuite/gfortran.dg/gomp/pr122570.f new file mode 100644 index 0000000..9897cc6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr122570.f @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-additional-options "-Wall" } + +! PR fortran/122570 + + SUBROUTINE INITAL + implicit none (type, external) + integer :: j, n + n = 5 +!$omp metadirective & +!$omp& when(user={condition(.true.)}: target teams & +!$omp& distribute parallel do) & +!$omp& when(user={condition(.false.)}: target teams & +!$omp& distribute parallel do) + DO J=1,N + END DO + END SUBROUTINE + + SUBROUTINE CALC3 + implicit none (type, external) + integer :: i, m + m = 99 +!$omp metadirective +!$omp& when(user={condition(.false.)}: +!$omp& simd) + DO 301 I=1,M + 301 CONTINUE + 300 CONTINUE ! { dg-warning "Label 300 at .1. defined but not used \\\[-Wunused-label\\\]" } + END SUBROUTINE diff --git a/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 b/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 index 61f9458..8278d69 100644 --- a/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 +++ b/gcc/testsuite/gfortran.dg/gomp/pr78026.f03 @@ -1,5 +1,5 @@ ! PR fortran/78026 select type (a) ! { dg-error "Selector shall be polymorphic in SELECT TYPE statement" } end select -!$omp declare simd(b) ! { dg-error "Unexpected !.OMP DECLARE SIMD statement" } +!$omp declare simd(b) ! { dg-error "\\!\\\$OMP DECLARE SIMD statement at \\(1\\) cannot appear after executable statements" } end ! { dg-error "should refer to containing procedure" "" { target *-*-* } .-1 } diff --git a/gcc/testsuite/gfortran.dg/gomp/requires-4.f90 b/gcc/testsuite/gfortran.dg/gomp/requires-4.f90 index 9d93619..0b7d4b8 100644 --- a/gcc/testsuite/gfortran.dg/gomp/requires-4.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/requires-4.f90 @@ -16,7 +16,7 @@ end subroutine foobar i = 5 ! < execution statement -!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "Unexpected ..OMP REQUIRES statement" } +!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "\\!\\\$OMP REQUIRES statement at \\(1\\) cannot appear after executable statements" } end program main diff --git a/gcc/testsuite/gfortran.dg/gomp/requires-6.f90 b/gcc/testsuite/gfortran.dg/gomp/requires-6.f90 index b20c218..dd55f93 100644 --- a/gcc/testsuite/gfortran.dg/gomp/requires-6.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/requires-6.f90 @@ -10,5 +10,5 @@ end subroutine foobar !$omp atomic i = i + 5 -!$omp requires atomic_default_mem_order(acq_rel) ! { dg-error "Unexpected !.OMP REQUIRES statement" } +!$omp requires atomic_default_mem_order(acq_rel) ! { dg-error "\\!\\\$OMP REQUIRES statement at \\(1\\) cannot appear after executable statements" } 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/hollerith_1.f90 b/gcc/testsuite/gfortran.dg/hollerith_1.f90 index fc163d8..9cbc5aa 100644 --- a/gcc/testsuite/gfortran.dg/hollerith_1.f90 +++ b/gcc/testsuite/gfortran.dg/hollerith_1.f90 @@ -6,7 +6,7 @@ ! Also verifies the functioning of hollerith formatting. character*72 c write(c,8000) -8000 format(36(2H!))) +8000 format(36(2H!))) ! { dg-warning "H format specifier" } do i = 1,72,2 if (c(i:i+1) /= '!)') STOP 1 end do diff --git a/gcc/testsuite/gfortran.dg/implied_do_io_9.f90 b/gcc/testsuite/gfortran.dg/implied_do_io_9.f90 new file mode 100644 index 0000000..5180b8a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implied_do_io_9.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! { dg-additional-options "-O2" } +! +! PR fortran/107968 +! +! Verify that array I/O optimization is not used for a section +! of an array pointer as the pointee can be non-contiguous +! +! Contributed by Nils Dreier + +PROGRAM foo + implicit none + + TYPE t_geographical_coordinates + REAL :: lon + REAL :: lat + END TYPE t_geographical_coordinates + + TYPE t_vertices + REAL, POINTER :: vlon(:) => null() + REAL, POINTER :: vlat(:) => null() + END TYPE t_vertices + + TYPE(t_geographical_coordinates), TARGET :: vertex(2) + TYPE(t_vertices), POINTER :: vertices_pointer + TYPE(t_vertices), TARGET :: vertices_target + + character(24) :: s0, s1, s2 + character(*), parameter :: fmt = '(2f8.3)' + + ! initialization + vertex%lon = [1,3] + vertex%lat = [2,4] + + ! obtain pointer to (non-contiguous) field + vertices_target%vlon => vertex%lon + + ! reference output of write + write (s0,fmt) vertex%lon + + ! set pointer vertices_pointer in a subroutine + CALL set_vertices_pointer(vertices_target) + + write (s1,fmt) vertices_pointer%vlon + write (s2,fmt) vertices_pointer%vlon(1:) + if (s1 /= s0 .or. s2 /= s0) then + print *, s0, s1, s2 + stop 3 + end if + +CONTAINS + + SUBROUTINE set_vertices_pointer(vertices) + TYPE(t_vertices), POINTER, INTENT(IN) :: vertices + + vertices_pointer => vertices + + write (s1,fmt) vertices %vlon + write (s2,fmt) vertices %vlon(1:) + if (s1 /= s0 .or. s2 /= s0) then + print *, s0, s1, s2 + stop 1 + end if + + write (s1,fmt) vertices_pointer%vlon + write (s2,fmt) vertices_pointer%vlon(1:) + if (s1 /= s0 .or. s2 /= s0) then + print *, s0, s1, s2 + stop 2 + end if + END SUBROUTINE set_vertices_pointer +END PROGRAM foo 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/import13.f90 b/gcc/testsuite/gfortran.dg/import13.f90 new file mode 100644 index 0000000..3bcfec3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/import13.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Contributed by Steve Kargl <sgk@troutmask.apl.washington.edu> +! +program foo + implicit none + integer i + i = 42 + if (i /= 42) stop 1 + call bah + contains + subroutine bah ! { dg-error "is already defined at" } + i = 43 + if (i /= 43) stop 2 + end subroutine bah + subroutine bah ! { dg-error "is already defined at" } + ! import statement missing a comma + import none ! { dg-error "Unexpected IMPORT statement" } + i = 44 ! { dg-error "Unexpected assignment" } + end subroutine bah ! { dg-error "Expecting END PROGRAM" } +end program foo 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/initialization_9.f90 b/gcc/testsuite/gfortran.dg/initialization_9.f90 index d904047..fe7ca63 100644 --- a/gcc/testsuite/gfortran.dg/initialization_9.f90 +++ b/gcc/testsuite/gfortran.dg/initialization_9.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options " " } ! ! PR fortran/31639 ! Contributed by Martin Michlmayr <tbm AT cyrius DOT com> 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/intent_optimize_10.f90 b/gcc/testsuite/gfortran.dg/intent_optimize_10.f90 index d8bc1bb..214f04c 100644 --- a/gcc/testsuite/gfortran.dg/intent_optimize_10.f90 +++ b/gcc/testsuite/gfortran.dg/intent_optimize_10.f90 @@ -63,4 +63,4 @@ end program main ! There is a clobber for tc, so we should manage to optimize away the associated initialization constant (but not other ! initialization constants). -! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } +! { dg-final { scan-tree-dump-not "= 123456789" "optimized" { target __OPTIMIZE__ } } } 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/interface_abstract_6.f90 b/gcc/testsuite/gfortran.dg/interface_abstract_6.f90 new file mode 100644 index 0000000..05b9a4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_abstract_6.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/122206 +! +! Verify that procedure interfaces are "stable" + +module test_example + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + abstract interface + function simple_interface(iarg1, arg2) bind(c) result(res) + import c_double, c_int + integer(c_int), value, intent(in) :: iarg1 + real(c_double), value, intent(in) :: arg2 + real(c_double) :: res + end function simple_interface + end interface + + procedure(simple_interface), bind(c,name="simple_function") :: simple_function + + interface + function other_interface(iarg1, arg2) result(res) + import c_double, c_int + integer(c_int), value, intent(in) :: iarg1 + real(c_double), value, intent(in) :: arg2 + real(c_double) :: res + end function other_interface + end interface + + procedure(other_interface) :: other_function + +contains + subroutine test_example_interface + implicit none + integer(c_int) :: iarg1 = 2 + real(c_double) :: arg2 = 10. + real(c_double) :: val1, val2 + + val1 = simple_function(iarg1, arg2) + val2 = simple_function(iarg1, arg2) + if (val1 /= val2) stop 1 + + val1 = other_function(iarg1, arg2) + val2 = other_function(iarg1, arg2) + if (val1 /= val2) stop 2 + + end subroutine test_example_interface +end module test_example + +! { dg-final { scan-tree-dump-times "simple_function \\(iarg1, arg2\\);" 2 "original"} } +! { dg-final { scan-tree-dump-times "other_function \\(iarg1, arg2\\);" 2 "original"} } diff --git a/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 b/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 index 4521c96..3358b4a 100644 --- a/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 +++ b/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options " " } ! Tests the fix for PR27900, in which an ICE would be caused because ! the actual argument LEN had no type. ! diff --git a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 index c6f9569..9e0a19b 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_1.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-std=f95" } +! { dg-options "-std=legacy" } ! Part I of the test of the IO constraints patch, which fixes PRs: ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. ! @@ -7,7 +7,7 @@ ! module fails - 2000 format (1h , 2i6) ! { dg-error "Format statement in module" } + 2000 format (2i6) ! { dg-error "Format statement in module" } end module fails @@ -21,7 +21,7 @@ contains subroutine foo (i) integer :: i write (*, 100) i - 100 format (1h , "i=", i6) ! { dg-warning "The H format specifier at ... is a Fortran 95 deleted feature" } + 100 format ("i=", i6) end subroutine foo end module global @@ -33,7 +33,7 @@ end module global ! Appending to a USE associated namelist is an extension. - NAMELIST /NL/ a,b ! { dg-error "already is USE associated" } + NAMELIST /NL/ a,b a=1 ; b=2 @@ -54,7 +54,7 @@ end module global ! R912 !Was correctly picked up before patch. - write(6, NML=NL, iostat = ierr) ! { dg-error "requires default INTEGER" } + write(6, NML=NL, iostat = ierr) ! Constraints !Was correctly picked up before patch. diff --git a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 index e0e0db6..5479c34 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_2.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_2.f90 @@ -17,7 +17,7 @@ contains subroutine foo (i) integer :: i write (*, 100) i - 100 format (1h , "i=", i6) ! { dg-warning "H format specifier" } + 100 format ("i=", i6) end subroutine foo end module global diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 new file mode 100644 index 0000000..091e43b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 @@ -0,0 +1,126 @@ +! { dg-do run } +! PR fortran/114023 - IS_CONTIGUOUS and pointers to non-contiguous targets +! +! Based on testcase by Federico Perini + +program main + implicit none + complex, parameter :: cvals(*) = [(1,-1),(2,-2),(3,-3)] + complex , target :: cref(size(cvals)) = cvals ! Reference + complex, allocatable, target :: carr(:) ! Test + + type cx + real :: re, im + end type cx + type(cx), parameter :: tvals(*) = [cx(1,-1),cx(2,-2),cx(3,-3)] + real, parameter :: expect(*) = tvals% re + type(cx) , target :: tref(size(cvals)) = tvals ! Reference + type(cx), allocatable, target :: tarr(:) + + real, pointer :: rr1(:), rr2(:), rr3(:), rr4(:) + class(*), pointer :: cp1(:), cp2(:), cp3(:), cp4(:) + + carr = cvals + tarr = tvals + + if (any (expect /= [1,2,3])) error stop 90 + + ! REAL pointer to non-contiguous effective target + rr1(1:3) => cref%re + rr2 => cref%re + rr3(1:3) => carr%re + rr4 => carr%re + + if (is_contiguous (rr1)) stop 1 + if (my_contiguous_real (rr1)) stop 2 + if (is_contiguous (cref(1:3)%re)) stop 3 +! if (my_contiguous_real (cref(1:3)%re)) stop 4 ! pr122397 + + if (is_contiguous (rr3)) stop 6 + if (my_contiguous_real (rr3)) stop 7 + if (is_contiguous (carr(1:3)%re)) stop 8 +! if (my_contiguous_real (carr(1:3)%re)) stop 9 + + if (is_contiguous (rr2)) stop 11 + if (my_contiguous_real (rr2)) stop 12 + if (is_contiguous (cref%re)) stop 13 +! if (my_contiguous_real (cref%re)) stop 14 + + if (is_contiguous (rr4)) stop 16 + if (my_contiguous_real (rr4)) stop 17 + if (is_contiguous (carr%re)) stop 18 +! if (my_contiguous_real (carr%re)) stop 19 + + rr1(1:3) => tref%re + rr2 => tref%re + rr3(1:3) => tarr%re + rr4 => tarr%re + + if (is_contiguous (rr1)) stop 21 + if (my_contiguous_real (rr1)) stop 22 + if (is_contiguous (tref(1:3)%re)) stop 23 +! if (my_contiguous_real (tref(1:3)%re)) stop 24 + + if (is_contiguous (rr3)) stop 26 + if (my_contiguous_real (rr3)) stop 27 + if (is_contiguous (tarr(1:3)%re)) stop 28 +! if (my_contiguous_real (tarr(1:3)%re)) stop 29 + + if (is_contiguous (rr2)) stop 31 + if (my_contiguous_real (rr2)) stop 32 + if (is_contiguous (tref%re)) stop 33 +! if (my_contiguous_real (tref%re)) stop 34 + + if (is_contiguous (rr4)) stop 36 + if (my_contiguous_real (rr4)) stop 37 + if (is_contiguous (tarr%re)) stop 38 +! if (my_contiguous_real (tarr%re)) stop 39 + + ! Unlimited polymorphic pointer to non-contiguous effective target + cp1(1:3) => cref%re + cp2 => cref%re + cp3(1:3) => carr%re + cp4 => carr%re + + if (is_contiguous (cp1)) stop 41 + if (my_contiguous_poly (cp1)) stop 42 + if (is_contiguous (cp2)) stop 43 + if (my_contiguous_poly (cp2)) stop 44 + if (is_contiguous (cp3)) stop 45 + if (my_contiguous_poly (cp3)) stop 46 + if (is_contiguous (cp4)) stop 47 + if (my_contiguous_poly (cp4)) stop 48 + + cp1(1:3) => tref%re + cp2 => tref%re + cp3(1:3) => tarr%re + cp4 => tarr%re + + if (is_contiguous (cp1)) stop 51 + if (my_contiguous_poly (cp1)) stop 52 + if (is_contiguous (cp2)) stop 53 + if (my_contiguous_poly (cp2)) stop 54 + if (is_contiguous (cp3)) stop 55 + if (my_contiguous_poly (cp3)) stop 56 + if (is_contiguous (cp4)) stop 57 + if (my_contiguous_poly (cp4)) stop 58 + + deallocate (carr, tarr) +contains + pure logical function my_contiguous_real (x) result (res) + real, pointer, intent(in) :: x(:) + res = is_contiguous (x) + if (any (x /= expect)) error stop 97 + end function my_contiguous_real + + pure logical function my_contiguous_poly (x) result (res) + class(*), pointer, intent(in) :: x(:) + res = is_contiguous (x) + select type (x) + type is (real) + if (any (x /= expect)) error stop 98 + class default + error stop 99 + end select + end function my_contiguous_poly +end diff --git a/gcc/testsuite/gfortran.dg/longline.f b/gcc/testsuite/gfortran.dg/longline.f index c2a5f5a..4b666fa 100644 --- a/gcc/testsuite/gfortran.dg/longline.f +++ b/gcc/testsuite/gfortran.dg/longline.f @@ -6,6 +6,6 @@ character*10 cpnam character*4 csig write (34,808) csig,ilax,cpnam - 808 format (/9X,4HTHE ,A4, 29HTIVE MINOS ERROR OF PARAMETER,I3, 2H - +, ,A10) + 808 format (/9X,'THE ',A4, 'TIVE MINOS ERROR OF PARAMETER',I3, ' + +,' ,A10) end diff --git a/gcc/testsuite/gfortran.dg/matmul_blas_3.f90 b/gcc/testsuite/gfortran.dg/matmul_blas_3.f90 new file mode 100644 index 0000000..bf02a38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/matmul_blas_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fexternal-blas64 -fdump-tree-original" } +! { dg-require-effective-target lp64 } +! PR 121161 - option for 64-bit BLAS for MATMUL. +! Check this by making sure there is no KIND=4 integer. +subroutine foo(a,b,c,n) + implicit none + integer(kind=8) :: n + real, dimension(n,n) :: a, b, c + c = matmul(a,b) +end subroutine foo +! { dg-final { scan-tree-dump-not "integer\\(kind=4\\)" "original" } } +! { dg-final { scan-tree-dump-times "sgemm" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/module_private_2.f90 b/gcc/testsuite/gfortran.dg/module_private_2.f90 index 847c58d..58dbb1e 100644 --- a/gcc/testsuite/gfortran.dg/module_private_2.f90 +++ b/gcc/testsuite/gfortran.dg/module_private_2.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O2 -fdump-tree-optimized" } +! { dg-options "-O2 -Wsurprising -fdump-tree-optimized" } ! ! PR fortran/47266 ! 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/namelist_assumed_char.f90 b/gcc/testsuite/gfortran.dg/namelist_assumed_char.f90 index b7d063c..25edf64 100644 --- a/gcc/testsuite/gfortran.dg/namelist_assumed_char.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_assumed_char.f90 @@ -8,7 +8,7 @@ ! Add -std=f95, add bar() ! subroutine foo(c) - character*(*) c + character*(*) c ! { dg-warning "Old-style character length" } namelist /abc/ c ! { dg-error "nonconstant character length in namelist" } end subroutine 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/pdt_11.f03 b/gcc/testsuite/gfortran.dg/pdt_11.f03 index 41b506a..3ddbafe 100644 --- a/gcc/testsuite/gfortran.dg/pdt_11.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_11.f03 @@ -47,6 +47,7 @@ program test write(*,*) 'o_fdef FAIL' STOP 2 end if + deallocate (o_fdef) end program test diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03 index 4ae1983..17d4d37 100644 --- a/gcc/testsuite/gfortran.dg/pdt_15.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_15.f03 @@ -98,9 +98,9 @@ contains if (int (pop_8 (root)) .ne. 3) STOP 1 if (int (pop_8 (root)) .ne. 2) STOP 2 if (int (pop_8 (root)) .ne. 1) STOP 3 -! if (int (pop_8 (root)) .ne. 0) STOP 4 + if (int (pop_8 (root)) .ne. 0) STOP 4 end subroutine end program ch2701 ! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } } -! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } } -! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } } +! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_17.f03 b/gcc/testsuite/gfortran.dg/pdt_17.f03 index 1b0a30d..eab9ee9 100644 --- a/gcc/testsuite/gfortran.dg/pdt_17.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_17.f03 @@ -6,6 +6,6 @@ ! program p type t(a) ! { dg-error "does not have a component" } - integer(kind=t()) :: x ! { dg-error "used before it is defined" } + integer(kind=t()) :: x ! { dg-error "empty type specification" } end type end diff --git a/gcc/testsuite/gfortran.dg/pdt_20.f03 b/gcc/testsuite/gfortran.dg/pdt_20.f03 index b712ed5..3c4b5b8 100644 --- a/gcc/testsuite/gfortran.dg/pdt_20.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_20.f03 @@ -16,5 +16,6 @@ program p allocate (t2(3) :: x) ! Used to segfault in trans-array.c. if (x%b .ne. 3) STOP 1 if (x%b .ne. size (x%r, 1)) STOP 2 - if (any (x%r%a .ne. 1)) STOP 3 + if (x%r%a .ne. 1) STOP 3 +! deallocate (x) ! Segmentation fault: triggered at trans-array.cc:11009. end diff --git a/gcc/testsuite/gfortran.dg/pdt_22.f03 b/gcc/testsuite/gfortran.dg/pdt_22.f03 index 929f398..23feb8c 100644 --- a/gcc/testsuite/gfortran.dg/pdt_22.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_22.f03 @@ -8,9 +8,10 @@ ! program p character(120) :: buffer - integer :: i(4) + integer :: i(3) type t(a) integer, len :: a + integer :: z = 4 end type type t2(b) integer, len :: b @@ -18,6 +19,10 @@ program p end type type(t2(3)) :: x write (buffer,*) x - read (buffer,*) i - if (any (i .ne. [3,1,1,1])) STOP 1 + read (buffer, *) i + if (any (i .ne. [4,4,4])) stop 1 + x%r = [t(1)(3),t(1)(2),t(1)(1)] + write (buffer,*) x + read (buffer, *) i + if (any (i .ne. [3,2,1])) stop 2 end diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03 b/gcc/testsuite/gfortran.dg/pdt_23.f03 index b2156b9..dadea11 100644 --- a/gcc/testsuite/gfortran.dg/pdt_23.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_23.f03 @@ -15,19 +15,20 @@ program p type(t(:)), allocatable :: x allocate (t(2) :: x) - x = t(2,'ab') + x = t(2)('ab') write (buffer, *) x%c ! Tests the fix for PR82720 read (buffer, *) chr if (trim (chr) .ne. 'ab') STOP 1 - x = t(3,'xyz') + x = t(3)('xyz') if (len (x%c) .ne. 3) STOP 2 - write (buffer, *) x ! Tests the fix for PR82719 - read (buffer, *) i, chr - if (i .ne. 3) STOP 3 + write (buffer, *) x ! Tests the fix for PR82719. PDT IO was incorrect (PRs 84143/84432). + read (buffer, *) chr +! if (i .ne. 3) STOP 3 if (chr .ne. 'xyz') STOP 4 - buffer = " 3 lmn" - read (buffer, *) x ! Some thought will be needed for PDT reads. + buffer = "lmn" + read (buffer, *) x ! PDT IO was incorrect (PRs 84143/84432). if (x%c .ne. 'lmn') STOP 5 +! if (allocated (x)) deallocate (x) ! Used to seg fault - invalid memory reference. end diff --git a/gcc/testsuite/gfortran.dg/pdt_26.f03 b/gcc/testsuite/gfortran.dg/pdt_26.f03 index b7e3bb6..86a585a 100644 --- a/gcc/testsuite/gfortran.dg/pdt_26.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_26.f03 @@ -13,7 +13,7 @@ module pdt_m implicit none type :: vec(k) integer, len :: k=3 - integer :: foo(k)=[1,2,3] + integer :: foo(k) end type vec contains elemental function addvv(a,b) result(c) @@ -43,4 +43,4 @@ program test_pdt if (any (c(1)%foo .ne. [13,15,17])) STOP 2 end program test_pdt ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } } -! { dg-final { scan-tree-dump-times "__builtin_malloc" 9 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_27.f03 b/gcc/testsuite/gfortran.dg/pdt_27.f03 index 525b999..de5f517 100644 --- a/gcc/testsuite/gfortran.dg/pdt_27.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_27.f03 @@ -1,22 +1,16 @@ -! { dg-do run } +! { dg-do compile } ! -! Test the fix for PR83611, in which the assignment caused a -! double free error and the initialization of 'foo' was not done. +! This originally tested the fix for PR83611, in which the assignment caused a +! double free error and the initialization of 'foo' was not done. However, the +! initialization is not conforming (see PR84432 & PR114815) and so this test +! is now compile only and verifies the error detection. The program part has +! been deleted. ! module pdt_m implicit none type :: vec(k) integer, len :: k=3 - integer :: foo(k)=[1,2,3] + integer :: foo(k)=[1,2,3] ! { dg-error "not compatible with a default initializer" } + character(len = k) :: chr = "ab" ! { dg-error "not compatible with a default initializer" } end type vec end module pdt_m - -program test_pdt - use pdt_m - implicit none - type(vec) :: u,v - if (any (u%foo .ne. [1,2,3])) STOP 1 - u%foo = [7,8,9] - v = u - if (any (v%foo .ne. [7,8,9])) STOP 2 -end program test_pdt diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 index e364eea..7359519 100644 --- a/gcc/testsuite/gfortran.dg/pdt_3.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -5,7 +5,7 @@ module vars integer :: d_dim = 4 integer :: mat_dim = 256 - integer, parameter :: ftype = kind(0.0d0) + integer, parameter :: ftype = kind(0.0) end module use vars @@ -32,9 +32,8 @@ end module type (mytype (b=s*2)) :: mat2 end type x - real, allocatable :: matrix (:,:) type(thytype(ftype, 4, 4)) :: w - type(x(8,4,256)) :: q + type(x(ftype,ftype,256)) :: q class(mytype(ftype, :)), allocatable :: cz w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) @@ -54,24 +53,23 @@ end module if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10 ! Now check some basic OOP with PDTs - matrix = w%d -! TODO - for some reason, using w%d directly in the source causes a seg fault. - allocate (cz, source = mytype(ftype, d_dim, 0, matrix)) +! Using w%d directly in the source used to cause a seg fault. + allocate (cz, source = mytype(ftype, d_dim)( 0, w%d)) ! Leaks 64 bytes in 1 block. select type (cz) type is (mytype(ftype, *)) if (int (sum (cz%d)) .ne. 136) STOP 11 - type is (thytype(ftype, *, 8)) + type is (thytype(ftype, *, ftype)) STOP 12 end select deallocate (cz) - allocate (thytype(ftype, d_dim*2, 8) :: cz) + allocate (thytype(ftype, d_dim*2, ftype) :: cz) cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) select type (cz) type is (mytype(ftype, *)) STOP 13 - type is (thytype(ftype, *, 8)) + type is (thytype(ftype, *, ftype)) if (int (sum (cz%d)) .ne. 20800) STOP 14 end select diff --git a/gcc/testsuite/gfortran.dg/pdt_38.f03 b/gcc/testsuite/gfortran.dg/pdt_38.f03 new file mode 100644 index 0000000..4eb8a41 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_38.f03 @@ -0,0 +1,21 @@ +! { dg-do compile ) +! +! Test the fix for pr84122 +! +! Contributed by Neil Carlson <neil.n.carlson@gmail.com> +! +module mod +type foo(idim) + integer, len, PUBLIC :: idim ! { dg-error "is not allowed" } + private + integer :: array(idim) +end type +end module + +module bar +type foo(idim) + private + integer,len :: idim ! { dg-error "must come before a PRIVATE statement" } + integer :: array(idim) +end type +end module diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03 new file mode 100644 index 0000000..7cfd232 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_39.f03 @@ -0,0 +1,123 @@ +! { dg-do run } +! +! Test the fix for pr95541. +! +! Contributed by Juergen Reuter <juergen.reuter@desy.de> +! +module mykinds + use, intrinsic :: iso_fortran_env, only : i4 => int32, r4 => real32, r8 => real64 + implicit none + private + public :: i4, r4, r8 +end module mykinds + +module matrix + use mykinds, only : r4, r8 + implicit none + private + + type, public :: mat_t(k,c,r) + !.. type parameters + integer, kind :: k = r4 + integer, len :: c = 1 + integer, len :: r = 1 + private + !.. private by default + !.. type data + real(kind=k) :: m_a(c,r) + end type mat_t + + interface assignment(=) + module procedure geta_r4 + module procedure seta_r4 + module procedure geta_r8 + module procedure seta_r8 + !.. additional bindings elided + end interface assignment(=) + + public :: assignment(=) + +contains + + subroutine geta_r4(a_lhs, t_rhs) + real(r4), allocatable, intent(out) :: a_lhs(:,:) + class(mat_t(k=r4,c=*,r=*)), intent(in) :: t_rhs + a_lhs = t_rhs%m_a + return + end subroutine geta_r4 + + subroutine geta_r8(a_lhs, t_rhs) + real(r8), allocatable, intent(out) :: a_lhs(:,:) + class(mat_t(k=r8,c=*,r=*)), intent(in) :: t_rhs + a_lhs = t_rhs%m_a ! Leaks 152 bytes in 2 blocks + return + end subroutine geta_r8 + + subroutine seta_r4(t_lhs, a_rhs) + class(mat_t(k=r4,c=*,r=*)), intent(inout) :: t_lhs + real(r4), intent(in) :: a_rhs(:,:) + !.. checks on size elided + t_lhs%m_a = a_rhs + return + end subroutine seta_r4 + + subroutine seta_r8(t_lhs, a_rhs) + class(mat_t(k=r8,c=*,r=*)), intent(inout) :: t_lhs + real(r8), intent(in) :: a_rhs(:,:) + !.. checks on size elided + t_lhs%m_a = a_rhs + return + end subroutine seta_r8 + +end module matrix + +program p + use mykinds, only : r4, r8 + use matrix, only : mat_t, assignment(=) + implicit none + type(mat_t(k=r4,c=:,r=:)), allocatable :: mat_r4 + type(mat_t(k=r8,c=:,r=:)), allocatable :: mat_r8 + real(r4), allocatable :: a_r4(:,:) + real(r8), allocatable :: a_r8(:,:) + integer :: N + integer :: M + integer :: i + integer :: istat + N = 2 + M = 3 + allocate( mat_t(k=r4,c=N,r=M) :: mat_r4, stat=istat ) + if ( istat /= 0 ) then + print *, " error allocating mat_r4: stat = ", istat + stop + end if + if (mat_r4%k /= r4) stop 1 + if (mat_r4%c /= N) stop 2 + if (mat_r4%r /= M) stop 3 + mat_r4 = reshape( [ (real(i, kind=mat_r4%k), i=1,N*M) ], [ N, M ] ) + a_r4 = mat_r4 ! Leaks 24 bytes in 1 block. + if (int (sum (a_r4)) /= 21) stop 4 + N = 4 + M = 4 + allocate( mat_t(k=r8,c=N,r=M) :: mat_r8, stat=istat ) + if ( istat /= 0 ) then + print *, " error allocating mat_r4: stat = ", istat + stop + end if + if (mat_r8%k /= r8) stop 5 + if (mat_r8%c /= N) stop 6 + if (mat_r8%r /= M) stop 7 + mat_r8 = reshape( [ (real(i, kind=mat_r8%k), i=1,N*M) ], [ N, M ] ) + a_r8 = mat_r8 + if (int (sum (a_r8)) /= 136) stop 8 + deallocate( mat_r4, stat=istat ) + if ( istat /= 0 ) then + print *, " error deallocating mat_r4: stat = ", istat + stop + end if + deallocate( mat_r8, stat=istat ) + if ( istat /= 0 ) then + print *, " error deallocating mat_r4: stat = ", istat + stop + end if + stop +end program p diff --git a/gcc/testsuite/gfortran.dg/pdt_40.f03 b/gcc/testsuite/gfortran.dg/pdt_40.f03 new file mode 100644 index 0000000..673ffde --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_40.f03 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Contributed by FortranFan at https://groups.google.com/g/comp.lang.fortran/c/NDE6JKTFbNU +! + integer, parameter :: parm = 42 + type :: t(ell) + integer, len :: ell + integer :: i + end type + + type :: u + type(t(ell=:)), allocatable :: x + end type + + type(t(ell=:)), allocatable :: foo + type(u) :: bar + + allocate( t(ell = parm) :: foo ) + foo%i = 2 * foo%ell + + bar = u (foo) ! Gave: Cannot convert TYPE(Pdtt) to TYPE(t) + + if (bar%x%ell /= parm) stop 1 ! Then these component references failed in + if (bar%x%i /= 2 * parm) stop 2 ! translation. + deallocate (foo, bar%x) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_41.f03 b/gcc/testsuite/gfortran.dg/pdt_41.f03 new file mode 100644 index 0000000..be2e871 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_41.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Test the fix for pr99709 in which the object being passed to a PDT dummy +! with the value attribute was not a deep copy. +! +! Contribute by Xiao Liu <xiao.liu@compiler-dev.com> +! +program value_f2008 + implicit none + type :: matrix(k) + integer, len :: k + integer :: elements(k, k) + !integer :: elements(2, 2) + end type matrix + + type, extends(matrix) :: child + end type child + + integer, parameter :: array_parm(2, 2) = reshape([1, 2, 3, 4], [2, 2]) + + type(child(2)) :: obj + obj%elements = array_parm + + call test_value_attr(2, obj) + if (any (obj%elements /= array_parm)) stop 1 + + call test(2, obj) + if (any (obj%elements /= 0)) stop 2 + +contains + + subroutine test(n, nonconstant_length_object) + integer :: n + type(child(n)) :: nonconstant_length_object + if (nonconstant_length_object%k /= 2) stop 3 + if (any (nonconstant_length_object%elements /= array_parm)) stop 4 + nonconstant_length_object%elements = 0 + end subroutine test + + subroutine test_value_attr(n, nonconstant_length_object) + integer :: n + type(child(n)), value :: nonconstant_length_object + if (nonconstant_length_object%k /= 2) stop 5 + if (any (nonconstant_length_object%elements /= array_parm)) stop 6 + nonconstant_length_object%elements = 0 + end subroutine test_value_attr +end program value_f2008 diff --git a/gcc/testsuite/gfortran.dg/pdt_42.f03 b/gcc/testsuite/gfortran.dg/pdt_42.f03 new file mode 100644 index 0000000..47743d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_42.f03 @@ -0,0 +1,46 @@ +! { dg-do run ) +! +! Test the fix for PR87669 in which SELECT TYPE was not identifying the difference +! between derived types with different type kind parameters, when the selector +! is unlimited polymorphic. +! +! Contributed by Etienne Descamps <etdescdev@gmail.com> +! +Program Devtest + Type dvtype(k) + Integer, Kind :: k + Real(k) :: a, b, c + End Type dvtype + type(dvtype(8)) :: dv + type(dvtype(4)) :: fv + integer :: ctr = 0 + + dv%a = 1; dv%b = 2; dv%c = 3 + call dvtype_print(dv) + if (ctr /= 2) stop 1 + + fv%a = 1; fv%b = 2; fv%c = 3 + call dvtype_print(fv) + if (ctr /= 0) stop 2 + +Contains + Subroutine dvtype_print(p) + class(*), intent(in) :: p + Select Type(p) + class is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + class is (dvtype(8)) + ctr = ctr + 1 + End Select + Select Type(p) + type is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + type is (dvtype(8)) + ctr = ctr + 1 + End Select + End Subroutine dvtype_print +End diff --git a/gcc/testsuite/gfortran.dg/pdt_43.f03 b/gcc/testsuite/gfortran.dg/pdt_43.f03 new file mode 100644 index 0000000..c9f2502 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_43.f03 @@ -0,0 +1,28 @@ +! { dg-do run ) +! +! Test the fix for PR89707 in which the procedure pointer component +! with a parameterized KIND expression caused an ICE in resolution. +! +! Contributed by Janus Weil <janus@gcc.gnu.org> +! +program pdt_with_ppc + integer, parameter :: kt = kind (0d0) + type :: q(k) + integer, kind :: k = 4 + procedure (real(kind=kt)), pointer, nopass :: p + end type + type (q(kt)) :: x + x%p => foo + if (int (x%p(2d0)) /= 4) stop 1 + x%p => bar + if (int (x%p(2d0, 4d0)) /= 16) stop 2 +contains + real(kind=kt) function foo (x) + real(kind = kt) :: x + foo = 2.0 * x + end + real(kind=kt) function bar (x, y) + real(kind = kt) :: x, y + bar = x ** y + end +end diff --git a/gcc/testsuite/gfortran.dg/pdt_44.f03 b/gcc/testsuite/gfortran.dg/pdt_44.f03 new file mode 100644 index 0000000..459001c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_44.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Test the fix for PRs83762 and 102457, in which type parameter expressions that +! are not of INTEGER type were either not being diagnosed or were inadequately +! diagnosed. +! +! PR83762 +module bar + implicit none + type :: foo(n) + integer, len :: n=10 + end type foo +contains + subroutine main + type(foo(undefined)) :: x ! { dg-error "must be of INTEGER type and not UNKNOWN" } + end subroutine main +end module bar + +! PR102457 +subroutine s + real :: m = 2 + type t(n) + integer, len :: n = 1 + character(n*n) :: c + end type + type(t(m)) :: x ! { dg-error "must be of INTEGER type and not REAL" } + call h(x) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_45.f03 b/gcc/testsuite/gfortran.dg/pdt_45.f03 new file mode 100644 index 0000000..ceba1ad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_45.f03 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! Contributed by Steve Kargl <kargl@gcc.gnu.org> +! +module mod + + type :: objects(k1,l1) + integer, kind :: k1 = selected_int_kind(4) + integer, len :: l1 + integer(k1) :: p(l1+1) + end type + + contains + subroutine foo(n) + integer n + type(objects(l1=n)) :: x + ! Any of these lines caused an ICE in compilation. + if (x%k1 /= selected_int_kind(4)) stop 1 + if (x%l1 /= n) stop 2 + if (size(x%p) /= x%l1+1) stop 3 + end subroutine + +end module + +program p + use mod + type(objects(1,30)) :: x + call foo(3) +end program p diff --git a/gcc/testsuite/gfortran.dg/pdt_46.f03 b/gcc/testsuite/gfortran.dg/pdt_46.f03 new file mode 100644 index 0000000..67d32df --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_46.f03 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR83763 in which a dependency was not handled correctly, which +! resulted in a runtime segfault. +! +! Contributed by Berke Durak <berke.durak@gmail.com> +! +module bar + implicit none + + type :: foo(n) + integer, len :: n = 10 + real :: vec(n) + end type foo + +contains + + function baz(a) result(b) + type(foo(n = *)), intent(in) :: a + type(foo(n = a%n)) :: b + + b%vec = a%vec * 10 + end function baz + +end module bar + +program test + use bar + implicit none + call main1 ! Original report + call main2 ! Check for memory loss with allocatable 'x' and 'y'. + +contains + + subroutine main1 + type(foo(5)) :: x, y + integer :: a(5) = [1,2,3,4,5] + + x = foo(5)(a) + x = baz (x) ! Segmentation fault because dependency not handled. + if (any (x%vec /= 10 * a)) stop 1 + y = x + x = baz (y) ! No dependecy and so this worked. + if (any (x%vec /= 100 * a)) stop 2 + end subroutine main1 + + subroutine main2 + type(foo(5)), allocatable :: x, y + integer :: a(5) = [1,2,3,4,5] + + x = foo(5)(a) + x = baz (x) ! Segmentation fault because dependency not handled. + if (any (x%vec /= 10 * a)) stop 3 + y = x + x = baz (y) ! No dependecy and so this worked. + if (any (x%vec /= 100 * a)) stop 4 + end subroutine main2 + +end program test +! { dg-final { scan-tree-dump-times "__builtin_free" 16 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 12 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_47.f03 b/gcc/testsuite/gfortran.dg/pdt_47.f03 new file mode 100644 index 0000000..f3b77d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_47.f03 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Test the fix for PR121948, in which the PDT constructor expressions without +! the type specification list, ie. relying on default values, failed. The fix +! also required that the incorrect initialization of functions with implicit +! function result be eliminated. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! + implicit none + + integer, parameter :: dp = kind(1d0) + real, parameter :: ap = 42.0 + real(dp), parameter :: ap_d = 42.0d0 + + type operands_t(k) + integer, kind :: k = kind(1.) + real(k) :: actual, expected + end type + + type(operands_t) :: x + type(operands_t(dp)) :: y + + x = operands (ap, 10 * ap) + if (abs (x%actual - ap) >1e-5) stop 1 + if (abs (x%expected - 10 * ap) > 1e-5) stop 2 + + + y = operands_dp (ap_d, 10d0 * ap_d) + if (abs (y%actual - ap_d) > 1d-10) stop 3 + if (abs (y%expected - 10d0 * ap_d) > 1d-10) stop 4 + if (kind (y%actual) /= dp) stop 5 + if (kind (y%expected) /= dp) stop 6 + +contains + + function operands(actual, expected) ! Use the default 'k' + real actual, expected + type(operands_t) :: operands + operands = operands_t(actual, expected) + end function + + + function operands_dp(actual, expected) ! Override the default + real(dp) actual, expected + type(operands_t(dp)) :: operands_dp + operands_dp = operands_t(dp)(actual, expected) + end function + +end diff --git a/gcc/testsuite/gfortran.dg/pdt_48.f03 b/gcc/testsuite/gfortran.dg/pdt_48.f03 new file mode 100644 index 0000000..41b4b04 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_48.f03 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Test the fix for P83746, which failed as in the comment below. +! +! Contributed by Berke Durak <berke.durak@gmail.com> +! +module pdt_m + implicit none + type :: vec(k) + integer, len :: k + integer :: foo(k) + end type vec +contains + elemental function diy_max(a,b) result(c) + integer, intent(in) :: a,b + integer :: c + c=max(a,b) + end function diy_max + + function add(a,b) result(c) + type(vec(k=*)), intent(in) :: a,b + type(vec(k=max(a%k,b%k))) :: c ! Fails + !type(vec(k=diy_max(a%k,b%k))) :: c ! Worked with diy_max + !type(vec(k=a%k+b%k)) :: c ! Worked with + + + c%foo(1:a%k)=a%foo + c%foo(a%k+1:) = 0 + c%foo(1:b%k)=c%foo(1:b%k)+b%foo + + if (c%k /= 5) stop 1 + end function add +end module pdt_m + +program test_pdt + use pdt_m + implicit none + type(vec(k=2)) :: u + type(vec(k=5)) :: v,w + + if (w%k /= 5) stop 2 + if (size(w%foo) /= 5) stop 3 + + u%foo=[1,2] + v%foo=[10,20,30,40,50] + w=add(u,v) + + if (w%k /= 5) stop 4 + if (size(w%foo) /= 5) stop 5 + if (any (w%foo /= [11,22,30,40,50])) stop 6 +end program test_pdt diff --git a/gcc/testsuite/gfortran.dg/pdt_49.f03 b/gcc/testsuite/gfortran.dg/pdt_49.f03 new file mode 100644 index 0000000..9ddfd14 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_49.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Check PR105380 has gone away. Used to ICE with, "internal compiler error: +! tree check: expected array_type, have record_type in ....." +! +! Contributed by Martin Liska <marxin@gcc.gnu.org> +! +program p + type t(n) + integer, len :: n + end type + type t2(m) + integer, len :: m + type(t(1)) :: a(m) + end type + type(t2(3)) :: x + + print *, x%m, size (x%a), x%a%n ! Outputs 3 3 1 as expected. +end diff --git a/gcc/testsuite/gfortran.dg/pdt_50.f03 b/gcc/testsuite/gfortran.dg/pdt_50.f03 new file mode 100644 index 0000000..9c036e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_50.f03 @@ -0,0 +1,54 @@ +! { dg-do compile } +! ! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR102241, which caused an ICE in gfc_get_derived_type. +! The test in comment 4 used to cause a spurious error. +! +! Contributed by Roland Wirth <roland_wirth@web.de> +! + MODULE mo + TYPE t1(n) + INTEGER, LEN :: n + INTEGER :: a(n) + END TYPE + + TYPE t2 + TYPE(t1(:)), allocatable :: p_t1 + END TYPE + END MODULE + +!---Check test in comment 4 now works--- + MODULE mo2 + TYPE u1(n) + INTEGER, LEN :: n + INTEGER :: a(n) + END TYPE + + TYPE u2 + TYPE(u1(2)), POINTER :: p_u1 + END TYPE + + CONTAINS + + SUBROUTINE sr + + type(u1(2)), target :: tgt + type(u2) :: pt + + tgt = u1(2)([42,84]) + pt%p_u1 => tgt + if (any (pt%p_u1%a /= [42,84])) stop 1 + END SUBROUTINE + END MODULE +!------ + + use mo + use mo2 + type(t2) :: d + d%p_t1 = t1(8)([42,43,44,45,42,43,44,45]) + if (any (d%p_t1%a /= [42,43,44,45,42,43,44,45])) stop 2 + call sr + deallocate (d%p_t1) +end +! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_51.f03 b/gcc/testsuite/gfortran.dg/pdt_51.f03 new file mode 100644 index 0000000..46697bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_51.f03 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR122089 in which the generic interface checking failed. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k) values_ + contains + generic :: values => double_precision_values + procedure double_precision_values + end type + +contains + function double_precision_values(self) + class(tensor_t(kind(1D0))) self + double precision double_precision_values + double_precision_values = self%values_ + end function +end module + +module input_output_pair_m + use tensor_m, only : tensor_t + implicit none + + type input_output_pair_t(k) + integer, kind :: k = kind(1.) + type(tensor_t(k)) inputs_ + end type + + interface + module subroutine double_precision_write_to_stdout(input_output_pairs) + implicit none + type(input_output_pair_t(kind(1D0))) input_output_pairs + end subroutine + end interface +end module + +submodule(input_output_pair_m) input_output_pair_s + implicit none +contains + module procedure double_precision_write_to_stdout + print *, input_output_pairs%inputs_%values() + end procedure +end submodule + + use input_output_pair_m + type(input_output_pair_t(kind(1d0))) :: tgt + tgt%inputs_%values_ = 42d0 + call double_precision_write_to_stdout(tgt) +end +! { dg-final { scan-tree-dump-times "double_precision_write_to_stdout \\(&tgt\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_52.f03 b/gcc/testsuite/gfortran.dg/pdt_52.f03 new file mode 100644 index 0000000..5acdecb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_52.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Test the fix for PR122089 in which an error occured in compiling the module +! because a spurious REAL(KIND=0) was being produced for 'values_'. +! +! Other failures are indicated by the comments. For reasons that are not to me, +! they didn't fail when combined with this test. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable :: values_ ! ICE if not allocatable + end type + + type input_output_pair_t(k) + integer, kind :: k + type(tensor_t(k)) inputs_, expected_outputs_ ! ICE if 2nd component dropped + end type + + type mini_batch_t(k) + integer, kind :: k + type(input_output_pair_t(k)) input_output_pairs_ + end type + +end module tensor_m + + use tensor_m + type (mini_batch_t(k = kind(1d0))) :: x + allocate (x%input_output_pairs_%inputs_%values_, source = 42d0) + print *, kind (x%input_output_pairs_%inputs_%values_), x%input_output_pairs_%inputs_%values_ + deallocate (x%input_output_pairs_%inputs_%values_) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_53.f03 b/gcc/testsuite/gfortran.dg/pdt_53.f03 new file mode 100644 index 0000000..9f3b4ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_53.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Test the fix for PR122089 in which an error occured in compiling the module +! because a spurious REAL(KIND=0) was being produced for 'values_'. +! +! This is a variant of pdt_52.f03. See the comments in that test. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k) :: values_ ! Used to ICE + end type + + type input_output_pair_t(k) + integer, kind :: k + type(tensor_t(k)) inputs_, expected_outputs_ + end type + + type mini_batch_t(k) + integer, kind :: k + type(input_output_pair_t(k)) input_output_pairs_ + end type + +end module tensor_m diff --git a/gcc/testsuite/gfortran.dg/pdt_54.f03 b/gcc/testsuite/gfortran.dg/pdt_54.f03 new file mode 100644 index 0000000..9631dad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_54.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Test the fix for PR122089 in which an error occured in compiling the module +! because a spurious REAL(KIND=0) was being produced for 'values_'. +! +! This is a variant of pdt_52.f03. See the comments in that test. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable :: values_ + end type + + type input_output_pair_t(k) + integer, kind :: k + type(tensor_t(k)) inputs_ ! Used to ICE if 2nd component dropped + end type + + type mini_batch_t(k) + integer, kind :: k + type(input_output_pair_t(k)) input_output_pairs_ + end type + +end module tensor_m diff --git a/gcc/testsuite/gfortran.dg/pdt_55.f03 b/gcc/testsuite/gfortran.dg/pdt_55.f03 new file mode 100644 index 0000000..bcdb151 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_55.f03 @@ -0,0 +1,96 @@ +! { dg-do run } +! +! Test fix for PRs 102240, 102686 and 93175. +! +! PR102240 +! Contributed by Roland Wirth <roland_wirth@web.de> +! +MODULE m1 + IMPLICIT NONE + private + public r + INTEGER :: n0, n ! Symbols that confused the parameter substitution. + type t0(m0,n0) + INTEGER, kind :: m0 + INTEGER, LEN :: n0 + INTEGER(kind=m0) :: a0(n0*2) + end type t0 + + TYPE t(m,n) + INTEGER, kind :: m + INTEGER, LEN :: n + INTEGER(kind=m) :: a(n/8:(n/2 + 4)) + type(t0(m,n)) :: p ! During testing, getting this to work fixed PR93175. + END TYPE t +contains + subroutine r + type (t(kind(1_8), 8)) :: x + x%a = [1,2,3,4,5,6,7,8] + if (kind (x%a) /= kind(1_8)) stop 1 + if (sum (x%a) /= 36_8) stop 2 + if (size(x%p%a0) /= 16) stop 3 + end +END + +! PR102686 +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +module m2 + implicit none + private + public s +contains + pure integer function n() ! Confused the parameter substitution. + n = 1 + end + subroutine s + type t(n) + integer, len :: n = 2 + character(len=n) :: c ! ICE because function n() referenced rather than parameter. + end type + type (t(4)) :: c_type, c_type2 + c_type = t(4)("abcd") + if (len (c_type%c) /= 4) stop 4 + if (c_type%c /= "abcd") stop 5 + c_type2%c = "efgh" + if (len (c_type2%c) /= 4) stop 6 + if (c_type2%c /= "efgh") stop 7 + end +end + +! PR93175 +! Contributed by Rich Townsend <townsend@astro.wisc.edu> +! +module m3 + private + public u + type :: matrix (k,n) + integer, kind :: k + integer, len :: n + real(k) :: a(n,n) + end type matrix + + type :: problem(n) + integer, len :: n + type(matrix(kind(0.D0),n)) :: m + end type problem + +contains + subroutine u + implicit none + type(problem(2)) :: p + + p%m%a = 1. + if (p%n /= 2) stop 8 + if (p%m%n /= 2) stop 9 + if (int (sum (p%m%a)) /= 4) stop 10 + end subroutine +end module m3 + + use m1 + use m2 + use m3 + call r + call s + call u +end diff --git a/gcc/testsuite/gfortran.dg/pdt_56.f03 b/gcc/testsuite/gfortran.dg/pdt_56.f03 new file mode 100644 index 0000000..681d479 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_56.f03 @@ -0,0 +1,96 @@ +! { dg-do compile } +! { dg-options "-fcheck=all" } +! +! Test the fix for PR102901, where pdt_13/14/15.f03 segfaulted in compilation +! with -fcheck=all. +! +! Reported by Tobias Burnus <burnus@gcc.gnu.org> +! +! This is pdt_13.f03. +! +module precision_module + implicit none + integer, parameter :: sp = selected_real_kind(6, 37) + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: qp = selected_real_kind( 30, 291) +end module precision_module + +module link_module + use precision_module + + type link(real_kind) + integer, kind :: real_kind + real (kind=real_kind) :: n + type (link(real_kind)), pointer :: next => NULL() + end type link + +contains + + function push_8 (self, arg) result(current) + real(dp) :: arg + type (link(real_kind=dp)), pointer :: self + type (link(real_kind=dp)), pointer :: current + + if (associated (self)) then + current => self + do while (associated (current%next)) + current => current%next + end do + + allocate (current%next) + current => current%next + else + allocate (current) + self => current + end if + + current%n = arg + current%next => NULL () + end function push_8 + + function pop_8 (self) result(res) + type (link(real_kind=dp)), pointer :: self + type (link(real_kind=dp)), pointer :: current => NULL() + type (link(real_kind=dp)), pointer :: previous => NULL() + real(dp) :: res + + res = 0.0_8 + if (associated (self)) then + current => self + do while (associated (current) .and. associated (current%next)) + previous => current + current => current%next + end do + + previous%next => NULL () + + res = current%n + if (associated (self, current)) then + deallocate (self) + else + deallocate (current) + end if + + end if + end function pop_8 + +end module link_module + +program ch2701 + use precision_module + use link_module + implicit none + integer, parameter :: wp = dp + type (link(real_kind=wp)), pointer :: root => NULL() + type (link(real_kind=wp)), pointer :: current + + current => push_8 (root, 1.0_8) + current => push_8 (root, 2.0_8) + current => push_8 (root, 3.0_8) + + if (int (pop_8 (root)) .ne. 3) STOP 1 + if (int (pop_8 (root)) .ne. 2) STOP 2 + if (int (pop_8 (root)) .ne. 1) STOP 3 + if (int (pop_8 (root)) .ne. 0) STOP 4 + +end program ch2701 diff --git a/gcc/testsuite/gfortran.dg/pdt_57.f03 b/gcc/testsuite/gfortran.dg/pdt_57.f03 new file mode 100644 index 0000000..457ec79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_57.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! Test the fix for pr95543. The variable declaration in each subroutine used to ICE +! because the substitution of a in the default initializers of b was not being done. +! +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +program p + call foo1 + call foo2 + call foo3 + call foo4 +contains + subroutine foo1 + type t(a, b) + integer, kind :: a = 4 + integer, kind :: b = a + 4 + end type + type(t()) :: z ! { dg-error "empty type specification" } + print *, z%b + end + subroutine foo2 + type t(a, b) + integer, kind :: a = 1 + integer, kind :: b = a + end type + type(t) :: z + print *, z%b + end + subroutine foo3 + type t(a, b) + integer, kind :: a = 1 + integer, kind :: b = a + end type + type(t(2)) :: z + print *, z%b + end + subroutine foo4 + type t(a, b) + integer, kind :: a = 4 + integer, kind :: b = a + 4 + end type + type(t(b = 6)) :: z + print *, z%b + end +end + diff --git a/gcc/testsuite/gfortran.dg/pdt_58.f03 b/gcc/testsuite/gfortran.dg/pdt_58.f03 new file mode 100644 index 0000000..cf26e8a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_58.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Test fix for PR103748. +! +! Contributed by Bastiaan Braams <b.j.braams@cwi.nl> +! +program test + implicit none + type f_type + integer, allocatable :: x(:) + end type f_type + type (f_type(n=9)) :: f ! { dg-error "is not parameterized" } + stop +end program test diff --git a/gcc/testsuite/gfortran.dg/pdt_59.f03 b/gcc/testsuite/gfortran.dg/pdt_59.f03 new file mode 100644 index 0000000..7367897 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_59.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! Test the fix for PR122191, which used to ICE in compilation. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module input_output_pair_m + implicit none + + type input_output_pair_t(k) + integer, kind :: k + integer :: a, b + end type + + type mini_batch_t(k) + integer, kind :: k = kind(1.) + type(input_output_pair_t(k)), allocatable :: input_output_pairs_(:) + end type + + interface + + module function default_real_construct() + implicit none + type(mini_batch_t) default_real_construct + end function + + end interface + +end module + +submodule(input_output_pair_m) input_output_pair_smod +contains + function default_real_construct() + type(mini_batch_t) default_real_construct + allocate (default_real_construct%input_output_pairs_(2)) + default_real_construct%input_output_pairs_%a = [42,43] + default_real_construct%input_output_pairs_%b = [420,421] + end +end submodule + + use input_output_pair_m + type(mini_batch_t), allocatable :: res + res = default_real_construct() + if (any (res%input_output_pairs_%a /= [42,43])) stop 1 + if (any (res%input_output_pairs_%b /= [420,421])) stop 2 + if (allocated (res)) deallocate (res) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_60.f03 b/gcc/testsuite/gfortran.dg/pdt_60.f03 new file mode 100644 index 0000000..dc9f7f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_60.f03 @@ -0,0 +1,65 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR122290. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module hyperparameters_m + implicit none + + type hyperparameters_t(k) + integer, kind :: k = kind(1.) + real(k) :: learning_rate_ = real(1.5,k) ! Gave "Invalid kind for REAL" + contains + generic :: operator(==) => default_real_equals, real8_equals ! Gave "Entity ‘default_real_equals’ at (1) + ! is already present in the interface" + generic :: g => default_real_equals, real8_equals ! Make sure that ordinary generic is OK + procedure default_real_equals + procedure real8_equals + end type + + interface + logical module function default_real_equals(lhs, rhs) + implicit none + class(hyperparameters_t), intent(in) :: lhs, rhs + end function + logical module function real8_equals(lhs, rhs) + implicit none + class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs + end function + end interface +end module + +! Added to test generic procedures are the correct ones. +submodule(hyperparameters_m) hyperparameters_s +contains + logical module function default_real_equals(lhs, rhs) + implicit none + class(hyperparameters_t), intent(in) :: lhs, rhs + default_real_equals = (lhs%learning_rate_ == rhs%learning_rate_) + end function + logical module function real8_equals(lhs, rhs) + implicit none + class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs + real8_equals = (lhs%learning_rate_ == rhs%learning_rate_) + end function +end submodule + + use hyperparameters_m + type (hyperparameters_t) :: a, b + type (hyperparameters_t(kind(1d0))) :: c, d + if (.not.(a == b)) stop 1 + if (.not.a%g(b)) stop 2 + a%learning_rate_ = real(2.5,a%k) + if (a == b) stop 3 + if (a%g(b)) stop 4 + + if (.not.(c == d)) stop 5 + if (.not.c%g(d)) stop 6 + c%learning_rate_ = real(2.5,c%k) + if (c == d) stop 7 + if (c%g(d)) stop 8 +end +! { dg-final { scan-tree-dump-times "default_real_equals" 8 "original" } } +! { dg-final { scan-tree-dump-times "real8_equals" 8 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_61.f03 b/gcc/testsuite/gfortran.dg/pdt_61.f03 new file mode 100644 index 0000000..20b97b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_61.f03 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Test the fix for PR95541, in which parameterized array and string components +! of PDT arrays caused an ICE in the ASSOCIATE selector expressions below. +! +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +program p + type t(n) + integer, len :: n + integer :: a(n) + character(len = n) :: chr + end type + type(t(3)) :: x(2) + integer :: tgt(2) + x(1)%a = [1, 2, 3] + x(1)%chr = "abc" + x(2)%a = [4, 5, 6] + x(2)%chr = "def" + associate (y => x(:)%a(3)) + if (any (y /= [3,6])) stop 1 + y = -y + end associate + associate (y => x%a(3)) + if (any (y /= [-3,-6])) stop 2 + y = -y * 10 + end associate + if (any (x%a(3) /= [30,60])) stop 3 + if (any (x%a(2) /= [2,5])) stop 4 + associate (y => x%chr(2:2)) + if (any (y /= ["b","e"])) stop 5 + y = ["x", "y"] + end associate + if (any (x%chr /= ["axc","dyf"])) stop 6 +end diff --git a/gcc/testsuite/gfortran.dg/pdt_62.f03 b/gcc/testsuite/gfortran.dg/pdt_62.f03 new file mode 100644 index 0000000..efbcdad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_62.f03 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! Test fix for PR122433 +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module neuron_m + implicit none + + type string_t + character(len=:), allocatable :: string_ + end type + + type neuron_t(k) + integer, kind :: k = kind(1.) + real(k) bias_ + type(neuron_t(k)), allocatable :: next + end type + +contains + recursive function from_json(neuron_lines, start) result(neuron) + type(string_t) neuron_lines(:) + integer start + type(neuron_t) neuron + character(len=:), allocatable :: line + line = neuron_lines(start+1)%string_ + read(line(index(line, ":")+1:), fmt=*) neuron%bias_ + line = adjustr(neuron_lines(start+3)%string_) +! Used to give "Error: Syntax error in IF-clause" for next line. + if (line(len(line):) == ",") neuron%next = from_json(neuron_lines, start+4) + end function + recursive function from_json_8(neuron_lines, start) result(neuron) + type(string_t) neuron_lines(:) + integer start + type(neuron_t(kind(1d0))) neuron + character(len=:), allocatable :: line + line = neuron_lines(start+1)%string_ + read(line(index(line, ":")+1:), fmt=*) neuron%bias_ + line = adjustr(neuron_lines(start+3)%string_) + if (line(len(line):) == ",") neuron%next = from_json_8(neuron_lines, start+4) + end function +end module + + use neuron_m + call foo + call bar +contains + subroutine foo + type(neuron_t) neuron + type(string_t) :: neuron_lines(8) + neuron_lines(2)%string_ = "real : 4.0 " + neuron_lines(4)%string_ = " ," + neuron_lines(6)%string_ = "real : 8.0 " + neuron_lines(8)%string_ = " " + neuron = from_json(neuron_lines, 1) + if (int (neuron%bias_) /= 4) stop 1 + if (allocated (neuron%next)) then + if (int (neuron%next%bias_) /= 8) stop 2 + else + stop 3 + endif + end subroutine + subroutine bar + type(neuron_t(kind(1d0))) neuron + type(string_t) :: neuron_lines(8) + neuron_lines(2)%string_ = "real : 4.0d0 " + neuron_lines(4)%string_ = " ," + neuron_lines(6)%string_ = "real : 8.0d0 " + neuron_lines(8)%string_ = " " + neuron = from_json_8(neuron_lines, 1) + if (int (neuron%bias_) /= 4) stop 1 + if (allocated (neuron%next)) then + if (int (neuron%next%bias_) /= 8) stop 2 + else + stop 3 + endif + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/pdt_63.f03 b/gcc/testsuite/gfortran.dg/pdt_63.f03 new file mode 100644 index 0000000..127e5fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_63.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Test fix for PR122434 +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module neuron_m + implicit none + + type neuron_t + real, allocatable :: weight_ + end type + + interface + type(neuron_t) pure module function from_json() result(neuron) + end function + end interface + +contains + module procedure from_json + associate(num_inputs => 1) +! Gave "Error: Bad allocate-object at (1) for a PURE procedure" in next line. + allocate(neuron%weight_, source=0.) + end associate + end procedure +end module diff --git a/gcc/testsuite/gfortran.dg/pdt_64.f03 b/gcc/testsuite/gfortran.dg/pdt_64.f03 new file mode 100644 index 0000000..dfa4e3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_64.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! Test the fix for PR122165. +! +! Contributed by Steve Kargl <kargls@comcast.net> +! +program foo + implicit none + type dt(k,l) + integer(8), len :: k = 1 + integer(8), KIND :: l = 1 + character(k) :: arr + end type + type(dt(:)), allocatable :: d1 + if (d1%k%kind /= 8) stop 1 ! { dg-error "cannot be followed by the type inquiry ref" } + if (d1%l%kind /= 8) stop 2 ! { dg-error "cannot be followed by the type inquiry ref" } +end diff --git a/gcc/testsuite/gfortran.dg/pdt_65.f03 b/gcc/testsuite/gfortran.dg/pdt_65.f03 new file mode 100644 index 0000000..d5e45c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_65.f03 @@ -0,0 +1,135 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test fix for PR122452 +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module kind_parameters_m + integer, parameter :: default_real = kind(1e0) + integer, parameter :: double_precision = kind(1d0) +end module + +module tensor_m + use kind_parameters_m, only : default_real, double_precision + implicit none + + private + public :: tensor_t + + type tensor_t(k) + integer, kind :: k = default_real + real(k), allocatable, private :: values_(:) + contains + generic :: values => default_real_values, double_precision_values + procedure, private, non_overridable :: default_real_values, double_precision_values + generic :: num_components => default_real_num_components, double_precision_num_components + procedure, private :: default_real_num_components, double_precision_num_components + end type + + interface tensor_t + + pure module function construct_default_real(values) result(tensor) + implicit none + real, intent(in) :: values(:) + type(tensor_t) tensor + end function + + pure module function construct_double_precision(values) result(tensor) + implicit none + double precision, intent(in) :: values(:) + type(tensor_t(double_precision)) tensor + end function + + end interface + + interface + + pure module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t), intent(in) :: self + real, allocatable :: tensor_values(:) + end function + + pure module function double_precision_values(self) result(tensor_values) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + double precision, allocatable :: tensor_values(:) + end function + + pure module function default_real_num_components(self) result(n) + implicit none + class(tensor_t), intent(in) :: self + integer n + end function + + pure module function double_precision_num_components(self) result(n) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + integer n + end function + + end interface + +end module tensor_m + +submodule(tensor_m) tensor_s +contains + + pure module function construct_default_real(values) result(tensor) + implicit none + real, intent(in) :: values(:) + type(tensor_t) tensor + tensor = tensor_t ()(values) + end function + + pure module function construct_double_precision(values) result(tensor) + implicit none + double precision, intent(in) :: values(:) + type(tensor_t(double_precision)) tensor + tensor = tensor_t (double_precision)(values) + end function + + pure module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t), intent(in) :: self + real, allocatable :: tensor_values(:) + tensor_values = self%values_ + end function + + pure module function double_precision_values(self) result(tensor_values) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + double precision, allocatable :: tensor_values(:) + tensor_values = self%values_ + end function + + + pure module function default_real_num_components(self) result(n) + implicit none + class(tensor_t), intent(in) :: self + integer n + n = default_real + end function + + pure module function double_precision_num_components(self) result(n) + implicit none + class(tensor_t(double_precision)), intent(in) :: self + integer n + n = double_precision + end function + +end submodule tensor_s + + + use tensor_m + type(tensor_t(kind(0e0))) :: a + type(tensor_t(kind(0D0))) :: b + a = tensor_t ([1e0,2e0]) + print *, a%num_components (), a%values () + b = tensor_t ([3d0,4d0]) + print *, b%num_components (), b%values () +end +! { dg-final { scan-tree-dump-times "construct_" 4 "original" } } +! { dg-final { scan-tree-dump-times "_components" 4 "original" } } +! { dg-final { scan-tree-dump-times "_values" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_66.f03 b/gcc/testsuite/gfortran.dg/pdt_66.f03 new file mode 100644 index 0000000..269f6b4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_66.f03 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for PR122501. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable, private :: values_(:) + contains + procedure default_real_values + end type + + interface tensor_t + type(tensor_t) module function construct_default_real(values) + implicit none + real values(:) + end function + end interface + + interface + module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t) self + real, allocatable :: tensor_values(:) + end function + end interface +end module + + use tensor_m + implicit none +contains + function copy(tensor) + type(tensor_t) tensor, copy, norm_copy + associate(tensor_values => tensor%default_real_values()) + +! This gave: "Component ‘values_’ at (1) is a PRIVATE component of ‘tensor_t’" + copy = tensor_t(tensor_values) + + end associate + +! Make sure that the fix really works :-) + associate(f => tensor%default_real_values()) + associate(tensor_values => tensor%default_real_values()) + norm_copy = tensor_t(tensor_values/maxval(f)) + end associate + end associate + end function +end +! { dg-final { scan-tree-dump-times "default_real_values" 3 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_67.f03 b/gcc/testsuite/gfortran.dg/pdt_67.f03 new file mode 100644 index 0000000..b59d201 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_67.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Check the fix for PR122524. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_map_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable :: values_(:) + end type + + interface tensor_t + module function tensor(values) + implicit none + double precision values(:) + type(tensor_t(kind(0D0))) tensor + end function + end interface + + type tensor_map_t(k) + integer, kind :: k = kind(1.) + real(k) slope_ + end type + +contains + function unnormalized_tensor(self, tensor) + type(tensor_map_t(kind(0D0))) self + type(tensor_t(kind(0D0))) tensor, unnormalized_tensor + associate(unnormalized_values => tensor%values_*self%slope_) + unnormalized_tensor = tensor_t(unnormalized_values) ! Caused an ICE. + end associate + end function +end module diff --git a/gcc/testsuite/gfortran.dg/pdt_68.f03 b/gcc/testsuite/gfortran.dg/pdt_68.f03 new file mode 100644 index 0000000..b3493b1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_68.f03 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for PR122566. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module double_precision_file_m + implicit none + + type file_t + integer :: i + end type + + type, extends(file_t) :: double_precision_file_t + end type + + type, extends(double_precision_file_t) :: training_configuration_t(m) + integer, kind :: m = kind(1.) + end type + +contains + pure module function training_configuration() + type(training_configuration_t) training_configuration + training_configuration%file_t = file_t(42) ! Needed parent type to be introduced explicitly + end function +end module + + use double_precision_file_m + type(training_configuration_t) :: x + x = training_configuration () + if (x%i /= 42) stop 1 +end +! { dg-final { scan-tree-dump-times "double_precision_file_t.file_t" 2 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_69.f03 b/gcc/testsuite/gfortran.dg/pdt_69.f03 new file mode 100644 index 0000000..6217337 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_69.f03 @@ -0,0 +1,58 @@ +! { dg-do compile } +! +! Test the fix for PR12276. +! Exmple from F2018: C.2.5 Structure constructors and generic names +! Failed in each of the functions with, for example: +! "Derived type ‘pdtt_4’ at (1) is being used before it is defined" +! For each of the functions, if the function type was declared within +! the function, all was well. +! +MODULE m + TYPE t(kind) + INTEGER, KIND :: kind + COMPLEX(kind) value + END TYPE + INTEGER,PARAMETER :: single = KIND(0.0), double = KIND(0d0) + + INTERFACE t + MODULE PROCEDURE real_to_t1, dble_to_t2, int_to_t1, int_to_t2 + END INTERFACE + + CONTAINS + TYPE(t(single)) FUNCTION real_to_t1(x) + REAL(single) x + real_to_t1%value = x + END FUNCTION + + TYPE(t(double)) FUNCTION dble_to_t2(x) + REAL(double) x + dble_to_t2%value = x + END FUNCTION + TYPE(t(single)) FUNCTION int_to_t1(x,mold) + INTEGER x + TYPE(t(single)) mold + int_to_t1%value = x + END FUNCTION + TYPE(t(double)) FUNCTION int_to_t2(x,mold) + INTEGER x + TYPE(t(double)) mold + int_to_t2%value = x + END FUNCTION + + END + + PROGRAM example + USE m + TYPE(t(single)) x + TYPE(t(double)) y + x = t(1.5) ! References real_to_t1 + print *, x%value + x = t(17,mold=x) ! References int_to_t1 + print *, x%value + y = t(1.5d0) ! References dble_to_t2 + print *, y%value + y = t(42,mold=y) ! References int_to_t2 + print *, y%value + y = t(kind(0d0)) ((0,1)) ! Uses the structure constructor for type t + print *, y%value + END diff --git a/gcc/testsuite/gfortran.dg/pdt_70.f03 b/gcc/testsuite/gfortran.dg/pdt_70.f03 new file mode 100644 index 0000000..25801ed --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_70.f03 @@ -0,0 +1,112 @@ +! { dg-do run } +! +! PR104650 +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +module m1 + type t1 + integer :: i + contains + final :: s + end type + type t2(n) + integer, len :: n = 1 + type(t1) :: a + end type + integer :: ctr = 0 + +contains + + impure elemental subroutine s(x) + type(t1), intent(in) :: x + ctr = ctr + x%i + end +end + +! From F2018: C.2.6 Final subroutines (7.5.6, 7.5.6.2, 7.5.6.3, 7.5.6.4) +module m2 + + type t(k) + integer, kind :: k + real(k), pointer :: vector(:) => NULL () + contains + final :: finalize_t1s, finalize_t1v, finalize_t2e + end type + + integer :: flag = 0 + +contains + + impure subroutine finalize_t1s(x) + type(t(kind(0.0))) x + if (associated(x%vector)) deallocate(x%vector) + flag = flag + 1 + END subroutine + + impure subroutine finalize_t1v(x) + type(t(kind(0.0))) x(:) + do i = lbound(x,1), ubound(x,1) + if (associated(x(i)%vector)) deallocate(x(i)%vector) + flag = flag + 1 + end do + end subroutine + + impure elemental subroutine finalize_t2e(x) + type(t(kind(0.0d0))), intent(inout) :: x + if (associated(x%vector)) deallocate(x%vector) + flag = flag + 1 + end subroutine + + elemental subroutine alloc_ts (x) + type(t(kind(0.0))), intent(inout) :: x + allocate (x%vector, source = [42.0,-42.0]) + end subroutine + + elemental subroutine alloc_td (x) + type(t(kind(0.0d0))), intent(inout) :: x + allocate (x%vector, source = [42.0d0,-42.0d0]) + end subroutine + +end module + + use m1 + use m2 + integer, parameter :: dims = 2 + integer :: p = 42 + +! Test pr104650 + call u (kind(0e0), p) + if (ctr /= p * (1 + kind(0e0))) stop 1 + +! Test the standard example + call example (dims) + if (flag /= 11 + dims**2) stop 2 + +contains + + subroutine u (k, p) + integer :: k, p + type (t2(k)) :: u_k, v_k(k) + u_k%a%i = p + v_k%a%i = p + end + +! Returning from 'example' will effectively do +! call finalize_t1s(a) +! call finalize_t1v(b) +! call finalize_t2e(d) +! No final subroutine will be called for variable C because the user +! omitted to define a suitable specific procedure for it. + subroutine example(n) + type(t(kind(0.0))) a, b(10), c(n,2) + type(t(kind(0.0d0))) d(n,n) + real(kind(0.0)),target :: tgt(1) + + ! Explicit allocation to provide a valid memory refence for deallocation. + call alloc_ts(a) + call alloc_ts(b) + call alloc_ts(c) + call alloc_td(d) + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/pdt_71.f03 b/gcc/testsuite/gfortran.dg/pdt_71.f03 new file mode 100644 index 0000000..ec9cde0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_71.f03 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the second part of the fix for PR103371. +! +! Compiled but gave the wrong result for the component 'z%x%n'. +! +! Contributed by Arseny Solokha <asolokha@gmx.com> +! +module m1 + implicit none + type t + integer :: n + end type + type t2 + ! t and t2 must be resolved to types in m1, not components in t2 + type(t) :: t(10) = t(1) + type(t) :: x = t(1) + integer :: t2 + type(t2), pointer :: p => NULL() + end type +end + +module m2 + type :: t(tn) + integer, kind :: tn + integer(kind=tn) :: n + end type + type :: t2(tm) + integer, kind :: tm + type(t(tm)) :: x = t(tm)(2*tm) + end type +end + + call test_m2 +contains + subroutine test_m2 + use m2 + type(t2(KIND (1))) :: z + print *, kind (z%x%n), z%x%n + end subroutine +end +! { dg-final { scan-tree-dump-times "Pdtt2_4.1.x.n = 8" 1 "original" } } +! { dg-final { scan-tree-dump-times "z = Pdtt2_4.1" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_72.f03 b/gcc/testsuite/gfortran.dg/pdt_72.f03 new file mode 100644 index 0000000..57640bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_72.f03 @@ -0,0 +1,110 @@ +! { dg-do compile } +! +! Tests the fix for pr122578, which failed in compilation with the errors +! shown below. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_map_m + use iso_c_binding, only : c_int + implicit none + + type tensor_t(k) + integer, kind :: k = kind(1.) + real(k), allocatable :: values_(:) ! Error: Cannot convert REAL(0) to REAL(4) at (1) + contains + generic :: values => default_real_values + procedure default_real_values + end type + + interface + pure module function default_real_values(self) result(tensor_values) + implicit none + class(tensor_t), intent(in) :: self + real, allocatable :: tensor_values(:) + end function + end interface + + type tensor_map_t(k) + integer, kind :: k = kind(1.) + real(k), dimension(:), allocatable :: intercept_, slope_ + contains + generic :: map_to_training_range => default_real_map_to_training_range + procedure :: default_real_map_to_training_range + generic :: map_from_training_range => default_real_map_from_training_range + procedure :: default_real_map_from_training_range + end type + + interface + elemental module function default_real_map_to_training_range(self, tensor) result(normalized_tensor) + implicit none + class(tensor_map_t), intent(in) :: self + type(tensor_t), intent(in) :: tensor + type(tensor_t) normalized_tensor + end function + + elemental module function default_real_map_from_training_range(self, tensor) result(unnormalized_tensor) + implicit none + class(tensor_map_t), intent(in) :: self + type(tensor_t), intent(in) :: tensor + type(tensor_t) unnormalized_tensor + end function + end interface + + type activation_t + integer(c_int) :: selection_ + contains + generic :: evaluate => default_real_evaluate + procedure default_real_evaluate + end type + + interface + elemental module function default_real_evaluate(self, x) result(y) + implicit none + class(activation_t), intent(in) :: self + real, intent(in) :: x + real y + end function + end interface + + type neural_network_t(k) + integer, kind :: k = kind(1.) + type(tensor_map_t(k)) input_map_, output_map_ + real(k), allocatable :: weights_(:,:,:), biases_(:,:) + integer, allocatable :: nodes_(:) + type(activation_t) :: activation_ + contains + generic :: infer => default_real_infer + procedure default_real_infer + end type + + integer, parameter :: input_layer = 0 +contains + elemental function default_real_infer(self, inputs) result(outputs) + class(neural_network_t), intent(in) :: self + type(tensor_t), intent(in) :: inputs + type(tensor_t) outputs + real, allocatable :: a(:,:) + integer l + associate(w => self%weights_, b => self%biases_, n => self%nodes_, output_layer => ubound(self%nodes_,1)) + allocate(a(maxval(n), input_layer:output_layer)) + associate(normalized_inputs => self%input_map_%map_to_training_range(inputs)) + a(1:n(input_layer),input_layer) = normalized_inputs%values() ! Error: Symbol ‘normalized_inputs’ + ! at (1) has no IMPLICIT type + + end associate + feed_forward: & + do l = input_layer+1, output_layer + associate(z => matmul(w(1:n(l),1:n(l-1),l), a(1:n(l-1),l-1)) + b(1:n(l),l)) + a(1:n(l),l) = self%activation_%evaluate(z) + end associate + end do feed_forward + associate(normalized_outputs => tensor_t(a(1:n(output_layer), output_layer))) + outputs = self%output_map_%map_from_training_range(normalized_outputs) ! Error: Found no matching specific + ! binding for the call to the GENERIC + ! ‘map_from_training_range’ at (1) + + end associate + end associate + end function +end module diff --git a/gcc/testsuite/gfortran.dg/pdt_73.f03 b/gcc/testsuite/gfortran.dg/pdt_73.f03 new file mode 100644 index 0000000..63a9234 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_73.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Tests the fix for pr122669, which falied with the error below. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! + implicit none + type tensor_t + real, allocatable :: values_ + end type + type(tensor_t) :: random_inputs(1) + type(tensor_t), allocatable :: outputs(:) + + random_inputs = [tensor_t(1.0)] + allocate(outputs, mold=random_inputs) ! Error: Array specification or array-valued + ! SOURCE= expression required in ALLOCATE statement at (1) + print *, size(outputs) +end diff --git a/gcc/testsuite/gfortran.dg/pdt_74.f03 b/gcc/testsuite/gfortran.dg/pdt_74.f03 new file mode 100644 index 0000000..c12db79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_74.f03 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! Tests the fix for pr122670, where use only did not compile for PDTs. Also, it +! was found in the course of developing the fix that import only did not work +! either. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(0.) + real(k), allocatable :: value_ + end type + + interface + function myfunc (arg) + import tensor_t + implicit none + type (tensor_t) myfunc + type (tensor_t), intent(in) :: arg + end function + end interface + +contains + function y(x) + type(tensor_t) x, y + y = tensor_t(x%value_) + end function +end module + +function myfunc (arg) + use tensor_m, only : tensor_t + implicit none + type (tensor_t) myfunc + type (tensor_t), intent(in) :: arg + myfunc = arg + myfunc%value_ = myfunc%value_ * 2.0 +end function + + use tensor_m, only : tensor_t, y, myfunc + implicit none + type(tensor_t) desired_output + desired_output = y(tensor_t(42.)) + desired_output = myfunc (desired_output) + print *, desired_output%value_ +end diff --git a/gcc/testsuite/gfortran.dg/pdt_75.f03 b/gcc/testsuite/gfortran.dg/pdt_75.f03 new file mode 100644 index 0000000..f700871 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_75.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! Tests the fix for pr122693, which failed in compilation with the errors +! shown below. +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + + type tensor_t(k) + integer, kind :: k = kind(0.) + end type + + interface tensor_t + module function tensor(unused_stuff) + implicit none + real unused_stuff + type(tensor_t) tensor + end function + end interface + +end module + + use tensor_m + implicit none +contains + function test_passed() + logical test_passed + type(tensor_t), allocatable :: tensor_array(:) + real, parameter :: junk = 0. + tensor_array = [tensor_t(junk)] !Error: Symbol ‘junk’ at (1) has no IMPLICIT type + test_passed = .false. !Error: ‘test_passed’ at (1) is not a variable + end function +end diff --git a/gcc/testsuite/gfortran.dg/pdt_76.f03 b/gcc/testsuite/gfortran.dg/pdt_76.f03 new file mode 100644 index 0000000..22c0a3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_76.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } + +! Make sure that pr103414 is fixed. +! +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +function p () + type t(n) + integer, kind :: n + character(n) :: c = '' + end type + type(t(3)) :: x = t(z'1') ! { dg-error "Expected an initialization expression" } +end + +function q () + type t(n) + integer, kind :: n + character(n) :: c = '' + end type + type(t(3)) :: x(1) = [t(z'1')] ! { dg-error "Syntax error in array constructor" } +end diff --git a/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 new file mode 100644 index 0000000..a6c0f6ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_generic_1.f90 @@ -0,0 +1,94 @@ +! { dg-do run } +! +! Check the fix for pr121398 +! +! Contributed by Damian Rouson <damian@archaeologic.codes> +! +module tensor_m + implicit none + private + public tensor_t + + type tensor_t(k) + integer, kind :: k + integer :: n + contains + procedure, private :: default_real_num_components + procedure, private :: default_real_num_components2 + procedure, private :: double_precision_num_components + procedure, private, pass(self) :: quad_precision_num_components + generic :: num_components => default_real_num_components, & ! Failed ambiguity test + default_real_num_components2, & + double_precision_num_components, & + quad_precision_num_components + end type + + interface + + module function default_real_num_components(self) result(res) + implicit none + class(tensor_t(kind(0.))) self + integer :: res + end function + + module function default_real_num_components2(self, another) result(res) + implicit none + class(tensor_t(kind(0.))) self, another + integer :: res + end function + + module function double_precision_num_components(self) result(res) + implicit none + class(tensor_t(kind(0.0_8))) self + integer :: res + end function + + module function quad_precision_num_components(l, self) result(res) + implicit none + class(tensor_t(kind(0.0_16))) self + integer :: l + integer :: res + end function + + end interface + +end module + +submodule (tensor_m) tensor_m_components +contains + module procedure default_real_num_components + implicit none + self%n = 10 + res = 1 + end + + module procedure default_real_num_components2 + implicit none + self%n = 2 * another%n + res = 1 + end + + module procedure double_precision_num_components + implicit none + self%n = 20 + res = 2 + end + + module procedure quad_precision_num_components + implicit none + self%n = 10 * l + res = l + end +end + + use tensor_m + type (tensor_t(kind(0.))) :: a + type (tensor_t(kind(0.))) :: ap + type (tensor_t(kind(0.0_8))) :: b + type (tensor_t(kind(0.0_16))) :: c + if (a%num_components () /= 1) stop 1 + if (ap%num_components (a) /= 1) stop 2 + if (2 * a%n /= ap%n) stop 3 + if (b%num_components () /= 2 ) stop 4 + if (c%num_components (42) /= 42 ) stop 5 +end diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 new file mode 100644 index 0000000..9282283 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_16.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Check the span of the descriptor of an array pointer after it has been +! assigned to from a polymorphic function result. + +program test + implicit none + type t + integer :: c + end type t + type, extends(t) :: u + integer :: d + end type u + type(t), pointer :: p(:) + class(t), allocatable, target :: a(:) + p => f() + ! print *, p%c + if (any(p%c /= [2,5,11,17,23])) error stop 1 +contains + function f() + class(t), pointer :: f(:) + a = [ u(2,3), u(5,7), u(11,13), u(17,19), u(23,29) ] + f => a + end function +end program diff --git a/gcc/testsuite/gfortran.dg/pointer_check_15.f90 b/gcc/testsuite/gfortran.dg/pointer_check_15.f90 new file mode 100644 index 0000000..13c6820 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_check_15.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-additional-options "-O -fcheck=pointer -fdump-tree-original" } +! +! PR fortran/121145 +! Erroneous runtime error: Proc-pointer actual argument 'ptr' is not associated +! +! Contributed by Federico Perini. + +module m + implicit none + + abstract interface + subroutine fun(x) + real, intent(in) :: x + end subroutine fun + end interface + +contains + + subroutine with_fun(sub) + procedure(fun), optional :: sub + if (present(sub)) stop 1 + end subroutine + + subroutine with_non_optional(sub) + procedure(fun) :: sub + end subroutine + +end module m + +program p + use m + implicit none + + procedure(fun), pointer :: ptr1 => null() + procedure(fun), pointer :: ptr2 => null() + + call with_fun() + call with_fun(sub=ptr1) ! no runtime check here + + if (associated (ptr2)) then + call with_non_optional(sub=ptr2) ! runtime check here + end if +end + +! { dg-final { scan-tree-dump-times "Proc-pointer actual argument .'ptr2.'" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pr103508.f90 b/gcc/testsuite/gfortran.dg/pr103508.f90 new file mode 100644 index 0000000..541b9b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr103508.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! Check the fix for PR103508. As noted in comment 6 of the PR, the bug +! has nothing to do with PDTs. However, the contributor's test has been +! retained. +! +! Contributed by Gerhard Steinmetz <gscfq@t-online.de> +! +program p + type t + integer :: n = 1 + character(3) :: c + end type + block + block + type(t) :: x + x%c = 'abc' + print *, len(x%c) + end ! { dg-error "END BLOCK statement expected" } + end ! { dg-error "END BLOCK statement expected" } +end +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/gcc/testsuite/gfortran.dg/pr104466.f90 b/gcc/testsuite/gfortran.dg/pr104466.f90 index ec0e458..bc14065 100644 --- a/gcc/testsuite/gfortran.dg/pr104466.f90 +++ b/gcc/testsuite/gfortran.dg/pr104466.f90 @@ -113,4 +113,4 @@ END ! { dg-final { scan-tree-dump-not ": dependent" "lim2" } } -! { dg-final { scan-tree-dump "Moving statement\[\n\r\]_\[0-9\]+ = n" "lim2" } } +! { dg-final { scan-tree-dump "Moving statement _\[0-9\]+ = n" "lim2" } } diff --git a/gcc/testsuite/gfortran.dg/pr111022.f90 b/gcc/testsuite/gfortran.dg/pr111022.f90 index eef55ff..798ba13 100644 --- a/gcc/testsuite/gfortran.dg/pr111022.f90 +++ b/gcc/testsuite/gfortran.dg/pr111022.f90 @@ -60,13 +60,13 @@ program pr111022 write(buffer,"(E0.3E0)") .6660_4 if (buffer.ne."0.666E+0") stop 27 write(buffer,"(E0.3)") .6660_4 - if (buffer.ne."0.666E+0") stop 28 + if (buffer.ne."0.666E+00") stop 28 write(buffer,"(E0.1E0)") .6660_4 if (buffer.ne."0.7E+0") stop 29 write(buffer,"(E0.1)") .6660_4 - if (buffer.ne."0.7E+0") stop 30 + if (buffer.ne."0.7E+00") stop 30 write(buffer,"(E0.5E0)") .6660_4 if (buffer.ne."0.66600E+0") stop 31 write(buffer,"(E0.5)") .6660_4 - if (buffer.ne."0.66600E+0") stop 32 + if (buffer.ne."0.66600E+00") stop 32 end program pr111022 diff --git a/gcc/testsuite/gfortran.dg/pr112459.f90 b/gcc/testsuite/gfortran.dg/pr112459.f90 index 7db243c..290f915 100644 --- a/gcc/testsuite/gfortran.dg/pr112459.f90 +++ b/gcc/testsuite/gfortran.dg/pr112459.f90 @@ -34,4 +34,6 @@ program myprog print *,"After allocation" end program myprog ! Final subroutines were called with std=gnu and -w = > 14 "_final"s. -! { dg-final { scan-tree-dump-times "_final" 12 "original" } } +! Count reduced from 12 after PR90519 fix - separate result symbols +! disambiguate procedure references from result variables. +! { dg-final { scan-tree-dump-times "_final" 6 "original" } } 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 index 9ecb080..2e36fae 100644 --- a/gcc/testsuite/gfortran.dg/pr119948.f90 +++ b/gcc/testsuite/gfortran.dg/pr119948.f90 @@ -1,7 +1,8 @@ -! { dg-do compile } +! { dg-do run } ! -! Test the fix for PR119948, which used to fail as indicated below with, -! "Error: Bad allocate-object at (1) for a PURE procedure" +! 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> ! @@ -18,33 +19,65 @@ module test_m type(test_t) :: test type(test_t), intent(in) :: arg end function - pure module function construct_test_sub(arg) result(test) + + 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) ! Used to fail here + 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_sub + 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 = 42 +! + dummy%i = int (rand () * 1e6) res = construct_test (dummy) if (res%i /= dummy%i) stop 1 - dummy%i = -42 - res = construct_test_sub (dummy) +! + 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/pr121234.f90 b/gcc/testsuite/gfortran.dg/pr121234.f90 new file mode 100644 index 0000000..8eb1af5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr121234.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR121234 Bogus diagnostic on READ of string with semicolon. + character(12) buffer,a + a = 'xxxxxxxxxx' + buffer="33;44" + read(buffer,*) a + if (a .ne. "33;44") stop 1 + a = 'xxxxxxxxxx' + buffer=" ;;33 ,44 " + read(buffer,*,decimal="comma") a + if (a .ne. 'xxxxxxxxxx') stop 2 ! A null read + a = 'xxxxxxxxxx' + buffer=" ;;33 ,44 " + read(buffer,*,decimal="point") a + if (a .ne. ';;33') stop 3 ! Spaces are delimiting + a = 'xxxxxxxxxx' + buffer=";;33;,44 " + read(buffer,*) a + if (a .ne. ';;33;') stop 4 ! Comma is delimiting + a = 'xxxxxxxxxx' + buffer=";;33;44;; " + read(buffer,*) a + if (a .ne. ';;33;44;;') stop 5 ! Space is delimiting + a = 'xxxxxxxxxx' + buffer=";;33;44;;;.7" + read(buffer,*) a + if (a .ne. ';;33;44;;;.7') stop 6 ! Space is delimiting +end diff --git a/gcc/testsuite/gfortran.dg/pr121627.f90 b/gcc/testsuite/gfortran.dg/pr121627.f90 new file mode 100644 index 0000000..c3ce218 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr121627.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program real_kinds ! { dg-error "already declared at" } + use iso_fortran_env ! { dg-error "already declared at" } + i = real64 +end program real_kinds diff --git a/gcc/testsuite/gfortran.dg/pr122513-2.f90 b/gcc/testsuite/gfortran.dg/pr122513-2.f90 new file mode 100644 index 0000000..3f6c5c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr122513-2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +! PR fortran/122513 + +! The error is not really new but seems to be untested +! before. The example is from the mentioned PR. + +program test + implicit none + integer :: i + do concurrent (i=1:2) default (none) local(i) ! { dg-error "Index variable 'i' at .1. cannot be specified in a locality-spec" } + block + integer, dimension(2,3), parameter :: & + ii = reshape((/ 1,2,3,4,5,6 /), (/2, 3/)) + print*,ii(i,:) + end block + end do +end program test diff --git a/gcc/testsuite/gfortran.dg/pr122513.f90 b/gcc/testsuite/gfortran.dg/pr122513.f90 new file mode 100644 index 0000000..9e12ab1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr122513.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR122513 do concurrent default (none) fails on parameter arrays +program test + implicit none + integer :: i + do concurrent (i=1:2) default (none) + block + integer, dimension(2,3), parameter :: & + ii = reshape((/ 1,2,3,4,5,6 /), (/2, 3/)) + print*,ii(i,:) + end block + end do +end program test diff --git a/gcc/testsuite/gfortran.dg/pr15140.f90 b/gcc/testsuite/gfortran.dg/pr15140.f90 index 80c08dd..7f9af4f 100644 --- a/gcc/testsuite/gfortran.dg/pr15140.f90 +++ b/gcc/testsuite/gfortran.dg/pr15140.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! { dg-options "-std=legacy" } ! PR 15140: we used to fail an assertion, because we don't use the ! argument of the subroutine directly, but instead use a copy of it. function M(NAMES) diff --git a/gcc/testsuite/gfortran.dg/pr20086.f90 b/gcc/testsuite/gfortran.dg/pr20086.f90 index 674261e..ffd5841 100644 --- a/gcc/testsuite/gfortran.dg/pr20086.f90 +++ b/gcc/testsuite/gfortran.dg/pr20086.f90 @@ -10,7 +10,7 @@ if (line.ne.' stiffness reformed for hello hello')STOP 2 stop - 2070 format (2x,37hstiffness reformed for this high step) - 2090 format (2x,34hstiffness reformed for hello hello) + 2070 format (2x,37hstiffness reformed for this high step) ! { dg-warning "H format specifier" } + 2090 format (2x,34hstiffness reformed for hello hello) ! { dg-warning "H format specifier" } end diff --git a/gcc/testsuite/gfortran.dg/pr41011.f b/gcc/testsuite/gfortran.dg/pr41011.f index c032310..376ae8b 100644 --- a/gcc/testsuite/gfortran.dg/pr41011.f +++ b/gcc/testsuite/gfortran.dg/pr41011.f @@ -1,5 +1,7 @@ ! { dg-do compile } ! { dg-options "-O3 -std=legacy" } + SUBROUTINE PR41011 (DCDX) + DIMENSION DCDX(*) CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" } *ITY,ISH,NSMT,F) CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA, diff --git a/gcc/testsuite/gfortran.dg/pr61669.f90 b/gcc/testsuite/gfortran.dg/pr61669.f90 index 5bceafd..ce38d13 100644 --- a/gcc/testsuite/gfortran.dg/pr61669.f90 +++ b/gcc/testsuite/gfortran.dg/pr61669.f90 @@ -1,7 +1,7 @@ ! { dg-do compile } write (*,"(a)") char(12) - CHARACTER*80 A /"A"/ ! { dg-error "Unexpected data declaration statement" } - REAL*4 B ! { dg-error "Unexpected data declaration statement" } + CHARACTER*80 A /"A"/ ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + REAL*4 B ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } write (*,"(a)") char(12) DATA B / 0.02 / ! { dg-warning "Obsolescent feature: DATA statement" } END diff --git a/gcc/testsuite/gfortran.dg/pr89092.f90 b/gcc/testsuite/gfortran.dg/pr89092.f90 new file mode 100644 index 0000000..2164994 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr89092.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +module AModule + implicit none + private + public Foo + + interface Foo + module procedure FooPrivate + end interface +contains + subroutine FooPrivate(x) + integer :: x + + write(*,*) 'Foo(integer)' + end subroutine +end module +module BModule + implicit none + private + + type, public :: BType + contains + procedure :: Foo + end type +contains + subroutine Foo(self) + class(BType) :: self + + write(*,*) 'Foo(BType)' + end subroutine +end module +program iface_tbp_test + use AModule + implicit none + + call test() + +contains + subroutine test() + use BModule + + type(BType) :: y + + call y%Foo() + call Foo(1) + end subroutine +end program +! { dg-final { scan-tree-dump-times "foo \\(&class.2\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pr95090.f90 b/gcc/testsuite/gfortran.dg/pr95090.f90 index ec77802..714802f 100644 --- a/gcc/testsuite/gfortran.dg/pr95090.f90 +++ b/gcc/testsuite/gfortran.dg/pr95090.f90 @@ -13,7 +13,7 @@ module m2345678901234567890123456789012345678901234567890123456789_123 contains subroutine s2345678901234567890123456789012345678901234567890123456789_123 type(t2345678901234567890123456789012345678901234567890123456789_123 & - (n2345678901234567890123456789012345678901234567890123456789_123)) :: & + (n2345678901234567890123456789012345678901234567890123456789_123 = 4)) :: & z2345678901234567890123456789012345678901234567890123456789_123 end end diff --git a/gcc/testsuite/gfortran.dg/pr96436_4.f90 b/gcc/testsuite/gfortran.dg/pr96436_4.f90 index 7d2cfef..145c6cb 100644 --- a/gcc/testsuite/gfortran.dg/pr96436_4.f90 +++ b/gcc/testsuite/gfortran.dg/pr96436_4.f90 @@ -2,7 +2,7 @@ ! { dg-options "-std=f2018 -pedantic" } character(20) :: fmt -character(9) :: buffer +character(12) :: buffer fmt = "(1a1,f0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" if (buffer.ne.">3.00<") stop 1 @@ -11,15 +11,15 @@ write(buffer,fmt) ">", 0.3, "<" if (buffer.ne.">0.30<") stop 2 fmt = "(1a1,d0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">0.30D+1<") stop 3 +if (buffer.ne.">0.30D+01<") stop 3 fmt = "(1a1,e0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">0.30E+1<") stop 4 +if (buffer.ne.">0.30E+01<") stop 4 fmt = "(1a1,en0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00E+0<") stop 5 +if (buffer.ne.">3.00E+00<") stop 5 fmt = "(1a1,es0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00E+0<") stop 6 +if (buffer.ne.">3.00E+00<") stop 6 end diff --git a/gcc/testsuite/gfortran.dg/pr96436_5.f90 b/gcc/testsuite/gfortran.dg/pr96436_5.f90 index 3870d98..4d95ed2 100644 --- a/gcc/testsuite/gfortran.dg/pr96436_5.f90 +++ b/gcc/testsuite/gfortran.dg/pr96436_5.f90 @@ -2,7 +2,7 @@ ! { dg-options "-pedantic" } character(20) :: fmt -character(9) :: buffer +character(12) :: buffer fmt = "(1a1,f0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" if (buffer.ne.">3.00<") stop 1 @@ -11,15 +11,15 @@ write(buffer,fmt) ">", 0.30, "<" if (buffer.ne.">0.30<") stop 2 fmt = "(1a1,d0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">0.30D+1<") stop 3 +if (buffer.ne.">0.30D+01<") stop 3 fmt = "(1a1,e0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">0.30E+1<") stop 4 +if (buffer.ne.">0.30E+01<") stop 4 fmt = "(1a1,en0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00E+0<") stop 5 +if (buffer.ne.">3.00E+00<") stop 5 fmt = "(1a1,es0.2,1a1)" write(buffer,fmt) ">", 3.0, "<" -if (buffer.ne.">3.00E+0<") stop 6 +if (buffer.ne.">3.00E+00<") stop 6 end diff --git a/gcc/testsuite/gfortran.dg/proc_target_1.f90 b/gcc/testsuite/gfortran.dg/proc_target_1.f90 new file mode 100644 index 0000000..050ee39 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_target_1.f90 @@ -0,0 +1,134 @@ +! { dg-do run } +! +! PR fortran/117070 - Procedure targets in derived-type constructors +! +! Contributed by Ivan Pribec + +module funcs + implicit none + + abstract interface + function retchar() + character(len=1) :: retchar + end function retchar + end interface +contains + function a() + character(len=1) :: a + a = 'a' + end function + function b() + character(len=1) :: b + b = 'b' + end function + function c() + character(len=1) :: c + c = 'c' + end function +end module + +module dispatch_table + use funcs + implicit none + + ! Procedure container + type :: pc + procedure(retchar), pointer, nopass :: rc => null() + end type pc + + type(pc), parameter :: dtab_p(3) = [pc(a),pc(b),pc(c)] ! Parameter + type(pc) :: dtab_v(3) = [pc(a),pc(b),pc(c)] ! Variable + +contains + + ! Dynamic dispatch table + function build_table() result(table) + type(pc) :: table(3) + table = [pc(a),pc(b),pc(c)] + end function build_table + +end module + +program test + use dispatch_table + implicit none + type(pc), parameter :: table_p(3) = [pc(a),pc(b),pc(c)] ! Parameter + type(pc) :: table_v(3) = [pc(a),pc(b),pc(c)] ! Variable + type(pc) :: table(3) + + ! Get dispatch table from local variable + table = table_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 1 + end associate + + associate (abc => table_v(1)%rc()//table_v(2)%rc()//table_v(3)%rc()) + if (abc /= 'abc') stop 2 + end associate + + table = table_p + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 3 + end associate + +! Bogus error: +! "Operands of string concatenation operator at (1) are PROCEDURE/PROCEDURE" +! associate (abc => table_p(1)%rc()//table_p(2)%rc()//table_p(3)%rc()) +! if (abc /= 'abc') stop 4 +! end associate + + ! Get dispatch table from other module and passed via local variable + table = build_table() ! Dynamic table + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 5 + end associate + + table = dtab_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 6 + end associate + + table = dtab_p + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 7 + end associate + + ! Dispatch table from other module directly used in associate + associate (abc => dtab_v(1)%rc()//dtab_v(2)%rc()//dtab_v(3)%rc()) + if (abc /= 'abc') stop 8 + end associate + +! associate (abc => dtab_p(1)%rc()//dtab_p(2)%rc()//dtab_p(3)%rc()) +! if (abc /= 'abc') stop 9 +! end associate + + ! Several variations + block + type(pc) :: table(3) = [pc(a),pc(b),pc(c)] + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 10 + end associate + end block + + block + use dispatch_table, only: table => dtab_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 11 + end associate + end block + +! block +! type(pc), parameter :: table(3) = [pc(a),pc(b),pc(c)] +! associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) +! if (abc /= 'abc') stop 12 +! end associate +! end block + +! block +! use dispatch_table, only: table => dtab_p +! associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) +! if (abc /= 'abc') stop 13 +! end associate +! end block + +end program diff --git a/gcc/testsuite/gfortran.dg/public_private_module_2.f90 b/gcc/testsuite/gfortran.dg/public_private_module_2.f90 index e84429e..87276cc 100644 --- a/gcc/testsuite/gfortran.dg/public_private_module_2.f90 +++ b/gcc/testsuite/gfortran.dg/public_private_module_2.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O2" } +! { dg-options "-O2 -Wsurprising" } ! { dg-require-visibility "" } ! ! PR fortran/52751 (top, "module mod") @@ -8,16 +8,16 @@ ! Ensure that (only) those module variables and procedures which are PRIVATE ! and have no C-binding label are optimized away. ! - module mod - integer :: aa - integer, private :: iii - integer, private, bind(C) :: jj ! { dg-warning "PRIVATE but has been given the binding label" } - integer, private, bind(C,name='lll') :: kk ! { dg-warning "PRIVATE but has been given the binding label" } - integer, private, bind(C,name='') :: mmmm - integer, bind(C) :: nnn - integer, bind(C,name='oo') :: pp - integer, bind(C,name='') :: qq - end module mod +module mod + integer :: aa + integer, private :: iii + integer, private, bind(C) :: jj ! { dg-warning "is marked PRIVATE" } + integer, private, bind(C,name='lll') :: kk + integer, private, bind(C,name='') :: mmmm + integer, bind(C) :: nnn + integer, bind(C,name='oo') :: pp + integer, bind(C,name='') :: qq +end module mod ! The two xfails below have appeared with the introduction of submodules. 'iii' and ! 'mmm' now are TREE_PUBLIC but has DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN set. @@ -43,10 +43,10 @@ CONTAINS integer FUNCTION two() two = 42 END FUNCTION two - integer FUNCTION three() bind(C) ! { dg-warning "PRIVATE but has been given the binding label" } + integer FUNCTION three() bind(C) ! { dg-warning "is marked PRIVATE" } three = 43 END FUNCTION three - integer FUNCTION four() bind(C, name='five') ! { dg-warning "PRIVATE but has been given the binding label" } + integer FUNCTION four() bind(C, name='five') four = 44 END FUNCTION four integer FUNCTION six() bind(C, name='') diff --git a/gcc/testsuite/gfortran.dg/pure_result.f90 b/gcc/testsuite/gfortran.dg/pure_result.f90 new file mode 100644 index 0000000..a4d30aa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pure_result.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! PR fortran/78640 - constraints on pure function results +! +! F2018:C1585, F2023:C1594: +! "The function result of a pure function shall not be both polymorphic and +! allocatable, or have a polymorphic allocatable ultimate component." + +program pr78640 + implicit none + + type foo_t + end type + + type bar_t + integer, allocatable :: dummy + class(*), allocatable :: c + end type bar_t + +contains + + pure function f() result(foo) ! { dg-error "is polymorphic allocatable" } + class(foo_t), allocatable :: foo + foo = foo_t() + end function + + pure function f2() ! { dg-error "is polymorphic allocatable" } + class(foo_t), allocatable :: f2 + f2 = foo_t() + end function + + pure function g() result(foo) ! { dg-error "is polymorphic allocatable" } + class(*), allocatable :: foo + foo = foo_t() + end function + + pure function g2() ! { dg-error "is polymorphic allocatable" } + class(*), allocatable :: g2 + g2 = foo_t() + end function + + pure function h() result(bar) ! { dg-error "polymorphic allocatable component" } + type(bar_t) :: bar + end function + + pure function h2() ! { dg-error "polymorphic allocatable component" } + type(bar_t) :: h2 + 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_contiguous.f90 b/gcc/testsuite/gfortran.dg/select_contiguous.f90 new file mode 100644 index 0000000..b947006 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_contiguous.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-O2 -Wextra -fdump-tree-optimized" } +! +! PR fortran/122709 - bogus warning for contiguous pointer assignment +! to select type target +! +! Contributed by <mscfd at gmx dot net> + +module sc_mod + implicit none + public + + type :: t + integer :: i = 0 + end type t + + type :: s + class(t), dimension(:), contiguous, pointer :: p => null() + end type s + +contains + + subroutine foo(x) + class(s), intent(in) :: x + type(t), dimension(:), contiguous, pointer :: q + select type (p_ => x%p) + type is (t) + q => p_ + if (.not. is_contiguous(x%p)) stop 1 + if (.not. is_contiguous(p_)) stop 2 ! Should get optimized out + if (.not. is_contiguous(q)) stop 3 + write(*,*) 'is contiguous: ', is_contiguous(x%p), & + is_contiguous(p_), is_contiguous(q) + end select + end subroutine foo + +end module sc_mod + +program select_contiguous + use sc_mod + implicit none + + type(s) :: x + + allocate(t :: x%p(1:10)) + call foo(x) + deallocate(x%p) + +end program select_contiguous + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } } 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/spec_statement_in_exec.f90 b/gcc/testsuite/gfortran.dg/spec_statement_in_exec.f90 new file mode 100644 index 0000000..9134a1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/spec_statement_in_exec.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } +! Test improved error messages for specification statements in executable section +! PR fortran/32365 - Better error message for specification statement in executable section + +subroutine test_spec_in_exec + implicit none + integer :: i + + ! First executable statement + i = 1 + + ! Test key specification statement types + integer :: j ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + real :: x ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + complex :: z ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + logical :: flag ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + character(len=20) :: name ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + double precision :: d ! { dg-error "data declaration statement at \\(1\\) cannot appear after executable statements" } + common /myblock/ i ! { dg-error "COMMON statement at \\(1\\) cannot appear after executable statements" } + equivalence (i, i) ! { dg-error "EQUIVALENCE statement at \\(1\\) cannot appear after executable statements" } + namelist /nml/ i ! { dg-error "NAMELIST statement at \\(1\\) cannot appear after executable statements" } +!$omp threadprivate(i) ! { dg-error "THREADPRIVATE statement at \\(1\\) cannot appear after executable statements" } +!$omp declare target (i) ! { dg-error "DECLARE TARGET statement at \\(1\\) cannot appear after executable statements" } + +end subroutine test_spec_in_exec diff --git a/gcc/testsuite/gfortran.dg/split_1.f90 b/gcc/testsuite/gfortran.dg/split_1.f90 new file mode 100644 index 0000000..21659b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = 0 + + call split(input, set, p) + if (p /= 1) STOP 1 + call split(input, set, p) + if (p /= 5) STOP 2 + call split(input, set, p) + if (p /= 10) STOP 3 + call split(input, set, p) + if (p /= 18) STOP 4 + call split(input, set, p) + if (p /= 19) STOP 5 + + call split(input, set, p, .true.) + if (p /= 18) STOP 6 + call split(input, set, p, .true.) + if (p /= 10) STOP 7 + call split(input, set, p, .true.) + if (p /= 5) STOP 8 + call split(input, set, p, .true.) + if (p /= 1) STOP 9 +end program b diff --git a/gcc/testsuite/gfortran.dg/split_2.f90 b/gcc/testsuite/gfortran.dg/split_2.f90 new file mode 100644 index 0000000..9afb30b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program b + integer, parameter :: ucs4 = selected_char_kind('ISO_10646') + character(kind=ucs4, len=:), allocatable :: input, set + integer :: p = 0 + + input = char(int(z'4f60'), ucs4) // char(int(z'597d'), ucs4) // char(int(z'4f60'), ucs4) // char(int(z'4e16'), ucs4) + set = char(int(z'597d'), ucs4) // char(int(z'4e16'), ucs4) + + call split(input, set, p) + if (p /= 2) stop 1 + call split(input, set, p) + if (p /= 4) stop 2 + call split(input, set, p) + if (p /= 5) stop 3 + call split(input, set, p, .true.) + if (p /= 4) stop 4 + call split(input, set, p, .true.) + if (p /= 2) stop 5 + call split(input, set, p, .true.) + if (p /= 0) stop 6 +end program b diff --git a/gcc/testsuite/gfortran.dg/split_3.f90 b/gcc/testsuite/gfortran.dg/split_3.f90 new file mode 100644 index 0000000..bec3fdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-shouldfail "Fortran runtime error" } + +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = -1 + call split(input, set, p) +end program b diff --git a/gcc/testsuite/gfortran.dg/split_4.f90 b/gcc/testsuite/gfortran.dg/split_4.f90 new file mode 100644 index 0000000..a3c27bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/split_4.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-shouldfail "Fortran runtime error" } + +program b + character(len=:), allocatable :: input + character(len=2) :: set = ', ' + integer :: p + input = " one,last example," + p = 0 + call split(input, set, p, .true.) +end program b diff --git a/gcc/testsuite/gfortran.dg/stat_3.f90 b/gcc/testsuite/gfortran.dg/stat_3.f90 new file mode 100644 index 0000000..9bfff1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stat_3.f90 @@ -0,0 +1,59 @@ +! { 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 + +subroutine sub3 () + implicit none + integer(1) :: ierr1, unit1 = 10 + integer(2) :: buff2(13) + integer(4) :: buff4(13) + integer(8) :: buff8(13) + character(len=32) :: name = "/etc/passwd" + ierr1 = stat (name,values=buff2) ! { dg-error "with kind 2" } + call fstat (unit1, values=buff2) ! { dg-error "with kind 2" } + call fstat (unit1, values=buff4, status=ierr1) ! { dg-error "at least four" } + call lstat (name, values=buff8, status=ierr1) ! { dg-error "at least four" } +end diff --git a/gcc/testsuite/gfortran.dg/stat_4.f90 b/gcc/testsuite/gfortran.dg/stat_4.f90 new file mode 100644 index 0000000..c2d36ff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/stat_4.f90 @@ -0,0 +1,94 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/82480 - make STAT/LSTAT/FSTAT generic + +subroutine fstat_sub_wrapper (unit, values8, status, opt_status4, opt_status8) + implicit none + integer(1), intent(in) :: unit + integer(8), intent(out) :: values8(:) + integer(2), intent(out) :: status + integer(4), intent(out), optional :: opt_status4 + integer(8), intent(out), optional :: opt_status8 + call fstat (unit, values8, status) + call fstat (unit, values8, opt_status4) + call fstat (unit, values8, opt_status8) +end + +subroutine stat_sub_wrapper (name, values4, status, opt_status4, opt_status8) + implicit none + character(*), intent(in) :: name + integer(4), intent(out) :: values4(:) + integer(2), intent(out) :: status + integer(4), intent(out), optional :: opt_status4 + integer(8), intent(out), optional :: opt_status8 + call stat (name, values4, status) + call lstat (name, values4, status) + call stat (name, values4, opt_status4) + call lstat (name, values4, opt_status4) + call stat (name, values4, opt_status8) + call lstat (name, values4, opt_status8) +end + +subroutine sub1 () + implicit none + character(len=32) :: name = "/etc/passwd" + integer(1) :: unit1 = 10 + integer(4) :: unit4 = 10, buff4(13) + integer(8) :: unit8 = 10, buff8(13) + integer :: ierr + ierr = fstat (unit1, values=buff4) + ierr = fstat (unit1, values=buff8) + ierr = fstat (unit4, values=buff4) + ierr = fstat (unit4, values=buff8) + ierr = fstat (unit8, values=buff4) + ierr = fstat (unit8, values=buff8) + ierr = stat (name, values=buff4) + ierr = stat (name, values=buff8) + ierr = lstat (name, values=buff4) + ierr = lstat (name, values=buff8) +end + +subroutine sub2 () + implicit none + integer(2) :: ierr2, unit2 = 10 + integer(4) :: ierr4, unit4 = 10, buff4(13) + integer(8) :: ierr8, unit8 = 10, buff8(13) + character(len=32) :: name = "/etc/passwd" + call fstat (unit2, values=buff4) + call fstat (unit2, values=buff8) + call fstat (unit4, values=buff4) + call fstat (unit4, values=buff8) + call fstat (unit8, values=buff4) + call fstat (unit8, values=buff8) + call stat (name, values=buff4) + call lstat (name, values=buff4) + call stat (name, values=buff8) + call lstat (name, values=buff8) + call fstat (unit4, values=buff4, status=ierr2) + call fstat (unit4, values=buff4, status=ierr4) + call fstat (unit4, values=buff4, status=ierr8) + call fstat (unit4, values=buff8, status=ierr2) + call fstat (unit4, values=buff8, status=ierr4) + call fstat (unit4, values=buff8, status=ierr8) + call stat (name, values=buff4, status=ierr4) + call lstat (name, values=buff4, status=ierr4) + call stat (name, values=buff4, status=ierr8) + call lstat (name, values=buff4, status=ierr8) + call stat (name, values=buff8, status=ierr4) + call lstat (name, values=buff8, status=ierr4) +end + +! { dg-final { scan-tree-dump-times "_gfortran_fstat_i4_sub" 6 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_lstat_i4_sub" 6 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stat_i4_sub" 6 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_fstat_i8_sub" 9 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_lstat_i8_sub" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stat_i8_sub" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_fstat_i4 " 3 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_fstat_i8 " 3 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_lstat_i4 " 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_lstat_i8 " 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stat_i4 " 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stat_i8 " 1 "original" } } +! { dg-final { scan-tree-dump-times "opt_status4" 11 "original" } } +! { dg-final { scan-tree-dump-times "opt_status8" 11 "original" } } diff --git a/gcc/testsuite/gfortran.dg/submodule_34.f90 b/gcc/testsuite/gfortran.dg/submodule_34.f90 new file mode 100644 index 0000000..5978ecd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_34.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! +! PR fortran/122046 +! The check for illegal recursion used to trigger on assertion when resolving +! the array spec of the dummy argument in the submodule +! +! Contributed by Tomáš Trnka <trnka@scm.com> + +module ChemicalSystemModule + + implicit none + private + + type, public :: ChemicalSystemType + contains + procedure, public :: NumAtoms + end type + +contains + + elemental integer function NumAtoms(self) + class(ChemicalSystemType), intent(in) :: self + + NumAtoms = 123 + + end function + +end module + +module ChemicalSystemUtilsModule + + use ChemicalSystemModule + + implicit none + private + + public :: ChemicalSystemRMSD + + interface + + module subroutine ChemicalSystemRMSD(modelSys, rmsdGrad) + type(ChemicalSystemType), intent(in) :: modelSys + real , intent(out) :: rmsdGrad(3,modelSys%NumAtoms()) + end subroutine + + end interface + +end module + +submodule(ChemicalSystemUtilsModule) ChemicalSystemUtilsSubModule + use ChemicalSystemModule + + implicit none + +contains + + module subroutine ChemicalSystemRMSD(modelSys, rmsdGrad) + type(ChemicalSystemType), intent(in) :: modelSys + real , intent(out) :: rmsdGrad(3,modelSys%NumAtoms()) + end subroutine + +end submodule + diff --git a/gcc/testsuite/gfortran.dg/team_form_3.f90 b/gcc/testsuite/gfortran.dg/team_form_3.f90 index d9aae33..13eb0c0 100644 --- a/gcc/testsuite/gfortran.dg/team_form_3.f90 +++ b/gcc/testsuite/gfortran.dg/team_form_3.f90 @@ -29,6 +29,6 @@ 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" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &D\\.\[0-9\]+, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &D\\.\[0-9\]+, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &D\\.\[0-9\]+, &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" } } diff --git a/gcc/testsuite/gfortran.dg/transfer_array_subref_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_subref_2.f90 new file mode 100644 index 0000000..9ff5198 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_array_subref_2.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-additional-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/122386 - passing of component ref of nested DT array to TRANSFER + +program main + implicit none + integer, parameter :: dp = 4 + + type cx + real(dp) :: re, im + end type cx + + type complex_wrap1 + type(cx) :: z(2) + end type complex_wrap1 + + type complex_wrap2 + type(cx), dimension(:), allocatable :: z + end type complex_wrap2 + + type(complex_wrap1) :: x = complex_wrap1([cx(1,2), cx(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" } } diff --git a/gcc/testsuite/gfortran.dg/transfer_class_5.f90 b/gcc/testsuite/gfortran.dg/transfer_class_5.f90 new file mode 100644 index 0000000..4ce5eb9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_class_5.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR fortran/121263 - fix TRANSFER with rank 1 unlimited polymorhpic +! +! Based on original testcase by Chris Cox. + +module stdlib_hashmap_wrappers + implicit none +contains + subroutine set_rank_one_key_int( key, value ) + integer, allocatable, intent(inout) :: key(:) + class(*), intent(in) :: value(:) + key = transfer( value, key ) + end subroutine + + subroutine set_rank_one_key_cx ( key, value ) + complex, allocatable, intent(inout) :: key(:) + class(*), intent(in) :: value(:) + key = transfer( value, key ) + end subroutine + + subroutine set_first_key_int ( key, value ) + integer, intent(inout) :: key + class(*), intent(in) :: value(:) + key = transfer( value(1), key ) + end subroutine +end module + +program p + use stdlib_hashmap_wrappers + implicit none + integer, allocatable :: a(:), b(:) + complex, allocatable :: c(:), d(:) + class(*),allocatable :: z(:) + integer :: m + a = [1, 2, 3, 4, 5] + c = cmplx (a, -a) + call set_rank_one_key_int (b, a) + call set_rank_one_key_cx (d, c) + call set_first_key_int (m, a) +! print *, b +! print *, d + if (size (a) /= size (b)) stop 1 + if (any (a /= b)) stop 2 + if (size (c) /= size (d)) stop 3 + if (any (c /= d)) stop 4 + if (m /= 1) stop 5 + deallocate (d) + z = c + d = transfer (z, d) + if (size (c) /= size (d)) stop 6 + if (any (c /= d)) stop 7 + deallocate (a, b, c, d, z) +end program p diff --git a/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_9.f90 b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_9.f90 new file mode 100644 index 0000000..06b0004 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_9.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original -fdump-tree-optimized -fsanitize=undefined" } +! +! PR fortran/122080 - UBSAN: uninitialized stride for missing actual argument +! +! Contributed by Henri Menke + +subroutine outer (optarr) + real, optional, intent(in) :: optarr(:,:) + interface + subroutine inner (optarr) + real, optional, intent(in) :: optarr(:,:) + end subroutine inner + end interface + call inner (optarr) +end subroutine outer + +! There will be 2 remaining UBSAN checks of stride wrapped by a check +! for argument presence: +! +! { dg-final { scan-tree-dump-times "if \\(optarr.0 != 0B\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "UBSAN_CHECK_SUB (.)* stride" 2 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 index 68ceee7..6d21a89 100644 --- a/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 +++ b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 @@ -32,7 +32,7 @@ contains subroutine foo1 (slist, i) character(*), dimension(*) :: slist integer i - write (slist(i), '(2hi=,i3)') i + write (slist(i), '(2hi=,i3)') i ! { dg-warning "H format specifier" } end subroutine foo1 ! This tests the additions to the fix that prevent the dummies of entry thunks diff --git a/gcc/testsuite/gfortran.dg/use_only_3.inc b/gcc/testsuite/gfortran.dg/use_only_3.inc index 7b86009..7ef449e 100644 --- a/gcc/testsuite/gfortran.dg/use_only_3.inc +++ b/gcc/testsuite/gfortran.dg/use_only_3.inc @@ -397,7 +397,7 @@ END MODULE control_flags REAL(DP) :: ecutw = 0.0d0 REAL(DP) :: gcutw = 0.0d0 - ! values for costant cut-off computations + ! values for constant cut-off computations REAL(DP) :: ecfix = 0.0d0 ! value of the constant cut-off REAL(DP) :: ecutz = 0.0d0 ! height of the penalty function (above ecfix) diff --git a/gcc/testsuite/gfortran.dg/value_10.f90 b/gcc/testsuite/gfortran.dg/value_10.f90 new file mode 100644 index 0000000..b1c8d1d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_10.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-additional-options "-Wcharacter-truncation -fdump-tree-original" } +! PR fortran/121727 + +program p + use iso_c_binding, only: c_char + implicit none + call cbind('abcd') ! { dg-warning "length of actual argument longer" } + call one ('efgh') ! { dg-warning "length of actual argument longer" } + call one4 (4_'IJKL') ! { dg-warning "length of actual argument longer" } + + call two4 (4_'MNOP') ! { dg-warning "length of actual argument longer" } + call three('efgh') ! { dg-warning "length of actual argument longer" } + call four ('ijklmn') ! { dg-warning "length of actual argument longer" } +contains + subroutine cbind(c) bind(C) + character(kind=c_char,len=1), value :: c + end + + subroutine one(x) + character(kind=1,len=1), value :: x + end + + subroutine one4(w) + character(kind=4,len=1), value :: w + end + + subroutine two4(y) + character(kind=4,len=2), value :: y + end + + subroutine three(z) + character(kind=1,len=3), value :: z + end + + subroutine four(v) + character(kind=1,len=4), optional, value :: v + end +end + +! { dg-final { scan-tree-dump-times "two4 \\(.*, 2\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "three \\(.*, 3\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "four \\(.*, 1, 4\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/value_optional_3.f90 b/gcc/testsuite/gfortran.dg/value_optional_3.f90 new file mode 100644 index 0000000..58464f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_optional_3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } + +module m + implicit none(type, external) + + logical :: is_present + logical :: is_allocated + integer :: has_value + +contains + + subroutine test(a) + integer, allocatable :: a + call sub_val(a) + end subroutine test + + subroutine test2(a) + integer, allocatable, optional :: a + call sub_val(a) + end subroutine test2 + + subroutine sub_val(x) + integer, optional, value :: x + if (present(x) .neqv. (is_present .and. is_allocated)) stop 1 + if (present(x)) then + if (x /= has_value) stop 2 + end if + end subroutine sub_val + +end module m + +use m +implicit none(type, external) +integer, allocatable :: b + +is_allocated = .false. +is_present = .false. +call test2() + +is_present = .true. +call test(b) +call test2(b) + +b = 4 +is_allocated = .true. +has_value = b +call test(b) +call test2(b) +deallocate(b) + +end program diff --git a/gcc/testsuite/gfortran.dg/vect/pr70102.f b/gcc/testsuite/gfortran.dg/vect/pr70102.f new file mode 100644 index 0000000..b6a2878 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/pr70102.f @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast" } + subroutine test (x,y,z) + integer x,y,z + real*8 a(5,x,y,z),b(5,x,y,z) + real*8 c + + c = 0.0d0 + do k=1,z + do j=1,y + do i=1,x + do l=1,5 + c = c + a(l,i,j,k)*b(l,i,j,k) + enddo + enddo + enddo + enddo + write(30,*)'c ==',c + return + end +! { dg-final { scan-tree-dump "vectorizing a reduction chain" "vect" { target vect_double } } } diff --git a/gcc/testsuite/gfortran.dg/whole_file_24.f90 b/gcc/testsuite/gfortran.dg/whole_file_24.f90 index 3ff6ca8..7b322f1 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_24.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_24.f90 @@ -27,7 +27,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end diff --git a/gcc/testsuite/gfortran.dg/whole_file_29.f90 b/gcc/testsuite/gfortran.dg/whole_file_29.f90 index 86d84cf..87ac4f3 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_29.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_29.f90 @@ -19,7 +19,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end diff --git a/gcc/testsuite/gfortran.dg/x_slash_1.f b/gcc/testsuite/gfortran.dg/x_slash_1.f index 73db12e..b3c7218 100644 --- a/gcc/testsuite/gfortran.dg/x_slash_1.f +++ b/gcc/testsuite/gfortran.dg/x_slash_1.f @@ -18,7 +18,7 @@ c Line 2 has nothing but x editing, followed by a slash. c Line 3 has x editing finished off by a 1h* write (10, 100) - 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/) + 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/) ! { dg-warning "H format specifier" } rewind (10) read (10, 200) a @@ -42,7 +42,7 @@ c Line 3 has tabs to the left of present position. write (10, 101) 101 format (1h1,58x,1h#,/,t38,2x,1h ,tr10,9x,1h$,/, - > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*) + > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*) ! { dg-warning "H format specifier" } rewind (10) read (10, 200) a |