diff options
Diffstat (limited to 'gcc/testsuite/gfortran.fortran-torture/execute')
138 files changed, 4496 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 new file mode 100644 index 00000000000..55a6f3cdf2c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 @@ -0,0 +1,17 @@ +! pr 15113 +! Ax edit descriptor x larger than destination +! A edit descriptor with no field width segfaults + character*16 C + character*4 D + data C / 'ABCDEFGHIJKLMNOP'/ + read(C,'(A7)')D + if (D.NE.'DEFG') then +! print*,D + call abort + endif + read(C,'(A)')D + if (D.NE.'ABCD') then +! print*,D + call abort + endif + end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 new file mode 100644 index 00000000000..61f717da7bc --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 @@ -0,0 +1,38 @@ +! Test allocation and deallocation. +program test_allocate + call t1 (.true.) + call t1 (.false.) + call t2 +contains + +! Implicit deallocation and saved aloocated variables. +subroutine t1(first) + real, allocatable, save :: p(:) + real, allocatable :: q(:) + logical first + + if (first) then + if (allocated (p)) call abort () + else + if (.not. allocated (p)) call abort () + end if + if (allocated (q)) call abort () + + if (first) then + allocate (p(5)) + else + deallocate (p) + end if + allocate (q(5)) +end subroutine + +! Explicit deallocation. +subroutine t2() + real, allocatable :: r(:) + + allocate (r(5)) + pr = 1.0 + deallocate (r) + if (allocated(r)) call abort () +end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 new file mode 100644 index 00000000000..5c77844e6da --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 @@ -0,0 +1,18 @@ +program alt_return + implicit none + + call myproc (1, *10, 42) +20 continue + call abort () +10 continue + call myproc(2, *20, 42) + call myproc(3, *20, 42) +contains +subroutine myproc(n, *, i) + integer n, i + if (i .ne. 42) call abort () + if (n .eq. 1) return 1 + if (n .eq. 2) return +end subroutine +end program alt_return + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 new file mode 100644 index 00000000000..263c795ed70 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 @@ -0,0 +1,22 @@ +! Program to test procudure args +subroutine test (a, b) + integer, intent (IN) :: a + integer, intent (OUT) :: b + + if (a .ne. 42) call abort + b = 43 +end subroutine + +program args + implicit none + external test + integer i, j + + i = 42 + j = 0 + CALL test (i, j) + if (i .ne. 42) call abort + if (j .ne. 43) call abort + i = 41 + CALL test (i + 1, j) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 new file mode 100644 index 00000000000..d06167e6814 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 @@ -0,0 +1,25 @@ +! Program to test the arithmetic if statement +function testif (a) + implicit none + integer a, b, testif + + if (a) 1, 2, 3 + b = 2 + goto 4 + 1 b = -1 + goto 4 + 2 b = 0 + goto 4 + 3 b = 1 + 4 testif = b +end function + +program testwrite + implicit none + integer i + integer testif + + if (testif (-10) .ne. -1) call abort + if (testif (0) .ne. 0) call abort + if (testif (10) .ne. 1) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 new file mode 100644 index 00000000000..b588d050b69 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 @@ -0,0 +1,145 @@ +! Program to test arrays +! The program outputs a series of numbers. +! Two digit numbers beginning with 0, 1, 2 or 3 is a normal. +! Three digit numbers starting with 4 indicate an error. +! Using 1D arrays isn't a sufficient test, the first dimension is often +! handled specially. + +! Fixed size parameter +subroutine f1 (a) + implicit none + integer, dimension (5, 8) :: a + + if (a(1, 1) .ne. 42) call abort + + if (a(5, 8) .ne. 43) call abort +end subroutine + + +program testprog + implicit none + integer, dimension(3:7, 4:11) :: a + a(:,:) = 0 + a(3, 4) = 42 + a(7, 11) = 43 + call test(a) +contains +subroutine test (parm) + implicit none + ! parameter + integer, dimension(2:, 3:) :: parm + ! Known size arry + integer, dimension(5, 8) :: a + ! Known size array with different bounds + integer, dimension(4:8, 3:10) :: b + ! Unknown size arrays + integer, dimension(:, :), allocatable :: c, d, e + ! Vectors + integer, dimension(5) :: v1 + integer, dimension(10, 10) :: v2 + integer n + external f1 + + ! Same size + allocate (c(5,8)) + ! Same size, different bounds + allocate (d(11:15, 12:19)) + ! A larger array + allocate (e(15, 24)) + a(:,:) = 0 + b(:,:) = 0 + c(:,:) = 0 + d(:,:) = 0 + a(1,1) = 42 + b(4, 3) = 42 + c(1,1) = 42 + d(11,12) = 42 + a(5, 8) = 43 + b(8, 10) = 43 + c(5, 8) = 43 + d(15, 19) = 43 + + v2(:, :) = 0 + do n=1,5 + v1(n) = n + end do + + v2 (3, 1::2) = v1 (5:1:-1) + v1 = v1 + 1 + + if (v1(1) .ne. 2) call abort + if (v2(3, 3) .ne. 4) call abort + + ! Passing whole arrays + call f1 (a) + call f1 (b) + call f1 (c) + call f2 (a) + call f2 (b) + call f2 (c) + ! passing expressions + a(1,1) = 41 + a(5,8) = 42 + call f1(a+1) + call f2(a+1) + a(1,1) = 42 + a(5,8) = 43 + call f1 ((a + b) / 2) + call f2 ((a + b) / 2) + ! Passing whole arrays as sections + call f1 (a(:,:)) + call f1 (b(:,:)) + call f1 (c(:,:)) + call f2 (a(:,:)) + call f2 (b(:,:)) + call f2 (c(:,:)) + ! Passing sections + e(:,:) = 0 + e(2, 3) = 42 + e(6, 10) = 43 + n = 3 + call f1 (e(2:6, n:10)) + call f2 (e(2:6, n:10)) + ! Vector subscripts + ! v1= index plus one, v2(3, ::2) = reverse of index + e(:,:) = 0 + e(2, 3) = 42 + e(6, 10) = 43 + call f1 (e(v1, n:10)) + call f2 (e(v1, n:10)) + ! Double vector subscript + e(:,:) = 0 + e(6, 3) = 42 + e(2, 10) = 43 + !These are not resolved properly + call f1 (e(v1(v2(3, ::2)), n:10)) + call f2 (e(v1(v2(3, ::2)), n:10)) + ! non-contiguous sections + e(:,:) = 0 + e(1, 1) = 42 + e(13, 22) = 43 + n = 3 + call f1 (e(1:15:3, 1:24:3)) + call f2 (e(::3, ::n)) + ! non-contiguous sections with bounds + e(:,:) = 0 + e(3, 4) = 42 + e(11, 18) = 43 + n = 19 + call f1 (e(3:11:2, 4:n:2)) + call f2 (e(3:11:2, 4:n:2)) + + ! Passing a dummy variable + call f1 (parm) + call f2 (parm) +end subroutine +! Assumed shape parameter +subroutine f2 (a) + integer, dimension (1:, 1:) :: a + + if (a(1, 1) .ne. 42) call abort + + if (a(5, 8) .ne. 43) call abort +end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 new file mode 100644 index 00000000000..9cb5b613d64 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 @@ -0,0 +1,21 @@ +! Program to test array arguments which depend on other array arguments +program arrayarg2 + integer, dimension(5) :: a, b + + a = (/1, 2, 3, 4, 5/) + b = (/2, 3, 4, 5, 6/) + + call test (a, b) + + if (any (b .ne. (/4, 7, 10, 13, 16/))) call abort +contains +subroutine test (x1, x2) + implicit none + integer, dimension(1:), intent(in) :: x1 + integer, dimension(1:), intent(inout) :: x2 + integer, dimension(1:size(x1)) :: x3 + + x3 = x1 * 2 + x2 = x2 + x3 +end subroutine test +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 new file mode 100644 index 00000000000..94b234bd512 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 @@ -0,0 +1,24 @@ +! Program to test arrays with the save attribute +program testarray + implicit none + integer, save, dimension (6, 5) :: a, b + + a = 0 + a(1, 1) = 42 + a(6, 5) = 43 + b(:,1:5) = a + + call fn (a) +contains +subroutine fn (a) + implicit none + integer, dimension(1:, 1:) :: a + integer, dimension(2) :: b + + b = ubound (a) + if (any (b .ne. (/6, 5/))) call abort + if (a(1, 1) .ne. 42) call abort + if (a(6, 5) .ne. 43) call abort +end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 new file mode 100644 index 00000000000..b2c4657c647 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 @@ -0,0 +1,39 @@ +! Program to test assumed size arrays +subroutine test2(p) + integer, dimension(2, *) :: p + + if (any (p(:, 1:3) .ne. reshape((/1, 2, 4, 5, 7, 8/), (/2, 3/)))) & + call abort () +end subroutine + +program assumed_size + integer, dimension (3, 3) :: a + external test2 + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + + call test1(a, (/1, 2, 3, 4, 5, 6/)) + if (a(1,1) .ne. 0) call abort + a(1, 1) = 1 + call test1(a(1:2, :), (/1, 2, 4, 5, 7, 8/)) + if (a(1,1) .ne. 0) call abort + a(1, 1) = 1 + call test1(a(3:1:-1, :), (/3, 2, 1, 6, 5, 4/)) + if (a(3,1) .ne. 0) call abort + a(3, 1) = 3 + call test1(a(:, 2:3), (/4, 5, 6, 7, 8, 9/)) + if (a(1, 2) .ne. 0) call abort + a(1, 2) = 4 + + call test2(a(1:2, :)) + call test2((/1, 2, 4, 5, 7, 8/)) +contains +subroutine test1(p, q) + integer, dimension(*) :: p + integer, dimension(1:) :: q + + if (any (p(1:size(q)) .ne. q)) call abort () + p(1) = 0 +end subroutine + +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 new file mode 100644 index 00000000000..b1ad840738c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 @@ -0,0 +1,35 @@ +! Program to test the upper and lower bound intrinsics +program testbounds + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(5) :: j + integer i + + allocate (a(3:8, 6:7)) + + ! With one parameter + j = 0; + j(3:4) = ubound(a) + if (j(3) .ne. 8) call abort + if (j(4) .ne. 7) call abort + + ! With two parameters, assigning to an array + j = lbound(a, 1) + if ((j(1) .ne. 3) .or. (j(5) .ne. 3)) call abort + + ! With a variable second parameter + i = 2 + i = lbound(a, i) + if (i .ne. 6) call abort + + call test(a) +contains +subroutine test (a) + real, dimension (1:, 1:) :: a + integer i + + i = 2 + if ((ubound(a, 1) .ne. 6) .or. (ubound(a, i) .ne. 2)) call abort +end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 new file mode 100644 index 00000000000..c42cea4fc21 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 @@ -0,0 +1,12 @@ +CHARACTER(LEN=6) :: C = "STEVEN" + +SELECT CASE (C) + CASE ("AAA":"EEE") + CALL abort + CASE ("R":"T") + CONTINUE + CASE DEFAULT + CALL abort +END SELECT +END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 new file mode 100644 index 00000000000..8e434c03342 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 @@ -0,0 +1,45 @@ +! Test complex munbers +program testcmplx + implicit none + complex(kind=4) c, d + complex(kind=8) z + real(kind=4) x, y + real(kind=8) q + + ! cmplx intrinsic + x = 3 + y = 4 + c = cmplx(x,y) + if (c .ne. (3.0, 4.0)) call abort + x = 4 + y = 3 + z = cmplx(x, y, 8) + if (z .ne. (4.0, 3.0)) call abort + z = c + if (z .ne. (3.0, 4.0)) call abort + + ! dcmplx intrinsic + x = 3 + y = 4 + z = dcmplx (x, y) + if (z .ne. (3.0, 4.0)) call abort + + ! conjucates and aimag + c = (1.0, 2.0) + c = conjg (c) + x = aimag (c) + if (abs (c - (1.0, -2.0)) .gt. 0.001) call abort + if (x .ne. -2.0) call abort + z = (2.0, 1.0) + z = conjg (z) + q = aimag (z) + if (z .ne. (2.0, -1.0)) call abort + if (q .ne. -1.0) call abort + + ! addition, subtraction and multiplication + c = (1, 3) + d = (5, 2) + if (c + d .ne. ( 6, 5)) call abort + if (c - d .ne. (-4, 1)) call abort + if (c * d .ne. (-1, 17)) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 new file mode 100644 index 00000000000..2ea1788eb54 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 @@ -0,0 +1,53 @@ +! Program to test COMMON and EQUIVALENCE. +program common + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + b = 100 + c = 200 + call common_pass + call common_par (a, b,c) + call global_equiv + call local_equiv +end + +! Use common block to pass values +subroutine common_pass + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort +end subroutine + +! Common variables as argument +subroutine common_par (a, b, c) + real (kind=8) a(8), b(5), c(5) + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort + if (any (b .ne. (/100,100,100,100,100/))) call abort + if (any (c .ne. (/200,200,200,200,200/))) call abort +end subroutine + +! Global equivalence +subroutine global_equiv + real (kind=8) a(8), b(5), c(5), x(8), y(4), z(4) + common /com2/b, c, y, z + equivalence (a(1), b(2)) + equivalence (x(4), y(1)) + b = 100 + c = 200 + y = 300 + z = 400 + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort + if (any (x .ne. (/200,200,200,300,300,300,300,400/))) call abort +end + +! Local equivalence +subroutine local_equiv + real (kind=8) a(8), b(10) + equivalence (a(1), b(3)) + b(1:5) = 100 + b(6:10) = 200 + if (any (a .ne. (/100,100,100,200,200,200,200,200/))) call abort +end subroutine diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 new file mode 100644 index 00000000000..936c41e3282 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 @@ -0,0 +1,10 @@ +! The size of common 'com1' should be 80, instead of 112. +program common_size + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + b = 100 + c = 200 + if ((a (4) .ne. 100) .or. (a(5) .ne. 200)) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 new file mode 100644 index 00000000000..96cb89d721c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 @@ -0,0 +1,29 @@ +! Program to test array constructors +program constructors + integer, dimension (4) :: a + integer, dimension (3, 2) :: b + integer i, j, k, l, m, n + + a = (/1, (i,i=2,4)/) + do i = 1, 4 + if (a(i) .ne. i) call abort + end do + + b = reshape ((/0, 1, 2, 3, 4, 5/), (/3, 2/)) + 1 + do i=1,3 + if (b(i, 1) .ne. i) call abort + if (b(i, 2) .ne. i + 3) call abort + end do + + k = 1 + l = 2 + m = 3 + n = 4 + ! The remainder assumes constant constructors work ok. + a = (/n, m, l, k/) + if (any (a .ne. (/4, 3, 2, 1/))) call abort + a = (/((/i+10, 42/), i = k, l)/) + if (any (a .ne. (/11, 42, 12, 42/))) call abort + a = (/(I, I=k,l) , (J, J=m,n)/) + if (any (a .ne. (/1, 2, 3, 4/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 new file mode 100644 index 00000000000..3c7117744dd --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 @@ -0,0 +1,16 @@ +program contained + implicit none + integer i + + i = 0; + call testproc (40) + if (i .ne. 42) call abort +contains + subroutine testproc (p) + implicit none + integer p + + if (p .ne. 40) call abort + i = p + 2 + end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 new file mode 100644 index 00000000000..cae94b704e1 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 @@ -0,0 +1,28 @@ +! Program to check resolution of symbols with the same name +program contained2 + implicit none + integer var1 + + var1 = 42 + if (f1() .ne. 1) call abort + call f2() + if (var1 .ne. 42) call abort +contains + +function f1 () + implicit none + integer f1 + integer var1 + integer f2 + + var1 = 1 + f2 = var1 + f1 = f2 +end function + +subroutine f2() + implicit none + if (f1() .ne. 1) call abort +end subroutine + +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 new file mode 100644 index 00000000000..680449f3ede --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 @@ -0,0 +1,78 @@ +! PR 14396 +! These we failing on targets which do not provide the c99 complex math +! functions. +! Extracted from intrinsic77.f in the g77 testsuite. + logical fail + common /flags/ fail + fail = .false. + call square_root + if (fail) call abort + end + subroutine square_root + intrinsic sqrt, dsqrt, csqrt + real x, a + x = 4.0 + a = 2.0 + call c_r(SQRT(x),a,'SQRT(real)') + call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)') + call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)') + call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)') + call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)') + call p_r_r(SQRT,x,a,'SQRT') + call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT') + call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT') + end + subroutine failure(label) +! Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + subroutine c_r(a,b,label) +! Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + subroutine c_d(a,b,label) +! Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_c(a,b,label) +! Check if COMPLEX a equals b, and fail otherwise + complex a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + subroutine p_r_r(f,x,a,label) +! Check if REAL f(x) equals a for REAL x + real f,x,a + character*(*) label + call c_r(f(x),a,label) + end + subroutine p_d_d(f,x,a,label) +! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x + double precision f,x,a + character*(*) label + call c_d(f(x),a,label) + end + subroutine p_c_c(f,x,a,label) +! Check if COMPLEX f(x) equals a for COMPLEX x + complex f,x,a + character*(*) label + call c_c(f(x),a,label) + end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 new file mode 100644 index 00000000000..81954e222b5 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 @@ -0,0 +1,72 @@ + ! Program to test data statement + program data + call sub1() + call sub2() + end + subroutine sub1() + integer i + type tmp + integer, dimension(4)::a + real :: r + end type + type tmp1 + type (tmp) t1(4) + integer b + end type + type (tmp1) tmp2(2) + ! Full array and scalar component initializer + data tmp2(2)%t1(2)%r, tmp2(1)%t1(3)%a, tmp2(1)%b/220,136,137,138,139,10/ + data tmp2(2)%t1(4)%a,tmp2(2)%t1(3)%a/241,242,4*5,233,234/ + ! implied DO + data (tmp2(1)%t1(2)%a(i),i=4,1,-1)/124,123,122,121/ + ! array section + data tmp2(1)%t1(4)%a(4:1:-1)/144,143,142,141/ + data tmp2(1)%t1(1)%a(1:4:2)/111,113/ + ! array element reference + data tmp2(2)%t1(2)%a(3), tmp2(2)%t1(2)%a(1)/223,221/ + + if (any(tmp2(1)%t1(1)%a .ne. (/111,0,113,0/))) call abort + if (tmp2(1)%t1(1)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(2)%a .ne. (/121,122,123,124/))) call abort + if (tmp2(1)%t1(2)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(3)%a .ne. (/136,137,138,139/))) call abort + if (tmp2(1)%t1(3)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(4)%a .ne. (/141,142,143,144/))) call abort + if (tmp2(1)%t1(4)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(2)%t1(1)%a .ne. (/0,0,0,0/))) call abort + if (tmp2(2)%t1(1)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(2)%a .ne. (/221,0,223,0/))) call abort + if (tmp2(2)%t1(2)%r .ne. 220.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(3)%a .ne. (/5,5,233,234/))) call abort + if (tmp2(2)%t1(3)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(4)%a .ne. (/241,242,5,5/))) call abort + if (tmp2(2)%t1(4)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + end + subroutine sub2() + integer a(4,4), b(10) + integer i,j,k + real r,t + data i,j,r,k,t,b(5),b(2),((a(i,j),i=1,4,1),j=4,1,-1)/1,2,3,4,5,5,2,& + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/ + if ((i.ne.1) .and. (j.ne.2).and.(k.ne.4)) call abort + if ((r.ne.3.0).and.(t.ne.5.0)) call abort + if (any(b.ne.(/0,2,0,0,5,0,0,0,0,0/))) call abort + if (any(a.ne.reshape((/13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4/),(/4,4/)))) call abort + end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 new file mode 100644 index 00000000000..0aa44f6052a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 @@ -0,0 +1,17 @@ +! Check more array variants of the data statement +program data_2 + implicit none + type t + integer i + end type t + integer, dimension(3) :: a + type (t), dimension(3) :: b + integer, dimension(2,2) :: c + data a(:), b%i /1, 2, 3, 4, 5, 6/ + data c(1, :), c(2, :) /7, 8, 9, 10/ + + if (any (a .ne. (/1, 2, 3/))) call abort () + if (any (b%i .ne. (/4, 5, 6/))) call abort () + if ((any (c(1, :) .ne. (/7, 8/))) & + .or. (any (c(2,:) .ne. (/9, 10/)))) call abort () +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 new file mode 100644 index 00000000000..c8eec5c73ac --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 @@ -0,0 +1,50 @@ +! This gives incorrect results when compiled with +! the intel and pgf90 compilers +Program Strange + + Implicit None + + Type Link + Integer, Dimension(2) :: Next + End Type Link + + Integer, Parameter :: N = 2 + Integer, dimension (2, 4) :: results + Integer :: i, j + + Type(Link), Dimension(:,:), Pointer :: Perm + Integer, Dimension(2) :: Current + + Allocate (Perm(N,N)) + +! Print*, 'Spanned by indices' + Do i = 1, N**2 + Perm(mod(i-1,N)+1, (i-1)/N+1)%Next = (/ Mod(i,N) + 1, Mod(i/N+1,N)+1/) +! Write(*,100) mod(i-1,N)+1, (i-1)/N+1, Perm(mod(i-1,N)+1, (i-1)/N+1)%Next +! Expected output: +! Spanned by indices +! 1 1---> 2 2 +! 2 1---> 1 1 +! 1 2---> 2 1 +! 2 2---> 1 2 + End Do + +! Print*, 'Spanned as a cycle' + Current = (/1,1/) + Do i = 1, n**2 + results (:, i) = Perm(Current(1), Current(2))%Next +! Write(*,100) Current, Perm(Current(1), Current(2))%Next +! Expected output: +! 1 1---> 2 2 +! 2 2---> 1 2 +! 1 2---> 2 1 +! 2 1---> 1 1 + Current = Perm(Current(1), Current(2))%Next + End Do + + if (any(results .ne. reshape ((/2,2,1,2,2,1,1,1/), (/2, 4/)))) call abort + +! 100 Format( 2I3, '--->', 2I3) + DeAllocate (Perm) + +End Program Strange diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 new file mode 100644 index 00000000000..72531f9acf6 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 @@ -0,0 +1,32 @@ +! Program to test derived type initializers and constructors +program der_init + implicit none + type t + integer :: i + integer :: j = 4 + end type + integer :: m, n + + ! Explicit initializer + type (t) :: var = t(1, 2) + ! Type (default) initializer + type (t) :: var2 + ! Initialization of arrays + type (t), dimension(2) :: var3 + type (t), dimension(2) :: var4 = (/t(7, 9), t(8, 6)/) + + if (var%i .ne. 1 .or. var%j .ne. 2) call abort + if (var2%j .ne. 4) call abort + var2 = t(6, 5) + if (var2%i .ne. 6 .or. var2%j .ne. 5) call abort + + if ((var3(1)%j .ne. 4) .or. (var3(2)%j .ne. 4)) call abort + if ((var4(1)%i .ne. 7) .or. (var4(2)%i .ne. 8) & + .or. (var4(1)%j .ne. 9) .or. (var4(2)%j .ne. 6)) call abort + + ! Non-constant constructor + n = 1 + m = 5 + var2 = t(n, n + m) + if (var2%i .ne. 1 .or. var2%j .ne. 6) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 new file mode 100644 index 00000000000..0e9b0716654 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 @@ -0,0 +1,67 @@ +! Program to test IO of derived types +program derived_io + character(100) :: buf1, buf2, buf3 + + type xyz_type + integer :: x + character(11) :: y + logical :: z + end type xyz_type + + type abcdef_type + integer :: a + logical :: b + type (xyz_type) :: c + integer :: d + real(4) :: e + character(11) :: f + end type abcdef_type + + type (xyz_type), dimension(2) :: xyz + type (abcdef_type) abcdef + + xyz(1)%x = 11111 + xyz(1)%y = "hello world" + xyz(1)%z = .true. + xyz(2)%x = 0 + xyz(2)%y = "go away" + xyz(2)%z = .false. + + abcdef%a = 0 + abcdef%b = .true. + abcdef%c%x = 111 + abcdef%c%y = "bzz booo" + abcdef%c%z = .false. + abcdef%d = 3 + abcdef%e = 4.0 + abcdef%f = "kawabanga" + + write (buf1, *), xyz(1)%x, xyz(1)%y, xyz(1)%z + ! Use function call to ensure it is only evaluated once + write (buf2, *), xyz(bar()) + if (buf1.ne.buf2) call abort + + write (buf1, *), abcdef + write (buf2, *), abcdef%a, abcdef%b, abcdef%c, abcdef%d, abcdef%e, abcdef%f + write (buf3, *), abcdef%a, abcdef%b, abcdef%c%x, abcdef%c%y, & + abcdef%c%z, abcdef%d, abcdef%e, abcdef%f + if (buf1.ne.buf2) call abort + if (buf1.ne.buf3) call abort + + call foo(xyz(1)) + + contains + + subroutine foo(t) + type (xyz_type) t + write (buf1, *), t%x, t%y, t%z + write (buf2, *), t + if (buf1.ne.buf2) call abort + end subroutine foo + + integer function bar() + integer, save :: i = 1 + bar = i + i = i + 1 + end function +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 new file mode 100644 index 00000000000..1dcb07c2108 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 @@ -0,0 +1,45 @@ +! Program to test DERIVED type with components point to the DERIVED +! type itself, and two DERIVED type with componets point to each +! other. +program nest_derived + type record + integer :: value + type(record), pointer :: rp + end type record + + type record1 + integer value + type(record2), pointer :: r1p + end type + + type record2 + integer value + type(record1), pointer :: r2p + end type + + type(record), target :: e1, e2, e3 + type(record1), target :: r1 + type(record2), target :: r2 + nullify(r1%r1p,r2%r2p,e1%rp,e2%rp,e3%rp) + + r1%r1p => r2 + r2%r2p => r1 + e1%rp => e2 + e2%rp => e3 + + r1%value = 11 + r2%value = 22 + + e1%value = 33 + e1%rp%value = 44 + e1%rp%rp%value = 55 + + if (r1%r1p%value .ne. 22) call abort + if (r2%r2p%value .ne. 11) call abort + if (e1%value .ne. 33) call abort + if (e2%value .ne. 44) call abort + if (e3%value .ne. 55) call abort + if (r1%value .ne. 11) call abort + if (r2%value .ne. 22) call abort + +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 new file mode 100644 index 00000000000..6a2716407bf --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 @@ -0,0 +1,45 @@ +! Program to test derived types +program der_type + implicit none + type t1 + integer, dimension (4, 5) :: a + integer :: s + end type + + type my_type + character(20) :: c + type (t1), dimension (4, 3) :: ca + type (t1) :: r + end type + + type init_type + integer :: i = 13 + integer :: j = 14 + end type + + type (my_type) :: var + type (init_type) :: def_init + type (init_type) :: is_init = init_type (10, 11) + integer i; + + if ((def_init%i .ne. 13) .or. (def_init%j .ne. 14)) call abort + if ((is_init%i .ne. 10) .or. (is_init%j .ne. 11)) call abort + ! Passing a component as a parameter tests getting the addr of a component + call test_call(def_init%i) + var%c = "Hello World" + if (var%c .ne. "Hello World") call abort + var%r%a(:, :) = 0 + var%ca(:, :)%s = 0 + var%r%a(1, 1) = 42 + var%r%a(4, 5) = 43 + var%ca(:, :)%s = var%r%a(:, 1:5:2) + if (var%ca(1, 1)%s .ne. 42) call abort + if (var%ca(4, 3)%s .ne. 43) call abort +contains + subroutine test_call (p) + integer p + + if (p .ne. 13) call abort + end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 new file mode 100644 index 00000000000..b8078f03d5e --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 @@ -0,0 +1,20 @@ +! demonstrates basic direct access using variables for REC +! pr14872 + OPEN(UNIT=10,ACCESS='DIRECT',RECL=128) + DO I = 1,10 + WRITE(10,REC=I,ERR=10)I + ENDDO + CLOSE(10) + OPEN(UNIT=10,ACCESS='DIRECT',RECL=128) + DO I = 1,10 + READ(10,REC=I,ERR=10)J + IF (J.NE.I) THEN +! PRINT*,' READ ',J,' EXPECTED ',I + CALL ABORT + ENDIF + ENDDO + STOP + 10 CONTINUE +! PRINT*,' ERR= RETURN FROM READ OR WRITE' + CALL ABORT + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 new file mode 100644 index 00000000000..fcfe233df9c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 @@ -0,0 +1,32 @@ +! Program to test elemental functions. +program test_elemental + implicit none + integer(kind = 4), dimension (2, 4) :: a + integer(kind = 4), dimension (2, 4) :: b + integer(kind = 8), dimension(2) :: c + + a = reshape ((/2, 3, 4, 5, 6, 7, 8, 9/), (/2, 4/)) + b = 0 + b(2, :) = e_fn (a(1, :), 1) + if (any (b .ne. reshape ((/0, 1, 0, 3, 0, 5, 0, 7/), (/2, 4/)))) call abort + a = e_fn (a(:, 4:1:-1), 1 + b) + if (any (a .ne. reshape ((/7, 7, 5, 3, 3, -1, 1, -5/), (/2, 4/)))) call abort + ! This tests intrinsic elemental conversion functions. + c = 2 * a(1, 1) + if (any (c .ne. 14)) call abort + + ! This triggered bug due to building ss chains in the wrong order. + b = 0; + a = a - e_fn (a, b) + if (any (a .ne. 0)) call abort + + ! Check expressions involving constants + a = e_fn (b + 1, 1) + if (any (a .ne. 0)) call abort +contains + +elemental integer function e_fn (p, q) + integer, intent(in) :: p, q + e_fn = p - q +end function +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 new file mode 100644 index 00000000000..242bee8b467 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 @@ -0,0 +1,14 @@ +! from NIST test FM406.FOR + CHARACTER*10 A10VK + A10VK = 'XXXXXXXXXX' + WRITE(A10VK,39110) +39110 FORMAT() +! +! the empty format should fill the target of the internal +! write with blanks. +! + IF (A10VK.NE.'') THEN +! PRINT*,A10VK + CALL ABORT + ENDIF + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 new file mode 100644 index 00000000000..0c19fa57108 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 @@ -0,0 +1,20 @@ +! Test empty if statements. We Used to fail this because we folded +! the if stmt before we finished building it. +program emptyif + implicit none + integer i + + i=1 + if(i .le. 0) then + else + i = 2 + endif + if (i .ne. 2) call abort() + + if (i .eq. 0) then + elseif (i .eq. 2) then + i = 3 + end if + if (i .ne. 3) call abort() +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp new file mode 100644 index 00000000000..a476ee945bf --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp @@ -0,0 +1,59 @@ +# Copyright (C) 2003 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# This file was written by Rob Savoye. (rob@cygnus.com) +# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com) + +# +# These tests come from many different contributors. +# + +if $tracelevel then { + strace $tracelevel +} + +# load support procs +load_lib fortran-torture.exp + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture-execute $testcase +} + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.F]] { + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture-execute $testcase +} + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f90]] { + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture-execute $testcase +} + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.f95]] { + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture-execute $testcase +} + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 new file mode 100644 index 00000000000..cb2f5eacd33 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 @@ -0,0 +1,10 @@ +! check F2.x edit descriptors +! PR 14746 + CHARACTER*15 LINE + RCON21 = 9. + RCON22 = .9 + WRITE(LINE,'(F2.0,1H,,F2.1)')RCON21,RCON22 + READ(LINE,'(F2.0,1X,F2.1)')XRCON21,XRCON22 + IF (RCON21.NE.XRCON21) CALL ABORT + IF (RCON22.NE.XRCON22) CALL ABORT + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 new file mode 100644 index 00000000000..b60e67fb0d7 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 @@ -0,0 +1,17 @@ +! Program to test the FORALL construct +program testforall + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + integer i + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + forall (i=1:3) + b(i) = sum (a(:, i)) + end forall + + if (b(1) .ne. 6) call abort + if (b(2) .ne. 15) call abort + if (b(3) .ne. 24) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 new file mode 100644 index 00000000000..806dede70f3 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 @@ -0,0 +1,61 @@ +! Program to test FORALL construct +program forall_1 + + call actual_variable () + call negative_stride () + call forall_index () + +contains + subroutine actual_variable () + integer:: x = -1 + integer a(3,4) + j = 100 + + ! Actual variable 'x' and 'j' used as FORALL index + forall (x = 1:3, j = 1:4) + a (x,j) = j + end forall + if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if ((x.ne.-1).or.(j.ne.100)) call abort + + call actual_variable_2 (x, j, a) + end subroutine + + subroutine actual_variable_2(x, j, a) + integer x,j,x1,j1 + integer a(3,4), b(3,4) + + ! Actual variable 'x' and 'j' used as FORALL index. + forall (x=3:1:-1, j=4:1:-1) + a(x,j) = j + b(x,j) = j + end forall + + if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if (any (b.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if ((x.ne.-1).or.(j.ne.100)) call abort + end subroutine + + subroutine negative_stride () + integer a(3,4) + integer x, j + + ! FORALL with negative stride + forall (x = 3:1:-1, j = 4:1:-1) + a(x,j) = j + x + end forall + if (any (a.ne.reshape ((/2,3,4,3,4,5,4,5,6,5,6,7/), (/3,4/)))) call abort + end subroutine + + subroutine forall_index + integer a(32,32) + + ! FORALL with arbitrary number indexes + forall (i1=1:2,i2=1:2,i3=1:2,i4=1:2,i5=1:2,i6=1:2,i7=1:2,i8=1:2,i9=1:2,& + i10=1:2) + a(i1+2*i3+4*i5+8*i7+16*i9-30,i2+2*i4+4*i6+8*i8+16*i10-30) = 1 + end forall + if ((a(5,5).ne.1).or. (a(32,32).ne.1)) call abort + end subroutine + +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 new file mode 100644 index 00000000000..92a4ff102cc --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 @@ -0,0 +1,20 @@ +!program to test nested forall construct and forall mask +program test + implicit none + integer a(4,4) + integer i, j + + do i=1,4 + do j=1,4 + a(j,i) = j-i + enddo + enddo + forall (i=2:4, a(1,i).GT.-2) + forall (j=1:4, a(j,2).GT.0) + a(j,i) = a(j,i-1) + end forall + end forall + if (any (a.ne.reshape ((/0,1,2,3,-1,0,2,3,-2,-1,0,1,-3,-2,-1,0/),& + (/4,4/)))) call abort +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 new file mode 100644 index 00000000000..957178c8a65 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 @@ -0,0 +1,36 @@ +! Really test forall with temporary +program evil_forall + implicit none + type t + logical valid + integer :: s + integer, dimension(:), pointer :: p + end type + type (t), dimension (5) :: v + integer i + + allocate (v(1)%p(2)) + allocate (v(2)%p(8)) + v(3)%p => NULL() + allocate (v(4)%p(8)) + allocate (v(5)%p(2)) + + v(:)%valid = (/.true., .true., .false., .true., .true./) + v(:)%s = (/1, 8, 999, 6, 2/) + v(1)%p(:) = (/9, 10/) + v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/) + v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/) + v(5)%p(:) = (/11, 12/) + + + forall (i=1:5,v(i)%valid) + v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s) + end forall + + if (any(v(1)%p(:) .ne. (/11, 10/))) call abort + if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort + if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort + if (any(v(5)%p(:) .ne. (/9, 10/))) call abort + + ! I should really free the memory I've allocated. +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 new file mode 100644 index 00000000000..f2dded73587 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 @@ -0,0 +1,27 @@ +! Program to test nested forall +program forall2 + implicit none + integer a(4,4,2) + integer i, j, k, n + + a(:,:,1) = reshape((/ 1, 2, 3, 4,& + 5, 6, 7, 8,& + 9,10,11,12,& + 13,14,15,16/), (/4,4/)) + a(:,:,2) = a(:,:,1) + 16 + n=4 + k=1 + ! Mirror half the matrix + forall (i=k:n) + forall (j=1:5-i) + a(i,j,:) = a(j,i,:) + end forall + end forall + + if (any (a(:,:,1) & + .ne. reshape((/ 1, 5, 9,13,& + 2, 6,10, 8,& + 3, 7,11,12,& + 4,14,15,16/),(/4,4/)))) call abort + if (any (a(:,:,2) .ne. a(:,:,1) + 16)) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 new file mode 100644 index 00000000000..0595adf0c89 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 @@ -0,0 +1,28 @@ +! Program to test FORALL with pointer assignment inside it. +program forall_5 + type element + integer, pointer, dimension(:)::p + end type + + type (element) q(5) + integer, target, dimension(25)::t + + n = 5 + do i = 1,5 + q(i)%p => t((i-1)*n + 1:i*n) + enddo + + forall (i = 2:5) + q(i)%p => q(i-1)%p + end forall + + do i = 1, 25 + t(i) = i + enddo + + if (any(q(1)%p .ne. (/1,2,3,4,5/))) call abort + if (any(q(2)%p .ne. (/1,2,3,4,5/))) call abort + if (any(q(3)%p .ne. (/6,7,8,9,10/))) call abort + if (any(q(4)%p .ne. (/11,12,13,14,15/))) call abort + if (any(q(5)%p .ne. (/16,17,18,19,20/))) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 new file mode 100644 index 00000000000..b277814fb3f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 @@ -0,0 +1,25 @@ +! Program to test FORALL with scalar pointer assignment inside it. +program forall_6 + type element + real, pointer :: p + end type + + type (element) q(5) + real, target, dimension(5) :: t + integer i; + + t = (/1.0, 2.0, 3.0, 4.0, 5.0/) + + do i = 1,5 + q(i)%p => t(i) + end do + + forall (i = 1:5) + q(i)%p => q(6 - i)%p + end forall + + + do i = 1,5 + if (q(i)%p .ne. t(6 - i)) call abort + end do +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 new file mode 100644 index 00000000000..e57ff161d29 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 @@ -0,0 +1,36 @@ +! This can fail because BB is not resolved correctly. +module M1 + +INTEGER p + +CONTAINS +subroutine AA () + implicit NONE + p = BB () + CONTAINS + subroutine AA_1 () + implicit NONE + integer :: i + i = BB () + end subroutine + + function BB() + integer :: BB + BB = 1 + end function +end subroutine + +function BB() + implicit NONE + integer :: BB + BB = 2 +end function +end module + +program P1 + USE M1 + implicit none + p = 0 + call AA () + if (p /= 1) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 new file mode 100644 index 00000000000..aa7b17def75 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 @@ -0,0 +1,9 @@ +! PR 14038- 'H' in hollerith causes mangling of string +program hollerith + IMPLICIT NONE + CHARACTER*4 LINE +100 FORMAT (4H12H4) + WRITE(LINE,100) + IF (LINE .NE. '12H4') call abort () +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 new file mode 100644 index 00000000000..55cc185f370 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 @@ -0,0 +1,26 @@ +! Program to test static variable initialization +! returns the parameter from the previous invocation, or 42 on the first call. +function test (parm) + implicit none + integer test, parm + integer :: val = 42 + + test = val + val = parm +end function + +program intializer + implicit none + integer test + character(11) :: c = "Hello World" + character(15) :: d = "Teststring" + integer, dimension(3) :: a = 1 + + if (any (a .ne. 1)) call abort + if (test(11) .ne. 42) call abort + ! The second call should return + if (test(0) .ne. 11) call abort + + if (c .ne. "Hello World") call abort + if (d .ne. "Teststring") call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 new file mode 100644 index 00000000000..492f74476d3 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 @@ -0,0 +1,8 @@ +! PR 14831 + CHARACTER*4 BLANK + CHARACTER*10 ACCESS + OPEN(UNIT=9,ACCESS='SEQUENTIAL') + INQUIRE(UNIT=9,ACCESS=ACCESS,BLANK=BLANK) + IF(BLANK.NE.'NULL') CALL ABORT + IF(ACCESS.NE.'SEQUENTIAL') CALL ABORT + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 new file mode 100644 index 00000000000..bc7ea74c39a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 @@ -0,0 +1,6 @@ +! PR 14837 + INTEGER UNIT + OPEN(FILE='CSEQ', UNIT=23) + INQUIRE(FILE='CSEQ',NUMBER=UNIT) + IF (UNIT.NE.23) CALL ABORT + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 new file mode 100644 index 00000000000..8967dcfbc0f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 @@ -0,0 +1,13 @@ +! pr14836 + OPEN(UNIT=9, ACCESS='DIRECT', RECL=80, FORM='UNFORMATTED') + INQUIRE(UNIT=9,NEXTREC=NREC) + WRITE(UNIT=9,REC=5) 1 + INQUIRE(UNIT=9,NEXTREC=NREC) +! PRINT*,NREC + IF (NREC.NE.6) CALL ABORT + READ(UNIT=9,REC=1) MVI + INQUIRE(UNIT=9,NEXTREC=NREC) + IF (NREC.NE.2) CALL ABORT +! PRINT*,NREC + END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 new file mode 100644 index 00000000000..5b94ad232bc --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 @@ -0,0 +1,20 @@ +! pr 14904 +! inquire lastrec not correct when two records written +! with one write statement + OPEN(UNIT=10,ACCESS='DIRECT',FORM='FORMATTED',RECL=120) + 100 FORMAT(I4) + WRITE(UNIT=10,REC=1,FMT=100)1 + INQUIRE(UNIT=10,NEXTREC=J) + IF (J.NE.2) THEN +! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 2' + CALL ABORT + ENDIF + 200 FORMAT(I4,/,I4) + WRITE(UNIT=10,REC=2,FMT=200)2,3 + INQUIRE(UNIT=10,NEXTREC=J) + IF (J.NE.4) THEN +! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 4' + CALL ABORT + ENDIF + END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 new file mode 100644 index 00000000000..148cd394e68 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 @@ -0,0 +1,71 @@ +PROGRAM Test_INTEGER_select + +! Every wrong branch leads to destruction. + + INTEGER, PARAMETER :: maxI = HUGE (maxI) + INTEGER, PARAMETER :: minI = -1 * maxI + INTEGER :: I = 0 + + SELECT CASE (I) + CASE (:-1) + CALL abort + CASE (1:) + CALL abort + CASE DEFAULT + CONTINUE + END SELECT + + SELECT CASE (I) + CASE (3,2,1) + CALL abort + CASE (0) + CONTINUE + CASE DEFAULT + call abort + END SELECT + +! Not aborted by here, so it worked +! See about weird corner cases + + I = maxI + + SELECT CASE (I) + CASE (:-1) + CALL abort + CASE (1:) + CONTINUE + CASE DEFAULT + CALL abort + END SELECT + + SELECT CASE (I) + CASE (3,2,1,:0) + CALL abort + CASE (maxI) + CONTINUE + CASE DEFAULT + call abort + END SELECT + + I = minI + + SELECT CASE (I) + CASE (:-1) + CONTINUE + CASE (1:) + CALL abort + CASE DEFAULT + CALL abort + END SELECT + + SELECT CASE (I) + CASE (3:,2,1,0) + CALL abort + CASE (minI) + CONTINUE + CASE DEFAULT + call abort + END SELECT + +END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 new file mode 100644 index 00000000000..cd9bb00a98c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 @@ -0,0 +1,31 @@ +INTEGER :: I = 1 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (1) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +I = -3 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (1) + CONTINUE + CASE DEFAULT + CONTINUE +END SELECT + +I = -5 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (-5) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT +END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 new file mode 100644 index 00000000000..1e492977b06 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 @@ -0,0 +1,11 @@ +! PR 14901 +! Internal writes were appending CR after the last char +! written by the format statement. + CHARACTER*10 A + WRITE(A,'(3HGCC)') + IF (A.NE.'GCC ') THEN +! PRINT*,'A was not filled correctly by internal write' +! PRINT*,' A = ',A + CALL ABORT + ENDIF + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 new file mode 100644 index 00000000000..9e44657bad1 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 @@ -0,0 +1,33 @@ +! Program to test the ABS intrinsic +program intrinsic_abs + implicit none + integer i + real(kind=4) r + real(kind=8) q + complex z + + i = 42 + i = abs(i) + if (i .ne. 42) call abort + i = -43 + i = abs(i) + if (i .ne. 43) call abort + + r = 42.0 + r = abs(r) + if (r .ne. 42.0) call abort + r = -43.0 + r = abs(r) + if (r .ne. 43.0) call abort + + q = 42.0_8 + q = abs(q) + if (q .ne. 42.0_8) call abort + q = -43.0_8 + q = abs(q) + if (q .ne. 43.0_8) call abort + + z = (3, 4) + r = abs(z) + if (r .ne. 5) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 new file mode 100644 index 00000000000..fba0a08974f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 @@ -0,0 +1,9 @@ +! Program to test the ACHAR and IACHAR intrinsics +program intrinsic_achar + integer i + + i = 32 + if (achar(i) .ne. " ") call abort + i = iachar("A") + if ((i .ne. 65) .or. char(i) .ne. "A") call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 new file mode 100644 index 00000000000..16e816c6bd0 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 @@ -0,0 +1,55 @@ +! Program to test AINT and ANINT intrinsics + +subroutine real4test (op, res1, res2) + implicit none + real(kind=4) :: op + real(kind=4) :: res1, res2 + + if (diff(aint(op), res1) .or. & + diff(anint(op), res2)) call abort +contains +function diff(a, b) + real(kind=4) :: a, b + logical diff + + diff = (abs (a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +subroutine real8test (op, res1, res2) + implicit none + real(kind=8) :: op + real(kind=8) :: res1, res2 + + if (diff(aint(op), res1) .or. & + diff(anint(op), res2)) call abort +contains +function diff(a, b) + real(kind=8) :: a, b + logical diff + + diff = (abs(a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +program aint_aninttest + implicit none + + call real4test (3.456, 3.0, 3.0) + call real4test (-2.798, -2.0, -3.0) + call real4test (3.678, 3.0, 4.0) + call real4test (-1.375, -1.0, -1.0) + call real4test (-0.5, 0.0,-1.0) + call real4test (0.4, 0.0,0.0) + + call real8test (3.456_8, 3.0_8, 3.0_8) + call real8test (-2.798_8, -2.0_8, -3.0_8) + call real8test (3.678_8, 3.0_8, 4.0_8) + call real8test (-1.375_8, -1.0_8, -1.0_8) + call real8test (-0.5_8, 0.0_8,-1.0_8) + call real8test (0.4_8, 0.0_8,0.0_8) + + ! Check large numbers + call real4test (2e34, 2e34, 2e34) + call real4test (-2e34, -2e34, -2e34) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 new file mode 100644 index 00000000000..d1b99dacb5d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 @@ -0,0 +1,26 @@ +! Program to test the ANY and ALL intrinsics +program anyall + implicit none + logical, dimension(3, 3) :: a + logical, dimension(3) :: b + + a = .false. + if (any(a)) call abort + a(1, 1) = .true. + a(2, 3) = .true. + if (.not. any(a)) call abort + b = any(a, 1) + if (.not. b(1)) call abort + if (b(2)) call abort + if (.not. b(3)) call abort + + a = .true. + if (.not. all(a)) call abort + a(1, 1) = .false. + a(2, 3) = .false. + if (all(a)) call abort + b = all(a, 1) + if (b(1)) call abort + if (.not. b(2)) call abort + if (b(3)) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 new file mode 100644 index 00000000000..24d647ef15a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 @@ -0,0 +1,137 @@ +! Program to test the ASSOCIATED intrinsic. +program intrinsic_associated + call pointer_to_section () + call associate_1 () + call pointer_to_derived_1 () + call associated_2 () +end + +subroutine pointer_to_section () + integer, dimension(100, 100), target :: xy + integer, dimension(:, :), pointer :: window + integer i, j, k, m, n + data xy /10000*0/ + logical t + + window => xy(10:50, 30:60) + window = 10 + window (1, 1) = 0101 + window (41, 31) = 4161 + window (41, 1) = 4101 + window (1, 31) = 0161 + + t = associated (window, xy(10:50, 30:60)) + if (.not.t) call abort () + if (window(1, 1) .ne. xy(10, 30)) call abort () + if (window(41, 31) .ne. xy(50, 60)) call abort () + if (window(1, 31) .ne. xy(10, 60)) call abort () + if (window(41, 1) .ne. xy(50, 30)) call abort () + if (xy(9, 29) .ne. 0) call abort () + if (xy(51,29 ) .ne. 0) call abort () + if (xy(9, 60) .ne. 0) call abort () + if (xy(51, 60) .ne. 0) call abort () + if (xy(11, 31) .ne. 10) call abort () + if (xy(49, 59) .ne. 10) call abort () + if (xy(11, 59) .ne. 10) call abort () + if (xy(49, 31) .ne. 10) call abort () +end + +subroutine sub1 (a, ap) + integer, pointer :: ap(:, :) + integer, target :: a(10, 10) + + ap => a +end + +subroutine nullify_pp (a) + integer, pointer :: a(:, :) + + if (.not. associated (a)) call abort () + nullify (a) +end + +subroutine associate_1 () + integer, pointer :: a(:, :), b(:, :) + interface + subroutine nullify_pp (a) + integer, pointer :: a(:, :) + end subroutine nullify_pp + end interface + + allocate (a(80, 80)) + b => a + if (.not. associated(a)) call abort () + if (.not. associated(b)) call abort () + call nullify_pp (a) + if (associated (a)) call abort () + if (.not. associated (b)) call abort () +end + +subroutine pointer_to_derived_1 () + type record + integer :: value + type(record), pointer :: rp + end type record + + type record1 + integer value + type(record2), pointer :: r1p + end type + + type record2 + integer value + type(record1), pointer :: r2p + end type + + type(record), target :: e1, e2, e3 + type(record1), target :: r1 + type(record2), target :: r2 + + nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp) + if (associated (r1%r1p)) call abort () + if (associated (r2%r2p)) call abort () + if (associated (e2%rp)) call abort () + if (associated (e1%rp)) call abort () + if (associated (e3%rp)) call abort () + r1%r1p => r2 + r2%r2p => r1 + r1%value = 11 + r2%value = 22 + e1%rp => e2 + e2%rp => e3 + e1%value = 33 + e1%rp%value = 44 + e1%rp%rp%value = 55 + if (.not. associated (r1%r1p)) call abort () + if (.not. associated (r2%r2p)) call abort () + if (.not. associated (e1%rp)) call abort () + if (.not. associated (e2%rp)) call abort () + if (associated (e3%rp)) call abort () + if (r1%r1p%value .ne. 22) call abort () + if (r2%r2p%value .ne. 11) call abort () + if (e1%value .ne. 33) call abort () + if (e2%value .ne. 44) call abort () + if (e3%value .ne. 55) call abort () + if (r1%value .ne. 11) call abort () + if (r2%value .ne. 22) call abort () + +end + +subroutine associated_2 () + integer, pointer :: xp(:, :) + integer, target :: x(10, 10) + integer, target :: y(100, 100) + interface + subroutine sub1 (a, ap) + integer, pointer :: ap(:, :) + integer, target :: a(10, 1) + end + endinterface + + xp => y + if (.not. associated (xp)) call abort () + call sub1 (x, xp) + if (associated (xp, y)) call abort () + if (.not. associated (xp, x)) call abort () +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 new file mode 100644 index 00000000000..5f353b2f85b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 @@ -0,0 +1,36 @@ +! Program to test the ASSOCIATED intrinsic with cross-kinds +program intrinsic_associated_2 + logical*4 :: t4, L44, L48 + logical*8 :: t8, L84, L88 + real*4, pointer :: a4p(:, :) + real*8, pointer :: a8p(:, :) + real*4, target :: a4(10, 10) + real*8, target :: a8(10, 10) + + t4 = .true. + t8 = .true. + t8 = t4 + a4p => a4 + a8p => a8 + L44 = t4 .and. associated (a4p, a4) + L84 = t8 .and. associated (a4p, a4) + L48 = t4 .and. associated (a8p, a8) + L88 = t8 .and. associated (a8p, a8) + if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort () + + nullify (a4p, a8p) + L44 = t4 .and. associated (a4p, a4) + L84 = t8 .and. associated (a4p, a4) + L48 = t4 .and. associated (a8p, a8) + L88 = t8 .and. associated (a8p, a8) + if (L44 .and. L84 .and. L48 .and. L88) call abort () + + a4p => a4(1:10:2, 1:10:2) + a8p => a8(1:4, 1:4) + L44 = t4 .and. associated (a4p, a4(1:10:2, 1:10:2)) + L84 = t8 .and. associated (a4p, a4(1:10:2, 1:10:2)) + L48 = t4 .and. associated (a8p, a8(1:4, 1:4)) + L88 = t8 .and. associated (a8p, a8(1:4, 1:4)) + if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort () +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 new file mode 100644 index 00000000000..95ff44c999e --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 @@ -0,0 +1,29 @@ +! Program to test intrinsic bitops +program intrinsic_bitops + implicit none + integer(kind=4) :: i, j, k, o, t + integer(kind=8) :: a, b, c + + o = 0 + i = 2 + j = 3 + k = 12 + + if (.not. btest (i, o+1)) call abort + if (btest (i, o+2)) call abort + if (iand (i, j) .ne. 2) call abort + if (ibclr (j, o+1) .ne. 1) call abort + if (ibclr (j, o+2) .ne. 3) call abort + if (ibits (k, o+1, o+2) .ne. 2) call abort + if (ibset (j, o+1) .ne. 3) call abort + if (ibset (j, o+2) .ne. 7) call abort + if (ieor (i, j) .ne. 1) call abort + if (ior (i, j) .ne. 3) call abort + if (ishft (k, o+2) .ne. 48) call abort + if (ishft (k, o-3) .ne. 1) call abort + if (ishft (k, o) .ne. 12) call abort + if (ishftc (k, o+30) .ne. 3) call abort + if (ishftc (k, o-30) .ne. 48) call abort + if (ishftc (k, o+1, o+3) .ne. 9) call abort + if (not (i) .ne. -3) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 new file mode 100644 index 00000000000..a2de59fb985 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 @@ -0,0 +1,21 @@ +! Program to test the COUNT intrinsic +program intrinsic_count + implicit none + logical(kind=4), dimension (3, 5) :: a + integer(kind=4), dimension (5) :: b + integer i + + a = .false. + if (count(a) .ne. 0) call abort + a = .true. + if (count(a) .ne. 15) call abort + a(1, 1) = .false. + a(2, 2) = .false. + a(2, 5) = .false. + if (count(a) .ne. 12) call abort + + b(1:3) = count(a, 2); + if (b(1) .ne. 4) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 5) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 new file mode 100644 index 00000000000..f188cd8f4bb --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 @@ -0,0 +1,43 @@ +! Program to test the cshift intrinsic +program intrinsic_cshift + integer, dimension(3, 3) :: a + integer, dimension(3, 3, 2) :: b + + ! Scalar shift + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, 1, 1) + if (any (a .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, -2, dim = 2) + if (any (a .ne. reshape ((/4, 5, 6, 7, 8, 9, 1, 2, 3/), (/3, 3/)))) & + call abort + + ! Array shift + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, (/1, 0, -1/)) + if (any (a .ne. reshape ((/2, 3, 1, 4, 5, 6, 9, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, (/2, -2, 0/), dim = 2) + if (any (a .ne. reshape ((/7, 5, 3, 1, 8, 6, 4, 2, 9/), (/3, 3/)))) & + call abort + + ! Test arrays > rank 2 + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,& + 18, 19/), (/3, 3, 2/)) + b = cshift (b, 1) + if (any (b .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7, 12, 13, 11, 15,& + 16, 14, 18, 19, 17/), (/3, 3, 2/)))) & + call abort + + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,& + 18, 19/), (/3, 3, 2/)) + b = cshift (b, reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)), 3) + if (any (b .ne. reshape ((/11, 2, 13, 4, 15, 6, 17, 8, 19, 1, 12, 3,& + 14, 5, 16, 7, 18, 9/), (/3, 3, 2/)))) & + call abort + +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 new file mode 100644 index 00000000000..4753de3606d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 @@ -0,0 +1,20 @@ +! Program to test the DIM intrinsic +program intrinsic_dim + implicit none + integer i, j + real(kind=4) :: r, s + real(kind=8) :: p, q + + i = 1 + j = 4 + if (dim (i, j) .ne. 0) call abort + if (dim (j, i) .ne. 3) call abort + r = 1.0 + s = 4.0 + if (dim (r, s) .ne. 0.0) call abort + if (dim (s, r) .ne. 3.0) call abort + p = 1.0 + q = 4.0 + if (dim (p, q) .ne. 0.0) call abort + if (dim (q, p) .ne. 3.0) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 new file mode 100644 index 00000000000..5444dd6dac1 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 @@ -0,0 +1,25 @@ +! Program to test the DOT_PRODUCT intrinsic +program testforall + implicit none + integer, dimension (3) :: a + integer, dimension (3) :: b + real, dimension(3) :: c + real r + complex, dimension (2) :: z1 + complex, dimension (2) :: z2 + complex z + + a = (/1, 2, 3/); + b = (/4, 5, 6/); + c = (/4, 5, 6/); + + if (dot_product(a, b) .ne. 32) call abort + + r = dot_product(a, c) + if (abs(r - 32.0) .gt. 0.001) call abort + + z1 = (/(1.0, 2.0), (2.0, 3.0)/) + z2 = (/(3.0, 4.0), (4.0, 5.0)/) + z = dot_product (z1, z2) + if (abs (z - (34.0, -4.0)) .gt. 0.001) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 new file mode 100644 index 00000000000..feb3367934b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 @@ -0,0 +1,13 @@ +! Program to test DPROD intrinsic +program intrinsic_dprod + implicit none + real r, s, t + double precision dp + + ! 6d60 doesn't fit in a 4-byte real + r = 2e30 + s = 4e30 + dp = dprod (r, s) + if ((dp .gt. 8.001d60) .or. (dp .lt. 7.999d60)) call abort +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 new file mode 100644 index 00000000000..2e8a3401492 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 @@ -0,0 +1,23 @@ +! Program to test passing intrinsic functions as actual arguments for +! dummy procedures. +subroutine test (proc) + implicit none + real proc + real a, b, c + + a = 1.0 + b = sin (a) + c = proc (a) + + if (abs (b - c) .gt. 0.001) call abort + +end subroutine + +program dummy + implicit none + external test + intrinsic sin + + call test (sin) +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 new file mode 100644 index 00000000000..12edc630e50 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 @@ -0,0 +1,60 @@ +! Program to test the eoshift intrinsic +program intrinsic_eoshift + integer, dimension(3, 3) :: a + integer, dimension(3, 3, 2) :: b + + ! Scalar shift and scalar bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 1, 99, 1) + if (any (a .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -2, dim = 2) + if (any (a .ne. reshape ((/0, 0, 0, 0, 0, 0, 1, 2, 3/), (/3, 3/)))) & + call abort + + ! Array shift and scalar bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/1, 0, -1/), 99, 1) + if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 99, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/2, -2, 0/), dim = 2) + if (any (a .ne. reshape ((/7, 0, 3, 0, 0, 6, 0, 2, 9/), (/3, 3/)))) & + call abort + + ! Scalar shift and array bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 1, (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/2, 3, 99, 5, 6, -1, 8, 9, 42/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -2, (/99, -1, 42/), 2) + if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) & + call abort + + ! Array shift and array bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/1, 0, -1/), (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 42, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/2, -2, 0/), (/99, -1, 42/), 2) + if (any (a .ne. reshape ((/7, -1, 3, 99, -1, 6, 99, 2, 9/), (/3, 3/)))) & + call abort + + ! Test arrays > rank 2 + b(:, :, 1) = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + b(:, :, 2) = 10 + reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + b = eoshift (b, 1, 99, 1) + if (any (b(:, :, 1) .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) & + call abort + if (any (b(:, :, 2) .ne. reshape ((/12, 13, 99, 15, 16, 99, 18, 19, 99/), (/3, 3/)))) & + call abort + + ! TODO: Test array sections +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 new file mode 100644 index 00000000000..a22d0b9f50a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 @@ -0,0 +1,84 @@ +!Program to test EXPONENT and FRACTION intrinsic function. + +program test_exponent_fraction + real x + integer*4 i + real*8 y + integer*8 j + equivalence (x, i), (y, j) + + x = 3. + call test_4(x) + + x = 0. + call test_4(x) + + i = o'00000000001' + call test_4(x) + + i = o'00010000000' + call test_4(x) + + i = o'17700000000' + call test_4(x) + + i = o'00004000001' + call test_4(x) + + i = o'17737777777' + call test_4(x) + + i = o'10000000000' + call test_4(x) + + i = o'0000010000' + call test_4(x) + + y = 0.5 + call test_8(y) + + y = 0. + call test_8(y) + + j = o'00000000001' + call test_8(y) + + y = 0.2938735877D-38 + call test_8(y) + + y = -1.469369D-39 + call test_8(y) + + y = z'7fe00000' + call test_8(y) + + y = -5.739719D+42 + call test_8(y) +end + +subroutine test_4(x) +real*4 x,y +integer z +y = fraction (x) +z = exponent(x) +if (z .gt. 0) then + y = (y * 2.) * (2. ** (z - 1)) +else + y = (y / 2.) * (2. ** (z + 1)) +end if +if (abs (x - y) .gt. abs(x * 1e-6)) call abort() +end + +subroutine test_8(x) +real*8 x, y +integer z +y = fraction (x) +z = exponent(x) +if (z .gt. 0) then + y = (y * 2._8) * (2._8 ** (z - 1)) +else + y = (y / 2._8) * (2._8 ** (z + 1)) +end if +if (abs (x - y) .gt. abs(x * 1e-6)) call abort() +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 new file mode 100644 index 00000000000..9b181775f9c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 @@ -0,0 +1,15 @@ +! Program to test the INDEX intrinsic +program test + character(len=10) a + integer w + if (index("FORTRAN", "R") .ne. 3) call abort + if (index("FORTRAN", "R", .TRUE.) .ne. 5) call abort + if (w ("FORTRAN") .ne. 3) call abort +end + +function w(str) + character(len=8) str + integer w + w = index(str, "R") +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 new file mode 100644 index 00000000000..43578ed54a7 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 @@ -0,0 +1,18 @@ +! Program to test the real->integer conversion routines. +program intrinsic_integer + implicit none + + call test (0.0, (/0, 0, 0, 0/)) + call test (0.3, (/0, 1, 0, 0/)) + call test (0.7, (/0, 1, 0, 1/)) + call test (-0.3, (/-1, 0, 0, 0/)) + call test (-0.7, (/-1, 0, 0, -1/)) +contains +subroutine test(val, res) + real :: val + integer, dimension(4) :: res + + if ((floor(val) .ne. res(1)) .or. (ceiling(val) .ne. res(2)) & + .or. (int(val) .ne. res(3)) .or. (nint(val) .ne. res(4))) call abort +end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 new file mode 100644 index 00000000000..6721738608f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 @@ -0,0 +1,22 @@ +! Program to test the LEN intrinsic +program test + character(len=10) a + character(len=8) w + type person + character(len=10) name + integer age + end type person + type(person) Tom + integer n + a = w (n) + + if ((a .ne. "01234567") .or. (n .ne. 8)) call abort + if (len(Tom%name) .ne. 10) call abort +end + +function w(i) + character(len=8) w + integer i + w = "01234567" + i = len(w) +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 new file mode 100644 index 00000000000..4b195d267bd --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 @@ -0,0 +1,24 @@ +! Program to test the MATMUL intrinsic +program intrinsic_matmul + implicit none + integer, dimension(2, 3) :: a + integer, dimension(3, 2) :: b + integer, dimension(2) :: x + integer, dimension(3) :: y + integer, dimension(2, 2) :: r + integer, dimension(3) :: v + + a = reshape((/1, 2, 2, 3, 3, 4/), (/2, 3/)) + b = reshape((/1, 2, 3, 3, 4, 5/), (/3, 2/)) + x = (/1, 2/) + y = (/1, 2, 3/) + + r = matmul(a, b) + if (any(r .ne. reshape((/14, 20, 26, 38/), (/2, 2/)))) call abort + + v = matmul(x, a) + if (any(v .ne. (/5, 8, 11/))) call abort + + v(1:2) = matmul(a, y) + if (any(v(1:2) .ne. (/14, 20/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 new file mode 100644 index 00000000000..b4fc18f4dd6 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 @@ -0,0 +1,15 @@ +! Program to test the MERGE intrinsic +program intrinsic_merge + integer, dimension(3) :: a, b + integer i + + a = (/-1, 2, 3/) + + i = 5 + if (merge (-1, 1, i .gt. 3) .ne. -1) call abort + i = 1 + if (merge (-1, 1, i .ge. 3) .ne. 1) call abort + + b = merge(a, 0, a .ge. 0) + if (any (b .ne. (/0, 2, 3/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 new file mode 100644 index 00000000000..02feaad1523 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 @@ -0,0 +1,37 @@ +! Program to test min and max intrinsics +program intrinsic_minmax + implicit none + integer i, j, k, m + real r, s, t, u + + i = 1 + j = -2 + k = 3 + m = 4 + if (min (i, k) .ne. 1) call abort + if (min (i, j, k, m) .ne. -2) call abort + if (max (i, k) .ne. 3) call abort + if (max (i, j, k, m) .ne. 4) call abort + if (max (i+1, j) .ne. 2) call abort + + r = 1 + s = -2 + t = 3 + u = 4 + if (min (r, t) .ne. 1) call abort + if (min (r, s, t, u) .ne. -2) call abort + if (max (r, t) .ne. 3) call abort + if (max (r, s, t, u) .ne. 4) call abort + + if (max (4d0, r) .ne. 4d0) call abort + if (amax0 (i, j) .ne. 1.0) call abort + if (min1 (r, s) .ne. -2) call abort + + ! Test simplify. + if (min (1, -2, 3, 4) .ne. -2) call abort + if (max (1, -2, 3, 4) .ne. 4) call abort + if (amax0 (1, -2) .ne. 1.0) call abort + if (min1 (1., -2.) .ne. -2) call abort + +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 new file mode 100644 index 00000000000..f64242af9e8 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 @@ -0,0 +1,52 @@ +! Program to test the MINLOC and MAXLOC intrinsics +program testmmloc + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m + integer i + + a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/)); + + b = minloc (a, 1) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + + m = .true. + m(1, 1) = .false. + m(1, 2) = .false. + b = minloc (a, 1, m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + + b(1:2) = minloc(a) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 1) call abort + + b(1:2) = minloc(a, mask=m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 1) call abort + + b = maxloc (a, 1) + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 1) call abort + + m = .true. + m(1, 2) = .false. + m(1, 3) = .false. + b = maxloc (a, 1, m) + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 2) call abort + + b(1:2) = maxloc(a) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 3) call abort + + b(1:2) = maxloc(a, mask=m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 3) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 new file mode 100644 index 00000000000..5f0b5b5da1d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 @@ -0,0 +1,22 @@ +program intrinsic_mmloc_2 + real a(-1:1), b(2:3), c(1:2) + integer, dimension(1):: i + real (kind = 8), dimension(-1:1) :: vc + + a = 0 + b = 0 + c = 0 + a(-1) = 1 + b(2) = 1 + c(1) = 1 + + if (maxloc (a, 1) .ne. 1) call abort() + if (maxloc (b, 1) .ne. 1) call abort() + if (maxloc (c, 1) .ne. 1) call abort() + + + ! We were giving MINLOC and MAXLOC the wrong return type + vc = (/4.0d0, 2.50d1, 1.0d1/) + i = minloc (vc) + if (i(1) .ne. 1) call abort() +END PROGRAM diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 new file mode 100644 index 00000000000..2e18a29bc16 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 @@ -0,0 +1,12 @@ +! Check we do the right thing with extreme values. +! From PR12704 +program intrinsic_mmloc_3 + integer, dimension(2) :: d + integer, dimension(2,2) :: a + + d = -huge (d) + if (maxloc (d, 1) .ne. 1) call abort() + a = huge (a) + d = minloc (a) + if (any (d .ne. 1)) call abort() +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 new file mode 100644 index 00000000000..2a53fb0124a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 @@ -0,0 +1,13 @@ +! Check zero sized arrays work correcly +! From PR12704 +program intrinsic_mmloc_4 + integer, allocatable, dimension(:) :: d + integer, allocatable, dimension(:,:) :: a + integer, dimension(2) :: b + + allocate (d(0)) + if (maxloc (d, 1) .ne. 0) call abort() + allocate (a(1, 0)) + b = minloc (a) + if (any (b .ne. 0)) call abort() +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 new file mode 100644 index 00000000000..368c83ba133 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 @@ -0,0 +1,28 @@ +! Program to test the MINVAL and MAXVAL intrinsics +program testmmval + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m + integer i + + a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/)); + + b = minval (a, 1) + if (any(b .ne. (/1, 4, 7/))) call abort + + m = .true. + m(1, 1) = .false. + m(1, 2) = .false. + b = minval (a, 1, m) + if (any(b .ne. (/2, 4, 7/))) call abort + + b = maxval (a, 1) + if (any(b .ne. (/3, 6, 9/))) call abort + + m = .true. + m(1, 2) = .false. + m(1, 3) = .false. + b = maxval (a, 1, m) + if (any(b .ne. (/3, 6, 8/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 new file mode 100644 index 00000000000..7050c2ccd53 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 @@ -0,0 +1,64 @@ +! Program to test MOD and MODULO intrinsics +subroutine integertest (ops, res) + implicit none + integer, dimension(2) :: ops + integer, dimension(2) :: res + + if ((mod(ops(1), ops(2)) .ne. res(1)) .or. & + (modulo(ops(1), ops(2)) .ne. res(2))) call abort +end subroutine + +subroutine real4test (ops, res) + implicit none + real(kind=4), dimension(2) :: ops + real(kind=4), dimension(2) :: res + + if (diff(mod(ops(1), ops(2)), res(1)) .or. & + diff(modulo(ops(1), ops(2)), res(2))) call abort +contains +function diff(a, b) + real(kind=4) :: a, b + logical diff + + diff = (abs (a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +subroutine real8test (ops, res) + implicit none + real(kind=8), dimension(2) :: ops + real(kind=8), dimension(2) :: res + + if (diff(mod(ops(1), ops(2)), res(1)) .or. & + diff(modulo(ops(1), ops(2)), res(2))) call abort +contains +function diff(a, b) + real(kind=8) :: a, b + logical diff + + diff = (abs(a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +program mod_modulotest + implicit none + + call integertest ((/8, 5/), (/3, 3/)) + call integertest ((/-8, 5/), (/-3, 2/)) + call integertest ((/8, -5/), (/3, -2/)) + call integertest ((/-8, -5/), (/-3, -3/)) + + call real4test ((/3.0, 2.5/), (/0.5, 0.5/)) + call real4test ((/-3.0, 2.5/), (/-0.5, 2.0/)) + call real4test ((/3.0, -2.5/), (/0.5, -2.0/)) + call real4test ((/-3.0, -2.5/), (/-0.5, -0.5/)) + + call real8test ((/3.0_8, 2.5_8/), (/0.5_8, 0.5_8/)) + call real8test ((/-3.0_8, 2.5_8/), (/-0.5_8, 2.0_8/)) + call real8test ((/3.0_8, -2.5_8/), (/0.5_8, -2.0_8/)) + call real8test ((/-3.0_8, -2.5_8/), (/-0.5_8, -0.5_8/)) + + ! Check large numbers + call real4test ((/2e34, 1.0/), (/0.0, 0.0/)) + call real4test ((/2e34, 1.5e34/), (/0.5e34, 0.5e34/)) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 new file mode 100644 index 00000000000..99d802e6189 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 @@ -0,0 +1,71 @@ +!Program to test NEAREST intrinsic function. + +program test_nearest + real s, r, x, y, inf, max, min + integer i, infi, maxi, mini + equivalence (s,i) + equivalence (inf,infi) + equivalence (max,maxi) + equivalence (min,mini) + + r = 2.0 + s = 3.0 + call test_n (s, r) + + i = z'00800000' + call test_n (s, r) + + i = z'007fffff' + call test_n (s, r) + + i = z'00800100' + call test_n (s, r) + + s = 0 + x = nearest(s, r) + y = nearest(s, -r) + if (.not. (x .gt. s .and. y .lt. s )) call abort() + + infi = z'7f800000' + maxi = z'7f7fffff' + mini = 1 + + call test_up(max, inf) + call test_up(-inf, -max) + call test_up(0, min) + call test_up(-min, 0) + + call test_down(inf, max) + call test_down(-max, -inf) + call test_down(0, -min) + call test_down(min, 0) +end + +subroutine test_up(s, e) + real s, e, x + + x = nearest(s, 1.0) + if (x .ne. e) call abort() +end + +subroutine test_down(s, e) + real s, e, x + + x = nearest(s, -1.0) + if (x .ne. e) call abort() +end + +subroutine test_n(s1, r) + real r, s1, x + + x = nearest(s1, r) + if (nearest(x, -r) .ne. s1) call abort() + x = nearest(s1, -r) + if (nearest(x, r) .ne. s1) call abort() + + s1 = -s1 + x = nearest(s1, r) + if (nearest(x, -r) .ne. s1) call abort() + x = nearest(s1, -r) + if (nearest(x, r) .ne. s1) call abort() +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 new file mode 100644 index 00000000000..565446e4e8b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 @@ -0,0 +1,12 @@ +! Program to test the PACK intrinsic +program intrinsic_pack + integer, dimension(3, 3) :: a + integer, dimension(6) :: b + + a = reshape ((/0, 0, 0, 0, 9, 0, 0, 0, 7/), (/3, 3/)) + b = 0 + b(1:6:3) = pack (a, a .ne. 0); + if (any (b(1:6:3) .ne. (/9, 7/))) call abort + b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/)); + if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 new file mode 100644 index 00000000000..d2e9981353d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 @@ -0,0 +1,40 @@ +! Program to test the PRESENT intrinsic +program intrinsic_present + implicit none + integer a + integer, pointer :: b + integer, dimension(10) :: c + integer, pointer, dimension(:) :: d + + if (testvar()) call abort () + if (.not. testvar(a)) call abort () + if (testptr()) call abort () + if (.not. testptr(b)) call abort () + if (testarray()) call abort () + if (.not. testarray(c)) call abort () + if (testparray()) call abort () + if (.not. testparray(d)) call abort () + +contains +logical function testvar (p) + integer, optional :: p + testvar = present(p) +end function + +logical function testptr (p) + integer, pointer, optional :: p + testptr = present(p) +end function + +logical function testarray (p) + integer, dimension (10), optional :: p + testarray = present(p) +end function + +logical function testparray (p) + integer, pointer, dimension(:), optional :: p + testparray = present(p) +end function + +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 new file mode 100644 index 00000000000..102832c9f9b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 @@ -0,0 +1,25 @@ +! Program to test the PRODUCT intrinsic +program testproduct + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + b = product (a, 1) + + if (any(b .ne. (/6, 120, 504/))) call abort + + if (product (a) .ne. 362880) call abort + + m = .true. + m(1, 1) = .false. + m(2, 1) = .false. + b = product (a, 2, m) + + if (any(b .ne. (/28, 40, 162/))) call abort + + if (product (a, mask=m) .ne. 181440) call abort + +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 new file mode 100644 index 00000000000..0f411a633b2 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 @@ -0,0 +1,27 @@ +!Program to test RRSPACING intrinsic function. + +program test_rrspacing + call test_real4(3.0) + call test_real4(33.0) + call test_real4(-3.0) + call test_real8(3.0_8) + call test_real8(33.0_8) + call test_real8(-33.0_8) +end +subroutine test_real4(x) + real x,y + integer p + p = 24 + y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p) + x = rrspacing(x) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end + +subroutine test_real8(x) + real*8 x,y,t + integer p + p = 53 + y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p) + x = rrspacing(x) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 new file mode 100644 index 00000000000..df483811415 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 @@ -0,0 +1,27 @@ +!Program to test SCALE intrinsic function. + +program test_scale + call test_real4 (3.0, 2) + call test_real4 (33.0, -2) + call test_real4 (-3., 2) + call test_real4 (0, 3) + call test_real8 (0, 3) + call test_real8 (3.0_8, 4) + call test_real8 (33.0_8, -4) + call test_real8 (-33._8, 4) +end +subroutine test_real4 (x, i) + real x,y + integer i + y = x * (2.0 ** i) + x = scale (x, i) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end + +subroutine test_real8 (x, i) + real*8 x,y + integer i + y = x * (2.0 ** i) + x = scale (x, i) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 new file mode 100644 index 00000000000..da84ea7d723 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 @@ -0,0 +1,91 @@ +!Program to test SET_EXPONENT intrinsic function. + +program test_set_exponent + call test_real4() + call test_real8() +end +subroutine test_real4() + real x,y + integer i,n + equivalence(x,i) + + n = -148 + x = 1024.0 + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = 8 + x = 1024.0 + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = 128 + i = o'00037777777' + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = -148 + x = -1024.0 + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = 8 + x = -1024.0 + y = set_exponent (x, n) + if (y .ne. -128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 128 + i = o'20037777777' + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + +end + +subroutine test_real8() + implicit none + real*8 x, y + integer*8 i, n, low + equivalence(x, i) + + n = -1073 + x = 1024.0_8 + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = 8 + x = 1024.0_8 + y = set_exponent (x, n) + if (y .ne. 128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 1024 + low = z'ffffffff' + i = z'000fffff' + i = ishft (i, 32) + low !'000fffffffffffff' + y = set_exponent (x, n) + low = z'fffffffe' + i = z'7fefffff' + i = ishft (i, 32) + low + if (exponent (y) .ne. n) call abort() + + n = -1073 + x = -1024.0 + y = set_exponent (x, n) + low = z'00000001' + if (exponent (y) .ne. n) call abort() + + n = 8 + x = -1024.0 + y = set_exponent (x, n) + if (y .ne. -128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 1024 + low = z'ffffffff' + i = z'800fffff' + i = ishft (i, 32) + low !z'800fffffffffffff' + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 new file mode 100644 index 00000000000..e1c5f7b4ba1 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 @@ -0,0 +1,22 @@ +! Program to test the shape intrinsic +program testbounds + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(2) :: j + integer i + + allocate (a(3:8, 6:7)) + + j = shape (a); + if (any (j .ne. (/ 6, 2 /))) call abort + + call test(a) +contains + +subroutine test (a) + real, dimension (1:, 1:) :: a + + if (any (shape (a) .ne. (/ 6, 2 /))) call abort +end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 new file mode 100644 index 00000000000..b231dc66ebe --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 @@ -0,0 +1,35 @@ +! Program to test SELECTED_INT_KIND intrinsic function. +Program test_si_kind + integer*1 i1 + integer*2 i2 + integer*4 i4 + integer*8 i8 + integer res + real t + + t = huge (i1) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 1) call abort + + t = huge (i2) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 2) call abort + + t = huge (i4) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 4) call abort + + t = huge (i8) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 8) call abort + + i4 = huge (i4) + res = selected_int_kind (i4) + if (res .ne. (-1)) call abort + +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 new file mode 100644 index 00000000000..fbc457d917c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 @@ -0,0 +1,31 @@ +! Program to test SIGN intrinsic +program intrinsic_sign + implicit none + integer i, j + real r, s + + i = 2 + j = 3 + if (sign (i, j) .ne. 2) call abort + i = 4 + j = -5 + if (sign (i, j) .ne. -4) call abort + i = -6 + j = 7 + if (sign (i, j) .ne. 6) call abort + i = -8 + j = -9 + if (sign (i, j) .ne. -8) call abort + r = 1 + s = 2 + if (sign (r, s) .ne. 1) call abort + r = 1 + s = -2 + if (sign (r, s) .ne. -1) call abort + s = 0 + if (sign (r, s) .ne. 1) call abort + ! Will fail on machines which cannot represent negative zero. + s = -s ! Negative zero + if (sign (r, s) .ne. -1) call abort +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 new file mode 100644 index 00000000000..729c55f2283 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 @@ -0,0 +1,37 @@ +! Program to test the SIZE intrinsics +program testsize + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(5) :: j + integer, dimension(2, 3) :: b + integer i + + if (size (b(2, :), 1) .ne. 3) call abort + + allocate (a(3:8, 5:7)) + + ! With one parameter + if (size(a) .ne. 18) call abort + + ! With two parameters, assigning to an array + j = size(a, 1) + if (any (j .ne. (/6, 6, 6, 6, 6/))) call abort + + ! With a variable second parameter + i = 2 + i = size(a, i) + if (i .ne. 3) call abort + + call test(a) +contains + +subroutine test (a) + real, dimension (1:, 1:) :: a + integer i + + i = 2 + if ((size(a, 1) .ne. 6) .or. (size(a, i) .ne. 3)) call abort + if (size (a) .ne. 18 ) call abort +end subroutine +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 new file mode 100644 index 00000000000..4fac9f1b303 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 @@ -0,0 +1,33 @@ +!Program to test SPACING intrinsic function. + +program test_spacing + call test_real4(3.0) + call test_real4(33.0) + call test_real4(-3.) + call test_real4(0) + call test_real8(0) + call test_real8(3.0_8) + call test_real8(33.0_8) + call test_real8(-33._8) +end +subroutine test_real4(x) + real x,y,t + integer p + p = 24 + y = 2.0 ** (exponent (x) - p) + t = tiny(x) + x = spacing(x) + if ((abs (x - y) .gt. abs(x * 1e-6)) & + .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort +end + +subroutine test_real8(x) + real*8 x,y,t + integer p + p = 53 + y = 2.0 ** (exponent (x) - p) + t = tiny (x) + x = spacing(x) + if ((abs (x - y) .gt. abs(x * 1e-6)) & + .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 new file mode 100644 index 00000000000..50b66ff6c2b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 @@ -0,0 +1,10 @@ +program foo + integer, dimension (2, 3) :: a + integer, dimension (2, 2, 3) :: b + + a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/)) + b = spread (a, 1, 2) + if (any (b .ne. reshape ((/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6/), & + (/2, 2, 3/)))) & + call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 new file mode 100644 index 00000000000..fe2f978197d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 @@ -0,0 +1,61 @@ +! Program to test SELECTED_REAL_KIND intrinsic function. +Program test_sr_kind + integer res, i4, i8, t + real*4 r4 + real*8 r8 + + i4 = int (log10 (huge (r4))) + t = - int (log10 (tiny (r4))) + if (i4 .gt. t) i4 = t + + i8 = int (log10 (huge (r8))) + t = - int (log10 (tiny (r8))) + if (i8 .gt. t) i8 = t + + res = selected_real_kind (r = i4) + if (res .ne. 4) call abort + + res = selected_real_kind (r = i8) + if (res .ne. 8) call abort + + res = selected_real_kind (r = (i8 + 1)) + if (res .ne. -2) call abort + + res = selected_real_kind (p = precision (r4)) + if (res .ne. 4) call abort + + res = selected_real_kind (p = precision (r4), r = i4) + if (res .ne. 4) call abort + + res = selected_real_kind (p = precision (r4), r = i8) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r4), r = i8 + 1) + if (res .ne. -2) call abort + + res = selected_real_kind (p = precision (r8)) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r8), r = i4) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r8), r = i8) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r8), r = i8 + 1) + if (res .ne. -2) call abort + + res = selected_real_kind (p = (precision (r8) + 1)) + if (res .ne. -1) call abort + + res = selected_real_kind (p = (precision (r8) + 1), r = i4) + if (res .ne. -1) call abort + + res = selected_real_kind (p = (precision (r8) + 1), r = i8) + if (res .ne. -1) call abort + + res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1) + if (res .ne. -3) call abort + +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 new file mode 100644 index 00000000000..43f832ec63c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 @@ -0,0 +1,26 @@ +! Program to test the FORALL construct +program testforall + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m + integer i + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + if (sum(a) .ne. 45) call abort + b = sum (a, 1) + if (b(1) .ne. 6) call abort + if (b(2) .ne. 15) call abort + if (b(3) .ne. 24) call abort + + m = .true. + m(1, 1) = .false. + m(2, 1) = .false. + + if (sum (a, mask=m) .ne. 42) call abort + b = sum (a, 2, m) + if (b(1) .ne. 11) call abort + if (b(2) .ne. 13) call abort + if (b(3) .ne. 18) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 new file mode 100644 index 00000000000..e1f268e310d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 @@ -0,0 +1,24 @@ +! Program to test the transpose intrinsic +program intrinsic_transpose + integer, dimension (3, 3) :: a, b + complex(kind=8), dimension (2, 2) :: c, d + complex(kind=4), dimension (2, 2) :: e + + a = 0 + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = transpose (b) + if (any (a .ne. reshape ((/1, 4, 7, 2, 5, 8, 3, 6, 9/), (/3, 3/)))) & + call abort + c = (0.0, 0.0) + d = reshape ((/(1d0,2d0), (3d0, 4d0), (5d0, 6d0), (7d0, 8d0)/), (/2, 2/)) + c = transpose (d); + if (any (c .ne. reshape ((/(1d0, 2d0), (5d0, 6d0), & + (3d0, 4d0), (7d0, 8d0)/), (/2, 2/)))) & + call abort (); + + e = reshape ((/(1.0,2.0), (3.0, 4.0), (5.0, 6.0), (7.0, 8.0)/), (/2, 2/)) + e = transpose (e); + if (any (e .ne. reshape ((/(1.0, 2.0), (5.0, 6.0), & + (3.0, 4.0), (7.0, 8.0)/), (/2, 2/)))) & + call abort (); +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 new file mode 100644 index 00000000000..90e4131685a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 @@ -0,0 +1,23 @@ +! Program to test the TRIM and REPEAT intrinsics. +program intrinsic_trim + character(len=8) a + character(len=4) b,work + a='1234 ' + b=work(9,a) + if (llt(b,"1234")) call abort() + a=' ' + b=trim(a) + if (b .gt. "") call abort() + b='12' + a=repeat(b,0) + if (a .gt. "") call abort() + a=repeat(b,2) + if (a .ne. "12 12 ") call abort() +end + +function work(i,a) + integer i + character(len=i) a + character(len=4) work + work = trim(a) +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 new file mode 100644 index 00000000000..807aadf136f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 @@ -0,0 +1,17 @@ +! Program to test the UNPACK intrinsic +program intrinsic_unpack + integer, dimension(3, 3) :: a, b + logical, dimension(3, 3) :: mask; + integer i + + mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& + &.false.,.false.,.true./), (/3, 3/)); + a = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b = unpack ((/2, 3, 4/), mask, a) + if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + call abort + b = -1 + b = unpack ((/2, 3, 4/), mask, 0) + if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 new file mode 100644 index 00000000000..040ae72d8e0 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 @@ -0,0 +1,53 @@ +! pr 14942, list directed io + program d + implicit none + integer i, j, m, n, nin, k + real x(3,4) + data x / 1,1,1,2,2,2,3,3,3,4,4,4 / + real y(3,4) + data y / 1,1,1,2,2,2,3,3,3,4,4,4 / + logical debug ! set me true to see the output + debug = .FALSE. + nin = 1 + n = 4 + open(unit = nin) + write(nin,*) n + do I = 1,3 + write(nin,*)(x(i,j), j=1, n) + end do + m = 3 + n = 4 + write(nin,*) m,n + do I = 1,3 + write(nin,*)(x(i,j), j=1, n) + enddo + close(nin) +! ok, the data file is written + open(unit = nin) + read(nin, fmt = *) n + if (debug ) write(*,'(A,I2)') 'n = ', n + do i = 1, 3 + do K = 1,n + x(i,k) = -1 + enddo + read(nin, fmt = *) (x(i,j), j=1, n) + if (debug) write(*, *) (x(i,j), j=1, n) + do K = 1,n + if (x(i,k).ne.y(i,k)) call abort + end do + end do + m = 0 + n = 0 + read(nin, fmt = *) m, n + if (debug) write(*,'(A,I2,2X,A,I2)') 'm = ', m, 'n = ', n + do i = 1, m + do K = 1,n + x(i,k) = -1 + enddo + read(nin, fmt = *) (x(i,j), j=1, n) + if (debug) write(*, *) (x(i,j), j=1, n) + do K = 1,n + if (x(i,k).ne.y(i,k)) call abort + end do + end do + end program d diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 new file mode 100644 index 00000000000..60c077c4347 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 @@ -0,0 +1,55 @@ +LOGICAL :: L = .FALSE. + +SELECT CASE (L) + CASE (.TRUE.) + CALL abort + CASE (.FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.TRUE., .FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.NOT. .TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (.NOT. L) + CASE (.TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (Truth_or_Dare() .OR. L) + CASE (.TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +CONTAINS + + FUNCTION Truth_or_Dare () + LOGICAL Truth_or_Dare + Truth_or_Dare = .TRUE. + END FUNCTION + +END + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 new file mode 100644 index 00000000000..f84e91f2525 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 @@ -0,0 +1,17 @@ +! Program to test compilation of subroutines following the main program +program mainsub + implicit none + integer i + external test + + i = 0 + call test (i) + if (i .ne. 42) call abort +end program + +subroutine test (p) + implicit none + integer p + + p = 42 +end subroutine diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 new file mode 100644 index 00000000000..4f54dcfc7fb --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 @@ -0,0 +1,100 @@ +! Program to test mathematical intrinsics +subroutine dotest (n, val4, val8, known) + implicit none + real(kind=4) val4, known + real(kind=8) val8 + integer n + + if (abs (val4 - known) .gt. 0.001) call abort + if (abs (real (val8, kind=4) - known) .gt. 0.001) call abort +end subroutine + +subroutine dotestc (n, val4, val8, known) + implicit none + complex(kind=4) val4, known + complex(kind=8) val8 + integer n + if (abs (val4 - known) .gt. 0.001) call abort + if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) call abort +end subroutine + +program testmath + implicit none + real(kind=4) r, two4, half4 + real(kind=8) q, two8, half8 + complex(kind=4) cr + complex(kind=8) cq + external dotest, dotest2 + + two4 = 2.0 + two8 = 2.0_8 + half4 = 0.5 + half8 = 0.5_8 + r = sin (two4) + q = sin (two8) + call dotest (1, r, q, 0.9093) + r = cos (two4) + q = cos (two8) + call dotest (2, r, q, -0.4161) + r = tan (two4) + q = tan (two8) + call dotest (3, r, q, -2.1850) + r = asin (half4) + q = asin (half8) + call dotest (4, r, q, 0.5234) + r = acos (half4) + q = acos (half8) + call dotest (5, r, q, 1.0472) + r = atan (half4) + q = atan (half8) + call dotest (6, r, q, 0.4636) + r = atan2 (two4, half4) + q = atan2 (two8, half8) + call dotest (7, r, q, 1.3258) + r = exp (two4) + q = exp (two8) + call dotest (8, r, q, 7.3891) + r = log (two4) + q = log (two8) + call dotest (9, r, q, 0.6931) + r = log10 (two4) + q = log10 (two8) + call dotest (10, r, q, 0.3010) + r = sinh (two4) + q = sinh (two8) + call dotest (11, r, q, 3.6269) + r = cosh (two4) + q = cosh (two8) + call dotest (12, r, q, 3.7622) + r = tanh (two4) + q = tanh (two8) + call dotest (13, r, q, 0.9640) + r = sqrt (two4) + q = sqrt (two8) + call dotest (14, r, q, 1.4142) + + r = atan2 (0.0, 1.0) + q = atan2 (0.0_8, 1.0_8) + call dotest (15, r, q, 0.0) + r = atan2 (-1.0, 1.0) + q = atan2 (-1.0_8, 1.0_8) + call dotest (16, r, q, -0.7854) + r = atan2 (0.0, -1.0) + q = atan2 (0.0_8, -1.0_8) + call dotest (17, r, q, 3.1416) + r = atan2 (-1.0, -1.0) + q = atan2 (-1.0_8, -1.0_8) + call dotest (18, r, q, -2.3562) + r = atan2 (1.0, 0.0) + q = atan2 (1.0_8, 0.0_8) + call dotest (19, r, q, 1.5708) + r = atan2 (-1.0, 0.0) + q = atan2 (-1.0_8, 0.0_8) + call dotest (20, r, q, -1.5708) + + cr = log ((-1.0, -1.0)) + cq = log ((-1.0_8, -1.0_8)) + call dotestc (21, cr, cq, (0.3466, -2.3562)) + +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 new file mode 100644 index 00000000000..86fd7914b4d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 @@ -0,0 +1,39 @@ +! We were incorrectly mangling procedures in interfaces in modules + +module module_interface + interface + subroutine foo () + end subroutine foo + end interface +contains +subroutine cs +end subroutine + +subroutine cproc + interface + subroutine bar () + end subroutine + end interface + call bar () + call foo () + call cs () +end subroutine +end module + +subroutine foo () +end subroutine + +subroutine bar () +end subroutine + +program module_interface_proc + use module_interface + interface + subroutine bar () + end subroutine + end interface + + call cproc () + call foo () + call bar () +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 new file mode 100644 index 00000000000..dba736654c4 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 @@ -0,0 +1,29 @@ +! Test generic interfaces declared in modules. +! We used to get the name mangling wrong for these. +module module_interface_2 + interface foo + subroutine myfoo (i) + integer i + end subroutine + module procedure bar + end interface +contains +subroutine bar (r) + real r + + if (r .ne. 1.0) call abort () +end subroutine +end module + +subroutine myfoo (i) + integer i + + if (i .ne. 42) call abort () +end subroutine + +program test + use module_interface_2 + + call foo (42) + call foo (1.0) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 new file mode 100644 index 00000000000..06fa21614ed --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 @@ -0,0 +1,23 @@ +! Program to test dummy procedures +subroutine bar() +end subroutine + +subroutine foo2(p) + external p + + call p() +end subroutine + +subroutine foo(p) + external p + ! We never actually discover if this is a function or a subroutine + call foo2(p) +end subroutine + +program intrinsic_minmax + implicit none + external bar + + call foo(bar) +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 new file mode 100644 index 00000000000..d2d54562503 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 @@ -0,0 +1,9 @@ +! Program to test array expressions in array constructors. +program nestcons + implicit none + integer, parameter :: w1(3)= (/ 5, 6, 7/) + integer, dimension(6) :: w2 + + w2 = (/ 1, 2, w1(3:1:-1), 3 /) + if (any (w2 .ne. (/ 1, 2, 7, 6, 5, 3/))) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 new file mode 100644 index 00000000000..8a8af73851d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 @@ -0,0 +1,12 @@ +! Program to test array parameter variables. +program parameter_1 + implicit none + integer i + INTEGER, PARAMETER :: ii(10) = (/ (I,I=1,10) /) + REAL, PARAMETER :: rr(10) = ii + + do i = 1, 10 + if (ii(i) /= i) call abort() + if (rr(i) /= i) call abort() + end do +end program parameter_1 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 new file mode 100644 index 00000000000..839ecf02f69 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 @@ -0,0 +1,15 @@ +! Program to test +subroutine test (p) + integer, dimension (3) :: p + + if (any (p .ne. (/ 2, 4, 6/))) call abort +end subroutine + +program partparm + implicit none + integer, dimension (2, 3) :: a + external test + + a = reshape ((/ 1, 2, 3, 4, 5, 6/), (/ 2, 3/)) + call test (a(2, :)) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 new file mode 100644 index 00000000000..7fc3eebb15b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 @@ -0,0 +1,15 @@ +! PR14005 +! The GMP conversion routines object to a leading "+" +program plusconst_1 + implicit none + real p + integer i + data p /+3.1415/ + data i /+42/ + real :: q = +1.234 + integer :: j = +100 + + if ((p .ne. 3.1415) .or. (i .ne. 42) .or. (q .ne. 1.234) .or. (j .ne. 100)) & + call abort +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 new file mode 100644 index 00000000000..91ddc73d3e4 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 @@ -0,0 +1,43 @@ +! Program to test the power (**) operator +program testpow + implicit none + real(kind=4) r, s, two + real(kind=8) :: q + complex(kind=4) :: c + real, parameter :: del = 0.0001 + integer i + + two = 2.0 + + r = two ** 1 + if (abs (r - 2.0) .gt. del) call abort + r = two ** 2 + if (abs (r - 4.0) .gt. del) call abort + r = two ** 3 + if (abs (r - 8.0) .gt. del) call abort + r = two ** 4 + if (abs (r - 16.0) .gt. del) call abort + r = two ** 0 + if (abs (r - 1.0) .gt. del) call abort + r = two ** (-1) + if (abs (r - 0.5) .gt. del) call abort + r = two ** (-2) + if (abs (r - 0.25) .gt. del) call abort + r = two ** (-4) + if (abs (r - 0.0625) .gt. del) call abort + s = 3.0 + r = two ** s + if (abs (r - 8.0) .gt. del) call abort + s = -3.0 + r = two ** s + if (abs (r - 0.125) .gt. del) call abort + i = 3 + r = two ** i + if (abs (r - 8.0) .gt. del) call abort + i = -3 + r = two ** i + if (abs (r - 0.125) .gt. del) call abort + c = (2.0, 3.0) + c = c ** two + if (abs(c - (-5.0, 12.0)) .gt. del) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 new file mode 100644 index 00000000000..37718f5fc43 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 @@ -0,0 +1,29 @@ +! Pogram to test +subroutine myp (a) + implicit none + integer a + + if (a .ne. 42) call abort +end subroutine + +subroutine test2 (p) + implicit none + external p + + call p(42) +end subroutine + +subroutine test (p) + implicit none + external p, test2 + + call p(42) + call test2(p) +end subroutine + +program arrayio + implicit none + external test, myp + + call test (myp) +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 new file mode 100644 index 00000000000..2675f0866c2 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 @@ -0,0 +1,20 @@ +program ptr + implicit none + integer, pointer, dimension(:) :: a, b + integer, pointer :: p + integer, target :: i + + allocate (a(1:6)) + + a = (/ 1, 2, 3, 4, 5, 6 /) + b => a + if (any (b .ne. (/ 1, 2, 3, 4, 5, 6 /))) call abort + b => a(1:6:2) + if (any (b .ne. (/ 1, 3, 5/))) call abort + + p => i + i = 42 + if (p .ne. 42) call abort + p => a(4) + if (p .ne. 4) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 new file mode 100644 index 00000000000..92e454025b5 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 @@ -0,0 +1,5 @@ +! PR 13919, segfault when file is empty + open(unit=8,file='/dev/null') + read(8,*,end=1)i +1 continue + end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 new file mode 100644 index 00000000000..a0bdc97c47d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 @@ -0,0 +1,45 @@ +! Program to test functions returning arrays + +program testfnarray + implicit none + integer, dimension (6, 5) :: a + integer n + +! These first two shouldn't require a temporary. + a = 0 + a = test(6, 5) + if (a(1,1) .ne. 42) call abort + if (a(6,5) .ne. 43) call abort + + a = 0 + a(1:6:2, 2:5) = test2() + if (a(1,2) .ne. 42) call abort + if (a(5,5) .ne. 43) call abort + + a = 1 + ! This requires a temporary + a = test(6, 5) - a + if (a(1,1) .ne. 41) call abort + if (a(6,5) .ne. 42) call abort + + contains + + function test (x, y) + implicit none + integer x, y + integer, dimension (1:x, 1:y) :: test + + test(1, 1) = 42 + test(x, y) = 43 + end function + + function test2 () result (foo) + implicit none + integer, dimension (3, 4) :: foo + + foo(1, 1) = 42 + foo(3, 4) = 43 + end function + +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 new file mode 100644 index 00000000000..ab14dd03caf --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 @@ -0,0 +1,20 @@ +! Procedure to test module procedures returning arrays. +! The array spec only gets applied to the result variable, not the function +! itself. As a result we missed it during resolution, and used the wrong +! calling convention (functions returning arrays must always have explicit +! interfaces). +module retarray_2 +contains + function z(a) result (aout) + integer, dimension(4) :: aout,a + aout = a + end function z +end module retarray_2 + +program retarray + use retarray_2 + integer, dimension(4) :: b, a=(/1,2,3,4/) + b = z(a) + if (any (b .ne. (/1, 2, 3, 4/))) call abort +end + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 new file mode 100644 index 00000000000..63004c82797 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 @@ -0,0 +1,23 @@ +! Program to test the scalarizer +program testarray + implicit none + integer, dimension (6, 5) :: a, b + integer n + + a = 0 + do n = 1, 5 + a(4, n) = n + end do + + b(:, 5:1:-1) = a + a(1:5, 2) = a(4, :) + 1 + + ! The following expression should cause loop reordering + a(:, 2:4) = a(:, 1:3) + + do n = 1, 5 + if (a(n, 3) .ne. (n + 1)) call abort + if (b(4, n) .ne. (6 - n)) call abort + end do +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 new file mode 100644 index 00000000000..608c051d31c --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 @@ -0,0 +1,24 @@ +! Program to test the scalarizer +program testarray + implicit none + integer, dimension (:, :), allocatable :: a, b + integer n + + allocate(a(6, 5), b(6, 5)) + a = 0 + do n = 1, 5 + a(4, n) = n + end do + + b(:, 5:1:-1) = a + a(1:5, 2) = a(4, :) + 1 + + ! The following expression should cause loop reordering + a(:, 2:4) = a(:, 1:3) + + do n = 1, 5 + if (a(n, 3) .ne. (n + 1)) call abort + if (b(4, n) .ne. (6 - n)) call abort + end do +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 new file mode 100644 index 00000000000..76d41484c70 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 @@ -0,0 +1,8 @@ +program foo + integer, dimension(3, 2) :: a + + a = reshape ((/1, 2, 3, 4, 5, 6/), (/3, 2/)) + a = a(3:1:-1, 2:1:-1); + + if (any (a .ne. reshape ((/6, 5, 4, 3, 2, 1/), (/3, 2/)))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 new file mode 100644 index 00000000000..c73d5432a31 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 @@ -0,0 +1,14 @@ +! pr 14762 - '/' not working in format + INTEGER N(5) + DATA N/1,2,3,4,5/ + OPEN(UNIT=7) + 100 FORMAT(I4) + WRITE(7,100)N + CLOSE(7) + OPEN(7) + 200 FORMAT(I4,///I4) + READ(7,200)I,J + CLOSE(7) + IF (I.NE.1) CALL ABORT + IF (J.NE.4) CALL ABORT + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 new file mode 100644 index 00000000000..be8e3f7487b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 @@ -0,0 +1,12 @@ +!pr 14056 + INTRINSIC IABS + INTEGER FF324 + IVCOMP = FF324(IABS,-7) + IF (IVCOMP.NE.8) CALL ABORT + END + INTEGER FUNCTION FF324(NINT, IDON03) + FF324 = NINT(IDON03) + 1 +! **** THE NAME NINT IS A DUMMY ARGUMENT +! AND NOT AN INTRINSIC FUNCTION REFERENCE ***** + RETURN + END diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 new file mode 100644 index 00000000000..d9f3ff0c7b2 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 @@ -0,0 +1,133 @@ +! Program to test intrinsic functions as actual arguments +subroutine test_r(fn, val, res) + real fn + real val, res + + if (diff(fn(val), res)) call abort +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d(fn, val, res) + double precision fn + double precision val, res + + if (diff(fn(val), res)) call abort +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_r2(fn, val1, val2, res) + real fn + real val1, val2, res + + if (diff(fn(val1, val2), res)) call abort +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d2(fn, val1, val2, res) + double precision fn + double precision val1, val2, res + + if (diff(fn(val1, val2), res)) call abort +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_dprod(fn) + if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort +end subroutine + +program specifics + intrinsic abs + intrinsic aint + intrinsic anint + intrinsic acos + intrinsic asin + intrinsic atan + intrinsic cos + intrinsic sin + intrinsic tan + intrinsic cosh + intrinsic sinh + intrinsic tanh + intrinsic alog + intrinsic exp + intrinsic sign + intrinsic amod + + intrinsic dabs + intrinsic dint + intrinsic dnint + intrinsic dacos + intrinsic dasin + intrinsic datan + intrinsic dcos + intrinsic dsin + intrinsic dtan + intrinsic dcosh + intrinsic dsinh + intrinsic dtanh + intrinsic dlog + intrinsic dexp + intrinsic dsign + intrinsic dmod + + intrinsic dprod + + !TODO: Also test complex variants + + call test_r (abs, -1.0, abs(-1.0)) + call test_r (aint, 1.7, 1.0) + call test_r (anint, 1.7, 2.0) + call test_r (acos, 0.5, acos(0.5)) + call test_r (asin, 0.5, asin(0.5)) + call test_r (atan, 0.5, atan(0.5)) + call test_r (cos, 1.0, cos(1.0)) + call test_r (sin, 1.0, sin(1.0)) + call test_r (tan, 1.0, tan(1.0)) + call test_r (cosh, 1.0, cosh(1.0)) + call test_r (sinh, 1.0, sinh(1.0)) + call test_r (tanh, 1.0, tanh(1.0)) + call test_r (alog, 2.0, alog(2.0)) + call test_r (exp, 1.0, exp(1.0)) + call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0)) + call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0)) + + call test_d (dabs, -1d0, abs(-1d0)) + call test_d (dint, 1.7d0, 1d0) + call test_d (dnint, 1.7d0, 2d0) + call test_d (dacos, 0.5d0, dacos(0.5d0)) + call test_d (dasin, 0.5d0, dasin(0.5d0)) + call test_d (datan, 0.5d0, datan(0.5d0)) + call test_d (dcos, 1d0, dcos(1d0)) + call test_d (dsin, 1d0, dsin(1d0)) + call test_d (dtan, 1d0, dtan(1d0)) + call test_d (dcosh, 1d0, dcosh(1d0)) + call test_d (dsinh, 1d0, dsinh(1d0)) + call test_d (dtanh, 1d0, dtanh(1d0)) + call test_d (dlog, 2d0, dlog(2d0)) + call test_d (dexp, 1d0, dexp(1d0)) + call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0)) + call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0)) + + call test_dprod(dprod) +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 new file mode 100644 index 00000000000..8bde9b2f740 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 @@ -0,0 +1,87 @@ +! Program to test STATEMENT function +program st_fuction + call simple_case + call with_function_call + call with_character_dummy + call with_derived_type_dummy + call with_pointer_dummy + call multiple_eval + +contains + subroutine simple_case + integer st1, st2 + integer c(10, 10) + st1 (i, j) = i + j + st2 (i, j) = c(i, j) + + if (st1 (1, 2) .ne. 3) call abort + c = 3 + if (st2 (1, 2) .ne. 3 .or. st2 (2, 3) .ne. 3) call abort + end subroutine + + subroutine with_function_call + integer fun, st3 + st3 (i, j) = fun (i) + fun (j) + + if (st3 (fun (2), 4) .ne. 16) call abort + end subroutine + + subroutine with_character_dummy + character (len=4) s1, s2, st4 + character (len=10) st5, s0 + st4 (i, j) = "0123456789"(i:j) + st5 (s1, s2) = s1 // s2 + + if (st4 (1, 4) .ne. "0123" ) call abort + if (st5 ("01", "02") .ne. "01 02 ") call abort + end subroutine + + subroutine with_derived_type_dummy + type person + integer age + character (len=50) name + end type person + type (person) me, p, tom + type (person) st6 + st6 (p) = p + + me%age = 5 + me%name = "Tom" + tom = st6 (me) + if (tom%age .ne. 5) call abort + if (tom%name .gt. "Tom") call abort + end subroutine + + subroutine with_pointer_dummy + character(len=4), pointer:: p, p1 + character(len=4), target:: i + character(len=6) a + a (p) = p // '10' + + p1 => i + i = '1234' + if (a (p1) .ne. '123410') call abort + end subroutine + + subroutine multiple_eval + integer st7, fun2, fun + + st7(i) = i + fun(i) + + if (st7(fun2(10)) .ne. 3) call abort + end subroutine +end + +! This functon returns the argument passed on the previous call. +integer function fun2 (i) + integer i + integer, save :: val = 1 + + fun2 = val + val = i +end function + +integer function fun (i) + integer i + fun = i * 2 +end function diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 new file mode 100644 index 00000000000..f839c8e36bc --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 @@ -0,0 +1,30 @@ +! Program to test the stack variable size limit. +program stack + call sub1 + call sub2 (1) +contains + + ! Local variables larger than 32768 in byte size shall be placed in static + ! storage area, while others be put on stack by default. + subroutine sub1 + real a, b(32768/4), c(32768/4+1) + integer m, n(1024,4), k(1024,1024) + a = 10.0 + b = 20.0 + c = 30.0 + m = 10 + n = 20 + k = 30 + if ((a .ne. 10.0).or.(b(1) .ne. 20.0).or.(c(1) .ne. 30.0)) call abort + if ((m .ne. 10).or.(n(256,4) .ne. 20).or.(k(1,1024) .ne. 30)) call abort + end + + ! Local variables defined in recursive subroutine are always put on stack. + recursive subroutine sub2 (n) + real a (32769) + a (1) = 42 + if (n .ge. 1) call sub2 (n-1) + if (a(1) .ne. 42) call abort + a (1) = 0 + end +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 new file mode 100644 index 00000000000..579e35a70a4 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 @@ -0,0 +1,18 @@ +! Test assumed length character functions. + +character*(*) function f() + f = "Hello" +end function + +character*6 function g() + g = "World" +end function + +program straret + character*6 f, g + character*12 v + + + v = f() // g() + if (v .ne. "Hello World ") call abort () +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 new file mode 100644 index 00000000000..95e9b038559 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 @@ -0,0 +1,13 @@ +subroutine foo(i) +character c +integer i +character(1),parameter :: hex_chars(0:15)=& + (/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/) + +c = hex_chars(i) +if (c.ne.'3') call abort() +end + +program strarray_1 +call foo(3) +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 new file mode 100644 index 00000000000..dbb3b89e43f --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 @@ -0,0 +1,14 @@ +subroutine foo(i,c) +character c +integer i +character(1),parameter :: hex_chars(0:15)=& + (/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/) + +c = hex_chars(i) +end + +program strarray_2 + character c + call foo(3,c) + if (c.ne.'3') call abort() +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 new file mode 100644 index 00000000000..9d369c7f196 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 @@ -0,0 +1,50 @@ +program strarray_3 + character(len=5), dimension(2) :: c + + c(1) = "Hello" + c(2) = "World" + + call foo1(c) + call foo2(c, 2) + call foo3(c, 5) + call foo4(c, 5, 2) + call foo5(c(2:1:-1)) +contains +subroutine foo1(a) + implicit none + character(len=5), dimension(2) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo2(a, m) + implicit none + integer m + character(len=5), dimension(m) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo3(a, n) + implicit none + integer n + character(len=n), dimension(:) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo4(a, n, m) + implicit none + integer n, m + character(len=n), dimension(m) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo5(a) + implicit none + character(len=2), dimension(5) :: a + + if ((a(1) .ne. "Wo") .or. (a(3) .ne. "dH") .or. (a(5) .ne. "lo")) call abort +end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 new file mode 100644 index 00000000000..c33f4b53d69 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 @@ -0,0 +1,39 @@ +program strarray_4 + character(len=5), dimension(2) :: c + + c(1) = "Hello" + c(2) = "World" + + call foo1(c) + call foo2(c, 2) + call foo3(c, 5, 2) +contains +subroutine foo1(a) + implicit none + character(len=5), dimension(2) :: a + character(len=5), dimension(2) :: b + + b = a; + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine + +subroutine foo2(a, m) + implicit none + integer m + character(len=5), dimension(m) :: a + character(len=5), dimension(m) :: b + + b = a + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine + +subroutine foo3(a, n, m) + implicit none + integer n, m + character(len=n), dimension(m) :: a + character(len=n), dimension(m) :: b + + b = a + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 new file mode 100644 index 00000000000..26980901c7e --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 @@ -0,0 +1,16 @@ +program test + implicit none + character(len=20) :: foo + + foo="hello" + + if (llt(foo, "hello")) call abort + if (.not. lle(foo, "hello")) call abort + if (lgt("hello", foo)) call abort + if (.not. lge("hello", foo)) call abort + + if (.not. llt(foo, "world")) call abort + if (.not. lle(foo, "world")) call abort + if (lgt(foo, "world")) call abort + if (lge(foo, "world")) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 new file mode 100644 index 00000000000..aa51ccf4bae --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 @@ -0,0 +1,28 @@ +! PR14081 character variables in common blocks. + +subroutine test1 + implicit none + common /block/ c + character(len=12) :: c + + if (c .ne. "Hello World") call abort +end subroutine + +subroutine test2 + implicit none + common /block/ a + character(len=6), dimension(2) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +program strcommon_1 + implicit none + common /block/ s, t + character(len=6) :: s, t + s = "Hello " + t = "World " + call test1 + call test2 +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 new file mode 100644 index 00000000000..f220f4a477b --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 @@ -0,0 +1,15 @@ +! Program to test string handling +program string + implicit none + character(len=5) :: a, b + character(len=20) :: c + + a = 'Hello' + b = 'World' + c = a//b + + if (c .ne. 'HelloWorld') call abort + if (c .eq. 'WorldHello') call abort + if (a//'World' .ne. 'HelloWorld') call abort + if (a .ge. b) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 new file mode 100644 index 00000000000..17f9aa277b6 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 @@ -0,0 +1,34 @@ +! Program to test the LEN and LEN_TRIM intrinsics. +subroutine test (c) + character(*) c + character(len(c)) d + + d = c + if (len(d) .ne. 20) call abort + if (d .ne. "Longer Test String") call abort + c = "Hello World" +end subroutine + +subroutine test2 (c) + character (*) c + character(len(c)) d + + d = c + if (len(d) .ne. 6) call abort + if (d .ne. "Foobar") call abort +end subroutine + +program strlen + implicit none + character(20) c + character(5) a, b + integer i + + c = "Longer Test String" + call test (c) + + if (len(c) .ne. 20) call abort + if (len_trim(c) .ne. 11) call abort + + call test2 ("Foobar"); +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 new file mode 100644 index 00000000000..7346fff5df7 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 @@ -0,0 +1,25 @@ +! Program to test caracter string return values +function test () + implicit none + character(len=10) :: test + test = "World" +end function + +function test2 () result (r) + implicit none + character(len=5) :: r + r = "Hello" +end function + +program strret + implicit none + character(len=15) :: s + character(len=10) :: test + character(len=5) :: test2 + + s = test () + if (s .ne. "World") call abort + + s = "Hello " // test () + if (s .ne. test2 () //" World") call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 new file mode 100644 index 00000000000..f2291cd832a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 @@ -0,0 +1,17 @@ +! Program to test handling of reduced rank array sections. This uncovered +! bugs in simplify_shape and the scalarization of array sections. +program test_slice + implicit none + + real (kind = 8), dimension(2, 2, 2) :: x + real (kind = 8) :: min, max + + x = 1.0 + if (minval(x(1, 1:2, 1:1)) .ne. 1.0) call abort () + if (maxval(x(1, 1:2, 1:1)) .ne. 1.0) call abort () + if (any (shape(x(1, 1:2, 1:1)) .ne. (/2, 1/))) call abort () + + if (any (shape(x(1, 1:2, 1)) .ne. (/2/))) call abort () + if (any (shape(x(1:1, 1:2, 1:1)) .ne. (/1, 2, 1/))) call abort () + +end program test_slice diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 new file mode 100644 index 00000000000..d87406ab4db --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 @@ -0,0 +1,13 @@ +! PR 14565 +program unopened_unit_1 + Integer I,J + Do I = 1,10 + Write(99,*)I + End Do + Rewind(99) + Do I = 1,10 + Read(99,*)J + If (J.ne.I) Call abort + End Do +End program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 new file mode 100644 index 00000000000..4fceb476685 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 @@ -0,0 +1,67 @@ +module uops + implicit none + interface operator (.foo.) + module procedure myfoo + end interface + + interface operator (*) + module procedure boolmul + end interface + + interface assignment (=) + module procedure int2bool + end interface + +contains +function myfoo (lhs, rhs) + implicit none + integer myfoo + integer, intent(in) :: lhs, rhs + + myfoo = lhs + rhs +end function + +! This is deliberately different from integer multiplication +function boolmul (lhs, rhs) + implicit none + logical boolmul + logical, intent(IN) :: lhs, rhs + + boolmul = lhs .and. .not. rhs +end function + +subroutine int2bool (lhs, rhs) + implicit none + logical, intent(out) :: lhs + integer, intent(in) :: rhs + + lhs = rhs .ne. 0 +end subroutine +end module + +program me + use uops + implicit none + integer i, j + logical b, c + + b = .true. + c = .true. + if (b * c) call abort + c = .false. + if (.not. (b * c)) call abort + if (c * b) call abort + b = .false. + if (b * c) call abort + + i = 0 + b = i + if (b) call abort + i = 2 + b = i + if (.not. b) call abort + + j = 3 + if ((i .foo. j) .ne. 5) call abort +end program + diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 new file mode 100644 index 00000000000..ba1f8a62579 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 @@ -0,0 +1,41 @@ +! Program to test WHERE inside FORALL +program where_1 + integer :: A(5,5) + + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + ! Where inside FORALL. + ! WHERE masks must be evaluated before executing the assignments + forall (I=1:5) + where (A(I,:) .EQ. 0) + A(:,I) = I + elsewhere (A(I,:) >2) + A(I,:) = 6 + endwhere + end forall + + if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 3, 0, & + 0, 1, 4, 2, 0, 0, 5, 6, 6, 5/), (/5, 5/)))) call abort + + ! Where inside DO + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + do I=1,5 + where (A(I,:) .EQ. 0) + A(:,I) = I + elsewhere (A(I,:) >2) + A(I,:) = 6 + endwhere + enddo + + if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 6, 0, & + 0, 1, 0, 2, 0, 0, 0, 5, 5, 5/), (/5, 5/)))) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 new file mode 100644 index 00000000000..25a8dc9e7a8 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 @@ -0,0 +1,22 @@ +! Program to test the WHERE constructs +program where_2 + integer temp(10), reduce(10) + + temp = 10 + reduce(1:3) = -1 + reduce(4:6) = 0 + reduce(7:8) = 5 + reduce(9:10) = 10 + + WHERE (reduce < 0) + temp = 100 + ELSE WHERE (reduce .EQ. 0) + temp = 200 + temp + ELSE WHERE + WHERE (reduce > 6) temp = temp + sum(reduce) + temp = 300 + temp + END WHERE + + if (any (temp .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) & + call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 new file mode 100644 index 00000000000..a9f7ef7bc08 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 @@ -0,0 +1,21 @@ +! Program to test WHERE on unknown size arrays +program where_3 + integer A(10, 2) + + A = 0 + call sub(A) + +contains + +subroutine sub(B) + integer, dimension(:, :) :: B + + B(1:5, 1) = 0 + B(6:10, 1) = 5 + where (B(:,1)>0) + B(:,1) = B(:,1) + 10 + endwhere + if (any (B .ne. reshape ((/0, 0, 0, 0, 0, 15, 15, 15, 15, 15, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/), (/10, 2/)))) call abort +end subroutine +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 new file mode 100644 index 00000000000..104096b356a --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 @@ -0,0 +1,13 @@ +! Tests WHERE statement with a data dependency +program where_4 + integer, dimension(5) :: a + integer, dimension(5) :: b + + a = (/1, 2, 3, 4, 5/) + b = (/1, 0, 1, 0, 1/) + + where (b .ne. 0) + a(:) = a(5:1:-1) + endwhere + if (any (a .ne. (/5, 2, 3, 4, 1/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 new file mode 100644 index 00000000000..58d24ecbb30 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 @@ -0,0 +1,13 @@ +! Tests WHERE satement with non-integer array in the mask expression +program where_5 + integer, dimension(5) :: a + real(kind=8), dimension(5) :: b + + a = (/1, 2, 3, 4, 5/) + b = (/1d0, 0d0, 1d0, 0d0, 1d0/) + + where (b .ne. 0d0) + a(:) = a(:) + 10 + endwhere + if (any (a .ne. (/11, 2, 13, 4, 15/))) call abort +end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 new file mode 100644 index 00000000000..274598b8d77 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 @@ -0,0 +1,23 @@ +! Program to test WHERE inside FORALL and the WHERE assignment need temporary +program where_6 + integer :: A(5,5) + + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + ! Where inside FORALL. + ! WHERE masks must be evaluated before executing the assignments + m=5 + forall (I=1:4) + where (A(I,:) .EQ. 0) + A(1:m,I) = A(1:m,I+1) + I + elsewhere (A(I,:) >2) + A(I,1:m) = 6 + endwhere + end forall + if (any (A .ne. reshape ((/1,2,6,2,1,0,1,2,1,2,0,1,2,5,0,0,1,6,2,0,0,0,2,& + 6,0/), (/5, 5/)))) call abort +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 new file mode 100644 index 00000000000..4e0060702f3 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 @@ -0,0 +1,23 @@ +! PR 14334, L edit descriptor does not work +! +! this test uses L1 and L4 to print TRUE and FALSE + logical true,false + character*10 b + true = .TRUE. + false = .FALSE. + b = '' + write (b, '(L1)') true + if (b(1:1) .ne. 'T') call abort + + b = '' + write (b, '(L1)') false + if (b(1:1) .ne. 'F') call abort + + b = '' + write(b, '(L4)') true + if (b(1:4) .ne. ' T') call abort + + b = '' + write(b, '(L4)') false + if (b(1:4) .ne. ' F') call abort + end |