diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
65 files changed, 2081 insertions, 20 deletions
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 new file mode 100644 index 0000000000..df42b342b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 @@ -0,0 +1,270 @@ +! { dg-do run } +! +! Check fix for correctly deep copying allocatable components. +! PR fortran/59678 +! Contributed by Andre Vehreschild <vehre@gmx.de> +! +program alloc_comp_copy_test + + type InnerT + integer :: ii + integer, allocatable :: ai + integer, allocatable :: v(:) + end type InnerT + + type T + integer :: i + integer, allocatable :: a_i + type(InnerT), allocatable :: it + type(InnerT), allocatable :: vec(:) + end type T + + type(T) :: o1, o2 + class(T), allocatable :: o3, o4 + o1%i = 42 + + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (allocated(o2%a_i)) call abort() + if (allocated(o2%it)) call abort() + if (allocated(o2%vec)) call abort() + + allocate (o1%a_i, source=2) + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (allocated(o2%it)) call abort() + if (allocated(o2%vec)) call abort() + + allocate (o1%it) + o1%it%ii = 3 + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (allocated(o2%it%ai)) call abort() + if (allocated(o2%it%v)) call abort() + if (allocated(o2%vec)) call abort() + + allocate (o1%it%ai) + o1%it%ai = 4 + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (.not. allocated(o2%it%ai)) call abort() + if (o2%it%ai /= 4) call abort() + if (allocated(o2%it%v)) call abort() + if (allocated(o2%vec)) call abort() + + allocate (o1%it%v(3), source= 5) + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (.not. allocated(o2%it%ai)) call abort() + if (o2%it%ai /= 4) call abort() + if (.not. allocated(o2%it%v)) call abort() + if (any (o2%it%v /= 5) .or. size (o2%it%v) /= 3) call abort() + if (allocated(o2%vec)) call abort() + + allocate (o1%vec(2)) + o1%vec(:)%ii = 6 + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (.not. allocated(o2%it%ai)) call abort() + if (o2%it%ai /= 4) call abort() + if (.not. allocated(o2%it%v)) call abort() + if (size (o2%it%v) /= 3) call abort() + if (any (o2%it%v /= 5)) call abort() + if (.not. allocated(o2%vec)) call abort() + if (size(o2%vec) /= 2) call abort() + if (any(o2%vec(:)%ii /= 6)) call abort() + if (allocated(o2%vec(1)%ai) .or. allocated(o2%vec(2)%ai)) call abort() + if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) call abort() + + allocate (o1%vec(2)%ai) + o1%vec(2)%ai = 7 + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (.not. allocated(o2%it%ai)) call abort() + if (o2%it%ai /= 4) call abort() + if (.not. allocated(o2%it%v)) call abort() + if (size (o2%it%v) /= 3) call abort() + if (any (o2%it%v /= 5)) call abort() + if (.not. allocated(o2%vec)) call abort() + if (size(o2%vec) /= 2) call abort() + if (any(o2%vec(:)%ii /= 6)) call abort() + if (allocated(o2%vec(1)%ai)) call abort() + if (.not. allocated(o2%vec(2)%ai)) call abort() + if (o2%vec(2)%ai /= 7) call abort() + if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) call abort() + + allocate (o1%vec(1)%v(3)) + o1%vec(1)%v = [8, 9, 10] + call copyO(o1, o2) + if (o2%i /= 42) call abort () + if (.not. allocated(o2%a_i)) call abort() + if (o2%a_i /= 2) call abort() + if (.not. allocated(o2%it)) call abort() + if (o2%it%ii /= 3) call abort() + if (.not. allocated(o2%it%ai)) call abort() + if (o2%it%ai /= 4) call abort() + if (.not. allocated(o2%it%v)) call abort() + if (size (o2%it%v) /= 3) call abort() + if (any (o2%it%v /= 5)) call abort() + if (.not. allocated(o2%vec)) call abort() + if (size(o2%vec) /= 2) call abort() + if (any(o2%vec(:)%ii /= 6)) call abort() + if (allocated(o2%vec(1)%ai)) call abort() + if (.not. allocated(o2%vec(2)%ai)) call abort() + if (o2%vec(2)%ai /= 7) call abort() + if (.not. allocated(o2%vec(1)%v)) call abort() + if (any (o2%vec(1)%v /= [8,9,10])) call abort() + if (allocated(o2%vec(2)%v)) call abort() + + ! Now all the above for class objects. + allocate (o3, o4) + o3%i = 42 + + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (allocated(o4%a_i)) call abort() + if (allocated(o4%it)) call abort() + if (allocated(o4%vec)) call abort() + + allocate (o3%a_i, source=2) + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (allocated(o4%it)) call abort() + if (allocated(o4%vec)) call abort() + + allocate (o3%it) + o3%it%ii = 3 + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (allocated(o4%it%ai)) call abort() + if (allocated(o4%it%v)) call abort() + if (allocated(o4%vec)) call abort() + + allocate (o3%it%ai) + o3%it%ai = 4 + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (.not. allocated(o4%it%ai)) call abort() + if (o4%it%ai /= 4) call abort() + if (allocated(o4%it%v)) call abort() + if (allocated(o4%vec)) call abort() + + allocate (o3%it%v(3), source= 5) + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (.not. allocated(o4%it%ai)) call abort() + if (o4%it%ai /= 4) call abort() + if (.not. allocated(o4%it%v)) call abort() + if (any (o4%it%v /= 5) .or. size (o4%it%v) /= 3) call abort() + if (allocated(o4%vec)) call abort() + + allocate (o3%vec(2)) + o3%vec(:)%ii = 6 + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (.not. allocated(o4%it%ai)) call abort() + if (o4%it%ai /= 4) call abort() + if (.not. allocated(o4%it%v)) call abort() + if (size (o4%it%v) /= 3) call abort() + if (any (o4%it%v /= 5)) call abort() + if (.not. allocated(o4%vec)) call abort() + if (size(o4%vec) /= 2) call abort() + if (any(o4%vec(:)%ii /= 6)) call abort() + if (allocated(o4%vec(1)%ai) .or. allocated(o4%vec(2)%ai)) call abort() + if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) call abort() + + allocate (o3%vec(2)%ai) + o3%vec(2)%ai = 7 + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (.not. allocated(o4%it%ai)) call abort() + if (o4%it%ai /= 4) call abort() + if (.not. allocated(o4%it%v)) call abort() + if (size (o4%it%v) /= 3) call abort() + if (any (o4%it%v /= 5)) call abort() + if (.not. allocated(o4%vec)) call abort() + if (size(o4%vec) /= 2) call abort() + if (any(o4%vec(:)%ii /= 6)) call abort() + if (allocated(o4%vec(1)%ai)) call abort() + if (.not. allocated(o4%vec(2)%ai)) call abort() + if (o4%vec(2)%ai /= 7) call abort() + if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) call abort() + + allocate (o3%vec(1)%v(3)) + o3%vec(1)%v = [8, 9, 10] + call copyO(o3, o4) + if (o4%i /= 42) call abort () + if (.not. allocated(o4%a_i)) call abort() + if (o4%a_i /= 2) call abort() + if (.not. allocated(o4%it)) call abort() + if (o4%it%ii /= 3) call abort() + if (.not. allocated(o4%it%ai)) call abort() + if (o4%it%ai /= 4) call abort() + if (.not. allocated(o4%it%v)) call abort() + if (size (o4%it%v) /= 3) call abort() + if (any (o4%it%v /= 5)) call abort() + if (.not. allocated(o4%vec)) call abort() + if (size(o4%vec) /= 2) call abort() + if (any(o4%vec(:)%ii /= 6)) call abort() + if (allocated(o4%vec(1)%ai)) call abort() + if (.not. allocated(o4%vec(2)%ai)) call abort() + if (o4%vec(2)%ai /= 7) call abort() + if (.not. allocated(o4%vec(1)%v)) call abort() + if (any (o4%vec(1)%v /= [8,9,10])) call abort() + if (allocated(o4%vec(2)%v)) call abort() + +contains + + subroutine copyO(src, dst) + type(T), intent(in) :: src + type(T), intent(out) :: dst + + dst = src + end subroutine copyO + +end program alloc_comp_copy_test + diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 new file mode 100644 index 0000000000..582a2b8e3e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Testcase for PR fortran/65841 +! Contributed by Damian Rousson +! +program alloc_comp_deep_copy_2 + type a + real, allocatable :: f + end type + type b + type(a), allocatable :: g + end type + + type(b) c,d + + c%g=a(1.) + d=c + if (d%g%f /= 1.0) call abort() + d%g%f = 2.0 + if (d%g%f /= 2.0) call abort() +end program diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_3.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_3.f03 new file mode 100644 index 0000000000..7032eaf8f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_3.f03 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR fortran/67721 +! Check that scalar to array assignments of derived type constructor +! deep copy the value when there are allocatable components. + +program p + implicit none + + type :: t1 + integer :: c1 + end type t1 + type :: t2 + type(t1), allocatable :: c2 + end type t2 + + block + type(t2) :: v(4) + + v = t2(t1(3)) + v(2)%c2%c1 = 7 + v(3)%c2%c1 = 11 + v(4)%c2%c1 = 13 + + if (v(1)%c2%c1 /= 3) call abort + if (v(2)%c2%c1 /= 7) call abort + if (v(3)%c2%c1 /= 11) call abort + if (v(4)%c2%c1 /= 13) call abort + end block +end program p diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 new file mode 100644 index 0000000000..532f364f39 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR66079. The original problem was with the first +! allocate statement. The rest of the testcase fixes problems found +! whilst working on it but these have been commented out in 5 branch +! since the pre-requisite patches in 6 branch have not been back +! ported. +! +! Reported by Damian Rouson <damian@sourceryinstitute.org> +! + type subdata + integer, allocatable :: b + endtype +! block + call newRealVec +! end block +contains + subroutine newRealVec + type(subdata), allocatable :: d, e, f + character(:), allocatable :: g, h, i + character(8), allocatable :: j + allocate(d,source=subdata(1)) ! memory was lost, now OK + allocate(e,source=d) ! OK + allocate(f,source=create (99)) ! memory was lost, now OK + if (d%b .ne. 1) call abort + if (e%b .ne. 1) call abort + if (f%b .ne. 99) call abort + allocate (g, source = greeting1("good day")) + if (g .ne. "good day") call abort + allocate (h, source = greeting2("hello")) + if (h .ne. "hello") call abort +! allocate (i, source = greeting3("hiya!")) +! if (i .ne. "hiya!") call abort +! call greeting4 (j, "Goodbye ") ! Test that dummy arguments are OK +! if (j .ne. "Goodbye ") call abort + end subroutine + + function create (arg) result(res) + integer :: arg + type(subdata), allocatable :: res, res1 + allocate(res, res1, source = subdata(arg)) + end function + + function greeting1 (arg) result(res) ! memory was lost, now OK + character(*) :: arg + Character(:), allocatable :: res + allocate(res, source = arg) + end function + + function greeting2 (arg) result(res) + character(5) :: arg + Character(:), allocatable :: res + allocate(res, source = arg) + end function + +! function greeting3 (arg) result(res) +! character(5) :: arg +! Character(5), allocatable :: res, res1 +! allocate(res, res1, source = arg) ! Caused an ICE +! if (res1 .ne. res) call abort +! end function + +! subroutine greeting4 (res, arg) +! character(8), intent(in) :: arg +! Character(8), allocatable, intent(out) :: res +! allocate(res, source = arg) ! Caused an ICE +! end subroutine +end +! { dg-final { scan-tree-dump-times "builtin_malloc" 15 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 17 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/allocate_with_arrayspec_1.f90 b/gcc/testsuite/gfortran.dg/allocate_with_arrayspec_1.f90 new file mode 100644 index 0000000000..686b612408 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_arrayspec_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +MODULE mo_test + + integer :: n = 0 +CONTAINS + + FUNCTION nquery() + INTEGER :: nquery + WRITE (0,*) "hello!" + n = n + 1 + nquery = n + END FUNCTION nquery + +END MODULE mo_test + + +! ---------------------------------------------------------------------- +! MAIN PROGRAM +! ---------------------------------------------------------------------- +PROGRAM example + USE mo_test + INTEGER, ALLOCATABLE :: query_buf(:) + ALLOCATE(query_buf(nquery())) + if (n /= 1 .or. size(query_buf) /= n) call abort() +END PROGRAM example + +! { dg-final { scan-tree-dump-times "nquery" 5 "original" } } diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 new file mode 100644 index 0000000000..76deb6174d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Checks the fix for PR67171, where the second ALLOCATE with and array section +! SOURCE produced a zero index based temporary, which threw the assignment. +! +! Contributed by Anton Shterenlikht <mexas@bristol.ac.uk> +! +program z + implicit none + integer, parameter :: DIM1_SIZE = 10 + real, allocatable :: d(:,:), tmp(:,:) + integer :: i, errstat + + allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat ) + + d(:,1) = [( real (i), i=1,DIM1_SIZE)] + d(:,2) = [( real(2*i), i=1,DIM1_SIZE)] +! write (*,*) d(1, :) + + call move_alloc (from = d, to = tmp) +! write (*,*) tmp( 1, :) + + allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat) + if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) call abort + deallocate (d) + + allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat) + if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) call abort + + deallocate (tmp , d) + +contains + function foo (arg) result (res) + real :: arg(:,:) + real :: res(size (arg, 1), size (arg, 2)) + res = arg + end function +end program z diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 new file mode 100644 index 0000000000..27b5c1775b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 @@ -0,0 +1,220 @@ +! { dg-do compile } +! +! Tests the fix for PR61819. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module foo_base_mod + integer, parameter :: foo_ipk_ = kind(1) + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer(foo_ipk_) :: nl=-1 + end type foo_desc_type + + +contains + + subroutine foo_init(ictxt) + integer :: ictxt + end subroutine foo_init + + + subroutine foo_exit(ictxt) + integer :: ictxt + end subroutine foo_exit + + subroutine foo_info(ictxt,iam,np) + integer(foo_ipk_) :: ictxt,iam,np + iam = 0 + np = 1 + end subroutine foo_info + + subroutine foo_cdall(ictxt,map,info,nl) + integer(foo_ipk_) :: ictxt, info + type(foo_desc_type) :: map + integer(foo_ipk_), optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + subroutine foo_cdasb(map,info) + integer(foo_ipk_) :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) & + & deallocate(this%v) + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer(foo_ipk_) :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer(foo_ipk_), parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer(foo_ipk_) ,save :: NumMy_xy_planes + integer(foo_ipk_) ,parameter :: NumGlobalElements = nx*ny*nz + integer(foo_ipk_) ,parameter :: NumGlobal_xy_planes = nz, Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(ictxt,NumMyElements,info) + integer(foo_ipk_) :: ictxt, NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(ictxt,map,info,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field(comm) result(this) + type(scalar_field) :: this + integer(foo_ipk_) ,intent(in) :: comm + real(foo_dpk_) ,allocatable :: f_v(:) + integer(foo_ipk_) :: i,j,k,NumMyElements, iam, np, info,ip + integer(foo_ipk_), allocatable :: idxs(:) + call foo_info(comm,iam,np) + NumMy_xy_planes = NumGlobal_xy_planes/np + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(comm,NumMyElements,info) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer(foo_ipk_) ::info + write(0,*) 'Freeing scalar_this%f' + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod, only : scalar_field,new_scalar_field + implicit none + type vector_field + type(scalar_field) :: u(1) + contains + procedure :: free + end type +contains + function new_vector_field(comm_in) result(this) + type(vector_field) :: this + integer(foo_ipk_), intent(in) :: comm_in + this%u = [new_scalar_field(comm_in)] ! Removing this line eliminates the memory leak + end function + + subroutine free(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + write(0,*) 'Freeing vector_this%u(',i,')' + call vf(i)%free() + end do + end associate + end subroutine free + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod,only: vector_field,new_vector_field + use foo_scalar_field_mod,only: map + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer(foo_ipk_) :: ictxt, iam, np, i,info + call foo_init(ictxt) + call foo_info(ictxt,iam,np) + u = new_vector_field(ictxt) + call u%free() + do i=1,10 + u = new_vector_field(ictxt) + call u%free() + end do + call u%free() + call foo_exit(ictxt) +end program diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 new file mode 100644 index 0000000000..5ca47a62e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR61830. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module foo_base_mod + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer :: nl=-1 + end type foo_desc_type + +contains + + subroutine foo_cdall(map,nl) + type(foo_desc_type) :: map + integer, optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + + subroutine foo_cdasb(map,info) + integer :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) then + write(0,*) 'Scalar deallocation' + deallocate(this%v) + end if + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + write(0,*) 'Deallocate class() component' + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer, parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer ,save :: NumMy_xy_planes + integer ,parameter :: NumGlobalElements = nx*ny*nz + integer ,parameter :: NumGlobal_xy_planes = nz, & + & Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(NumMyElements) + integer :: NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(map,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field() result(this) + type(scalar_field) :: this + real(foo_dpk_) ,allocatable :: f_v(:) + integer :: i,j,k,NumMyElements, iam, np, info,ip + integer, allocatable :: idxs(:) + + NumMy_xy_planes = NumGlobal_xy_planes + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(NumMyElements) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer ::info + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod + implicit none + type vector_field + type(scalar_field) :: u(1) + end type vector_field +contains + function new_vector_field() result(this) + type(vector_field) :: this + integer :: i + do i=1, size(this%u) + associate(sf=>this%u(i)) + sf = new_scalar_field() + end associate + end do + end function + + subroutine free_v_field(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + call vf(i)%free() + end do + end associate + end subroutine free_v_field + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod + use foo_scalar_field_mod + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer :: iam, np, i,info + + u = new_vector_field() + call foo_geall(v,map,info) + call free_v_field(u) + do i=1,10 + u = new_vector_field() + call free_v_field(u) + av = v%get_vect() + end do +! This gets rid of the "memory leak" + if (associated (u%u(1)%map)) deallocate (u%u(1)%map) + call free_v_field(u) + call v%free() + deallocate(av) +end program +! { dg-final { scan-tree-dump-times "__builtin_malloc" 21 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } } diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_15.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_15.f03 new file mode 100644 index 0000000000..f939aa3d9d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_15.f03 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Tests the fix for PR67933, which was a side effect of the fix for PR67171. +! +! Contributed by Andrew <mandrew9@vt.edu> +! +module test_mod + implicit none + + type :: class_t + integer :: i + end type class_t + + type, extends(class_t) :: class_e + real :: r + end type class_e + + type :: wrapper_t + class(class_t), allocatable :: class_var +! type(class_t), allocatable :: class_var +! integer, allocatable :: class_id + end type wrapper_t + + type :: list_t + type(wrapper_t) :: classes(20) + contains + procedure :: Method + procedure :: Typeme + procedure :: Dealloc + end type list_t + +contains + subroutine Method(this) + class(list_t) :: this + integer :: i + do i = 1, 20 + if (i .gt. 10) then + allocate (this%classes(i)%class_var, source = class_t (i)) + else + allocate (this%classes(i)%class_var, source = class_e (i, real (2 * i))) + end if + end do + end subroutine Method + subroutine Dealloc(this) + class(list_t) :: this + integer :: i + do i = 1, 20 + if (allocated (this%classes(i)%class_var)) & + deallocate (this%classes(i)%class_var) + end do + end subroutine Dealloc + subroutine Typeme(this) + class(list_t) :: this + integer :: i, j(20) + real :: r(20) + real :: zero = 0.0 + do i = 1, 20 + j(i) = this%classes(i)%class_var%i + select type (p => this%classes(i)%class_var) + type is (class_e) + r(i) = p%r + class default + r(i) = zero + end select + end do +! print "(10i6,/)", j + if (any (j .ne. [(i, i = 1,20)])) call abort +! print "(10f6.2,/)", r + if (any (r(1:10) .ne. [(real (2 * i), i = 1,10)])) call abort + if (any (r(11:20) .ne. zero)) call abort + end subroutine Typeme +end module test_mod + + use test_mod + type(list_t) :: x + call x%Method + call x%Typeme + call x%dealloc +end diff --git a/gcc/testsuite/gfortran.dg/array_constructor_26.f03 b/gcc/testsuite/gfortran.dg/array_constructor_26.f03 index ac5dc90cc8..9993099af9 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_26.f03 +++ b/gcc/testsuite/gfortran.dg/array_constructor_26.f03 @@ -11,7 +11,6 @@ MODULE WinData integer :: i TYPE TWindowData CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)] - ! { dg-error "no IMPLICIT type" "" { target *-*-* } 13 } ! { dg-error "specification expression" "" { target *-*-* } 13 } END TYPE TWindowData END MODULE WinData diff --git a/gcc/testsuite/gfortran.dg/array_constructor_27.f03 b/gcc/testsuite/gfortran.dg/array_constructor_27.f03 index 8068364ce4..21adac82ad 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_27.f03 +++ b/gcc/testsuite/gfortran.dg/array_constructor_27.f03 @@ -9,7 +9,6 @@ implicit none type t character (a) :: arr (1) = [ "a" ] - ! { dg-error "no IMPLICIT type" "" { target *-*-* } 11 } ! { dg-error "specification expression" "" { target *-*-* } 11 } end type t diff --git a/gcc/testsuite/gfortran.dg/char_length_2.f90 b/gcc/testsuite/gfortran.dg/char_length_2.f90 index 5673a2ed58..f35c9b5621 100644 --- a/gcc/testsuite/gfortran.dg/char_length_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_length_2.f90 @@ -1,14 +1,13 @@ -! { dg-do link } -! { dg-options "-Wsurprising" } -! Tests the fix for PR 31250 -! CHARACTER lengths weren't reduced early enough for all checks of -! them to be meaningful. Furthermore negative string lengths weren't -! dealt with correctly. +! { dg-do compile } +! Tests the fix for PR 31250. +! The fix for PR fortran/67987 supercedes PR 31250, which removes +! the -Wsurprising option. +! CHARACTER(len=0) :: c1 ! This is OK. -CHARACTER(len=-1) :: c2 ! { dg-warning "has negative length" } +CHARACTER(len=-1) :: c2 PARAMETER(I=-100) -CHARACTER(len=I) :: c3 ! { dg-warning "has negative length" } -CHARACTER(len=min(I,500)) :: c4 ! { dg-warning "has negative length" } +CHARACTER(len=I) :: c3 +CHARACTER(len=min(I,500)) :: c4 CHARACTER(len=max(I,500)) :: d1 ! no warning CHARACTER(len=5) :: d2 ! no warning diff --git a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 index e4fab80205..bfa7945dbc 100644 --- a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 @@ -1,8 +1,11 @@ ! { dg-do compile } ! PR31251 Non-integer character length leads to segfault ! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> - character(len=2.3) :: s ! { dg-error "must be of INTEGER type" } - character(kind=1,len=4.3) :: t ! { dg-error "must be of INTEGER type" } +! +! Updated to deal with the fix for PR fortran/67805. +! + character(len=2.3) :: s ! { dg-error "INTEGER expression expected" } + character(kind=1,len=4.3) :: t ! { dg-error "INTEGER expression expected" } character(len=,,7.2,kind=1) :: u ! { dg-error "Syntax error in CHARACTER declaration" } character(len=7,kind=2) :: v ! ! { dg-error "Kind 2 is not supported for CHARACTER" } character(kind=2) :: w ! ! { dg-error "Kind 2 is not supported for CHARACTER" } diff --git a/gcc/testsuite/gfortran.dg/class_allocate_20.f90 b/gcc/testsuite/gfortran.dg/class_allocate_20.f90 new file mode 100644 index 0000000000..defe9df9d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_20.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR fortran/64921 +! Test that the finalization wrapper procedure get the always_explicit +! attribute so that the array is not passed without descriptor from +! T3's finalization wrapper procedure to T2's one. +! +! Contributed by Mat Cross <mathewc@nag.co.uk> + +Program test + Implicit None + Type :: t1 + Integer, Allocatable :: i + End Type + Type :: t2 + Integer, Allocatable :: i + End Type + Type, Extends (t1) :: t3 + Type (t2) :: j + End Type + Type, Extends (t3) :: t4 + Integer, Allocatable :: k + End Type + Call s + Print *, 'ok' +Contains + Subroutine s + Class (t1), Allocatable :: x + Allocate (t4 :: x) + End Subroutine +End Program +! { dg-output "ok" } diff --git a/gcc/testsuite/gfortran.dg/co_reduce_1.f90 b/gcc/testsuite/gfortran.dg/co_reduce_1.f90 new file mode 100644 index 0000000000..1d3e89f65c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/co_reduce_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original -fcoarray=lib" } +! +! Check that we don't take twice the address of procedure simple_reduction +! in the generated code. +! +! Contributed by Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> + +program simple_reduce + implicit none + + integer :: me + + me = this_image() + + sync all + + call co_reduce(me,simple_reduction) + + write(*,*) this_image(),me + +contains + + pure function simple_reduction(a,b) + integer,intent(in) :: a,b + integer :: simple_reduction + + simple_reduction = a * b + end function simple_reduction + +end program simple_reduce + +! { dg-final { scan-tree-dump "_gfortran_caf_co_reduce \\(&desc\\.\\d+,\\s*simple_reduction," "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 index d7fb00b336..064e67cf59 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 @@ -33,7 +33,7 @@ contains end function hc end program test -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., &fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, &gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., &hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90 b/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90 new file mode 100644 index 0000000000..f3a739f503 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Checks the fix for PR67977 in which automatic reallocation on assignment +! was performed when the lhs had a substring reference. +! +! Contributed by Anton Shterenlikht <mexas@bristol.ac.uk> +! + character(:), allocatable :: z + integer :: length + z = "cockatoo" + length = len (z) + z(:) = '' + if (len(z) .ne. length) call abort + if (trim (z) .ne. '') call abort + z(:3) = "foo" + if (len(z) .ne. length) call abort + if (trim (z) .ne. "foo") call abort + z(4:) = "__bar" + if (len(z) .ne. length) call abort + if (trim (z) .ne. "foo__bar") call abort + deallocate (z) +end diff --git a/gcc/testsuite/gfortran.dg/generic_30.f90 b/gcc/testsuite/gfortran.dg/generic_30.f90 new file mode 100644 index 0000000000..5f82373cfb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_30.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR fortran/66929 +! Generic procedures as actual argument used to lead to +! a NULL pointer dereference in gfc_get_proc_ifc_for_expr +! because the generic symbol was used as procedure symbol, +! instead of the specific one. + +module iso_varying_string + type, public :: varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + interface operator(/=) + module procedure op_ne_VS_CH + end interface operator (/=) + interface trim + module procedure trim_ + end interface +contains + elemental function op_ne_VS_CH (string_a, string_b) result (op_ne) + type(varying_string), intent(in) :: string_a + character(LEN=*), intent(in) :: string_b + logical :: op_ne + op_ne = .true. + end function op_ne_VS_CH + elemental function trim_ (string) result (trim_string) + type(varying_string), intent(in) :: string + type(varying_string) :: trim_string + trim_string = varying_string(["t", "r", "i", "m", "m", "e", "d"]) + end function trim_ +end module iso_varying_string +module syntax_rules + use iso_varying_string, string_t => varying_string +contains + subroutine set_rule_type_and_key + type(string_t) :: key + if (trim (key) /= "") then + print *, "non-empty" + end if + end subroutine set_rule_type_and_key +end module syntax_rules diff --git a/gcc/testsuite/gfortran.dg/generic_31.f90 b/gcc/testsuite/gfortran.dg/generic_31.f90 new file mode 100644 index 0000000000..2c0d029900 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_31.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/66929 +! Check that the specific FIRST symbol is used for the call to FOO, +! so that the J argument is not assumed to be present + +module m + interface foo + module procedure first + end interface foo +contains + elemental function bar(j) result(r) + integer, intent(in), optional :: j + integer :: r, s(2) + ! We used to have NULL dereference here, in case of a missing J argument + s = foo(j, [3, 7]) + r = sum(s) + end function bar + elemental function first(i, j) result(r) + integer, intent(in), optional :: i + integer, intent(in) :: j + integer :: r + if (present(i)) then + r = i + else + r = -5 + end if + end function first +end module m +program p + use m + integer :: i + i = bar() + if (i /= -10) call abort +end program p diff --git a/gcc/testsuite/gfortran.dg/iomsg_2.f90 b/gcc/testsuite/gfortran.dg/iomsg_2.f90 new file mode 100644 index 0000000000..29500ed01a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iomsg_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +subroutine foo1 + implicit none + integer i + open(1, iomsg=666) ! { dg-error "IOMSG must be" } + open(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + open(1, iomsg=i) ! { dg-error "IOMSG must be" } + close(1, iomsg=666) ! { dg-error "IOMSG must be" } + close(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + close(1, iomsg=i) ! { dg-error "IOMSG must be" } +end subroutine foo1 + +subroutine foo + implicit none + integer i + real :: x = 1 + write(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } + write(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } + read(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } + read(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } + flush(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + flush(1, iomsg=i) ! { dg-error "IOMSG must be" } + rewind(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + rewind(1, iomsg=i) ! { dg-error "IOMSG must be" } + backspace(1,iomsg='sgk') ! { dg-error "IOMSG must be" } + backspace(1,iomsg=i) ! { dg-error "IOMSG must be" } + wait(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + wait(1, iomsg=i) ! { dg-error "IOMSG must be" } +end subroutine foo + +subroutine bar + implicit none + integer i + real :: x = 1 + character(len=20) s(2) + open(1, iomsg=s) ! { dg-error "must be scalar" } + close(1, iomsg=s) ! { dg-error "must be scalar" } + write(1, *, iomsg=s) x ! { dg-error "must be scalar" } + read(1, *, iomsg=s) x ! { dg-error "must be scalar" } + flush(1, iomsg=s) ! { dg-error "must be scalar" } + rewind(1, iomsg=s) ! { dg-error "must be scalar" } + backspace(1,iomsg=s) ! { dg-error "must be scalar" } + wait(1, iomsg=s) ! { dg-error "must be scalar" } +end subroutine bar diff --git a/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 b/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 index 0660b497a6..128376963b 100644 --- a/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 +++ b/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 @@ -1,6 +1,5 @@ ! { dg-do run } ! { dg-require-effective-target fortran_large_real } -! { dg-xfail-if "" { "*-*-freebsd*" } { "*" } { "" } } ! Testing erf and erfc library calls on large real kinds (larger than kind=8) implicit none diff --git a/gcc/testsuite/gfortran.dg/module_private_2.f90 b/gcc/testsuite/gfortran.dg/module_private_2.f90 new file mode 100644 index 0000000000..847c58d5e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_private_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/47266 +! +! Check whether the private procedure "priv" is optimized away +! +module m + implicit none + private :: priv + private :: export1, export2 + public :: pub +contains + integer function priv() + priv = 44 + end function priv + integer function export1() + export1 = 45 + end function export1 + function export2() bind(C) ! { dg-warning "is marked PRIVATE" } + use iso_c_binding, only: c_int + integer(c_int) :: export2 + export2 = 46 + end function export2 + subroutine pub(a,b) + integer :: a + procedure(export1), pointer :: b + a = priv() + b => export1 + end subroutine pub +end module m +! { dg-final { scan-tree-dump-times "priv" 0 "optimized" } } +! { dg-final { scan-tree-dump-times "export1 \\(\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "export2 \\(\\)" 1 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/move_alloc_15.f90 b/gcc/testsuite/gfortran.dg/move_alloc_15.f90 new file mode 100644 index 0000000000..1c96ccba1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_15.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Fix for PR...... +! +! The 'to' components of 'mytemp' would remain allocated after the call to +! MOVE_ALLOC, resulting in memory leaks. +! +! Contributed by Alberto Luaces. +! +! See https://groups.google.com/forum/#!topic/comp.lang.fortran/k3bkKUbOpFU +! +module alloctest + type myallocatable + integer, allocatable:: i(:) + end type myallocatable + +contains + subroutine f(num, array) + implicit none + integer, intent(in) :: num + integer :: i + type(myallocatable):: array(:) + + do i = 1, num + allocate(array(i)%i(5), source = [1,2,3,4,5]) + end do + + end subroutine f +end module alloctest + +program name + use alloctest + implicit none + type(myallocatable), allocatable:: myarray(:), mytemp(:) + integer, parameter:: OLDSIZE = 7, NEWSIZE = 20 + logical :: flag + + allocate(myarray(OLDSIZE)) + call f(size(myarray), myarray) + + allocate(mytemp(NEWSIZE)) + mytemp(1:OLDSIZE) = myarray + + flag = .false. + call foo + call bar + + deallocate(myarray) + if (allocated (mytemp)) deallocate (mytemp) + + allocate(myarray(OLDSIZE)) + call f(size(myarray), myarray) + + allocate(mytemp(NEWSIZE)) + mytemp(1:OLDSIZE) = myarray + +! Verfify that there is no segfault if the allocatable components +! are deallocated before the call to move_alloc + flag = .true. + call foo + call bar + + deallocate(myarray) +contains + subroutine foo + integer :: i + if (flag) then + do i = 1, OLDSIZE + deallocate (mytemp(i)%i) + end do + end if + call move_alloc(mytemp, myarray) + end subroutine + + subroutine bar + integer :: i + do i = 1, OLDSIZE + if (.not.flag .and. allocated (myarray(i)%i)) then + if (any (myarray(i)%i .ne. [1,2,3,4,5])) call abort + else + if (.not.flag) call abort + end if + end do + end subroutine +end program name +! { dg-final { scan-tree-dump-times "__builtin_malloc" 11 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } } diff --git a/gcc/testsuite/gfortran.dg/move_alloc_16.f90 b/gcc/testsuite/gfortran.dg/move_alloc_16.f90 new file mode 100644 index 0000000000..fc09f7778c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_16.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Tests the fix for PR67177 in which MOVE_ALLOC was not assigning the string +! length for deferred length characters. +! +! Contributed by <templed@tcd.ie> +! +program str + implicit none + + type string + character(:), Allocatable :: text + end type string + + type strings + type(string), allocatable, dimension(:) :: strlist + end type strings + + type(strings) :: teststrs + type(string) :: tmpstr + integer :: strlen = 20 + + allocate (teststrs%strlist(1)) + allocate (character(len=strlen) :: tmpstr%text) + + allocate (character(len=strlen) :: teststrs%strlist(1)%text) + +! Full string reference was required because reallocation on assignment is +! functioning when it should not if the lhs is a substring - PR67977 + tmpstr%text(1:3) = 'foo' + + if (.not.allocated (teststrs%strlist(1)%text)) call abort + if (len (tmpstr%text) .ne. strlen) call abort + + call move_alloc(tmpstr%text,teststrs%strlist(1)%text) + + if (.not.allocated (teststrs%strlist(1)%text)) call abort + if (len (teststrs%strlist(1)%text) .ne. strlen) call abort + if (trim (teststrs%strlist(1)%text(1:3)) .ne. 'foo') call abort + +! Clean up so that valgrind reports all allocated memory freed. + if (allocated (teststrs%strlist(1)%text)) deallocate (teststrs%strlist(1)%text) + if (allocated (teststrs%strlist)) deallocate (teststrs%strlist) +end program str diff --git a/gcc/testsuite/gfortran.dg/pr36192_1.f90 b/gcc/testsuite/gfortran.dg/pr36192_1.f90 new file mode 100644 index 0000000000..77df31765a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr36192_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/36192 +program three_body + real, parameter :: n = 2, d = 2 + real, dimension(n,d) :: x_hq ! { dg-error "of INTEGER type|of INTEGER type" } + call step(x_hq) + contains + subroutine step(x) + real, dimension(:,:), intent(in) :: x + end subroutine step +end program three_body +! { dg-prune-output "must have constant shape" } diff --git a/gcc/testsuite/gfortran.dg/pr51993.f90 b/gcc/testsuite/gfortran.dg/pr51993.f90 new file mode 100644 index 0000000000..753dd6fc80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr51993.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/51993 +! Code contributed by Sebastien Bardeau <bardeau at iram dot fr> +module mymod + type :: mytyp + character(len=3) :: a = .true. ! { dg-error "convert LOGICAL" } + end type mytyp +end module mymod diff --git a/gcc/testsuite/gfortran.dg/pr56520.f90 b/gcc/testsuite/gfortran.dg/pr56520.f90 new file mode 100644 index 0000000000..b074b8024c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr56520.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/56520 +! +program misleading + implicit none + real a, c + a = 1.0 + c = exp(+a) ) ! { dg-error "Unclassifiable statement" } + c = exp(-a) ) ! { dg-error "Unclassifiable statement" } + c = exp((a)) ) ! { dg-error "Unclassifiable statement" } + c = exp(a) ) ! { dg-error "Unclassifiable statement" } + c = exp(a) +end program misleading diff --git a/gcc/testsuite/gfortran.dg/pr58027.f90 b/gcc/testsuite/gfortran.dg/pr58027.f90 new file mode 100644 index 0000000000..bef893c212 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr58027.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/58027 +integer, parameter :: i(1)=(/z'ff800000'/) ! { dg-error "overflow converting" } +print *, isclass +end diff --git a/gcc/testsuite/gfortran.dg/pr58754.f90 b/gcc/testsuite/gfortran.dg/pr58754.f90 new file mode 100644 index 0000000000..a366985634 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr58754.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! Tests the fix for PR58754 +! + type :: char_type + character, allocatable :: chr (:) + end type + character, allocatable :: c(:) + type(char_type) :: d + character :: t(1) = ["w"] + + allocate (c (1), source = t) + if (any (c .ne. t)) call abort + c = ["a"] + if (any (c .ne. ["a"])) call abort + deallocate (c) + +! Check allocatable character components, whilst we are about it. + allocate (d%chr (2), source = [t, char (ichar (t) + 1)]) + if (any (d%chr .ne. ["w", "x"])) call abort + d%chr = ["a","b","c","d"] + if (any (d%chr .ne. ["a","b","c","d"])) call abort + deallocate (d%chr) +end diff --git a/gcc/testsuite/gfortran.dg/pr66311.f90 b/gcc/testsuite/gfortran.dg/pr66311.f90 new file mode 100644 index 0000000000..dc40cb6b72 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66311.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-additional-options "-fno-range-check -w" } +! +! Check that we can print large constants +! +! "-fno-range-check -w" is used so the testcase compiles even with targets +! that don't support large integer kinds. + +program test + use iso_fortran_env, only : ikinds => integer_kinds + implicit none + + ! Largest integer kind + integer, parameter :: k = ikinds(size(ikinds)) + integer, parameter :: hk = k / 2 + + if (k <= 8) stop + + call check(9000000000000000000_k, "9000000000000000000") + call check(90000000000000000000_k, "90000000000000000000") + call check(int(huge(1_hk), kind=k), "9223372036854775807") + call check(2_k**63, "9223372036854775808") + call check(10000000000000000000_k, "10000000000000000000") + call check(18446744065119617024_k, "18446744065119617024") + call check(2_k**64 - 1, "18446744073709551615") + call check(2_k**64, "18446744073709551616") + call check(20000000000000000000_k, "20000000000000000000") + call check(huge(0_k), "170141183460469231731687303715884105727") + call check(huge(0_k)-1, "170141183460469231731687303715884105726") + + call check(-9000000000000000000_k, "-9000000000000000000") + call check(-90000000000000000000_k, "-90000000000000000000") + call check(-int(huge(1_hk), kind=k), "-9223372036854775807") + call check(-2_k**63, "-9223372036854775808") + call check(-10000000000000000000_k, "-10000000000000000000") + call check(-18446744065119617024_k, "-18446744065119617024") + call check(-(2_k**64 - 1), "-18446744073709551615") + call check(-2_k**64, "-18446744073709551616") + call check(-20000000000000000000_k, "-20000000000000000000") + call check(-huge(0_k), "-170141183460469231731687303715884105727") + call check(-(huge(0_k)-1), "-170141183460469231731687303715884105726") + call check(-huge(0_k)-1, "-170141183460469231731687303715884105728") + + call check(2_k * huge(1_hk), "18446744073709551614") + call check((-2_k) * huge(1_hk), "-18446744073709551614") + +contains + + subroutine check (i, str) + implicit none + integer(kind=k), intent(in), value :: i + character(len=*), intent(in) :: str + + character(len=100) :: buffer + write(buffer,*) i + if (adjustl(buffer) /= adjustl(str)) call abort + end subroutine + +end + diff --git a/gcc/testsuite/gfortran.dg/pr66465.f90 b/gcc/testsuite/gfortran.dg/pr66465.f90 new file mode 100644 index 0000000000..ab86830505 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66465.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Tests the fix for PR66465, in which the arguments of the call to +! ASSOCIATED were falsly detected to have different type/kind. +! +! Contributed by Damian Rouson <damian@sourceryinstitute.org> +! + interface + real function HandlerInterface (arg) + real :: arg + end + end interface + + type TextHandlerTestCase + procedure (HandlerInterface), nopass, pointer :: handlerOut=>null() + end type + + type(TextHandlerTestCase) this + + procedure (HandlerInterface), pointer :: procPtr=>null() + + print*, associated(procPtr, this%handlerOut) +end diff --git a/gcc/testsuite/gfortran.dg/pr66545_1.f90 b/gcc/testsuite/gfortran.dg/pr66545_1.f90 new file mode 100644 index 0000000000..7daa800b60 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66545_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR fortran/66545 +! +subroutine p + complex, parameter :: c1 = (c1) ! { dg-error "before its definition" } + complex, parameter :: c2 = c2 ! { dg-error "before its definition" } + complex :: c3 = (c3) ! { dg-error "has not been declared or is a variable" } + complex :: c4 = c4 ! { dg-error "has not been declared or is a variable" } +end subroutine p + +subroutine q + real, parameter :: r1 = (r1) ! { dg-error "before its definition" } + real, parameter :: r2 = r2 ! { dg-error "before its definition" } + real :: r3 = (r3) ! { dg-error "has not been declared or is a variable" } + real :: r4 = r4 ! { dg-error "has not been declared or is a variable" } +end subroutine q diff --git a/gcc/testsuite/gfortran.dg/pr66545_2.f90 b/gcc/testsuite/gfortran.dg/pr66545_2.f90 new file mode 100644 index 0000000000..e15d8ba792 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66545_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Wuninitialized" } +! PR fortran/66545 +! +program foo + implicit none + call p1 + call q1 +end program foo + +subroutine p1 + complex :: c5 + complex :: c6 + c5 = (c5) ! { dg-warning "used uninitialized in this" } + c6 = c6 ! { dg-warning "used uninitialized in this" } +end subroutine p1 + +subroutine q1 + real :: r5 + real :: r6 + r5 = (r5) ! { dg-warning "used uninitialized in this" } + r6 = r6 ! { dg-warning "used uninitialized in this" } +end subroutine q1 diff --git a/gcc/testsuite/gfortran.dg/pr66725.f90 b/gcc/testsuite/gfortran.dg/pr66725.f90 new file mode 100644 index 0000000000..8ad97f7e18 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66725.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/66725 +! +program foo + + open(unit=1,access = 999) ! { dg-error "ACCESS requires" } + open(unit=1,action = 999) ! { dg-error "ACTION requires" } + open(unit=1,asynchronous = 999) ! { dg-error "ASYNCHRONOUS requires" } + open(unit=1,blank = 999) ! { dg-error "BLANK requires" } + open(unit=1,decimal = 999) ! { dg-error "DECIMAL requires" } + open(unit=1,delim = 999) ! { dg-error "DELIM requires" } + open(unit=1,encoding = 999) ! { dg-error "ENCODING requires" } + open(unit=1,form = 999) ! { dg-error "FORM requires" } + open(unit=1,pad = 999) ! { dg-error "PAD requires" } + open(unit=1,position = 999) ! { dg-error "POSITION requires" } + open(unit=1,round = 999) ! { dg-error "ROUND requires" } + open(unit=1,sign = 999) ! { dg-error "SIGN requires" } + open(unit=1,status = 999) ! { dg-error "STATUS requires" } + + close(unit=1, status=999) ! { dg-error "STATUS requires" } + + write (unit=1, asynchronous=257) ! { dg-error "ASYNCHRONOUS requires" } + write (unit=1, delim=257) ! { dg-error "DELIM requires" } + write (unit=1, decimal=257) ! { dg-error "DECIMAL requires" } + write (unit=1, round=257) ! { dg-error "ROUND requires" } + write (unit=1, sign=257) ! { dg-error "SIGN requires" } + + write (unit=1, blank=257) ! { dg-error "BLANK requires" } + write (unit=1, pad=257) ! { dg-error "PAD requires" } + +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr66864.f90 b/gcc/testsuite/gfortran.dg/pr66864.f90 new file mode 100644 index 0000000000..ebea99b389 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66864.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/66864 +! +program t + implicit none + real(8) x + x = 2.0d0**26.5d0 + if (floor(x) /= 94906265) call abort + if (floor(2.0d0**26.5d0)/= 94906265) call abort + x = 777666555.6d0 + if (floor(x) /= 777666555) call abort + if (floor(777666555.6d0) /= 777666555) call abort + x = 2000111222.6d0 + if (floor(x) /= 2000111222) call abort + if (floor(2000111222.6d0) /= 2000111222) call abort +end program t diff --git a/gcc/testsuite/gfortran.dg/pr66979.f90 b/gcc/testsuite/gfortran.dg/pr66979.f90 new file mode 100644 index 0000000000..c102e91e91 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr66979.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/66979 +program p + implicit none + integer::i + flush (iostat=i) ! { dg-error "UNIT number missing" } +end program p diff --git a/gcc/testsuite/gfortran.dg/pr67460.f90 b/gcc/testsuite/gfortran.dg/pr67460.f90 new file mode 100644 index 0000000000..ede55e1229 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67460.f90 @@ -0,0 +1,24 @@ +! Bogus "all warnings being treated as errors" +! { dg-do compile } +! { dg-options "-std=f2003 -Werror" } +MODULE btree_i8_k_sp2d_v + TYPE btree_node + INTEGER id + TYPE(btree_node_p), DIMENSION(:), POINTER :: subtrees + TYPE(btree_node), POINTER :: parent + END TYPE btree_node + TYPE btree_node_p + TYPE(btree_node), POINTER :: node + END TYPE btree_node_p +CONTAINS + RECURSIVE SUBROUTINE btree_verify_node (tree, node, level, nids, lastv,& + count, num_nodes, max_leaf_level, min_leaf_level, printing) + TYPE(btree_node), INTENT(IN) :: node + INTEGER :: branch + IF (ASSOCIATED (node%subtrees(branch)%node)) THEN + IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN + WRITE(*,*)'foo' + ENDIF + ENDIF + END SUBROUTINE btree_verify_node +END MODULE btree_i8_k_sp2d_v diff --git a/gcc/testsuite/gfortran.dg/pr67525.f90 b/gcc/testsuite/gfortran.dg/pr67525.f90 new file mode 100644 index 0000000000..35f716dc6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67525.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/67525 +! Code contributed by Gerhard Steinmetz +! +real function f(x) + select type (x) ! { dg-error "shall be polymorphic" } + end select +end function f + +real function g(x) + select type (x=>null()) ! { dg-error "shall be polymorphic" } + end select +end function g + +subroutine a(x) + select type (x) ! { dg-error "shall be polymorphic" } + end select +end subroutine a diff --git a/gcc/testsuite/gfortran.dg/pr67526.f90 b/gcc/testsuite/gfortran.dg/pr67526.f90 new file mode 100644 index 0000000000..3c0834f28d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67526.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Original code from gerhard dot steinmetz dot fortran at t-online dot de +! PR fortran/67526 +program p + character :: c1 = 'abc'(: ! { dg-error "error in SUBSTRING" } + character :: c2 = 'abc'(3: ! { dg-error "error in SUBSTRING" } + character :: c3 = 'abc'(:1 ! { dg-error "error in SUBSTRING" } + character :: c4 = 'abc'(2:2 ! { dg-error "error in SUBSTRING" } +end diff --git a/gcc/testsuite/gfortran.dg/pr67614.f90 b/gcc/testsuite/gfortran.dg/pr67614.f90 new file mode 100644 index 0000000000..ed07385970 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67614.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/67614 +! +program foo + implicit none + integer, pointer :: z + if (null(z)) 10, 20, 30 ! { dg-error "Invalid NULL" } +10 continue +20 continue +30 continue +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr67615.f90 b/gcc/testsuite/gfortran.dg/pr67615.f90 new file mode 100644 index 0000000000..fb95958007 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67615.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/67615 +! +program foo + + implicit none + + integer i(2), j + real x + complex z + + j = 2 + if (j) 10, 20, 30 + + x = -1 + if (x) 10, 20, 30 + + z = (1,2) + if (z) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + + i = [1, 2] + if (i) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + + if ( [1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + if ( [1, -1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + if ( [real :: 1, -1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + +10 stop +20 stop +30 stop + +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr67616.f90 b/gcc/testsuite/gfortran.dg/pr67616.f90 new file mode 100644 index 0000000000..3c2107d175 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67616.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/67616 +! Original code contributed by Gerhard Steinmetz +program p + type t + end type + type(t) :: y + data y /t()/ + block + type(t) :: x + data x /t()/ ! Prior to patch, this would ICE. + end block +end diff --git a/gcc/testsuite/gfortran.dg/pr67802.f90 b/gcc/testsuite/gfortran.dg/pr67802.f90 new file mode 100644 index 0000000000..2ccd8c5111 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67802.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/67802 +! Original code contribute by gerhard.steinmetz.fortran at t-online.de +program p + character(1.) :: c1 = ' ' ! { dg-error "INTEGER expression expected" } + character(1d1) :: c2 = ' ' ! { dg-error "INTEGER expression expected" } + character((0.,1.)) :: c3 = ' ' ! { dg-error "INTEGER expression expected" } + character(.true.) :: c4 = ' ' ! { dg-error "INTEGER expression expected" } +end program p diff --git a/gcc/testsuite/gfortran.dg/pr67803.f90 b/gcc/testsuite/gfortran.dg/pr67803.f90 new file mode 100644 index 0000000000..b9a0a9e5c7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67803.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/67803 +! Original code submitted by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de > +! +program p + character(2) :: x(1) + x = '0' // [character :: 1] ! { dg-error "Incompatiable typespec for" } + x = '0' // [character :: 1.] ! { dg-error "Incompatiable typespec for" } + x = '0' // [character :: 1d1] ! { dg-error "Incompatiable typespec for" } + x = '0' // [character :: (0.,1.)] ! { dg-error "Incompatiable typespec for" } + x = '0' // [character :: .true.] ! { dg-error "Incompatiable typespec for" } + x = '0' // [character :: null()] ! { dg-error "Incompatiable typespec for" } +end diff --git a/gcc/testsuite/gfortran.dg/pr67805.f90 b/gcc/testsuite/gfortran.dg/pr67805.f90 new file mode 100644 index 0000000000..7371991717 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67805.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! PR fortran/67805 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +subroutine p + integer, parameter :: n = 1 + integer, parameter :: m(3) = [1, 2, 3] + character(len=1) s(2) + s = [character((m(1))) :: 'x', 'y'] ! OK. + s = [character(m(1)) :: 'x', 'y'] ! OK. + s = [character(m) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + ! The next line should case an error, but causes an ICE. + s = [character(m(2:3)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + call foo(s) + s = [character('') :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(['']) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.true.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.false.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1d1]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([(0.,1.)]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([null()]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + call foo(s) +end subroutine p + +subroutine q + print *, '1: ', [character(.true.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '2: ', [character(.false.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '3: ', [character(1.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '4: ', [character(1d1) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '5: ', [character((0.,1.)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '6: ', [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }. +end subroutine q diff --git a/gcc/testsuite/gfortran.dg/pr67805_2.f90 b/gcc/testsuite/gfortran.dg/pr67805_2.f90 new file mode 100644 index 0000000000..4438d3e691 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67805_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/68108 +! Code contributed by Juergen Reuter (juergen.reuter at desy dot de) +! Test fix for regression caused by PR fortran/67805. +module lexers + implicit none + type :: template_t + character(256) :: charset1 + integer :: len1 + end type template_t + +contains + + subroutine match_quoted (tt, s, n) + type(template_t), intent(in) :: tt + character(*), intent(in) :: s + integer, intent(out) :: n + character(tt%len1) :: ch1 + ch1 = tt%charset1 + end subroutine match_quoted + +end module lexers diff --git a/gcc/testsuite/gfortran.dg/pr67885.f90 b/gcc/testsuite/gfortran.dg/pr67885.f90 new file mode 100644 index 0000000000..9b9adce490 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67885.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR fortran/67885 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +program p + block + integer, parameter :: a(2) = [1, 2] + integer :: x(2) + x = a + if (x(1) /= 1) call abort + end block +end diff --git a/gcc/testsuite/gfortran.dg/pr67900.f90 b/gcc/testsuite/gfortran.dg/pr67900.f90 new file mode 100644 index 0000000000..c077fbcfd8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67900.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/67900 +! Original code contributed by Giorgian Borca-Tasciuc +! giorgianb at gmail dot com +! +program main + implicit none + interface f + function f_real(x) + real, bind(c) :: x + real :: f_real + end function f_real + + function f_integer(x) + integer, bind(c) :: x + integer :: f_integer + end function f_integer + end interface f +end program main diff --git a/gcc/testsuite/gfortran.dg/pr67939.f90 b/gcc/testsuite/gfortran.dg/pr67939.f90 new file mode 100644 index 0000000000..d1694bb043 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67939.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/67939 +! Original code by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +program p + character(100) :: x + data x(998:99) /'ab'/ ! { dg-warning "Unused initialization string" } + call a +end + +subroutine a + character(2) :: x + data x(:-1) /'ab'/ ! { dg-warning "Unused initialization string" } +end subroutine a + +subroutine b + character(8) :: x + data x(3:1) /'abc'/ ! { dg-warning "Unused initialization string" } +end subroutine b + diff --git a/gcc/testsuite/gfortran.dg/pr67987.f90 b/gcc/testsuite/gfortran.dg/pr67987.f90 new file mode 100644 index 0000000000..1d57f9bda0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67987.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/67987 +! PR fortran/67988 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +subroutine p + character(-8) :: c = ' ' +end subroutine p + +subroutine pp + character(3), parameter :: c = 'abc' + character(3) :: x(1) + x = c(:-2) + print *, len(trim(x(1))) + x = [ c(:-2) ] + print *, len(trim(x(1))) +end subroutine pp + diff --git a/gcc/testsuite/gfortran.dg/pr68019.f90 b/gcc/testsuite/gfortran.dg/pr68019.f90 new file mode 100644 index 0000000000..2e304c3a26 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68019.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Original code from Gerhard Steinmetz +! Gerhard dot Steinmetz for fortran at t-online dot de +! PR fortran/68019 +! +program p + integer :: i + type t + integer :: n + end type + type(t), parameter :: vec(*) = [(t(i), i = 1, 4)] + type(t), parameter :: arr(*) = reshape(vec, [2, 2]) ! { dg-error "ranks 1 and 2 in assignment" } +end diff --git a/gcc/testsuite/gfortran.dg/pr68053.f90 b/gcc/testsuite/gfortran.dg/pr68053.f90 new file mode 100644 index 0000000000..e59693c5f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68053.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR fortran/68053 +! Original code contributed by Gerhard Steinmetz +! <gerhard dot steinmetx dot fortran at t-online dot de> +program p + integer, parameter :: n(3) = [1,2,3] + integer, parameter :: x(1) = 7 + integer, parameter :: z(n(2):*) = x + if (lbound(z,1) /= 2) call abort +end diff --git a/gcc/testsuite/gfortran.dg/pr68054.f90 b/gcc/testsuite/gfortran.dg/pr68054.f90 new file mode 100644 index 0000000000..c4b6a341f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68054.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/68054 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +!program p + real, protected :: x ! { dg-error "only allowed in specification" } +end diff --git a/gcc/testsuite/gfortran.dg/pr68055.f90 b/gcc/testsuite/gfortran.dg/pr68055.f90 new file mode 100644 index 0000000000..c84a6451d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68055.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/68055 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! + integer*3 c ! { dg-error "not supported at" } + real*9 x ! { dg-error "not supported at" } + logical*11 a ! { dg-error "not supported at" } + complex*42 z ! { dg-error "not supported at" } + c = 1 + x = 1 + call foo(a) +end diff --git a/gcc/testsuite/gfortran.dg/pr68151.f90 b/gcc/testsuite/gfortran.dg/pr68151.f90 new file mode 100644 index 0000000000..830d9f4f43 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68151.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/68151 +! Original code contribute by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de> +! +program p + integer :: k = 1 + select case (k) + case (:huge(1._4)) ! { dg-error "Expression in CASE" } + case (:huge(2._8)) ! { dg-error "Expression in CASE" } + case ((1.0,2.0)) ! { dg-error "Expression in CASE" } + end select +end diff --git a/gcc/testsuite/gfortran.dg/pr68153.f90 b/gcc/testsuite/gfortran.dg/pr68153.f90 new file mode 100644 index 0000000000..1a360f80cd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68153.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/68153 +! Original code contribute by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de> +! +program foo + integer, parameter :: a(2) = [2, -2] + integer, parameter :: b(2,2) = reshape([1, 2, 3, 4], a) ! { dg-error "cannot be negative" } +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr68154.f90 b/gcc/testsuite/gfortran.dg/pr68154.f90 new file mode 100644 index 0000000000..6415eb0b80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68154.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/68154 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +program p + character(1), parameter :: x1(2) = 'a' + character(*), parameter :: x2(2) = x1 + character(*), parameter :: x3(*) = x1 +end diff --git a/gcc/testsuite/gfortran.dg/pr68224.f90 b/gcc/testsuite/gfortran.dg/pr68224.f90 new file mode 100644 index 0000000000..a5962bb866 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68224.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/68224 +! Original code contribute by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de> +! +program p + integer, parameter :: a(null()) = [1, 2] ! { dg-error "scalar INTEGER expression" } + integer, parameter :: b(null():*) = [1, 2] ! { dg-error "scalar INTEGER expression" } + integer, parameter :: c(1:null()) = [1, 2] ! { dg-error "scalar INTEGER expression" } +end program p diff --git a/gcc/testsuite/gfortran.dg/pr68318_1.f90 b/gcc/testsuite/gfortran.dg/pr68318_1.f90 new file mode 100644 index 0000000000..1a3d59402f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68318_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O0" +! PR fortran/68318 +! Original code submitted by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de> +! +module m + implicit none +contains + subroutine s1 + entry e ! { dg-error "(2)" } + end + subroutine s2 + entry e ! { dg-error "is already defined" } + end +end module +! { dg-prune-output "Duplicate ENTRY attribute specified" } + diff --git a/gcc/testsuite/gfortran.dg/pr68318_2.f90 b/gcc/testsuite/gfortran.dg/pr68318_2.f90 new file mode 100644 index 0000000000..451b28f2a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68318_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/68318 +! Original code submitted by Gerhard Steinmetz +! <gerhard dot steinmetz dot fortran at t-online dot de> +! +module m1 + implicit none +contains + subroutine s1 + entry e + end +end module + +module m2 + use m1 ! { dg-error "(2)" } + implicit none +contains + subroutine s2 + entry e ! { dg-error "is already defined" } + end +end module +! { dg-prune-output "Cannot change attribute" } diff --git a/gcc/testsuite/gfortran.dg/pr68319.f90 b/gcc/testsuite/gfortran.dg/pr68319.f90 new file mode 100644 index 0000000000..941316d71e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr68319.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/68319 +! +subroutine foo + + interface + + real function bar(i) + f(i) = 2 * i ! { dg-error "cannot appear within" } + end function bar + + real function bah(j) + entry boo(j) ! { dg-error "cannot appear within" } + end function bah + + real function fu(j) + data i /1/ ! { dg-error "cannot appear within" } + end function fu + + real function fee(j) +10 format('(A)') ! { dg-error "cannot appear within" } + end function fee + + end interface + +end subroutine foo diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 new file mode 100644 index 0000000000..43084f67e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_47.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR68196 +! +! Contributed by Damian Rouson <damian@sourceryinstitute.org> +! + type AA + integer :: i + procedure(foo), pointer :: funct + end type + class(AA), allocatable :: my_AA + type(AA) :: res + + allocate (my_AA, source = AA (1, foo)) + + res = my_AA%funct () + + if (res%i .ne. 3) call abort + if (.not.associated (res%funct)) call abort + if (my_AA%i .ne. 4) call abort + if (associated (my_AA%funct)) call abort + +contains + function foo(A) + class(AA), allocatable :: A + type(AA) foo + + if (.not.allocated (A)) then + allocate (A, source = AA (2, foo)) + endif + + select type (A) + type is (AA) + foo = AA (3, foo) + A = AA (4, NULL ()) + end select + end function +end diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_13.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_13.f03 new file mode 100644 index 0000000000..c74e325ce8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_13.f03 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Contributed by Melven Roehrig-Zoellner <Melven.Roehrig-Zoellner@DLR.de> +! PR fortran/66035 + +program test_pr66035 + type t + end type t + type w + class(t), allocatable :: c + end type w + + type(t) :: o + + call test(o) +contains + subroutine test(o) + class(t), intent(inout) :: o + type(w), dimension(:), allocatable :: list + + select type (o) + class is (t) + list = [w(o)] ! This caused an ICE + class default + call abort() + end select + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 index 5eea79dec7..13d7f8e466 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03 @@ -48,7 +48,7 @@ contains call foo (y)
y => tgt ! This is OK, of course.
- tgt => y ! { dg-error "must be unlimited polymorphic" }
+ tgt => y ! { dg-error "Data-pointer-object at .1. must be unlimited polymorphic" }
select type (y) ! This is the correct way to accomplish the previous
type is (integer)
diff --git a/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 index 5654d97688..ef2c679e08 100644 --- a/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 +++ b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 @@ -17,14 +17,14 @@ CONTAINS test1 = "foobar" END FUNCTION test1 - CHARACTER(len=x) FUNCTION test2 (x) ! { dg-bogus "used before|of INTEGER" } + CHARACTER(len=x) FUNCTION test2 (x) ! { dg-error "of INTEGER" } IMPLICIT INTEGER(a-z) test2 = "foobar" END FUNCTION test2 END MODULE testmod -CHARACTER(len=i) FUNCTION test3 (i) ! { dg-bogus "used before|of INTEGER" } +CHARACTER(len=i) FUNCTION test3 (i) ! i is IMPLICIT INTEGER by default test3 = "foobar" END FUNCTION test3 |