diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
30 files changed, 705 insertions, 42 deletions
diff --git a/gcc/testsuite/gfortran.dg/abstract_type_5.f03 b/gcc/testsuite/gfortran.dg/abstract_type_5.f03 new file mode 100644 index 00000000000..a0060f81795 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/abstract_type_5.f03 @@ -0,0 +1,45 @@ +! { dg-do "compile" } + +! Abstract Types. +! Check for correct handling of abstract-typed base object references. + +MODULE m + IMPLICIT NONE + + TYPE, ABSTRACT :: abstract_t + INTEGER :: i + CONTAINS + PROCEDURE, NOPASS :: proc + PROCEDURE, NOPASS :: func + END TYPE abstract_t + + TYPE, EXTENDS(abstract_t) :: concrete_t + END TYPE concrete_t + +CONTAINS + + SUBROUTINE proc () + IMPLICIT NONE + ! Do nothing + END SUBROUTINE proc + + INTEGER FUNCTION func () + IMPLICIT NONE + func = 1234 + END FUNCTION func + + SUBROUTINE test () + IMPLICIT NONE + TYPE(concrete_t) :: obj + + ! These are ok. + obj%abstract_t%i = 42 + CALL obj%proc () + PRINT *, obj%func () + + ! These are errors (even though the procedures are not DEFERRED!). + CALL obj%abstract_t%proc () ! { dg-error "is of ABSTRACT type" } + PRINT *, obj%abstract_t%func () ! { dg-error "is of ABSTRACT type" } + END SUBROUTINE test + +END MODULE m diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_9.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_9.f90 new file mode 100644 index 00000000000..9051bafa019 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_9.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Test the fix for PR39519, where the presence of the pointer +! as the first component was preventing the second from passing +! the "alloc_comp" attribute to the derived type. +! +! Contributed by Gilbert Scott <gilbert.scott@easynet.co.uk> +! +PROGRAM X + TYPE T + INTEGER, POINTER :: P + INTEGER, ALLOCATABLE :: A(:) + END TYPE T + TYPE(T) :: T1,T2 + ALLOCATE ( T1%A(1) ) + ALLOCATE ( T2%A(1) ) + T1%A = 23 + T2 = T1 + T1%A = 42 + if (T2%A(1) .NE. 23) CALL ABORT +END PROGRAM X diff --git a/gcc/testsuite/gfortran.dg/array_constructor_11.f90 b/gcc/testsuite/gfortran.dg/array_constructor_11.f90 index 395d2927b9e..bb9f0dddb11 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_11.f90 +++ b/gcc/testsuite/gfortran.dg/array_constructor_11.f90 @@ -10,20 +10,20 @@ contains call test (1, 11, 3, (/ (i, i = 1, 11, 3) /)) call test (3, 20, 2, (/ (i, i = 3, 20, 2) /)) - call test (4, 0, 11, (/ (i, i = 4, 0, 11) /)) + call test (4, 0, 11, (/ (i, i = 4, 0, 11) /)) ! { dg-warning "will be executed zero times" } call test (110, 10, -3, (/ (i, i = 110, 10, -3) /)) call test (200, 20, -12, (/ (i, i = 200, 20, -12) /)) - call test (29, 30, -6, (/ (i, i = 29, 30, -6) /)) + call test (29, 30, -6, (/ (i, i = 29, 30, -6) /)) ! { dg-warning "will be executed zero times" } call test (1, order, 3, (/ (i, i = 1, order, 3) /)) call test (order, 1, -3, (/ (i, i = order, 1, -3) /)) ! Triggers compile-time iterator calculations in trans-array.c call test (1, 1000, 2, (/ (i, i = 1, 1000, 2), (i, i = order, 0, 1) /)) - call test (1, 0, 3, (/ (i, i = 1, 0, 3), (i, i = order, 0, 1) /)) - call test (1, 2000, -5, (/ (i, i = 1, 2000, -5), (i, i = order, 0, 1) /)) - call test (3000, 99, 4, (/ (i, i = 3000, 99, 4), (i, i = order, 0, 1) /)) + call test (1, 0, 3, (/ (i, i = 1, 0, 3), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } + call test (1, 2000, -5, (/ (i, i = 1, 2000, -5), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } + call test (3000, 99, 4, (/ (i, i = 3000, 99, 4), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } call test (400, 77, -39, (/ (i, i = 400, 77, -39), (i, i = order, 0, 1) /)) do j = -10, 10 diff --git a/gcc/testsuite/gfortran.dg/array_constructor_18.f90 b/gcc/testsuite/gfortran.dg/array_constructor_18.f90 index 246f448063c..c78976839d0 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_18.f90 +++ b/gcc/testsuite/gfortran.dg/array_constructor_18.f90 @@ -5,7 +5,7 @@ ! ! Contributed by Joost VandeVondele <jv244@cam.ac.uk> ! - call foo ((/(S1(i),i=1,3,-1)/)) + call foo ((/(S1(i),i=1,3,-1)/)) ! { dg-warning "will be executed zero times" } CONTAINS FUNCTION S1(i) CHARACTER(LEN=1) :: S1 diff --git a/gcc/testsuite/gfortran.dg/array_constructor_22.f90 b/gcc/testsuite/gfortran.dg/array_constructor_22.f90 index d29039a80e6..0dcdaea68c1 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_22.f90 +++ b/gcc/testsuite/gfortran.dg/array_constructor_22.f90 @@ -7,7 +7,7 @@ module test function my_string(x) integer i real, intent(in) :: x(:) - character(0) h4(1:minval([(1,i=1,0)],1)) + character(0) h4(1:minval([(1,i=1,0)],1)) ! { dg-warning "will be executed zero times" } character(0) sv1(size(x,1):size(h4)) character(0) sv2(2*lbound(sv1,1):size(h4)) character(lbound(sv2,1)-3) my_string diff --git a/gcc/testsuite/gfortran.dg/char_result_13.f90 b/gcc/testsuite/gfortran.dg/char_result_13.f90 new file mode 100644 index 00000000000..741d55f166a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_result_13.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Tests the fix for PR38538, where the character length for the +! argument of 'func' was not calculated. +! +! Contributed by Vivek Rao <vivekrao4@yahoo.com> +! +module abc + implicit none +contains + subroutine xmain (i, j) + integer i, j + call foo (func ("_"//bar (i)//"x"//bar (j)//"x"), "_abcxabx") ! original was elemental + call foo (nfunc("_"//bar (j)//"x"//bar (i)//"x"), "_abxabcx") + end subroutine xmain +! + function bar (i) result(yy) + integer i, j, k + character (len = i) :: yy(2) + do j = 1, size (yy, 1) + do k = 1, i + yy(j)(k:k) = char (96+k) + end do + end do + end function bar +! + elemental function func (yy) result(xy) + character (len = *), intent(in) :: yy + character (len = len (yy)) :: xy + xy = yy + end function func +! + function nfunc (yy) result(xy) + character (len = *), intent(in) :: yy(:) + character (len = len (yy)) :: xy(size (yy)) + xy = yy + end function nfunc +! + subroutine foo(cc, teststr) + character (len=*), intent(in) :: cc(:) + character (len=*), intent(in) :: teststr + if (any (cc .ne. teststr)) call abort + end subroutine foo +end module abc + + use abc + call xmain(3, 2) +end +! { dg-final { cleanup-modules "abc" } } + diff --git a/gcc/testsuite/gfortran.dg/do_1.f90 b/gcc/testsuite/gfortran.dg/do_1.f90 index 20e1f31ca67..171275af3f2 100644 --- a/gcc/testsuite/gfortran.dg/do_1.f90 +++ b/gcc/testsuite/gfortran.dg/do_1.f90 @@ -29,17 +29,17 @@ program do_1 ! Zero iterations j = 0 - do i = 1, 0, 1 + do i = 1, 0, 1 ! { dg-warning "executed zero times" } j = j + 1 end do if (j .ne. 0) call abort j = 0 - do i = 1, 0, 2 + do i = 1, 0, 2 ! { dg-warning "executed zero times" } j = j + 1 end do if (j .ne. 0) call abort j = 0 - do i = 1, 2, -1 + do i = 1, 2, -1 ! { dg-warning "executed zero times" } j = j + 1 end do if (j .ne. 0) call abort diff --git a/gcc/testsuite/gfortran.dg/do_3.F90 b/gcc/testsuite/gfortran.dg/do_3.F90 index 3cada5a0051..67723a508f4 100644 --- a/gcc/testsuite/gfortran.dg/do_3.F90 +++ b/gcc/testsuite/gfortran.dg/do_3.F90 @@ -21,16 +21,16 @@ program test TEST_LOOP(i, 0, 1, 2, 1, test_i, 2) TEST_LOOP(i, 0, 1, 3, 1, test_i, 3) TEST_LOOP(i, 0, 1, huge(0), 1, test_i, huge(0)) - TEST_LOOP(i, 0, 1, -1, 0, test_i, 0) - TEST_LOOP(i, 0, 1, -2, 0, test_i, 0) - TEST_LOOP(i, 0, 1, -3, 0, test_i, 0) - TEST_LOOP(i, 0, 1, -huge(0), 0, test_i, 0) - TEST_LOOP(i, 0, 1, -huge(0)-1, 0, test_i, 0) - - TEST_LOOP(i, 1, 0, 1, 0, test_i, 1) - TEST_LOOP(i, 1, 0, 2, 0, test_i, 1) - TEST_LOOP(i, 1, 0, 3, 0, test_i, 1) - TEST_LOOP(i, 1, 0, huge(0), 0, test_i, 1) + TEST_LOOP(i, 0, 1, -1, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -2, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -3, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -huge(0), 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -huge(0)-1, 0, test_i, 0) ! { dg-warning "executed zero times" } + + TEST_LOOP(i, 1, 0, 1, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, 2, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, 3, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, huge(0), 0, test_i, 1) ! { dg-warning "executed zero times" } TEST_LOOP(i, 1, 0, -1, 2, test_i, -1) TEST_LOOP(i, 1, 0, -2, 1, test_i, -1) TEST_LOOP(i, 1, 0, -3, 1, test_i, -2) @@ -58,14 +58,14 @@ program test TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -huge(i1)-1_1, 2, test_i1, -huge(i1)-2_1) TEST_LOOP(i1, -2_1, 3_1, huge(i1), 1, test_i1, huge(i1)-2_1) - TEST_LOOP(i1, -2_1, 3_1, -huge(i1), 0, test_i1, -2_1) + TEST_LOOP(i1, -2_1, 3_1, -huge(i1), 0, test_i1, -2_1) ! { dg-warning "executed zero times" } TEST_LOOP(i1, 2_1, -3_1, -huge(i1), 1, test_i1, 2_1-huge(i1)) - TEST_LOOP(i1, 2_1, -3_1, huge(i1), 0, test_i1, 2_1) + TEST_LOOP(i1, 2_1, -3_1, huge(i1), 0, test_i1, 2_1) ! { dg-warning "executed zero times" } ! Real loops TEST_LOOP(r, 0.0, 1.0, 0.11, 1 + int(1.0/0.11), test_r, 0.0) - TEST_LOOP(r, 0.0, 1.0, -0.11, 0, test_r, 0.0) - TEST_LOOP(r, 0.0, -1.0, 0.11, 0, test_r, 0.0) + TEST_LOOP(r, 0.0, 1.0, -0.11, 0, test_r, 0.0) ! { dg-warning "executed zero times" } + TEST_LOOP(r, 0.0, -1.0, 0.11, 0, test_r, 0.0) ! { dg-warning "executed zero times" } TEST_LOOP(r, 0.0, -1.0, -0.11, 1 + int(1.0/0.11), test_r, 0.0) TEST_LOOP(r, 0.0, 0.0, 0.11, 1, test_r, 0.0) TEST_LOOP(r, 0.0, 0.0, -0.11, 1, test_r, 0.0) diff --git a/gcc/testsuite/gfortran.dg/do_4.f b/gcc/testsuite/gfortran.dg/do_4.f new file mode 100644 index 00000000000..6d688a0a323 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_4.f @@ -0,0 +1,9 @@ +! { dg-do compile } +! Verify that the loop not terminated on an action-stmt is correctly rejected + do10i=1,20 + if(i.eq.5)then + goto 10 + 10 endif ! { dg-error "is within another block" } + end +! { dg-excess-errors "" } + diff --git a/gcc/testsuite/gfortran.dg/do_check_1.f90 b/gcc/testsuite/gfortran.dg/do_check_1.f90 new file mode 100644 index 00000000000..94d8a848810 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for zero STEP +! +program test + implicit none + integer :: i,j + j = 0 + do i = 1, 40, j + print *, i + end do +end program test +! { dg-output "Fortran runtime error: DO step value is zero" } diff --git a/gcc/testsuite/gfortran.dg/do_check_2.f90 b/gcc/testsuite/gfortran.dg/do_check_2.f90 new file mode 100644 index 00000000000..c40760d2598 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! +program test + implicit none + integer :: i,j + do i = 1, 10 + call modLoopVar(i) + end do +contains + subroutine modLoopVar(i) + integer :: i + i = i + 1 + end subroutine modLoopVar +end program test +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/gcc/testsuite/gfortran.dg/do_check_3.f90 b/gcc/testsuite/gfortran.dg/do_check_3.f90 new file mode 100644 index 00000000000..15086c20a13 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! +program test + implicit none + real :: i, j, k + j = 10.0 + k = 1.0 + do i = 1.0, j, k ! { dg-warning "must be integer" } + call modLoopVar(i) + end do +contains + subroutine modLoopVar(x) + real :: x + x = x + 1 + end subroutine modLoopVar +end program test +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/gcc/testsuite/gfortran.dg/do_check_4.f90 b/gcc/testsuite/gfortran.dg/do_check_4.f90 new file mode 100644 index 00000000000..65bc92c7e1a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_4.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! +PROGRAM test + IMPLICIT NONE + INTEGER :: i + DO i=1,100 + CALL do_something() + ENDDO +CONTAINS + SUBROUTINE do_something() + IMPLICIT NONE + DO i=1,10 + ENDDO + END SUBROUTINE do_something +END PROGRAM test +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/gcc/testsuite/gfortran.dg/do_check_5.f90 b/gcc/testsuite/gfortran.dg/do_check_5.f90 new file mode 100644 index 00000000000..081a228cfc7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_check_5.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR/fortran 38432 +! DO-loop compile-time checks +! +implicit none +integer :: i +real :: r +do i = 1, 0 ! { dg-warning "executed zero times" } +end do + +do i = 1, -1, 1 ! { dg-warning "executed zero times" } +end do + +do i = 1, 2, -1 ! { dg-warning "executed zero times" } +end do + +do i = 1, 2, 0 ! { dg-error "cannot be zero" } +end do + +do r = 1, 0 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, -1, 1 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, 2, -1 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, 2, 0 ! { dg-error "must be integer|cannot be zero" } +end do +end diff --git a/gcc/testsuite/gfortran.dg/fmt_f0_1.f90 b/gcc/testsuite/gfortran.dg/fmt_f0_1.f90 new file mode 100644 index 00000000000..166846b87fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fmt_f0_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run ) +! PR39304 write of 0.0 with F0.3 gives ** +! Test case developed from case provided by reporter. + REAL :: x + CHARACTER(80) :: str + x = 0.0 + write (str,'(f0.0)') x + if (str.ne."0.") call abort + write (str,'(f0.1)') x + if (str.ne."0.0") call abort + write (str,'(f0.2)') x + if (str.ne."0.00") call abort + write (str,'(f0.3)') x + if (str.ne."0.000") call abort + write (str,'(f0.4)') x + if (str.ne."0.0000") call abort + END diff --git a/gcc/testsuite/gfortran.dg/gomp/pr39354.f90 b/gcc/testsuite/gfortran.dg/gomp/pr39354.f90 new file mode 100644 index 00000000000..3b9c327849a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/pr39354.f90 @@ -0,0 +1,37 @@ +! PR fortran/39354 +! { dg-do compile } +! { dg-options "-fopenmp" } + SUBROUTINE ltest(l1, l2, l3, l4, r1, r2, r3, r4) + LOGICAL l1, l2, l3, l4, r1, r2, r3, r4 +!$OMP ATOMIC + l1 = l1 .and. r1 +!$OMP ATOMIC + l2 = l2 .or. r2 +!$OMP ATOMIC + l3 = l3 .eqv. r3 +!$OMP ATOMIC + l4 = l4 .neqv. r4 + END + SUBROUTINE itest(l1, l2, l3, l4, l5, l6, l7, l8, l9, & +& r1, r2, r3, r4, r5, r6, r7, r8, r9) + INTEGER l1, l2, l3, l4, l5, l6, l7, l8, l9, & +& r1, r2, r3, r4, r5, r6, r7, r8, r9 +!$OMP ATOMIC + l1 = l1 + r1 +!$OMP ATOMIC + l2 = l2 - r2 +!$OMP ATOMIC + l3 = l3 * r3 +!$OMP ATOMIC + l4 = l4 / r4 +!$OMP ATOMIC + l5 = max (l5, r1, r5) +!$OMP ATOMIC + l6 = min (r1, r6, l6) +!$OMP ATOMIC + l7 = iand (l7, r7) +!$OMP ATOMIC + l8 = ior (r8, l8) +!$OMP ATOMIC + l9 = ieor (l9, r9) + END diff --git a/gcc/testsuite/gfortran.dg/goto_2.f90 b/gcc/testsuite/gfortran.dg/goto_2.f90 index acff590a9cd..fc5e8d83008 100644 --- a/gcc/testsuite/gfortran.dg/goto_2.f90 +++ b/gcc/testsuite/gfortran.dg/goto_2.f90 @@ -2,51 +2,51 @@ ! Checks for corrects warnings if branching to then end of a ! construct at various nesting levels subroutine check_if(i) - goto 10 + goto 10 ! { dg-warning "Label at ... is not in the same block" } if (i > 0) goto 40 if (i < 0) then goto 40 -10 end if +10 end if ! { dg-warning "Label at ... is not in the same block" } if (i == 0) then i = i+1 - goto 20 ! { dg-warning "jumps to END of construct" } + goto 20 goto 40 -20 end if ! { dg-warning "jumps to END of construct" } +20 end if if (i == 1) then i = i+1 if (i == 2) then - goto 30 ! { dg-warning "jumps to END of construct" } + goto 30 end if goto 40 -30 end if ! { dg-warning "jumps to END of construct" } +30 end if return 40 i = -1 end subroutine check_if subroutine check_select(i) - goto 10 + goto 10 ! { dg-warning "Label at ... is not in the same block" } select case (i) case default goto 999 -10 end select +10 end select ! { dg-warning "Label at ... is not in the same block" } select case (i) case (2) i = 1 - goto 20 ! { dg-warning "jumps to END of construct" } + goto 20 goto 999 case default goto 999 -20 end select ! { dg-warning "jumps to END of construct" } +20 end select j = i select case (j) case default select case (i) case (1) i = 2 - goto 30 ! { dg-warning "jumps to END of construct" } + goto 30 end select goto 999 -30 end select ! { dg-warning "jumps to END of construct" } +30 end select return 999 i = -1 end subroutine check_select diff --git a/gcc/testsuite/gfortran.dg/goto_4.f90 b/gcc/testsuite/gfortran.dg/goto_4.f90 index d48af7240fe..7340814cc01 100644 --- a/gcc/testsuite/gfortran.dg/goto_4.f90 +++ b/gcc/testsuite/gfortran.dg/goto_4.f90 @@ -1,10 +1,11 @@ ! { dg-do run } ! PR 17708: Jumping to END DO statements didn't do the right thing +! PR 38507: The warning we used to give was wrong program test j = 0 do 10 i=1,3 - if(i == 2) goto 10 ! { dg-warning "jumps to END" } + if(i == 2) goto 10 j = j+1 -10 enddo ! { dg-warning "jumps to END" } +10 enddo if (j/=2) call abort end diff --git a/gcc/testsuite/gfortran.dg/goto_5.f90 b/gcc/testsuite/gfortran.dg/goto_5.f90 new file mode 100644 index 00000000000..44ba6972492 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goto_5.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! PR 38507 +! Verify that we correctly flag invalid gotos, while not flagging valid gotos. +integer i,j + +do i=1,10 + goto 20 +20 end do ! { dg-warning "is not in the same block" } + +goto 20 ! { dg-warning "is not in the same block" } +goto 25 ! { dg-warning "is not in the same block" } +goto 40 ! { dg-warning "is not in the same block" } +goto 50 ! { dg-warning "is not in the same block" } + +goto 222 +goto 333 +goto 444 + +222 if (i < 0) then +25 end if ! { dg-warning "is not in the same block" } + +333 if (i > 0) then + do j = 1,20 + goto 30 + end do +else if (i == 0) then + goto 30 +else + goto 30 +30 end if + +444 select case(i) +case(0) + goto 50 + goto 60 ! { dg-warning "is not in the same block" } +case(1) + goto 40 + goto 50 + 40 continue ! { dg-warning "is not in the same block" } + 60 continue ! { dg-warning "is not in the same block" } +50 end select ! { dg-warning "is not in the same block" } +continue + +end diff --git a/gcc/testsuite/gfortran.dg/power1.f90 b/gcc/testsuite/gfortran.dg/power1.f90 new file mode 100644 index 00000000000..50dbac2756d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/power1.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! Test fix for PR fortran/38823. +program power + + implicit none + + integer, parameter :: & + & s = kind(1.e0), & + & d = kind(1.d0), & + & e = max(selected_real_kind(precision(1.d0)+1), d) + + real(s), parameter :: ris = 2.e0_s**2 + real(d), parameter :: rid = 2.e0_d**2 + real(e), parameter :: rie = 2.e0_e**2 + complex(s), parameter :: cis = (2.e0_s,1.e0_s)**2 + complex(d), parameter :: cid = (2.e0_d,1.e0_d)**2 + complex(e), parameter :: cie = (2.e0_e,1.e0_e)**2 + + real(s), parameter :: rrs = 2.e0_s**2.e0 + real(d), parameter :: rrd = 2.e0_d**2.e0 + real(e), parameter :: rre = 2.e0_e**2.e0 + complex(s), parameter :: crs = (2.e0_s,1.e0_s)**2.e0 + complex(d), parameter :: crd = (2.e0_d,1.e0_d)**2.e0 + complex(e), parameter :: cre = (2.e0_e,1.e0_e)**2.e0 + + real(s), parameter :: rds = 2.e0_s**2.e0_d + real(d), parameter :: rdd = 2.e0_d**2.e0_d + real(e), parameter :: rde = 2.e0_e**2.e0_d + complex(s), parameter :: cds = (2.e0_s,1.e0_s)**2.e0_d + complex(d), parameter :: cdd = (2.e0_d,1.e0_d)**2.e0_d + complex(e), parameter :: cde = (2.e0_e,1.e0_e)**2.e0_d + + real(s), parameter :: eps_s = 1.e-5_s + real(d), parameter :: eps_d = 1.e-10_d + real(e), parameter :: eps_e = 1.e-10_e + + if (abs(ris - 4) > eps_s) call abort + if (abs(rid - 4) > eps_d) call abort + if (abs(rie - 4) > eps_e) call abort + if (abs(real(cis, s) - 3) > eps_s .or. abs(aimag(cis) - 4) > eps_s) call abort + if (abs(real(cid, d) - 3) > eps_d .or. abs(aimag(cid) - 4) > eps_d) call abort + if (abs(real(cie, e) - 3) > eps_e .or. abs(aimag(cie) - 4) > eps_e) call abort + + if (abs(rrs - 4) > eps_s) call abort + if (abs(rrd - 4) > eps_d) call abort + if (abs(rre - 4) > eps_e) call abort + if (abs(real(crs, s) - 3) > eps_s .or. abs(aimag(crs) - 4) > eps_s) call abort + if (abs(real(crd, d) - 3) > eps_d .or. abs(aimag(crd) - 4) > eps_d) call abort + if (abs(real(cre, e) - 3) > eps_e .or. abs(aimag(cre) - 4) > eps_e) call abort + + if (abs(rds - 4) > eps_s) call abort + if (abs(rdd - 4) > eps_d) call abort + if (abs(rde - 4) > eps_e) call abort + if (abs(real(cds, s) - 3) > eps_s .or. abs(aimag(cds) - 4) > eps_s) call abort + if (abs(real(cdd, d) - 3) > eps_d .or. abs(aimag(cdd) - 4) > eps_d) call abort + if (abs(real(cde, e) - 3) > eps_e .or. abs(aimag(cde) - 4) > eps_e) call abort + +end program power diff --git a/gcc/testsuite/gfortran.dg/pr39516.f b/gcc/testsuite/gfortran.dg/pr39516.f new file mode 100644 index 00000000000..3d6104a8ebf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39516.f @@ -0,0 +1,20 @@ +C PR tree-optimization/39516 +C { dg-do compile } +C { dg-options "-O2 -ftree-loop-linear" } + SUBROUTINE SUB(A, B, M) + IMPLICIT NONE + DOUBLE PRECISION A(20,20), B(20) + INTEGER*8 I, J, K, M + DO I=1,M + DO J=1,M + A(I,J)=A(I,J)+1 + END DO + END DO + DO K=1,20 + DO I=1,M + DO J=1,M + B(I)=B(I)+A(I,J) + END DO + END DO + END DO + END SUBROUTINE diff --git a/gcc/testsuite/gfortran.dg/read_repeat.f90 b/gcc/testsuite/gfortran.dg/read_repeat.f90 new file mode 100644 index 00000000000..192ebe81ffb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/read_repeat.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR39528 repeated entries not read when using list-directed input. +! Test case derived from reporters example. +program rread + implicit none + integer :: iarr(1:7), ia, ib, i + + iarr = 0 + + write(10,*) " 2*1 3*2 /" + write(10,*) " 12" + write(10,*) " 13" + rewind(10) + + read(10,*) (iarr(i), i=1,7) + read(10,*) ia, ib + + if (any(iarr(1:2).ne.1)) call abort + if (any(iarr(3:5).ne.2)) call abort + if (any(iarr(6:7).ne.0)) call abort + if (ia .ne. 12 .or. ib .ne. 13) call abort + + close(10, status="delete") +end program rread diff --git a/gcc/testsuite/gfortran.dg/recursive_check_7.f90 b/gcc/testsuite/gfortran.dg/recursive_check_7.f90 new file mode 100644 index 00000000000..c1af8adc810 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_check_7.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! { dg-shouldfail "Recursion check" } +! +! PR fortran/32626 +! Recursion run-time check +! + +subroutine NormalFunc() +end subroutine NormalFunc + +recursive subroutine valid(x) + logical :: x + if(x) call sndValid() + print *, 'OK' +end subroutine valid + +subroutine sndValid() + call valid(.false.) +end subroutine sndValid + +subroutine invalid(x) + logical :: x + if(x) call sndInvalid() + print *, 'BUG' + call abort() +end subroutine invalid + +subroutine sndInvalid() + call invalid(.false.) +end subroutine sndInvalid + +call valid(.true.) +call valid(.true.) +call NormalFunc() +call NormalFunc() +call invalid(.true.) +end + +! { dg-output "Fortran runtime error: Recursive call to nonrecursive procedure 'invalid'" } diff --git a/gcc/testsuite/gfortran.dg/trim_1.f90 b/gcc/testsuite/gfortran.dg/trim_1.f90 new file mode 100644 index 00000000000..ac1e1f2032d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/trim_1.f90 @@ -0,0 +1,41 @@ +! { dg-do run } + +! Torture-test TRIM and LEN_TRIM for correctness. + + +! Given a total string length and a trimmed length, construct an +! appropriate string and check gfortran gets it right. + +SUBROUTINE check_trim (full_len, trimmed_len) + IMPLICIT NONE + INTEGER, INTENT(IN) :: full_len, trimmed_len + CHARACTER(LEN=full_len) :: string + + string = "" + IF (trimmed_len > 0) THEN + string(trimmed_len:trimmed_len) = "x" + END IF + + IF (LEN (string) /= full_len & + .OR. LEN_TRIM (string) /= trimmed_len & + .OR. LEN (TRIM (string)) /= trimmed_len & + .OR. TRIM (string) /= string (1:trimmed_len)) THEN + PRINT *, full_len, trimmed_len + PRINT *, LEN (string), LEN_TRIM (string) + CALL abort () + END IF +END SUBROUTINE check_trim + + +! The main program, check with various combinations. + +PROGRAM main + IMPLICIT NONE + INTEGER :: i, j + + DO i = 0, 20 + DO j = 0, i + CALL check_trim (i, j) + END DO + END DO +END PROGRAM main diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_10.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_10.f03 new file mode 100644 index 00000000000..3f372c815f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_10.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for resolution errors with DEFERRED, namely checks about invalid +! overriding and taking into account inherited DEFERRED bindings. +! Also check that DEFERRED attribute is saved to module correctly. + +MODULE m1 + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: def + PROCEDURE, NOPASS :: nodef => realproc + END TYPE abstract_type + +CONTAINS + + SUBROUTINE realproc () + END SUBROUTINE realproc + +END MODULE m1 + +MODULE m2 + USE m1 + IMPLICIT NONE + + TYPE, ABSTRACT, EXTENDS(abstract_type) :: sub_type1 + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: nodef ! { dg-error "must not be DEFERRED" } + END TYPE sub_type1 + + TYPE, EXTENDS(abstract_type) :: sub_type2 ! { dg-error "must be ABSTRACT" } + END TYPE sub_type2 + +END MODULE m2 + +! { dg-final { cleanup-modules "m1" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_11.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_11.f03 new file mode 100644 index 00000000000..fafc149f574 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_11.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! Type-bound procedures +! Test that legal usage of DEFERRED is accepted. + +MODULE testmod + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: p1 + PROCEDURE(realproc), DEFERRED, NOPASS :: p2 + END TYPE abstract_type + + TYPE, EXTENDS(abstract_type) :: sub_type + CONTAINS + PROCEDURE, NOPASS :: p1 => realproc + PROCEDURE, NOPASS :: p2 => realproc + END TYPE sub_type + +CONTAINS + + SUBROUTINE realproc () + END SUBROUTINE realproc + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 index 3eb9687ad02..92adc1a852a 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 @@ -30,10 +30,6 @@ MODULE testmod PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" } PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" } PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" } - - ! TODO: Correct these when things get implemented. - PROCEDURE, DEFERRED :: x ! { dg-error "not yet implemented" } - PROCEDURE(abc) ! { dg-error "not yet implemented" } END TYPE t CONTAINS diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 new file mode 100644 index 00000000000..9106de69579 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for basic parsing errors for invalid DEFERRED. + +MODULE testmod + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE not_abstract + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: proc ! { dg-error "is not ABSTRACT" } + END TYPE not_abstract + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE, DEFERRED :: p2 ! { dg-error "Interface must be specified" } + PROCEDURE(intf), NOPASS :: p3 ! { dg-error "should be declared DEFERRED" } + PROCEDURE(intf), DEFERRED, NON_OVERRIDABLE :: p4 ! { dg-error "can't both" } + PROCEDURE(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|module procedure" } + PROCEDURE(intf), DEFERRED, DEFERRED :: p6 ! { dg-error "Duplicate DEFERRED" } + PROCEDURE(intf), DEFERRED :: p6 => proc ! { dg-error "is invalid for DEFERRED" } + PROCEDURE(), DEFERRED :: p7 ! { dg-error "Interface-name expected" } + PROCEDURE(intf, DEFERRED) :: p8 ! { dg-error "'\\)' expected" } + END TYPE abstract_type + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } diff --git a/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 b/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 new file mode 100644 index 00000000000..e16131502db --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/fast-math-pr38968.f90 @@ -0,0 +1,21 @@ +program mymatmul + implicit none + integer, parameter :: kp = 4 + integer, parameter :: n = 2000 + real(kp), dimension(n,n) :: rr, ri + complex(kp), dimension(n,n) :: a,b,c + real :: t1, t2 + integer :: i, j, k + + do j = 1, n + do k = 1, n + do i = 1, n + c(i,j) = c(i,j) + a(i,k) * b(k,j) + end do + end do + end do + +end program mymatmul + +! { dg-final { scan-tree-dump "vectorized 1 loops" "vect" } } +! { dg-final { cleanup-tree-dump "vect" } } diff --git a/gcc/testsuite/gfortran.dg/vect/pr39318.f90 b/gcc/testsuite/gfortran.dg/vect/pr39318.f90 new file mode 100644 index 00000000000..9e58a17b526 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vect/pr39318.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-c -fopenmp -fexceptions -O2 -ftree-vectorize" } + + subroutine adw_trajsp (F_u,i0,in,j0,jn) + implicit none + real F_u(*) + integer i0,in,j0,jn + integer n,i,j + real*8 xsin(i0:in,j0:jn) +!$omp parallel do private(xsin) + do j=j0,jn + do i=i0,in + xsin(i,j) = sqrt(F_u(n)) + end do + end do +!$omp end parallel do + return + end + +! { dg-final { cleanup-tree-dump "vect" } } + |