diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
| -rw-r--r-- | gcc/testsuite/gfortran.dg/bind_c_dts_5.f90 | 54 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_optimize_7.f90 | 3 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/inline_product_1.f90 | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/inline_sum_1.f90 | 194 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/inline_sum_2.f90 | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/inline_sum_bounds_check_1.f90 | 22 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/inline_sum_bounds_check_2.f90 | 23 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/module_parameter_array_refs_2.f90 | 23 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/open_dev_null.f90 | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pr50769.f90 | 30 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/quad_2.f90 | 63 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_call_21.f03 | 39 |
12 files changed, 494 insertions, 10 deletions
diff --git a/gcc/testsuite/gfortran.dg/bind_c_dts_5.f90 b/gcc/testsuite/gfortran.dg/bind_c_dts_5.f90 new file mode 100644 index 00000000000..497c0501b11 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_dts_5.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! +! PR fortran/50933 +! +! Check whether type-compatibility checks for BIND(C) work. +! +! Contributed by Richard Maine +! + +MODULE liter_cb_mod +USE ISO_C_BINDING +CONTAINS + FUNCTION liter_cb(link_info) bind(C) + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER(c_int) liter_cb + + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + + TYPE(info_t) :: link_info + + liter_cb = 0 + + END FUNCTION liter_cb + +END MODULE liter_cb_mod + +PROGRAM main + USE ISO_C_BINDING + interface + FUNCTION liter_cb(link_info) bind(C) + USE ISO_C_BINDING + IMPLICIT NONE + INTEGER(c_int) liter_cb + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + TYPE(info_t) :: link_info + END FUNCTION liter_cb + end interface + + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + type(info_t) :: link_info + + write (*,*) liter_cb(link_info) + +END PROGRAM main + +! { dg-final { cleanup-modules "liter_cb_mod" } } diff --git a/gcc/testsuite/gfortran.dg/function_optimize_7.f90 b/gcc/testsuite/gfortran.dg/function_optimize_7.f90 index 212c8fbd491..e0c404b6a2a 100644 --- a/gcc/testsuite/gfortran.dg/function_optimize_7.f90 +++ b/gcc/testsuite/gfortran.dg/function_optimize_7.f90 @@ -12,6 +12,7 @@ subroutine xx(n, m, a, b, c, d, x, z, i, s_in, s_out) real, intent(out) :: z character(60) :: line real, external :: ext_func + integer :: one = 1 interface elemental function element(x) real, intent(in) :: x @@ -33,7 +34,7 @@ subroutine xx(n, m, a, b, c, d, x, z, i, s_in, s_out) z = element(x) + element(x) i = mypure(x) - mypure(x) z = elem_impure(x) - elem_impure(x) - s_out = sum(s_in,1) + 3.14 / sum(s_in,1) ! { dg-warning "Creating array temporary" } + s_out = sum(s_in,one) + 3.14 / sum(s_in,one) ! { dg-warning "Creating array temporary" } end subroutine xx ! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/inline_product_1.f90 b/gcc/testsuite/gfortran.dg/inline_product_1.f90 new file mode 100644 index 00000000000..72c096bff4a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_product_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -O -fdump-tree-original" } +! +! PR fortran/43829 +! Scalarization of reductions. +! Test that product is properly inlined. + +! For more extended tests, see inline_sum_1.f90 + + implicit none + + + integer :: i + + integer, parameter :: q = 2 + integer, parameter :: nx=3, ny=2*q, nz=5 + integer, parameter, dimension(nx,ny,nz) :: p = & + & reshape ((/ (i, i=1,size(p)) /), shape(p)) + + + integer, dimension(nx,ny,nz) :: a + integer, dimension(nx, nz) :: ay + + a = p + + ay = product(a,2) + +end +! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 0 "original" } } +! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 0 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_product_" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/inline_sum_1.f90 b/gcc/testsuite/gfortran.dg/inline_sum_1.f90 new file mode 100644 index 00000000000..4538e5e117f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_sum_1.f90 @@ -0,0 +1,194 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -O -fdump-tree-original" } +! +! PR fortran/43829 +! Scalarization of reductions. +! Test that sum is properly inlined. + +! This is the compile time test only; for the runtime test see inline_sum_2.f90 +! We can't test for temporaries on the run time test directly, as it tries +! several optimization options among which -Os, and sum inlining is disabled +! at -Os. + + + implicit none + + + integer :: i, j, k + + integer, parameter :: q = 2 + integer, parameter :: nx=3, ny=2*q, nz=5 + integer, parameter, dimension(nx,ny,nz) :: p = & + & reshape ((/ (i**2, i=1,size(p)) /), shape(p)) + + integer, parameter, dimension( ny,nz) :: px = & + & reshape ((/ (( & + & nx*( nx*j+nx*ny*k+1)*( nx*j+nx*ny*k+1+ (nx-1)) & + & + nx*(nx-1)*(2*nx-1)/6, & + & j=0,ny-1), k=0,nz-1) /), shape(px)) + + integer, parameter, dimension(nx, nz) :: py = & + & reshape ((/ (( & + & ny*(i +nx*ny*k+1)*(i +nx*ny*k+1+nx *(ny-1)) & + & +(nx )**2*ny*(ny-1)*(2*ny-1)/6, & + & i=0,nx-1), k=0,nz-1) /), shape(py)) + + integer, parameter, dimension(nx,ny ) :: pz = & + & reshape ((/ (( & + & nz*(i+nx*j +1)*(i+nx*j +1+nx*ny*(nz-1)) & + & +(nx*ny)**2*nz*(nz-1)*(2*nz-1)/6, & + & i=0,nx-1), j=0,ny-1) /), shape(pz)) + + + integer, dimension(nx,ny,nz) :: a + integer, dimension( ny,nz) :: ax + integer, dimension(nx, nz) :: ay + integer, dimension(nx,ny ) :: az + + logical, dimension(nx,ny,nz) :: m, true + + + integer, dimension(nx,ny) :: b + + integer, dimension(nx,nx) :: onesx + integer, dimension(ny,ny) :: onesy + integer, dimension(nz,nz) :: onesz + + + a = p + m = reshape((/ ((/ .true., .false. /), i=1,size(m)/2) /), shape(m)) + true = reshape((/ (.true., i=1,size(true)) /), shape(true)) + + onesx = reshape((/ ((1, j=1,i),(0,j=1,nx-i),i=1,size(onesx,2)) /), shape(onesx)) + onesy = reshape((/ ((1, j=1,i),(0,j=1,ny-i),i=1,size(onesy,2)) /), shape(onesy)) + onesz = reshape((/ ((1, j=1,i),(0,j=1,nz-i),i=1,size(onesz,2)) /), shape(onesz)) + + ! Correct results in simple cases + ax = sum(a,1) + if (any(ax /= px)) call abort + + ay = sum(a,2) + if (any(ay /= py)) call abort + + az = sum(a,3) + if (any(az /= pz)) call abort + + + ! Masks work + if (any(sum(a,1,.false.) /= 0)) call abort + if (any(sum(a,2,.true.) /= py)) call abort + if (any(sum(a,3,m) /= merge(pz,0,m(:,:,1)))) call abort + if (any(sum(a,2,m) /= merge(sum(a(:, ::2,:),2),& + sum(a(:,2::2,:),2),& + m(:,1,:)))) call abort + + + ! It works too with array constructors ... + if (any(sum( & + reshape((/ (i*i,i=1,size(a)) /), shape(a)), & + 1, & + true) /= ax)) call abort + + ! ... and with vector subscripts + if (any(sum( & + a((/ (i,i=1,nx) /), & + (/ (i,i=1,ny) /), & + (/ (i,i=1,nz) /)), & + 1) /= ax)) call abort + + if (any(sum( & + a(sum(onesx(:,:),1), & ! unnecessary { dg-warning "Creating array temporary" } + sum(onesy(:,:),1), & ! unnecessary { dg-warning "Creating array temporary" } + sum(onesz(:,:),1)), & ! unnecessary { dg-warning "Creating array temporary" } + 1) /= ax)) call abort + + + ! Nested sums work + if (sum(sum(sum(a,1),1),1) /= sum(a)) call abort + if (sum(sum(sum(a,1),2),1) /= sum(a)) call abort + if (sum(sum(sum(a,3),1),1) /= sum(a)) call abort + if (sum(sum(sum(a,3),2),1) /= sum(a)) call abort + + if (any(sum(sum(a,1),1) /= sum(sum(a,2),1))) call abort + if (any(sum(sum(a,1),2) /= sum(sum(a,3),1))) call abort + if (any(sum(sum(a,2),2) /= sum(sum(a,3),2))) call abort + + + ! Temps are unavoidable here (function call's argument or result) + ax = sum(neid3(a),1) ! { dg-warning "Creating array temporary" } + ! Sums as part of a bigger expr work + if (any(1+sum(eid(a),1)+ax+sum( & + neid3(a), & ! { dg-warning "Creating array temporary" } + 1)+1 /= 3*ax+2)) call abort + if (any(1+eid(sum(a,2))+ay+ & + neid2( & ! { dg-warning "Creating array temporary" } + sum(a,2) & ! { dg-warning "Creating array temporary" } + )+1 /= 3*ay+2)) call abort + if (any(sum(eid(sum(a,3))+az+2* & + neid2(az) & ! { dg-warning "Creating array temporary" } + ,1)+1 /= 4*sum(az,1)+1)) call abort + + if (any(sum(transpose(sum(a,1)),1)+sum(az,1) /= sum(ax,2)+sum(sum(a,3),1))) call abort + + + ! Creates a temp when needed. + a(1,:,:) = sum(a,1) ! unnecessary { dg-warning "Creating array temporary" } + if (any(a(1,:,:) /= ax)) call abort + + b = p(:,:,1) + call set(b(2:,1), sum(b(:nx-1,:),2)) ! { dg-warning "Creating array temporary" } + if (any(b(2:,1) /= ay(1:nx-1,1))) call abort + + b = p(:,:,1) + call set(b(:,1), sum(b,2)) ! unnecessary { dg-warning "Creating array temporary" } + if (any(b(:,1) /= ay(:,1))) call abort + + b = p(:,:,1) + call tes(sum(eid(b(:nx-1,:)),2), b(2:,1)) ! { dg-warning "Creating array temporary" } + if (any(b(2:,1) /= ay(1:nx-1,1))) call abort + + b = p(:,:,1) + call tes(eid(sum(b,2)), b(:,1)) ! unnecessary { dg-warning "Creating array temporary" } + if (any(b(:,1) /= ay(:,1))) call abort + +contains + + elemental function eid (x) + integer, intent(in) :: x + integer :: eid + + eid = x + end function eid + + function neid2 (x) + integer, intent(in) :: x(:,:) + integer :: neid2(size(x,1),size(x,2)) + + neid2 = x + end function neid2 + + function neid3 (x) + integer, intent(in) :: x(:,:,:) + integer :: neid3(size(x,1),size(x,2),size(x,3)) + + neid3 = x + end function neid3 + + elemental subroutine set (o, i) + integer, intent(in) :: i + integer, intent(out) :: o + + o = i + end subroutine set + + elemental subroutine tes (i, o) + integer, intent(in) :: i + integer, intent(out) :: o + + o = i + end subroutine tes +end +! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 13 "original" } } +! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 13 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_sum_" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/inline_sum_2.f90 b/gcc/testsuite/gfortran.dg/inline_sum_2.f90 new file mode 100644 index 00000000000..0b7c60ad9e9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_sum_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + +! PR fortran/43829 +! Scalarization of reductions. +! Test that inlined sum is correct. + +! We can't check for the absence of temporary arrays generated on the run-time +! testcase, as inlining is disabled at -Os, so it will fail in that case. +! Thus, the test is splitted into two independant files, one checking for +! the absence of temporaries, and one (this one) checking that the code +! generated remains valid at all optimization levels. +include 'inline_sum_1.f90' diff --git a/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_1.f90 b/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_1.f90 new file mode 100644 index 00000000000..39984683d4b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + + integer, parameter :: nx = 3, ny = 4 + + integer :: i, j, too_big + + integer, parameter, dimension(nx,ny) :: p = & + reshape((/ (i*i, i=1,size(p)) /), shape(p)) + + integer, dimension(nx,ny) :: a + + integer, dimension(:), allocatable :: b + + allocate(b(nx)) + + a = p + too_big = ny + 1 + + b = sum(a(:,1:too_big),2) + end +! { dg-shouldfail "outside of expected range" } diff --git a/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_2.f90 b/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_2.f90 new file mode 100644 index 00000000000..8de80fdc9f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inline_sum_bounds_check_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + + integer, parameter :: nx = 3, ny = 4 + + integer :: i, j, too_big + + integer, parameter, dimension(nx,ny) :: p = & + reshape((/ (i*i, i=1,size(p)) /), shape(p)) + + integer, dimension(nx,ny) :: a + + integer, dimension(:), allocatable :: c + + + allocate(c(ny)) + + a = p + too_big = nx + 1 + + c = sum(a(1:too_big,:),2) + end +! { dg-shouldfail "outside of expected range" } diff --git a/gcc/testsuite/gfortran.dg/module_parameter_array_refs_2.f90 b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_2.f90 new file mode 100644 index 00000000000..385761d1d17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O" } +! { dg-final { scan-assembler-not "i_am_optimized_away" } } +! +! PR fortran/50960 +! +! PARAMETER arrays and derived types exists as static variables. +! Check that the their read-only nature is taken into account +! when optimizations are done. +! + +module m + integer, parameter :: PARA(*) = [1,2,3,4,5,6,7,8,9,10] +end module m + +subroutine test() +use m +integer :: i +i = 1 +if (para(i) /= 1) call i_am_optimized_away() +end + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/open_dev_null.f90 b/gcc/testsuite/gfortran.dg/open_dev_null.f90 deleted file mode 100644 index 00394cb55a6..00000000000 --- a/gcc/testsuite/gfortran.dg/open_dev_null.f90 +++ /dev/null @@ -1,9 +0,0 @@ -! { dg-do run } -! PR45723 opening /dev/null for appending writes fails -logical :: thefile -inquire(file="/dev/null",exist=thefile) -if (thefile) then - open(unit=7,file="/dev/null",position="append") - close(7) -endif -end diff --git a/gcc/testsuite/gfortran.dg/pr50769.f90 b/gcc/testsuite/gfortran.dg/pr50769.f90 new file mode 100644 index 00000000000..3a98543e3a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr50769.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-tail-merge -fno-delete-null-pointer-checks -fno-guess-branch-probability" } +! +! based on testsuite/gfortran.dg/alloc_comp_optional_1.f90, +! which was contributed by David Kinniburgh <davidkinniburgh@yahoo.co.uk> +! +program test_iso + type ivs + character(LEN=1), dimension(:), allocatable :: chars + end type ivs + type(ivs) :: v_str + integer :: i + call foo(v_str, i) + if (v_str%chars(1) .ne. "a") call abort + if (i .ne. 0) call abort + call foo(flag = i) + if (i .ne. 1) call abort +contains + subroutine foo (arg, flag) + type(ivs), optional, intent(out) :: arg + integer :: flag + if (present(arg)) then + arg = ivs([(char(i+96), i = 1,10)]) + flag = 0 + else + flag = 1 + end if + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/quad_2.f90 b/gcc/testsuite/gfortran.dg/quad_2.f90 new file mode 100644 index 00000000000..c1334db9cd4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/quad_2.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! This test checks whether the largest possible +! floating-point number works. +! +! This is a run-time check. Depending on the architecture, +! this tests REAL(8), REAL(10) or REAL(16) and REAL(16) +! might be a hardware or libquadmath 128bit number. +! +program test_qp + use iso_fortran_env, only: real_kinds + implicit none + integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1)) + real(qp) :: fp1, fp2, fp3, fp4 + character(len=80) :: str1, str2, str3, str4 + fp1 = 1 + fp2 = sqrt (2.0_qp) + write (str1,*) fp1 + write (str2,'(g0)') fp1 + write (str3,*) fp2 + write (str4,'(g0)') fp2 + +! print '(3a)', '>',trim(str1),'<' +! print '(3a)', '>',trim(str2),'<' +! print '(3a)', '>',trim(str3),'<' +! print '(3a)', '>',trim(str4),'<' + + read (str1, *) fp3 + if (fp1 /= fp3) call abort() + read (str2, *) fp3 + if (fp1 /= fp3) call abort() + read (str3, *) fp4 + if (fp2 /= fp4) call abort() + read (str4, *) fp4 + if (fp2 /= fp4) call abort() + + select case (qp) + case (8) + if (str1 /= " 1.0000000000000000") call abort() + if (str2 /= "1.0000000000000000") call abort() + if (str3 /= " 1.4142135623730951") call abort() + if (str4 /= "1.4142135623730951") call abort() + case (10) + if (str1 /= " 1.00000000000000000000") call abort() + if (str2 /= "1.00000000000000000000") call abort() + if (str3 /= " 1.41421356237309504876") call abort() + if (str4 /= "1.41421356237309504876") call abort() + case (16) + if (str1 /= " 1.00000000000000000000000000000000000") call abort() + if (str2 /= "1.00000000000000000000000000000000000") call abort() + if (str3 /= " 1.41421356237309504880168872420969798") call abort() + if (str4 /= "1.41421356237309504880168872420969798") call abort() + block + real(qp), volatile :: fp2a + fp2a = 2.0_qp + fp2a = sqrt (fp2a) + if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) call abort() + end block + case default + call abort() + end select + +end program test_qp diff --git a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 new file mode 100644 index 00000000000..5f7d67283c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 50919: [OOP] Don't use vtable for NON_OVERRIDABLE TBP +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + +module m + +type t +contains + procedure, nopass, NON_OVERRIDABLE :: testsub + procedure, nopass, NON_OVERRIDABLE :: testfun +end type t + +contains + + subroutine testsub() + print *, "t's test" + end subroutine + + integer function testfun() + testfun = 1 + end function + +end module m + + + use m + class(t), allocatable :: x + allocate(x) + call x%testsub() + print *,x%testfun() +end + +! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } } + +! { dg-final { cleanup-modules "m" } } +! { dg-final { cleanup-tree-dump "original" } } |