Index: Fortran/gfortran/regression/iall_iany_iparity_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iall_iany_iparity_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/38282 +! +implicit none +integer :: a(2,1) + +a(1,1) = 35 +a(2,1) = -74 + +if (iand(a(1,1),a(2,1)) /= iall(a)) STOP 1 +if (iand(a(1,1),a(2,1)) /= iall(array=[35, -74])) STOP 2 +if (any (iand(a(1,1),a(2,1)) /= iall(a,dim=1))) STOP 3 +if (iand(a(1,1),a(2,1)) /= iall(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 4 + +if (ior(a(1,1),a(2,1)) /= iany(a)) STOP 5 +if (ior(a(1,1),a(2,1)) /= iany(array=[35, -74])) STOP 6 +if (any (ior(a(1,1),a(2,1)) /= iany(a,dim=1))) STOP 7 +if (ior(a(1,1),a(2,1)) /= iany(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 8 + +if (ieor(a(1,1),a(2,1)) /= iparity(a)) STOP 9 +if (ieor(a(1,1),a(2,1)) /= iparity(array=[35, -74])) STOP 10 +if (any (ieor(a(1,1),a(2,1)) /= iparity(a,dim=1))) STOP 11 +if (ieor(a(1,1),a(2,1)) /= iparity(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 12 + +end Index: Fortran/gfortran/regression/iall_iany_iparity_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iall_iany_iparity_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/38282 +! +implicit none +integer :: a(2,1) + +a(1,1) = 35 +a(2,1) = -74 + +if (iand(a(1,1),a(2,1)) /= iall(a)) stop 1 ! { dg-error " .iall. at .1. has no IMPLICIT type" } + +if (ior(a(1,1),a(2,1)) /= iany(a)) stop 1 ! { dg-error " .iany. at .1. has no IMPLICIT type" } + +if (ieor(a(1,1),a(2,1)) /= iparity(a)) stop 1 ! { dg-error " .iparity. at .1. has no IMPLICIT type" } + +end Index: Fortran/gfortran/regression/iall_masked.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iall_masked.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR fortran/96890 - Wrong answer with intrinsic IALL +program p + implicit none + integer :: iarr1(0), iarr2(2,2), iarr3(2,2,2) + logical :: mask1(0), mask2(2,2), mask3(2,2,2) + + if ( iall(iarr1, mask1) /= -1 ) stop 1 + if ( iall(iarr1, 1, mask1) /= -1 ) stop 2 + + iarr2 = reshape ([ 1, 2, 3, 4 ], shape (iarr2)) + mask2 = reshape ([ .true., .false., .true., .false. ], shape (mask2)) + + if (any (iall(iarr2, 2, mask2) /= [1,-1]) ) stop 3 + + iarr3 = reshape ([ 1, 2, 3, 4, & + 5, 6, 7, 8 ], shape (iarr3)) + mask3 = reshape ([ .true., .false., .true., .false.,& + .true., .false., .true., .false. ], shape (iarr3)) + + if (any (iall(iarr3, 2, mask3) /= reshape ([1,-1,5,-1],[2,2]))) stop 4 +end Index: Fortran/gfortran/regression/iargc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iargc.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options " -std=f95" } +! PR fortran/20248 +program z + if (iargc() /= 0) STOP 1 +end program z Index: Fortran/gfortran/regression/ibclr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ibclr_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program a + integer :: i = 42 + integer l + l = ibclr(i, -1) ! { dg-error "must be nonnegative" } + l = ibclr(i, 65) ! { dg-error "must be less than" } +end program a Index: Fortran/gfortran/regression/ibits.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ibits.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fallow-invalid-boz" } +! Test that the mask is properly converted to the kind type of j in ibits. +program ibits_test + implicit none + integer(8), parameter :: & + & n = z'00000000FFFFFFFF' ! { dg-warning "BOZ literal constant" } + integer(8) i,j,k,m + j = 1 + do i=1,70 + j = ishft(j,1) + 1 + k = ibits(j, 0, 32) + m = iand(j,n) + if (k /= m) STOP 1 + end do +end program ibits_test + Index: Fortran/gfortran/regression/ibits_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ibits_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/44346 +! Original test sumbitted by Vittorio Zecca, zeccav at gmail dot com. +! Modified by Steven G. Kargl for dejagnu testsuite. +! +program a + integer :: j, i = 42 + j = ibits(i, -1, 1) ! { dg-error "must be nonnegative" } + j = ibits(i, 1, -1) ! { dg-error "must be nonnegative" } + j = ibits(i, 100, 100) ! { dg-error "must be less than" } +end program a + Index: Fortran/gfortran/regression/ibits_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ibits_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bits" } +! PR fortran/108937 - Intrinsic IBITS(I,POS,LEN) fails when LEN equals +! to BIT_SIZE(I) +! Contributed by saitofuyuki@jamstec.go.jp + +program test_bits + implicit none + integer, parameter :: KT = kind (1) + integer, parameter :: lbits = bit_size (0_KT) + integer(kind=KT) :: x, y0, y1 + integer(kind=KT) :: p, l + + x = -1 + p = 0 + do l = 0, lbits + y0 = ibits (x, p, l) + y1 = ibits_1(x, p, l) + if (y0 /= y1) then + print *, l, y0, y1 + stop 1+l + end if + end do +contains + elemental integer(kind=KT) function ibits_1(I, POS, LEN) result(n) + !! IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN) + implicit none + integer(kind=KT),intent(in) :: I + integer, intent(in) :: POS, LEN + n = IAND (ISHFT(I, - POS), NOT(ISHFT(-1_KT, LEN))) + end function ibits_1 +end program test_bits Index: Fortran/gfortran/regression/ibset_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ibset_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program a + integer :: i = 42 + integer l + l = ibset(i, -1) ! { dg-error "must be nonnegative" } + l = ibset(i, 65) ! { dg-error "must be less than" } +end program a Index: Fortran/gfortran/regression/ichar_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ichar_1.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR20879 +! Check that we reject expressions longer than one character for the +! ICHAR and IACHAR intrinsics. + +! Assumed length variables are special because the frontend doesn't have +! an expression for their length +subroutine test (c) + character(len=*) :: c + integer i + i = ichar(c) + i = ichar(c(2:)) + i = ichar(c(:1)) +end subroutine + +program ichar_1 + type derivedtype + character(len=4) :: addr + end type derivedtype + + type derivedtype1 + character(len=1) :: addr + end type derivedtype1 + + integer i + integer, parameter :: j = 2 + character(len=8) :: c = 'abcd' + character(len=1) :: g1(2) + character(len=1) :: g2(2,2) + character*1, parameter :: s1 = 'e' + character*2, parameter :: s2 = 'ef' + type(derivedtype) :: dt + type(derivedtype1) :: dt1 + + if (ichar(c(3:3)) /= 97) STOP 1 + if (ichar(c(:1)) /= 97) STOP 2 + if (ichar(c(j:j)) /= 98) STOP 3 + if (ichar(s1) /= 101) STOP 4 + if (ichar('f') /= 102) STOP 5 + g1(1) = 'a' + if (ichar(g1(1)) /= 97) STOP 6 + if (ichar(g1(1)(:)) /= 97) STOP 7 + g2(1,1) = 'a' + if (ichar(g2(1,1)) /= 97) STOP 8 + + i = ichar(c) ! { dg-error "must be of length one" } + i = ichar(c(:)) ! { dg-error "must be of length one" } + i = ichar(s2) ! { dg-error "must be of length one" } + i = ichar(c(1:2)) ! { dg-error "must be of length one" } + i = ichar(c(1:)) ! { dg-error "must be of length one" } + i = ichar('abc') ! { dg-error "must be of length one" } + + ! ichar and iachar use the same checking routines. DO a couple of tests to + ! make sure it's not totally broken. + + if (ichar(c(3:3)) /= 97) STOP 9 + i = ichar(c) ! { dg-error "must be of length one" } + + i = ichar(dt%addr(1:1)) + i = ichar(dt%addr) ! { dg-error "must be of length one" } + i = ichar(dt%addr(1:2)) ! { dg-error "must be of length one" } + i = ichar(dt%addr(1:)) ! { dg-error "must be of length one" } + + i = ichar(dt1%addr(1:1)) + i = ichar(dt1%addr) + + + call test(g1(1)) +end program ichar_1 Index: Fortran/gfortran/regression/ichar_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ichar_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! Test char and ichar intrinsic functions +Program test +integer i + +if (ichar (char (0)) .ne. 0) STOP 1 +if (ichar (char (255)) .ne. 255) STOP 2 +if (ichar (char (127)) .ne. 127) STOP 3 + +i = 0 +if (ichar (char (i)) .ne. i) STOP 4 +i = 255 +if (ichar (char (i)) .ne. i) STOP 5 +i = 127 +if (ichar (char (i)) .ne. i) STOP 6 +end Index: Fortran/gfortran/regression/ichar_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ichar_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/59599 +! The call to ichar was triggering an ICE. +! +! Original testcase from Fran Martinez Fadrique + +character(1) cpk(2) +integer res(2) +cpk = 'a' +res = ichar( cpk, kind=1 ) +print *, ichar( cpk, kind=1 ) +end Index: Fortran/gfortran/regression/illegal_boz_arg_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/illegal_boz_arg_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +program foo + implicit none + integer :: i = 42 + print *, storage_size(z'1234') ! { dg-error "cannot be an actual" } + print *, transfer(z'1234', i) ! { dg-error "cannot be an actual" } + print *, transfer(i, z'1234') ! { dg-error "cannot be an actual" } + print *, transfer(i, i, z'1234') ! { dg-error "must be INTEGER" } +end program foo Index: Fortran/gfortran/regression/illegal_boz_arg_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/illegal_boz_arg_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/103412 + +program p + integer, parameter :: a = sizeof(z'1') ! { dg-error "cannot be an actual" } +end Index: Fortran/gfortran/regression/illegal_boz_arg_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/illegal_boz_arg_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/103778 + +program p + use iso_c_binding, only : c_sizeof + integer, parameter :: a = c_sizeof(z'1') ! { dg-error "cannot appear" } +end Index: Fortran/gfortran/regression/illegal_boz_arg_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/illegal_boz_arg_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/103413 +! Contributed by G.Steinmetz + +program p + type t + class(*), allocatable :: a + end type + type(t) :: x + allocate (x%a, source=z'1') ! { dg-error "type incompatible" } + allocate (x%a, mold=z'1') ! { dg-error "type incompatible" } +end Index: Fortran/gfortran/regression/illegal_char.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/illegal_char.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 82372 - show hexcode of illegal, non-printable characters +program main + tmp =� 1.0 ! { dg-error "Invalid character 0xC8" } + print *,tmp +end Index: Fortran/gfortran/regression/imag_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/imag_1.f @@ -0,0 +1,11 @@ +! { dg-do compile } + program bug + implicit none + complex(kind=8) z + double precision x,y + z = cmplx(1.e0_8,2.e0_8) + y = imag(z) + y = imagpart(z) + x = realpart(z) + end + Index: Fortran/gfortran/regression/impl_do_var_data.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impl_do_var_data.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 80442 +! This test case used to produce an bogus error +! about the variables being below the lower +! array bounds +program main + implicit none + integer:: i + integer, dimension(3):: A + data (A(i:i+2:i+1), i=1,2) /1, 2, 3/ + if(any(A .ne. [1,3,2])) STOP 1 +end program Index: Fortran/gfortran/regression/implicit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 13575 -- we used to not see that c0 has no type, and then ICE later +module AHFinder_dat +implicit none +save c0 ! { dg-error "no IMPLICIT type" "no IMPLICIT type" } +end module AHFinder_dat +! PR 15978 -- we used to not see that aaa has no type, and then ICE later +implicit none +common/rommel/aaa ! { dg-error "no IMPLICIT type" "no IMPLICIT type" } +end Index: Fortran/gfortran/regression/implicit_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_10.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Check fix for PR24783 where we did try to resolve the implicit type +! from the wrong namespace thus rejecting valid code. + MODULE mod1 + IMPLICIT NONE + CONTAINS + SUBROUTINE sub(vec, ny) + IMPLICIT REAL (a-h,o-z) + IMPLICIT INTEGER (i-n) + DIMENSION vec(ny) + ny = fun(vec(ny),1,1) + RETURN + END SUBROUTINE sub + REAL FUNCTION fun(r1, i1, i2) + IMPLICIT REAL (r,f) + IMPLICIT INTEGER (i) + DIMENSION r1(i1:i2) + r1(i1) = i1 + 1 + r1(i2) = i2 + 1 + fun = r1(i1) + r1(i2) + END FUNCTION fun + END MODULE mod1 + + use mod1 + IMPLICIT REAL (d) + INTEGER i + dimension di(5) + i = 1 + if (fun(di(i),1,2).NE.5) STOP 1 + call sub(di(i),i) + if (i.NE.4) STOP 2 + end Index: Fortran/gfortran/regression/implicit_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_11.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/34760 +! The problem with implict typing is that it is unclear +! whether an existing symbol is a variable or a function. +! Thus it remains long FL_UNKNOWN, which causes extra +! problems; it was failing here since ISTAT was not +! FL_VARIABLE but still FL_UNKNOWN. +! +! Test case contributed by Dick Hendrickson. +! + MODULE TESTS + PRIVATE :: ISTAT + PUBLIC :: ISTAT2 + CONTAINS + SUBROUTINE AD0001 + REAL RLA1(:) + ALLOCATABLE RLA1 + ISTAT = -314 + ALLOCATE (RLA1(NF10), STAT = ISTAT) + ALLOCATE (RLA1(NF10), STAT = ISTAT2) + END SUBROUTINE + END MODULE + + MODULE TESTS2 + PRIVATE :: ISTAT2 + CONTAINS + function istat2() + istat2 = 0 + end function istat2 + SUBROUTINE AD0001 + REAL RLA1(:) + ALLOCATABLE RLA1 + ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "requires an argument list" } + END SUBROUTINE + END MODULE tests2 Index: Fortran/gfortran/regression/implicit_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_12.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR fortran/37400 +! +module mod + implicit character(len=*,kind=kind('A')) (Q) + parameter(Q1 = '12345678') ! len=8 + parameter(Q2 = 'abcdefghijkl') ! len=12 + contains + subroutine sub(Q3) + if(len('#'//Q3//'#') /= 15) STOP 1 + if('#'//Q3//'#' /= '#ABCDEFGHIJKLM#') STOP 2 + end subroutine sub +end module mod +program startest + use mod + implicit none + if(len('#'//Q1//'#') /= 10) STOP 3 + if(len('#'//Q2//'#') /= 14) STOP 4 + if('#'//Q1//'#' /='#12345678#') STOP 5 + if('#'//Q2//'#' /='#abcdefghijkl#') STOP 6 + call sub('ABCDEFGHIJKLM') ! len=13 +end program startest Index: Fortran/gfortran/regression/implicit_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_13.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } + +! PR fortran/35770 +! Implicit declaration hides type of internal function. + +! Contributed by Dick Hendrickson + +IMPLICIT CHARACTER (s) +REAL :: RDA + +RDA = S_REAL_SQRT_I(42) ! { dg-bogus "Can't convert" } + +CONTAINS + +REAL FUNCTION S_REAL_SQRT_I(I) RESULT (R) + IMPLICIT NONE + INTEGER :: I + R = 0.0 +END FUNCTION S_REAL_SQRT_I + +END Index: Fortran/gfortran/regression/implicit_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_14.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Support Fortran 2018's IMPLICIT NONE with spec list +! (currently implemented as vendor extension) + +implicit none (type) ! { dg-error "Fortran 2018: IMPLICIT NONE with spec list at \\(1\\)" } +end Index: Fortran/gfortran/regression/implicit_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_15.f90 @@ -0,0 +1,70 @@ +! { dg-do compile } +! { dg-options "" } +! +! Support Fortran 2015's IMPLICIT NONE with spec list +! + +subroutine sub1 +implicit none (type) +call test() +i = 1 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" } +end subroutine sub1 + +subroutine sub2 +implicit none ( external ) +call foo() ! { dg-error "Procedure 'foo' called at .1. is not explicitly declared" } +i = 2 +end subroutine sub2 + +subroutine sub3 +implicit none ( external, type, external, type ) +call foo() ! { dg-error "Procedure 'foo' called at .1. is not explicitly declared" } +i = 3 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" } +end subroutine sub3 + +subroutine sub4 +implicit none ( external ,type) +external foo +call foo() +i = 4 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" } +end subroutine sub4 + +subroutine sub5 ! OK +implicit integer(a-z) +implicit none ( external ) +procedure() :: foo +call foo() +i = 5 +end subroutine sub5 + +subroutine sub6 ! OK +implicit none ( external ) +implicit integer(a-z) +procedure() :: foo +call foo() +i = 5 +end subroutine sub6 + +subroutine sub7 +implicit none ( external ) +implicit none ! { dg-error "Duplicate IMPLICIT NONE statement" } +end subroutine sub7 + +subroutine sub8 +implicit none +implicit none ( type ) ! { dg-error "Duplicate IMPLICIT NONE statement" } +end subroutine sub8 + +subroutine sub9 +implicit none ( external, type ) +implicit integer(a-z) ! { dg-error "IMPLICIT statement at .1. following an IMPLICIT NONE .type. statement" } +procedure() :: foo +call foo() +end subroutine sub9 + +subroutine sub10 +implicit integer(a-z) +implicit none ( external, type ) ! { dg-error "IMPLICIT NONE .type. statement at .1. following an IMPLICIT statement" } +procedure() :: foo +call foo() +end subroutine sub10 Index: Fortran/gfortran/regression/implicit_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_16.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "" } +! +! Support Fortran 2015's IMPLICIT NONE with empty spec list +! +! And IMPLICIT with ";" followed by an additional statement. +! Contributed by Alan Greynolds +! + +module m + type t + end type t +end module m + +subroutine sub0 +implicit integer (a-h,o-z); parameter (i=0) +end subroutine sub0 + +subroutine sub1 +implicit integer (a-h,o-z)!test +parameter (i=0) +end subroutine sub1 + +subroutine sub2 +use m +implicit type(t) (a-h,o-z); parameter (i=0) +end subroutine sub2 + + +subroutine sub3 +use m +implicit type(t) (a-h,o-z)! Foobar +parameter (i=0) +end subroutine sub3 + +subroutine sub4 +implicit none () +call test() +i = 1 ! { dg-error "Symbol 'i' at .1. has no IMPLICIT type" } +end subroutine sub4 Index: Fortran/gfortran/regression/implicit_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_2.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } + +module implicit_2 + ! This should cause an error if function types are resolved from the + ! module namespace. + implicit none + type t + integer i + end type +contains +! This caused an ICE because we were trying to apply the implicit type +! after we had applied the explicit type. +subroutine test() + implicit type (t) (v) + type (t) v1, v2 + v1%i = 1 + call foo (v2%i) +end subroutine + +! A similar error because we failed to apply the implicit type to a function. +! This is a contained function to check we lookup the type in the function +! namespace, not it's parent. +function f() result (val) + implicit type (t) (v) + + val%i = 1 +end function + +! And again for a result variable. +function fun() + implicit type (t) (f) + + fun%i = 1 +end function + +! intrinsic types are resolved later than derived type, so check those as well. +function test2() + implicit integer (t) + test2 = 42 +end function +subroutine bar() + ! Check that implicit types are applied to names already known to be + ! variables. + implicit type(t) (v) + save v + v%i = 42 +end subroutine +end module Index: Fortran/gfortran/regression/implicit_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Verify that INTERFACEs don't inherit the implicit types of the +! surrounding namespace. +implicit complex (i-k) + +interface + function f(k,l) + ! k should be default INTEGER + dimension l(k) + end function f +end interface +end Index: Fortran/gfortran/regression/implicit_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_4.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Verify error diagnosis for invalid combinations of IMPLICIT statements +IMPLICIT NONE +IMPLICIT NONE ! { dg-error "Duplicate" } +END + +SUBROUTINE a +IMPLICIT REAL(b-j) +implicit none ! { dg-error "IMPLICIT NONE .type. statement at .1. following an IMPLICIT statement" } +END SUBROUTINE a + +subroutine b +implicit none +implicit real(g-k) ! { dg-error "IMPLICIT statement at .1. following an IMPLICIT NONE .type. statement" } +end subroutine b + +subroutine c +implicit real(a-b) +implicit integer (b-c) ! { dg-error "already" } +implicit real(d-f), complex(f-g) ! { dg-error "already" } +end subroutine c Index: Fortran/gfortran/regression/implicit_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_5.f90 @@ -0,0 +1,22 @@ +! PR fortran/21729 +! { dg-do compile } +function f1 () ! { dg-error "has no IMPLICIT type" "f1" } + implicit none +end function f1 +function f2 () result (r2) ! { dg-error "has no IMPLICIT type" "r2" } + implicit none +end function f2 +function f3 () ! { dg-error "has no IMPLICIT type" "f3" } + implicit none +entry e3 () ! { dg-error "has no IMPLICIT type" "e3" } +end function f3 +function f4 () + implicit none + real f4 +entry e4 () ! { dg-error "has no IMPLICIT type" "e4" } +end function f4 +function f5 () ! { dg-error "has no IMPLICIT type" "f5" } + implicit none +entry e5 () + real e5 +end function f5 Index: Fortran/gfortran/regression/implicit_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_6.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR 24643 +! substring references on implicitly typed CHARACTER variables didn't work + PROGRAM P + IMPLICIT CHARACTER*8 (Y) + YLOCAL='A' + YBTABLE=YLOCAL(1:2) + END Index: Fortran/gfortran/regression/implicit_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_7.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 24643 +! This tests a case where the compiler used to ICE in an early +! incarnation of the patch +ylocal=1 +ybtable=ylocal(1:2) ! { dg-error "Unclassifiable" } +end Index: Fortran/gfortran/regression/implicit_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR 24748 + +! The compiler used to crash trying to take a substring of an implicit +! real scalar. +subroutine variant1 + ybtable=ylocal(1:2) ! { dg-error "Syntax error in argument list" } +end + +! We want the behavior to be the same whether ylocal is implicitly +! or explicitly typed. +subroutine variant2 + real ylocal + ybtable=ylocal(1:2) ! { dg-error "Syntax error in argument list" } +end + Index: Fortran/gfortran/regression/implicit_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_9.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Tests patch for PR29373, in which the implicit character +! statement messes up the function declaration because the +! requisite functions in decl.c were told nothing about +! implicit types. +! +! Contributed by Tobias Schlueter +! + implicit character*32 (a-z) + CHARACTER(len=255), DIMENSION(1,2) :: a + +! Reporters original, which triggers another error: +! gfc_todo: Not Implemented: complex character array +! constructors.=> PR29431 +! a = reshape((/ to_string(1.0) /), (/ 1, 2 /)) + + a = to_string(1.0) + print *, a + CONTAINS + CHARACTER*(32) FUNCTION to_string(x) + REAL, INTENT(in) :: x + WRITE(to_string, FMT="(F6.3)") x + END FUNCTION +END PROGRAM Index: Fortran/gfortran/regression/implicit_actual.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_actual.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests patch for problem that was found whilst investigating +! PR24158. The call to foo would cause an ICE because the +! actual argument was of a type that was not defined. The USE +! GLOBAL was commented out, following the fix for PR29364. +! +! Contributed by Paul Thomas +! +module global + type :: t2 + type(t3), pointer :: d ! { dg-error "has not been declared" } + end type t2 +end module global + +program snafu +! use global + implicit type (t3) (z) ! { dg-error "has not been declared" } + + call foo (zin) ! { dg-error "defined|Type mismatch" } + +contains + + subroutine foo (z) + + type :: t3 + integer :: i + end type t3 + + type(t3) :: z + z%i = 1 + + end subroutine foo +end program snafu Index: Fortran/gfortran/regression/implicit_class_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_class_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-skip-if "" { powerpc-ibm-aix* } } +! +! PR 56500: [OOP] "IMPLICIT CLASS(...)" wrongly rejected +! +! Contributed by Reinhold Bader + +! Add dump-fortran-original to check, if the patch preventing a gfortran +! segfault is working correctly. No cleanup needed, because the dump +! goes to stdout. +! { dg-options "-fdump-fortran-original" } +! { dg-allow-blank-lines-in-output 1 } +! { dg-prune-output "Namespace:.*-{42}" } + +program upimp + implicit class(foo) (a-b) + implicit class(*) (c) + type :: foo + integer :: i + end type + allocatable :: aaf, caf + + allocate(aaf, source=foo(2)) + select type (aaf) + type is (foo) + if (aaf%i /= 2) STOP 1 + class default + STOP 2 + end select + + allocate(caf, source=foo(3)) + select type (caf) + type is (foo) + if (caf%i /= 3) STOP 3 + class default + STOP 4 + end select + +contains + subroutine gloo(x) + implicit class(*) (a-z) + end +end program Index: Fortran/gfortran/regression/implicit_derived_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_derived_type_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +! PR fortran/36746 +! Check that parsing of component references for symbols with IMPLICIT +! derived-type works. + +! Reduced test from the PR. +! Contributed by Tobias Burnus + +module m + type t + integer :: i + end type t +contains + subroutine s(x) + implicit type(t)(x) + dimension x(:) + print *, x(1)%i + end subroutine s +end module m Index: Fortran/gfortran/regression/implicit_pure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_1.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! PR fortran/51218 +! +! Contributed by Harald Anlauf +! + +module a + implicit none + integer :: neval = 0 +contains + subroutine inc_eval + neval = neval + 1 + end subroutine inc_eval +end module a + +module b + use a + implicit none +contains + function f(x) ! Should be implicit pure + real :: f + real, intent(in) :: x + f = x + end function f + + function g(x) ! Should NOT be implicit pure + real :: g + real, intent(in) :: x + call inc_eval + g = x + end function g +end module b + +program gfcbug114a + use a + use b + implicit none + real :: x = 1, y = 1, t, u, v, w + if (neval /= 0) STOP 1 + t = f(x)*f(y) + if (neval /= 0) STOP 2 + u = f(x)*f(y) + f(x)*f(y) + if (neval /= 0) STOP 3 + v = g(x)*g(y) + if (neval /= 2) STOP 4 + w = g(x)*g(y) + g(x)*g(y) + if (neval /= 6) STOP 5 + if (t /= 1.0 .or. u /= 2.0 .or. v /= 1.0 .or. w /= 2) STOP 6 +end program gfcbug114a + +! { dg-final { scan-module "b" "IMPLICIT_PURE" } } Index: Fortran/gfortran/regression/implicit_pure_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR 51502 - this was wrongly detected to be implicit pure. +module m + integer :: i +contains + subroutine foo(x) + integer, intent(inout) :: x + outer: block + block + i = 5 + end block + end block outer + end subroutine foo +end module m + +! { dg-final { scan-module-absence "m" "IMPLICIT_PURE" } } Index: Fortran/gfortran/regression/implicit_pure_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_3.f90 @@ -0,0 +1,108 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/54556 +! +! Contributed by Joost VandeVondele +! +MODULE parallel_rng_types + + IMPLICIT NONE + + ! Global parameters in this module + INTEGER, PARAMETER :: dp=8 + + TYPE rng_stream_type + PRIVATE + CHARACTER(LEN=40) :: name + INTEGER :: distribution_type + REAL(KIND=dp), DIMENSION(3,2) :: bg,cg,ig + LOGICAL :: antithetic,extended_precision + REAL(KIND=dp) :: buffer + LOGICAL :: buffer_filled + END TYPE rng_stream_type + + REAL(KIND=dp), DIMENSION(3,3) :: a1p0,a1p76,a1p127,& + a2p0,a2p76,a2p127,& + inv_a1,inv_a2 + + INTEGER, PARAMETER :: GAUSSIAN = 1,& + UNIFORM = 2 + + REAL(KIND=dp), PARAMETER :: norm = 2.328306549295727688e-10_dp,& + m1 = 4294967087.0_dp,& + m2 = 4294944443.0_dp,& + a12 = 1403580.0_dp,& + a13n = 810728.0_dp,& + a21 = 527612.0_dp,& + a23n = 1370589.0_dp,& + two17 = 131072.0_dp,& ! 2**17 + two53 = 9007199254740992.0_dp,& ! 2**53 + fact = 5.9604644775390625e-8_dp ! 1/2**24 + + +CONTAINS + + FUNCTION rn32(rng_stream) RESULT(u) + + TYPE(rng_stream_type), POINTER :: rng_stream + REAL(KIND=dp) :: u + + INTEGER :: k + REAL(KIND=dp) :: p1, p2 + +! ------------------------------------------------------------------------- +! Component 1 + + p1 = a12*rng_stream%cg(2,1) - a13n*rng_stream%cg(1,1) + k = INT(p1/m1) + p1 = p1 - k*m1 + IF (p1 < 0.0_dp) p1 = p1 + m1 + rng_stream%cg(1,1) = rng_stream%cg(2,1) + rng_stream%cg(2,1) = rng_stream%cg(3,1) + rng_stream%cg(3,1) = p1 + + ! Component 2 + + p2 = a21*rng_stream%cg(3,2) - a23n*rng_stream%cg(1,2) + k = INT(p2/m2) + p2 = p2 - k*m2 + IF (p2 < 0.0_dp) p2 = p2 + m2 + rng_stream%cg(1,2) = rng_stream%cg(2,2) + rng_stream%cg(2,2) = rng_stream%cg(3,2) + rng_stream%cg(3,2) = p2 + + ! Combination + + IF (p1 > p2) THEN + u = (p1 - p2)*norm + ELSE + u = (p1 - p2 + m1)*norm + END IF + + IF (rng_stream%antithetic) u = 1.0_dp - u + + END FUNCTION rn32 + +! ***************************************************************************** + FUNCTION rn53(rng_stream) RESULT(u) + + TYPE(rng_stream_type), POINTER :: rng_stream + REAL(KIND=dp) :: u + + u = rn32(rng_stream) + + IF (rng_stream%antithetic) THEN + u = u + (rn32(rng_stream) - 1.0_dp)*fact + IF (u < 0.0_dp) u = u + 1.0_dp + ELSE + u = u + rn32(rng_stream)*fact + IF (u >= 1.0_dp) u = u - 1.0_dp + END IF + + END FUNCTION rn53 + +END MODULE + +! { dg-final { scan-module-absence "parallel_rng_types" "IMPLICIT_PURE" } } +! { dg-final { scan-tree-dump-times "rn32 \\(rng_stream" 3 "optimized" } } Index: Fortran/gfortran/regression/implicit_pure_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/60543 +! PR fortran/60283 +! +module m +contains + REAL(8) FUNCTION random() + CALL RANDOM_NUMBER(random) + END FUNCTION random + REAL(8) FUNCTION random2() + block + block + block + CALL RANDOM_NUMBER(random2) + end block + end block + end block + END FUNCTION random2 +end module m + +! { dg-final { scan-module-absence "m" "IMPLICIT_PURE" } } Index: Fortran/gfortran/regression/implicit_pure_5.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_5.c @@ -0,0 +1,7 @@ +#include + +extern int num_calls; +int side_effect_c() +{ + num_calls ++; +} Index: Fortran/gfortran/regression/implicit_pure_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implicit_pure_5.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-additional-sources implicit_pure_5.c } +! PR fortran/96018 - a wrongly marked implicit_pure +! function caused wrong code. +module wrapper + use, intrinsic :: iso_c_binding, only : c_int + implicit none + integer(kind=c_int), bind(C) :: num_calls +contains + + integer function call_side_effect() result(ierr) + call side_effect(ierr) + end function call_side_effect + + integer function inner_3d(array) result(ierr) + real, intent(in) :: array(:,:,:) + integer dimensions(3) + dimensions = shape(array) + ierr = call_side_effect() + end function inner_3d + + integer function inner_4d(array) result(ierr) + real, intent(in) :: array(:,:,:,:) + integer dimensions(4) + dimensions = shape(array) + ierr = call_side_effect() + end function inner_4d + + subroutine write_3d() + real :: array(1,1,1) + integer ierr + ierr = inner_3d(array) + ierr = call_side_effect() + end subroutine write_3d + + subroutine write_4d() + real array(1,1,1,1) + integer ierr + ierr = inner_4d(array) + ierr = call_side_effect() + end subroutine write_4d + + subroutine side_effect(ierr) + integer, intent(out) :: ierr ! Error code + interface + integer(c_int) function side_effect_c() bind(C,name='side_effect_c') + use, intrinsic :: iso_c_binding, only: c_int + end function side_effect_c + end interface + ierr = side_effect_c() + end subroutine side_effect + +end module wrapper + +program self_contained + use wrapper + implicit none + call write_3d() + if (num_calls /= 2) stop 1 + call write_4d() + if (num_calls /= 4) stop 2 +end program self_contained + Index: Fortran/gfortran/regression/implied_do_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR fortran/29458 - spurious warning for implied do-loop counter + + integer :: n, i + i = 10 + n = 5 + n = SUM((/(i,i=1,n)/)) + + ! 'i' must not be changed + IF (i /= 10) STOP 1 +END Index: Fortran/gfortran/regression/implied_do_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/56667 +program error_message + implicit none + integer :: ir + write(*,*) ( ir, ir = 1,10 ! { dg-error "Expected a right parenthesis" } +end program error_message Index: Fortran/gfortran/regression/implied_do_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Test the fix for PR98458 in which array expressions within the implied-do +! array constructor caused an ICE in trans-array.c(gfc_conv_array_initializer). +! +! Contributed by Xiao Liu +! +program test + implicit none + integer :: i + integer, parameter :: t(6) = [1,2,3,4,5,6] + integer, parameter :: tmp(3,2) = reshape([(t(i:i+1),i=1,3)],[3,2]) + print *, tmp ! Used to ICE +end Index: Fortran/gfortran/regression/implied_do_io_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_1.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! PR/35339 +! This test ensures optimization of implied do loops in io statements + +program main + implicit none + integer:: i, j, square + integer, parameter:: k = 2, linenum = 14 + integer, dimension(2):: a = [(i, i=1,2)] + integer, dimension(2,2):: b = reshape([1, 2, 3, 4], shape(b)) + character (len=30), dimension(linenum) :: res + character (len=30) :: line + type tp + integer, dimension(2):: i + end type + type(tp), dimension(2):: t = [tp([1, 2]), tp([1, 2])] + data res / & + ' a 2 2', & + ' b 1 2', & + ' c 1 2', & + ' d 1 2', & + ' e 1 2 1 2', & + ' f 1 2 1 1 2 2', & + ' g 1 2 3 4', & + ' h 1 3 2 4', & + ' i 2', & + ' j 2', & + ' k 1 2 1 2', & + ' l 1', & + ' m 1 1', & + ' n 1 2'/ + + open(10,file="test.dat") + + write (10,1000) 'a', (a(k), i=1,2) + write (10,1000) 'b', (b(i, 1), i=1,2) + write (10,1000) 'c', b(1:2:1, 1) + write (10,1000) 'd', (a(i), i=1,2) + write (10,1000) 'e', ((a(i), i=1,2), j=1,2) + write (10,1000) 'f', (a, b(i, 1), i = 1,2) + write (10,1000) 'g', ((b(i, j), i=1,2),j=1,2) + write (10,1000) 'h', ((b(j, i), i=1,2),j=1,2) + write (10,1000) 'i', (a(i+1), i=1,1) + write (10,1000) 'j', (a(i*2), i=1,1) + write (10,1000) 'k', (a(i), i=1,2), (a(i), i=1,2) + write (10,1000) 'l', (a(i), i=1,1) + write (10,1000) 'm', (1, i=1,2) + write (10,1000) 'n', (t(i)%i(i), i=1,2) + rewind (10) + do i=1,linenum + read (10,'(A)') line + if (line .ne. res(i)) STOP 1 + end do + close(10,status="delete") +1000 format (A2,100I4) +end program main + +! { dg-final { scan-tree-dump-times "(?n)^\\s*while \\(1\\)$" 7 "original" } } Index: Fortran/gfortran/regression/implied_do_io_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! Test that allocatable characters with deferred length +! are written correctly +program main + implicit none + integer:: i + integer, parameter:: N = 10 + character(len=:), dimension(:),allocatable:: ca + character(len=50):: buffer, line + allocate(character(len=N):: ca(3)) + buffer = "foo bar xyzzy" + ca(1) = "foo" + ca(2) = "bar" + ca(3) = "xyzzy" + write (unit=line, fmt='(3A5)') (ca(i),i=1,3) + if (line /= buffer) STOP 1 + ca(1) = "" + ca(2) = "" + ca(3) = "" + read (unit=line, fmt='(3A5)') (ca(i),i=1,3) + if (line /= buffer) STOP 2 +end program + Index: Fortran/gfortran/regression/implied_do_io_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_3.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 80988 - implied do loops with diagonal elements +! were not written correctly +program main + implicit none + integer :: i,j,k + integer, dimension(3,3) :: a + integer, dimension(3,3,3) :: b + character(len=40) :: line + a = reshape([(((i*10+j),i=1,3),j=1,3)], shape(a)) + i = 2147483548 + write (unit=line,fmt='(10I3)') (a(i,i),i=1,3) + if (line /= ' 11 22 33') STOP 1 + write (unit=line,fmt='(10I3)') (a(i+1,i+1),i=1,2) + if (line /= ' 22 33') STOP 2 + do k=1,3 + do j=1,3 + do i=1,3 + b(i,j,k) = i*100 + j*10 + k + end do + end do + end do + i = -2147483548 + write (unit=line,fmt='(10I4)') ((b(i,j,i),i=1,3),j=1,3) + if (line /= ' 111 212 313 121 222 323 131 232 333') STOP 3 +end program main Index: Fortran/gfortran/regression/implied_do_io_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-additional-options "-ffrontend-optimize -fdump-tree-original" } +! PR fortran/35339 - make sure that I/O of an implied DO loop +! of allocatable character arrays a) works and b) is converted +! to a transfer_array +program main + implicit none + integer:: i + integer, parameter:: N = 10 + character(len=:), dimension(:),allocatable:: ca + allocate(character(len=N):: ca(3)) + open(unit=10,status="scratch") + ca(1) = "foo" + ca(2) = "bar" + ca(3) = "xyzzy" + write (10, '(3A10)') (ca(i),i=1,3) + rewind (10) + ca(:) = '' + read (10, '(3A10)') (ca(i),i=1,3) + if (ca(1) /= 'foo' .or. ca(2) /= 'bar' .or. ca(3) /= 'xyzzy') call abort +end program +! { dg-final { scan-tree-dump-times "_gfortran_transfer_array" 2 "original" } } Index: Fortran/gfortran/regression/implied_do_io_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_5.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-additional-options "-ffrontend-optimize" } +! PR fortran/85387 - incorrect output +! Original test case by Vittorio Zecca +program main + real :: efg_pw(2,2) + character (len=80) :: c1, c2 + efg_pw(1,1)=1 + efg_pw(2,1)=2 + efg_pw(1,2)=3 + efg_pw(2,2)=4 + write (unit=c1,fmt='(3F12.5)') ((efg_pw(i, j), i=1, j), j=1, 2) + write (unit=c2,fmt='(3F12.5)') 1.0, 3.0, 4.0 + if (c1 /= c2) stop 1 +end Index: Fortran/gfortran/regression/implied_do_io_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_6.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 86837 - this was mis-optimized by trying to turn this into an +! array I/O statement. +! Original test case by "Pascal". + +Program read_loop + + implicit none + + integer :: i, j + + ! number of values per column + integer, dimension(3) :: nvalues + data nvalues / 1, 2, 4 / + + ! values in a 1D array + real, dimension(7) :: one_d + data one_d / 1, 11, 12, 21, 22, 23, 24 / + + ! where to store the data back + real, dimension(4, 3) :: two_d + + ! 1 - write our 7 values in one block + open(unit=10, file="loop.dta", form="unformatted") + write(10) one_d + close(unit=10) + + ! 2 - read them back in chosen cells of a 2D array + two_d = -9 + open(unit=10, file="loop.dta", form="unformatted", status='old') + read(10) ((two_d(i,j), i=1,nvalues(j)), j=1,3) + close(unit=10, status='delete') + + ! 4 - print the whole array, just in case + + if (any(reshape(two_d,[12]) /= [1.,-9.,-9.,-9.,11.,12.,-9.,-9.,21.,22.,23.,24.])) call abort + +end Program read_loop Index: Fortran/gfortran/regression/implied_do_io_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_do_io_7.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 100227 - this was falsely optimized, leading to nonsense results. +! Original test case by "Mathieu". + +program p + implicit none + integer, parameter :: nbmode = 3 + integer :: k + real :: mass(nbmode*2) + character (len=80) :: line + do k = 1, nbmode*2 + mass(k) = k + end do + write (unit=line,fmt='(*(F6.2))') (mass(k+k), k=1,nbmode) + if (line /= ' 2.00 4.00 6.00') stop 1 +end program Index: Fortran/gfortran/regression/implied_shape_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_shape_1.f08 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! Test for correct semantics of implied-shape arrays. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + INTEGER, PARAMETER :: n = 3 + + ! Should be able to reduce complex expressions. + REAL, PARAMETER :: arr1(n:*) = SQRT ((/ 1.0, 2.0, 3.0 /)) + 42 + + ! With dimension statement. + REAL, DIMENSION(*), PARAMETER :: arr2 = arr1 + + ! Rank > 1. + INTEGER, PARAMETER :: arr3(n:*, *) = RESHAPE ((/ 1, 2, 3, 4 /), (/ 2, 2/)) + + ! Character array. + CHARACTER(LEN=*), PARAMETER :: arr4(*) = (/ CHARACTER(LEN=3) :: "ab", "cde" /) + + IF (LBOUND (arr1, 1) /= n .OR. UBOUND (arr1, 1) /= n + 2) STOP 1 + IF (SIZE (arr1) /= 3) STOP 2 + + IF (LBOUND (arr2, 1) /= 1 .OR. UBOUND (arr2, 1) /= 3) STOP 3 + IF (SIZE (arr2) /= 3) STOP 4 + + IF (ANY (LBOUND (arr3) /= (/ n, 1 /) .OR. UBOUND (arr3) /= (/ n + 1, 2 /))) & + STOP 5 + IF (SIZE (arr3) /= 4) STOP 6 + + IF (LBOUND (arr4, 1) /= 1 .OR. UBOUND (arr4, 1) /= 2) STOP 7 + IF (SIZE (arr4) /= 2) STOP 8 +END PROGRAM main Index: Fortran/gfortran/regression/implied_shape_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_shape_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Test for rejection of implied-shape prior to Fortran 2008. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, PARAMETER :: arr(*) = (/ 2, 3, 4 /) ! { dg-error "Fortran 2008" } +END PROGRAM main Index: Fortran/gfortran/regression/implied_shape_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_shape_3.f08 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! Test for errors with implied-shape declarations. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + INTEGER :: n + INTEGER, PARAMETER :: mat(2, 2) = RESHAPE ((/ 1, 2, 3, 4 /), (/ 2, 2 /)) + + ! Malformed declaration. + INTEGER, PARAMETER :: arr1(*, *, 5) = mat ! { dg-error "Bad array specification for implied-shape array" } + + ! Rank mismatch in initialization. + INTEGER, PARAMETER :: arr2(*, *) = (/ 1, 2, 3, 4 /) ! { dg-error "Incompatible ranks" } + + ! Non-PARAMETER implied-shape, with and without initializer. + INTEGER :: arr3(*, *) ! { dg-error "Non-PARAMETER" } + INTEGER :: arr4(*, *) = mat ! { dg-error "Non-PARAMETER" } + + ! Missing initializer. + INTEGER, PARAMETER :: arr5(*) ! { dg-error "is missing an initializer" } + + ! Initialization from scalar. + INTEGER, PARAMETER :: arr6(*) = 0 ! { dg-error "with scalar" } + + ! Automatic bounds. + n = 2 + BLOCK + INTEGER, PARAMETER :: arr7(n:*) = (/ 2, 3, 4 /) ! { dg-error "Non-constant lower bound" } + END BLOCK +END PROGRAM main Index: Fortran/gfortran/regression/implied_shape_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_shape_4.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-additional-options "-std=f2008" } +! +! PR fortran/68020 +! +! Contributed by Gerhard Steinmetz +! +subroutine rank_1_2 + integer, parameter :: a(1, 2) = 0 + integer, parameter :: x(*, *) = a + integer, parameter :: y(11:*, 12:*) = a + integer :: k + if (any (lbound(x) /= [1,1])) stop 1 + if (any (ubound(x) /= [1,2])) stop 2 + if (any (lbound(y) /= [11,12])) stop 3 + if (any (ubound(y) /= [11,13])) stop 4 +end + +subroutine rank_3 + integer, parameter :: a(1, 2, 3) = 0 + integer, parameter :: x(*, *, *) = a + integer, parameter :: y(11:*, 12:*, 13:*) = a + integer :: k + if (any (lbound(x) /= [1,1,1])) stop 5 + if (any (ubound(x) /= [1,2,3])) stop 6 + if (any (lbound(y) /= [11,12,13])) stop 7 + if (any (ubound(y) /= [11,13,15])) stop 8 +end + +subroutine rank_4 + integer, parameter :: a(1, 2, 3, 4) = 0 + integer, parameter :: x(*, *, *, *) = a + integer, parameter :: y(11:*, 12:*, 13:*, 14:*) = a + integer :: k + if (any (lbound(x) /= [1,1,1,1])) stop 9 + if (any (ubound(x) /= [1,2,3,4])) stop 10 + if (any (lbound(y) /= [11,12,13,14])) stop 11 + if (any (ubound(y) /= [11,13,15,17])) stop 12 +end + +program p + call rank_1_2 + call rank_3 + call rank_4 +end program p Index: Fortran/gfortran/regression/implied_shape_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/implied_shape_5.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/68020 +! +! Reject mixing explicit-shape and implied-shape arrays +! +subroutine rank_1_2 + integer, parameter :: a(1, 2) = 0 + integer, parameter :: y(11:11, 12:*) = a ! { dg-error "Assumed size array at .1. must be a dummy argument" } + integer, parameter :: x(:, *) = a ! { dg-error "Bad specification for deferred shape array" } +end + +subroutine rank_3 + integer, parameter :: a(1, 2, 3) = 0 + integer, parameter :: y(11:*, 12:14, 13:*) = a ! { dg-error "Bad specification for assumed size array" } + integer, parameter :: x(11:*, :, 13:*) = a ! { dg-error "Bad specification for assumed size array" } +end + +subroutine rank_4 + integer, parameter :: a(1, 2, 3, 4) = 0 + integer, parameter :: y(11:*, 12:*, 13:*, 14:17) = a ! { dg-error "Bad array specification for implied-shape array" } + integer, parameter :: y(11:*, 12:*, 13:*, 14:) = a ! { dg-error "Bad array specification for implied-shape array" } +end + +program p + call rank_1_2 + call rank_3 + call rank_4 +end program p Index: Fortran/gfortran/regression/import.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! Test whether import works +! PR fortran/29601 + +subroutine test(x) + type myType3 + sequence + integer :: i + end type myType3 + type(myType3) :: x + if(x%i /= 7) STOP 1 + x%i = 1 +end subroutine test + + +subroutine bar(x,y) + type myType + sequence + integer :: i + end type myType + type(myType) :: x + integer(8) :: y + if(y /= 8) STOP 2 + if(x%i /= 2) STOP 3 + x%i = 5 + y = 42 +end subroutine bar + +module testmod + implicit none + integer, parameter :: kind = 8 + type modType + real :: rv + end type modType + interface + subroutine other(x,y) + import + real(kind) :: x + type(modType) :: y + end subroutine + end interface +end module testmod + +program foo + integer, parameter :: dp = 8 + type myType + sequence + integer :: i + end type myType + type myType3 + sequence + integer :: i + end type myType3 + interface + subroutine bar(x,y) + import + type(myType) :: x + integer(dp) :: y + end subroutine bar + subroutine test(x) + import :: myType3 + import myType3 ! { dg-warning "already IMPORTed from" } + type(myType3) :: x + end subroutine test + end interface + + type(myType) :: y + type(myType3) :: z + integer(8) :: i8 + y%i = 2 + i8 = 8 + call bar(y,i8) + if(y%i /= 5 .or. i8/= 42) STOP 4 + z%i = 7 + call test(z) + if(z%i /= 1) STOP 5 +end program foo Index: Fortran/gfortran/regression/import10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import10.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/53537 +! The use of WP in the ODE_DERIVATIVE interface used to be rejected because +! the symbol was imported under the original name DP. +! +! Original test case from Arjen Markus + +module select_precision + integer, parameter :: dp = kind(1.0) +end module select_precision + +module ode_types + use select_precision, only: wp => dp + implicit none + interface + subroutine ode_derivative(x) + import :: wp + real(wp) :: x + end subroutine ode_derivative + end interface +end module ode_types + + Index: Fortran/gfortran/regression/import11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import11.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/53537 +! The definition of T1 in the interface used to be rejected because T3 +! was imported under the original name T1. + + MODULE MOD + TYPE T1 + SEQUENCE + integer :: j + END TYPE t1 + END + PROGRAM MAIN + USE MOD, T3 => T1 + INTERFACE SUBR + SUBROUTINE SUBR1(X,y) + IMPORT :: T3 + type t1 +! sequence +! integer :: i + end type t1 + TYPE(T3) X +! TYPE(T1) X + END SUBROUTINE + END INTERFACE SUBR + END PROGRAM MAIN + + Index: Fortran/gfortran/regression/import2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! { dg-shouldfail "Fortran 2003 feature with -std=f95" } +! Test whether import does not work with -std=f95 +! PR fortran/29601 + +module testmod + implicit none + integer, parameter :: kind = 8 + type modType + real :: rv + end type modType + interface + subroutine other(x,y) + import ! { dg-error "Fortran 2003: IMPORT statement" } + type(modType) :: y ! { dg-error "is being used before it is defined" } + real(kind) :: x ! { dg-error "has not been declared" } + end subroutine + end interface +end module testmod + +program foo + integer, parameter :: dp = 8 + type myType + sequence + integer :: i + end type myType + type myType3 + sequence + integer :: i + end type myType3 + interface + subroutine bar(x,y) + import ! { dg-error "Fortran 2003: IMPORT statement" } + type(myType) :: x ! { dg-error "is being used before it is defined" } + integer(dp) :: y ! { dg-error "has not been declared" } + end subroutine bar + subroutine test(x) + import :: myType3 ! { dg-error "Fortran 2003: IMPORT statement" } + import myType3 ! { dg-error "Fortran 2003: IMPORT statement" } + type(myType3) :: x ! { dg-error "is being used before it is defined" } + end subroutine test + end interface + +end program foo Index: Fortran/gfortran/regression/import3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import3.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-shouldfail "Invalid use of IMPORT" } +! Test invalid uses of import +! PR fortran/29601 + +subroutine test() + type myType3 + import ! { dg-error "only permitted in an INTERFACE body" } + sequence + integer :: i + end type myType3 +end subroutine test + +program foo + import ! { dg-error "only permitted in an INTERFACE body" } + type myType + sequence + integer :: i + end type myType + type myType3 + sequence + integer :: i + end type myType3 + interface + import ! { dg-error "only permitted in an INTERFACE body" } + subroutine bar() + import foob ! { dg-error "Cannot IMPORT 'foob' from host scoping unit" } + end subroutine bar + subroutine test() + import :: ! { dg-error "Expecting list of named entities" } + end subroutine test + end interface +end program foo Index: Fortran/gfortran/regression/import4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import4.f90 @@ -0,0 +1,98 @@ +! { dg-do run } +! Test for import in modules +! PR fortran/29601 + +subroutine bar(r) + implicit none + integer(8) :: r + if(r /= 42) STOP 1 + r = 13 +end subroutine bar + +subroutine foo(a) + implicit none + type myT + sequence + character(len=3) :: c + end type myT + type(myT) :: a + if(a%c /= "xyz") STOP 2 + a%c = "abc" +end subroutine + +subroutine new(a,b) + implicit none + type gType + sequence + integer(8) :: c + end type gType + real(8) :: a + type(gType) :: b + if(a /= 99.0 .or. b%c /= 11) STOP 3 + a = -123.0 + b%c = -44 +end subroutine new + +module general + implicit none + integer,parameter :: ikind = 8 + type gType + sequence + integer(ikind) :: c + end type gType +end module general + +module modtest + use general + implicit none + type myT + sequence + character(len=3) :: c + end type myT + integer, parameter :: dp = 8 + interface + subroutine bar(x) + import :: dp + integer(dp) :: x + end subroutine bar + subroutine foo(c) + import :: myT + type(myT) :: c + end subroutine foo + subroutine new(x,y) + import :: ikind,gType + real(ikind) :: x + type(gType) :: y + end subroutine new + end interface + contains + subroutine test + integer(dp) :: y + y = 42 + call bar(y) + if(y /= 13) STOP 4 + end subroutine test + subroutine test2() + type(myT) :: z + z%c = "xyz" + call foo(z) + if(z%c /= "abc") STOP 5 + end subroutine test2 +end module modtest + +program all + use modtest + implicit none + call test() + call test2() + call test3() +contains + subroutine test3() + real(ikind) :: r + type(gType) :: t + r = 99.0 + t%c = 11 + call new(r,t) + if(r /= -123.0 .or. t%c /= -44) STOP 6 + end subroutine test3 +end program all Index: Fortran/gfortran/regression/import5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import5.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! Test for import in interfaces PR fortran/30922 +! +! Contributed by Tobias Burnus +! +module test_import + implicit none + + type :: my_type + integer :: data + end type my_type + integer, parameter :: n = 20 + + interface + integer function func1(param) + import + type(my_type) :: param(n) + end function func1 + + integer function func2(param) + import :: my_type + type(my_type), value :: param + end function func2 + end interface + +contains + + subroutine sub1 () + + interface + integer function func3(param) + import + type(my_type), dimension (n) :: param + end function func3 + + integer function func4(param) + import :: my_type, n + type(my_type), dimension (n) :: param + end function func4 + end interface + + end subroutine sub1 +end module test_import Index: Fortran/gfortran/regression/import6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import6.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! Tests the fix for PR32827, in which IMPORT :: my_type put the +! symbol into the interface namespace, thereby generating an error +! when the declaration of 'x' is compiled. +! +! Contributed by Douglas Wells +! +subroutine func1(param) + type :: my_type + sequence + integer :: data + end type my_type + type(my_type) :: param + param%data = 99 +end subroutine func1 + +subroutine func2(param) + type :: my_type + sequence + integer :: data + end type my_type + type(my_type) :: param + param%data = 21 +end subroutine func2 + + type :: my_type + sequence + integer :: data + end type my_type + + interface + subroutine func1(param) + import :: my_type + type(my_type) :: param + end subroutine func1 + end interface + interface + subroutine func2(param) + import + type(my_type) :: param + end subroutine func2 + end interface + + type(my_type) :: x + call func1(x) + print *, x%data + call func2(x) + print *, x%data +end Index: Fortran/gfortran/regression/import7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import7.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! +! PR39688: IMPORT of derived type fails +! +! Contributed by Bob Corbett + + MODULE MOD + TYPE T1 + SEQUENCE + TYPE(T2), POINTER :: P + END TYPE + TYPE T2 + SEQUENCE + INTEGER I + END TYPE + END + + PROGRAM MAIN + USE MOD, T3 => T1, T4 => T2 + TYPE T1 + SEQUENCE + TYPE(T2), POINTER :: P + END TYPE + INTERFACE SUBR + SUBROUTINE SUBR1(X) + IMPORT T3 + TYPE(T3) X + END SUBROUTINE + SUBROUTINE SUBR2(X) + IMPORT T1 + TYPE(T1) X + END SUBROUTINE + END INTERFACE + TYPE T2 + SEQUENCE + REAL X + END TYPE + END + + SUBROUTINE SUBR1(X) + USE MOD + TYPE(T1) X + END + + SUBROUTINE SUBR2(X) + TYPE T1 + SEQUENCE + TYPE(T2), POINTER :: P + END TYPE + TYPE T2 + SEQUENCE + REAL X + END TYPE + TYPE(T1) X + END Index: Fortran/gfortran/regression/import8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/44614 +! +! + +implicit none + +type, abstract :: Connection +end type Connection + +abstract interface + subroutine generic_desc(self) + ! <<< missing IMPORT + class(Connection) :: self ! { dg-error "is being used before it is defined" } + end subroutine generic_desc +end interface +end Index: Fortran/gfortran/regression/import9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/import9.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR fortran/48821 +! +! Contributed by Daniel Carrera +! + +contains + pure subroutine rk4_vec(t, Y, dY, h) + real, intent(inout) :: t, Y(:) + real, intent(in) :: h + real, dimension(size(Y)) :: k1, k2, k3, k4 + + interface + pure function dY(t0, y0) + import :: Y + real, intent(in) :: t0, y0(size(Y)) + real :: dY(size(y0)) + end function + end interface + + k1 = dY(t, Y) + k2 = dY(t + h/2, Y + k1*h/2) + k3 = dY(t + h/2, Y + k2*h/2) + k4 = dY(t + h , Y + k3*h) + + Y = Y + (k1 + 2*k2 + 2*k3 + k4) * h/6 + t = t + h + end subroutine +end Index: Fortran/gfortran/regression/impure_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_1.f08 @@ -0,0 +1,69 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! PR fortran/45197 +! Check that IMPURE and IMPURE ELEMENTAL in particular works. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + INTEGER, PARAMETER :: n = 5 + + INTEGER :: i + INTEGER :: arr(n) + +CONTAINS + + ! This ought to work (without any effect). + IMPURE SUBROUTINE foobar () + END SUBROUTINE foobar + + IMPURE ELEMENTAL SUBROUTINE impureSub (a) + INTEGER, INTENT(IN) :: a + + arr(i) = a + i = i + 1 + + PRINT *, a + END SUBROUTINE impureSub + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + INTEGER :: a(n), b(n), s + + a = (/ (i, i = 1, n) /) + + ! Traverse in forward order. + s = 0 + b = accumulate (a, s) + IF (ANY (b /= (/ 1, 3, 6, 10, 15 /))) STOP 1 + + ! And now backward. + s = 0 + b = accumulate (a(n:1:-1), s) + IF (ANY (b /= (/ 5, 9, 12, 14, 15 /))) STOP 2 + + ! Use subroutine. + i = 1 + arr = 0 + CALL impureSub (a) + IF (ANY (arr /= a)) STOP 3 + +CONTAINS + + IMPURE ELEMENTAL FUNCTION accumulate (a, s) + INTEGER, INTENT(IN) :: a + INTEGER, INTENT(INOUT) :: s + INTEGER :: accumulate + + s = s + a + accumulate = s + END FUNCTION accumulate + +END PROGRAM main Index: Fortran/gfortran/regression/impure_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_2.f08 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! PR fortran/45197 +! Check for errors with IMPURE. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + +CONTAINS + + IMPURE PURE SUBROUTINE foobar () ! { dg-error "must not appear both" } + + PURE ELEMENTAL IMPURE FUNCTION xyz () ! { dg-error "must not appear both" } + + IMPURE ELEMENTAL SUBROUTINE mysub () + END SUBROUTINE mysub + + PURE SUBROUTINE purified () + CALL mysub () ! { dg-error "is not PURE" } + END SUBROUTINE purified + +END MODULE m Index: Fortran/gfortran/regression/impure_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/45197 +! Check that IMPURE gets rejected without F2008. + +! Contributed by Daniel Kraft, d@domob.eu. + +IMPURE SUBROUTINE foobar () ! { dg-error "Fortran 2008" } + +IMPURE ELEMENTAL FUNCTION xyz () ! { dg-error "Fortran 2008" } Index: Fortran/gfortran/regression/impure_actual_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_actual_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Tests the fix for PR25056 in which a non-PURE procedure could be +! passed as the actual argument to a PURE procedure. +! +! Contributed by Joost VandeVondele +! +MODULE M1 +CONTAINS + FUNCTION L() + L=1 + END FUNCTION L + PURE FUNCTION J(K) + INTERFACE + PURE FUNCTION K() + END FUNCTION K + END INTERFACE + J=K() + END FUNCTION J +END MODULE M1 +USE M1 + write(6,*) J(L) ! { dg-error "Mismatch in PURE attribute" } +END Index: Fortran/gfortran/regression/impure_assignment_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_assignment_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests fix for PR25059, which gave and ICE after error message +! Contributed by Joost VandeVondele +MODULE M1 + TYPE T1 + INTEGER :: I + END TYPE T1 + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE S1 + END INTERFACE +CONTAINS + SUBROUTINE S1(I,J) + TYPE(T1), INTENT(OUT):: I + TYPE(T1), INTENT(IN) :: J + I%I=J%I**2 + END SUBROUTINE S1 +END MODULE M1 + +USE M1 +CONTAINS +PURE SUBROUTINE S2(I,J) + TYPE(T1), INTENT(OUT):: I + TYPE(T1), INTENT(IN) :: J + I=J ! { dg-error "is not PURE" } +END SUBROUTINE S2 +END Index: Fortran/gfortran/regression/impure_assignment_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_assignment_2.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! Tests the fix for PR20863 and PR20882, which were concerned with incorrect +! application of constraints associated with "impure" variables in PURE +! procedures. +! +! resolve.c (gfc_impure_variable) detects the following: +! 12.6 Constraint: In a pure subprogram any variable which is in common or +! accessed by host or use association, is a dummy argument to a pure function, +! is a dummy argument with INTENT (IN) to a pure subroutine, or an object that +! is storage associated with any such variable, shall not be used in the +! following contexts: (clients of this function). */ +! +! Contributed by Joost VandeVondele +! +MODULE pr20863 + TYPE node_type + TYPE(node_type), POINTER :: next=>null() + END TYPE +CONTAINS +! Original bug - pointer assignments to "impure" derived type with +! pointer component. + PURE FUNCTION give_next1(node) + TYPE(node_type), POINTER :: node + TYPE(node_type), POINTER :: give_next + give_next => node%next ! { dg-error "Bad target" } + node%next => give_next ! { dg-error "variable definition context" } + END FUNCTION +! Comment #2 + PURE integer FUNCTION give_next2(i) + TYPE node_type + sequence + TYPE(node_type), POINTER :: next + END TYPE + TYPE(node_type), POINTER :: node + TYPE(node_type), target :: t + integer, intent(in) :: i + node%next = t ! This is OK + give_next2 = i + END FUNCTION + PURE FUNCTION give_next3(node) + TYPE(node_type), intent(in) :: node + TYPE(node_type) :: give_next + give_next = node ! { dg-error "pure subprogram" } + END FUNCTION +END MODULE pr20863 + +MODULE pr20882 + TYPE T1 + INTEGER :: I + END TYPE T1 + TYPE(T1), POINTER :: B +CONTAINS + PURE FUNCTION TST(A) RESULT(RES) + TYPE(T1), INTENT(IN), TARGET :: A + TYPE(T1), POINTER :: RES + RES => A ! { dg-error "Bad target" } + RES => B ! { dg-error "Bad target" } + B => RES ! { dg-error "variable definition context" } + END FUNCTION + PURE FUNCTION TST2(A) RESULT(RES) + TYPE(T1), INTENT(IN), TARGET :: A + TYPE(T1), POINTER :: RES + allocate (RES) + RES = A + B = RES ! { dg-error "variable definition context" } + RES = B + END FUNCTION +END MODULE pr20882 Index: Fortran/gfortran/regression/impure_assignment_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_assignment_3.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR 43169: [OOP] gfortran rejects PURE procedure with SELECT TYPE construct +! +! Original test case by Todd Hay +! Modified by Janus Weil + + implicit none + real :: g + +contains + + pure subroutine sub1(x) + type :: myType + real :: a + end type myType + class(myType), intent(inout) :: x + real :: r3 + select type(x) + class is (myType) + x%a = 42. + r3 = 43. + g = 44. ! { dg-error "variable definition context" } + end select + end subroutine + + pure subroutine sub2 + real :: r1 + block + real :: r2 + r1 = 45. + r2 = 46. + g = 47. ! { dg-error "variable definition context" } + end block + end subroutine + + pure subroutine sub3 + block + integer, save :: i ! { dg-error "cannot be specified in a PURE procedure" } + integer :: j = 5 ! { dg-error "is not allowed in a PURE procedure" } + end block + end subroutine + +end Index: Fortran/gfortran/regression/impure_constructor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_constructor_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/43362 +! +module m + implicit none + type t + integer, pointer :: a + end type t + type t2 + type(t) :: b + end type t2 + type t3 + type(t), pointer :: b + end type t3 +contains + pure subroutine foo(x) + type(t), target, intent(in) :: x + type(t2) :: y + type(t3) :: z + + ! The following gave an ICE but is valid: + y = t2(x) ! Note: F2003, C1272 (3) and (4) do not apply + + ! Variant which is invalid as C1272 (3) applies + z = t3(x) ! { dg-error "Invalid expression in the structure constructor" } + end subroutine foo +end module m Index: Fortran/gfortran/regression/impure_spec_expr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/impure_spec_expr_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Checks the fix for PR33664, in which the apparent function reference +! n(1) caused a seg-fault. +! +! Contributed by Henrik Holst +! +module test +contains + subroutine func_1(u,n) + integer :: n + integer :: u(n(1)) ! { dg-error "must be PURE" } + end subroutine +end module test Index: Fortran/gfortran/regression/in_pack_rank7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/in_pack_rank7.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 21354: Rank 7 was not handled correctly by many library +! functions, including in_pack. +program main + real, dimension (2,2,2,2,2,2,2):: a + a = 1.0 + call foo(a(2:1:-1,:,:,:,:,:,:)) +end program main + +subroutine foo(a) + real, dimension (2,2,2,2,2,2,2):: a +end subroutine foo Index: Fortran/gfortran/regression/include_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_1.f90 @@ -0,0 +1,9 @@ +! PR debug/33739 +! { dg-do compile } +! { dg-options "-g3" } +subroutine a +include 'include_1.inc' +end subroutine a +subroutine b +include 'include_1.inc' +end subroutine b Index: Fortran/gfortran/regression/include_1.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_1.inc @@ -0,0 +1 @@ +integer :: i Index: Fortran/gfortran/regression/include_10.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_10.f @@ -0,0 +1,11 @@ +c { dg-do compile } + subroutine foo + implicit none + include 'include_10.inc' + i = 1 + end subroutine foo + subroutine bar + implicit none + i n cl UD e'include_10.inc' + i = 1 + end subroutine bar Index: Fortran/gfortran/regression/include_10.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_10.inc @@ -0,0 +1 @@ + integer i Index: Fortran/gfortran/regression/include_11.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_11.f @@ -0,0 +1,20 @@ +c { dg-do compile } + subroutine foo + implicit none +c We used to accept following in fixed mode. Shall we at least +c warn about it? +include 'include_10.inc' + i = 1 + end subroutine foo + subroutine bar +c Likewise here. + implicit none + include'include_10.inc' + i = 1 + end subroutine bar + subroutine baz +c And here. + implicit none + include 'include_10.inc' + i = 1 + end subroutine baz Index: Fortran/gfortran/regression/include_12.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_12.f @@ -0,0 +1,65 @@ +c { dg-do compile } +c { dg-options "-fdec-include" } + subroutine foo + implicit none + 0include 'include_10.inc' + i = 1 + end subroutine foo + subroutine bar + implicit none + i + ;n + +c + +c some comment + + ll +C comment line + uu + DD + ee'include_10.inc' + i = 1 + end subroutine bar + subroutine baz + implicit none + 0include + + 'include_10.inc' + i = 1 + end subroutine baz + subroutine qux + implicit none + i n C lude 'inc +* another comment line + &lude_10.inc' + i = 1 + end subroutine qux + subroutine quux + implicit none + 0inc + 1lud + 2e ' + 3include_10.inc' + i = 1 + end subroutine quux + program include_12 + implicit none + include +! comment + +'include_10.inc' + end program + subroutine quuz + implicit none + integer include + include + +"include_10.inc" + i = 1 + include + + = 2 + write (*,*) include + end subroutine quuz + subroutine corge + implicit none + include + +'include_10.inc' + i = 1 + end subroutine corge Index: Fortran/gfortran/regression/include_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_13.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fdec" } +subroutine foo + implicit none + incl& ! comment1 +&u& + &de & ! comment2 +'include& + &_10.inc' + i = 1 +end subroutine foo +subroutine bar + implicit none +include & + +! comment3 + +"include_10.inc" + i = 1 +end subroutine bar +subroutine baz + implicit none + include& +&'include_10.& +&inc' + i = 1 +end subroutine baz +subroutine qux + implicit none + include '& +include_10.inc' +end subroutine qux +subroutine quux + implicit none + include & + &'include_10.inc' + i = 1 +end subroutine quux +subroutine quuz + implicit none + include & + &"include_10.inc" + i = 1 +end subroutine quuz Index: Fortran/gfortran/regression/include_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_14.f90 @@ -0,0 +1,6 @@ +! { dg-additional-options "-cpp -idirafter /fdaf/ -I bar -J foo/bar" } +end +! default: warn for -I and -J but ignore other options. +! { dg-warning "Nonexistent include directory 'bar'" "" { target *-*-* } 0 } +! { dg-warning "Nonexistent include directory 'foo/bar'" "" { target *-*-* } 0 } + Index: Fortran/gfortran/regression/include_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_15.f90 @@ -0,0 +1,9 @@ +! { dg-additional-options "-cpp -idirafter /fdaf/ -I bar -J foo/bar -Wmissing-include-dirs" } +end + +! { dg-warning " /fdaf/: No such file or directory" "" { target *-*-* } 0 } +! { dg-warning " bar: No such file or directory" "" { target *-*-* } 0 } +! { dg-warning " foo/bar: No such file or directory" "" { target *-*-* } 0 } + +! Depending how the testsuite is run, it may or may not print the following warning: +! { dg-prune-output "Warning: finclude: No such file or directory" } Index: Fortran/gfortran/regression/include_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_16.f90 @@ -0,0 +1,2 @@ +! { dg-additional-options "-cpp -idirafter /fdaf/ -I bar -J foo/bar -Wno-missing-include-dirs" } +end Index: Fortran/gfortran/regression/include_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_17.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-I foo-bar -J foo/bar" } +end +! { dg-warning "Nonexistent include directory 'foo-bar'" "" { target *-*-* } 0 } +! { dg-warning "Nonexistent include directory 'foo/bar'" "" { target *-*-* } 0 } + Index: Fortran/gfortran/regression/include_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_18.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-I nothere -J neither/here -Wmissing-include-dirs" } +end +! { dg-warning "Nonexistent include directory 'nothere'" "" { target *-*-* } 0 } +! { dg-warning "Nonexistent include directory 'neither/here'" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/include_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_19.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! { dg-options "-I nothere -J foobar/foo -Wno-missing-include-dirs" } +program main +end program main Index: Fortran/gfortran/regression/include_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_2.f90 @@ -0,0 +1,29 @@ +# 1 "include_2.F90" +# 1 "/tmp/" +# 1 "" +# 1 "" +# 1 "include_2.F90" +#define S1 1 +#define B a +# 1 "include_2.inc" 1 +subroutine a +#undef S2 +#define S2 1 +integer :: i +end subroutine a +# 4 "include_2.F90" 2 +#undef B +#define B b +# 1 "include_2.inc" 1 +subroutine b +#undef S2 +#define S2 1 +integer :: i +end subroutine b +# 6 "include_2.F90" 2 +! PR debug/33739 +! { dg-do link } +! { dg-options "-fpreprocessed -g3" } + call a + call b +end Index: Fortran/gfortran/regression/include_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_20.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-J foobar/foo" } +program main +end program main +! { dg-warning "Nonexistent include directory" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/include_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_21.f90 @@ -0,0 +1,26 @@ +# 1 "../../../trunk/libgfortran/generated/_abs_c4.F90" +# 1 "C:\\msys\\1.0.10\\home\\FX\\ibin\\i586-pc-mingw32\\libgfortran//" +# 1 "" +# 1 "" +# 1 "../../../trunk/libgfortran/generated/_abs_c4.F90" +! Comment here + +# 1 "./config.h" 1 + +# 37 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +# 1 "./kinds.inc" 1 +# 38 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +# 1 "./c99_protos.inc" 1 +# 39 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +elemental function abs_c4 (parm) + complex (kind=4), intent (in) :: parm + real (kind=4) :: abs_c4 + + abs_c4 = abs (parm) +end function + +! { dg-do compile } +! { dg-options "-fpreprocessed -g3 -Wno-missing-include-dirs" } Index: Fortran/gfortran/regression/include_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_23.f90 @@ -0,0 +1,4 @@ +implicit none +include "nonexisting/file.f90" ! { dg-error "Cannot open included file 'nonexisting/file.f90'" } +end +! { dg-prune-output "compilation terminated." } Index: Fortran/gfortran/regression/include_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_24.f90 @@ -0,0 +1,4 @@ +implicit none +include "." ! { dg-error "Included file '.' is not a regular file" } +end +! { dg-prune-output "compilation terminated." } Index: Fortran/gfortran/regression/include_3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_3.f95 @@ -0,0 +1,27 @@ +# 1 "../../../trunk/libgfortran/generated/_abs_c4.F90" +# 1 "C:\\msys\\1.0.10\\home\\FX\\ibin\\i586-pc-mingw32\\libgfortran//" +# 1 "" +# 1 "" +# 1 "../../../trunk/libgfortran/generated/_abs_c4.F90" +! Comment here + +# 1 "./config.h" 1 + +# 37 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +# 1 "./kinds.inc" 1 +# 38 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +# 1 "./c99_protos.inc" 1 +# 39 "../../../trunk/libgfortran/generated/_abs_c4.F90" 2 + +elemental function abs_c4 (parm) + complex (kind=4), intent (in) :: parm + real (kind=4) :: abs_c4 + + abs_c4 = abs (parm) +end function + +! { dg-do compile } +! { dg-options "-fpreprocessed -g3" } +! { dg-warning "Nonexistent include directory" "missing directory" { target *-*-* } 0 } Index: Fortran/gfortran/regression/include_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/37821 +! +! Ensure that for #include "..." and for include the +! current directory/directory of the source file is +! included. See also include_5.f90 + +subroutine one() + include "include_4.inc" + integer(i4) :: i +end subroutine one Index: Fortran/gfortran/regression/include_4.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_4.inc @@ -0,0 +1,4 @@ +! Used by include_4.f90 and include_5.f90 +! PR fortran/37821 +! +integer, parameter :: i4 = 4 Index: Fortran/gfortran/regression/include_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-cpp" } +! +! PR fortran/37821 +! +! Ensure that for #include "..." and for include the +! current directory/directory of the source file is +! included. + +subroutine one() + include "include_4.inc" + integer(i4) :: i +end subroutine one + +subroutine two() +# include "include_4.inc" + integer(i4) :: i +end subroutine two Index: Fortran/gfortran/regression/include_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_6.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-I gfortran.log" } +! { dg-error "'gfortran.log' is not a directory" "" { target *-*-* } 0 } +! { dg-prune-output "compilation terminated." } +end + Index: Fortran/gfortran/regression/include_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_7.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-I nothere" } +! { dg-warning "Nonexistent include directory" "missing directory" { target *-*-* } 0 } +end + Index: Fortran/gfortran/regression/include_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_8.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-J./" } +! PR 55919 - a trailing dir separator would cause a warning +! on Windows. +program main +end program main Index: Fortran/gfortran/regression/include_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/include_9.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR69043 Trying to include a directory causes an infinite loop + include '.' + program main + end program +! { dg-error "is not a regular file" " " { target *-*-* } 3 } +! { dg-prune-output "compilation terminated." } Index: Fortran/gfortran/regression/index.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! pr35940 + program FA1031 + implicit none + integer I + INTEGER IDA1(10) + LOGICAL GDA1(10) + INTEGER RSLT(10) + DATA RSLT /4,1,4,1,4,1,4,1,4,1/ + IDA1 = 0 + gda1 = (/ (i/2*2 .ne. I, i=1,10) /) + + IDA1 = INDEX ( 'DEFDEF' , 'DEF', GDA1 ) !fails + do I = 1, 10 + if (IDA1(i).NE.RSLT(i)) STOP 1 + end do + IDA1 = INDEX ( (/ ('DEFDEF',i=1,10) /) , 'DEF', GDA1 ) !works + do I = 1, 10 + if (IDA1(i).NE.RSLT(i)) STOP 2 + end do + + END Index: Fortran/gfortran/regression/index_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index_2.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! PR fortran/36462 +! + implicit none + character(len=10,kind=1) string1 + character(len=10,kind=4) string4 + string1 = 'ABCDEEDCBA' + string4 = 'ABCDEEDCBA' + + if(index(string1,1_'A') /= 1) STOP 1 + if(index(string4,4_'A') /= 1) STOP 2 + if(index(string1,1_'A',kind=4) /= 1_4) STOP 3 + if(index(string4,4_'A',kind=4) /= 1_4) STOP 4 + if(index(string1,1_'A',kind=1) /= 1_1) STOP 5 + if(index(string4,4_'A',kind=1) /= 1_1) STOP 6 + + if(index(string1,1_'A',back=.true.) /= 10) STOP 7 + if(index(string4,4_'A',back=.true.) /= 10) STOP 8 + if(index(string1,1_'A',kind=4,back=.true.) /= 10_4) STOP 9 + if(index(string4,4_'A',kind=4,back=.true.) /= 10_4) STOP 10 + if(index(string1,1_'A',kind=1,back=.true.) /= 10_1) STOP 11 + if(index(string4,4_'A',kind=1,back=.true.) /= 10_1) STOP 12 + + if(index(string1,1_'A',back=.false.) /= 1) STOP 13 + if(index(string4,4_'A',back=.false.) /= 1) STOP 14 + if(index(string1,1_'A',kind=4,back=.false.) /= 1_4) STOP 15 + if(index(string4,4_'A',kind=4,back=.false.) /= 1_4) STOP 16 + if(index(string1,1_'A',kind=1,back=.false.) /= 1_1) STOP 17 + if(index(string4,4_'A',kind=1,back=.false.) /= 1_1) STOP 18 + + if(scan(string1,1_'A') /= 1) STOP 19 + if(scan(string4,4_'A') /= 1) STOP 20 + if(scan(string1,1_'A',kind=4) /= 1_4) STOP 21 + if(scan(string4,4_'A',kind=4) /= 1_4) STOP 22 + if(scan(string1,1_'A',kind=1) /= 1_1) STOP 23 + if(scan(string4,4_'A',kind=1) /= 1_1) STOP 24 + + if(scan(string1,1_'A',back=.true.) /= 10) STOP 25 + if(scan(string4,4_'A',back=.true.) /= 10) STOP 26 + if(scan(string1,1_'A',kind=4,back=.true.) /= 10_4) STOP 27 + if(scan(string4,4_'A',kind=4,back=.true.) /= 10_4) STOP 28 + if(scan(string1,1_'A',kind=1,back=.true.) /= 10_1) STOP 29 + if(scan(string4,4_'A',kind=1,back=.true.) /= 10_1) STOP 30 + + if(scan(string1,1_'A',back=.false.) /= 1) STOP 31 + if(scan(string4,4_'A',back=.false.) /= 1) STOP 32 + if(scan(string1,1_'A',kind=4,back=.false.) /= 1_4) STOP 33 + if(scan(string4,4_'A',kind=4,back=.false.) /= 1_4) STOP 34 + if(scan(string1,1_'A',kind=1,back=.false.) /= 1_1) STOP 35 + if(scan(string4,4_'A',kind=1,back=.false.) /= 1_1) STOP 36 + end + +! { dg-final { scan-tree-dump-times "if ..integer.kind=1.. _gfortran_string_index" 6 "original" } } +! { dg-final { scan-tree-dump-times "if ..integer.kind=1.. _gfortran_string_scan" 6 "original" } } Index: Fortran/gfortran/regression/index_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index_3.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 91651 - this used to give an ICE. +! Bug report by Gerhard Steinmetz. +program p + integer :: z(2) + z = index('100101', '10', [.false.,.true.],kind=4) + if (z(1) /= 1 .or. z(2) /= 4) stop 1 +end Index: Fortran/gfortran/regression/index_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index_4.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "string_index" 0 "original" } } +! PR fortran/95979 + +program p + implicit none + integer, parameter :: i0 = index( 'abcd', 'b' , .true. , kind=4) + integer, parameter :: i1(*) = index(['abcd'], 'b' , .true. , kind=4) + integer, parameter :: i2(*) = index( 'abcd' ,['b'], .true. ) + integer, parameter :: i3(*) = index( 'abcd' , 'b' ,[.true.] ) + integer, parameter :: i4(*) = index(['abcd'],['b'],[.true.], kind=8) + if (size (i1) /= 1) stop 1 + if (size (i2) /= 1) stop 2 + if (size (i3) /= 1) stop 3 + if (size (i4) /= 1) stop 4 + if (i0 /= 2) stop 5 + if (i1(1) /= 2 .or. i2(1) /= 2 .or. i3(1) /= 2 .or. i4(1) /= 2) stop 6 +end Index: Fortran/gfortran/regression/index_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index_5.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/97896 +! An ICE occured with INDEX when the KIND argument was present +! because of a mismatch between the number of arguments expected +! during the scalarization process and the number of arguments actually +! used. +! +! Test contributed by Harald Anlauf , based on an initial +! submission by G. Steinmetz . + +program p + implicit none + logical :: a(2) + integer :: b(2) + integer(8) :: d(2) + b = index ('xyxyz','yx', back=a) + b = index ('xyxyz','yx', back=a, kind=4) + d = index ('xyxyz','yx', back=a, kind=8) + b = index ('xyxyz','yx', back=a, kind=8) + d = index ('xyxyz','yx', back=a, kind=4) + b = index ('xyxyz','yx', a, 4) + d = index ('xyxyz','yx', a, 8) +end + Index: Fortran/gfortran/regression/index_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/index_6.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/105691 - Incorrect calculation of INDEX(str1,str2) at compile time + +program main + implicit none + integer :: i + character(*), parameter :: s1 = "fortran.f90" + character(*), parameter :: s2 = "fortran" + character(*), parameter :: s3 = s2 // "*" + integer, parameter :: i0 = index(s1, s2) + integer, parameter :: i1 = index(s1, s2, back= .true.) + integer, parameter :: i2(*) = index(s1, s2, back=[.true.,.false.]) + integer, parameter :: i3(*) = index(s1, s2, back=[(i==1, i=1,2)] ) + integer, parameter :: i4 = index(s1, s3) + integer, parameter :: i5 = index(s1, s3, back= .true.) + integer, parameter :: i6(*) = index(s1, s3, back=[.true.,.false.]) + integer, parameter :: i7(*) = index(s1, s3, back=[(i==1, i=1,2)] ) + integer, parameter :: i8 = index(s1, "f", back= .true.) + if ( i0 /= 1 ) stop 1 + if ( i1 /= 1 ) stop 2 + if (any (i2 /= 1)) stop 3 + if (any (i3 /= 1)) stop 4 + if ( i4 /= 0 ) stop 5 + if ( i5 /= 0 ) stop 6 + if (any (i6 /= 0)) stop 7 + if (any (i7 /= 0)) stop 8 + if (i8 /= len(s1)-2) stop 9 +end program + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/init_char_with_nonchar_ctr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_char_with_nonchar_ctr.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } + +! Initialization of character by non-character constructor + +subroutine s1 + type t + integer :: n = 0 + end type + type t2 + character :: c = t() ! { dg-error "Cannot convert TYPE\\(t\\) to CHARACTER\\(1\\)" } + end type +end subroutine + +subroutine s2 + type t + end type + type t2 + character :: c(1) = [t()] ! { dg-error "Cannot convert TYPE\\(t\\) to CHARACTER\\(1\\)" } + end type +end subroutine + +subroutine s3 + type t + integer :: a = 1 + character :: c = t() ! { dg-error "Cannot convert TYPE\\(t\\) to CHARACTER\\(1\\)" } + end type +end subroutine + +subroutine s4 + type t + integer, allocatable :: a + character :: c = t() ! { dg-error "Cannot convert TYPE\\(t\\) to CHARACTER\\(1\\)" } + end type +end subroutine Index: Fortran/gfortran/regression/init_flag_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_1.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-options "-finit-local-zero -fbackslash" } + +program init_flag_1 + call real_test + call logical_test + call int_test + call complex_test + call char_test +end program init_flag_1 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine real_test + real r1 + real r2(10) + dimension r3(10,10) + if (r1 /= 0.0) STOP 1 + if (r2(2) /= 0.0) STOP 2 + if (r3(5,5) /= 0.0) STOP 3 + if (r4 /= 0.0) STOP 4 +end subroutine real_test + +subroutine logical_test + logical l1 + logical l2(2) + if (l1 .neqv. .false.) STOP 5 + if (l2(2) .neqv. .false.) STOP 6 +end subroutine logical_test + +subroutine int_test + integer i1 + integer i2(10) + dimension i3(10,10) + if (i1 /= 0) STOP 7 + if (i2(2) /= 0) STOP 8 + if (i3(5,5) /= 0) STOP 9 + if (i4 /= 0) STOP 10 +end subroutine int_test + +subroutine complex_test + complex c1 + complex c2(20,20) + if (c1 /= (0.0,0.0)) STOP 11 + if (c2(1,1) /= (0.0,0.0)) STOP 12 +end subroutine complex_test + +subroutine char_test + character*1 c1 + character*8 c2, c3(5) + character c4(10) + if (c1 /= '\0') STOP 13 + if (c2 /= '\0\0\0\0\0\0\0\0') STOP 14 + if (c3(1) /= '\0\0\0\0\0\0\0\0') STOP 15 + if (c3(5) /= '\0\0\0\0\0\0\0\0') STOP 16 + if (c4(5) /= '\0') STOP 17 +end subroutine char_test Index: Fortran/gfortran/regression/init_flag_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_10.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-options "-finit-real=NAN" } +! { dg-add-options ieee } +! +! PR fortran/50619 +! +! Contributed by Fred Krogh +! +! The NaN initialization used to set the associate name to NaN! +! + +module testa2 +type, public :: test_ty + real :: rmult = 1.0e0 +end type test_ty + +contains + subroutine test(e, var1) + type(test_ty) :: e + real :: var1, var2 ! Should get NaN initialized + + ! Should be the default value + if (e%rmult /= 1.0) STOP 1 + + ! Check that NaN initialization is really turned on + if (var1 == var1) STOP 2 + if (var2 == var2) STOP 3 + + ! The following was failing: + associate (rmult=>e%rmult) + if (e%rmult /= 1.0) STOP 4 + end associate + end subroutine test +end module testa2 + +program testa1 + use testa2 + type(test_ty) :: e + real :: var1 ! Should get NaN initialized + call test(e, var1) + stop +end program testa1 Index: Fortran/gfortran/regression/init_flag_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_11.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-finit-local-zero -fno-automatic" } +! +! PR fortran/53818 +! +! Contributed by John Moyard +! +logical function testing(date1, date2) result(test) + integer date1, date2 + test = ( (date1 < date2) .or. ( date1==date2 )) +end function testing Index: Fortran/gfortran/regression/init_flag_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_12.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -finit-local-zero" } +! +! PR 55907: [4.7/4.8/4.9 Regression] ICE with -fno-automatic -finit-local-zero +! +! Contributed by J.R. Garcia + +subroutine cchaine (i) + implicit none + integer :: i + character(len=i) :: chaine + write(*,*) chaine +end subroutine Index: Fortran/gfortran/regression/init_flag_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_13.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-finit-local-zero -finit-derived -fdump-tree-original" } +! +! Make sure -finit-derived initializes components of local derived type +! variables to zero with -finit-local-zero. +! + +subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2) + implicit none + integer, intent(in) :: i1 + real, intent(in) :: r1 + character, intent(in) :: c1 + logical, intent(in) :: l1 + integer, intent(out) :: i2 + real, intent(out) :: r2 + character, intent(out) :: c2 + logical, intent(out) :: l2 +end subroutine + +type t2 + integer i2 + real r2 + character c2 + logical l2 +end type + +type t1 + logical l1 + real r1 + character c1 + integer i1 + type (t2) y +end type + +type (t1) :: x + +call dummy (x%i1, x%r1, x%c1, x%l1, x%y%i2, x%y%r2, x%y%c2, x%y%l2) + +end + +! We expect to see each component initialized exactly once in MAIN. +! NB. the "once" qualifier also tests that the dummy variables aren't +! given an extraneous initializer. +! { dg-final { scan-tree-dump-times "i1= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "r1= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "c1= *\"\"" 1 "original" } } +! { dg-final { scan-tree-dump-times "l1= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "i2= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "r2= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "c2= *\"\"" 1 "original" } } +! { dg-final { scan-tree-dump-times "l2= *0" 1 "original" } } Index: Fortran/gfortran/regression/init_flag_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_14.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-finit-derived -finit-integer=42 -finit-real=inf -finit-logical=true -finit-character=32 -fdump-tree-original" } +! +! Make sure -finit-derived initializes components of local derived type +! variables according to other -finit-* flags. +! + +subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2) + implicit none + integer, intent(in) :: i1 + real, intent(in) :: r1 + character, intent(in) :: c1 + logical, intent(in) :: l1 + integer, intent(out) :: i2 + real, intent(out) :: r2 + character, intent(out) :: c2 + logical, intent(out) :: l2 +end subroutine + +type t2 + integer i2 + real r2 + character c2 + logical l2 +end type + +type t1 + logical l1 + real r1 + character c1 + integer i1 + type (t2) y +end type + +type (t1) :: x + +call dummy (x%i1, x%r1, x%c1, x%l1, x%y%i2, x%y%r2, x%y%c2, x%y%l2) + +end + +! We expect to see each component initialized exactly once in MAIN. +! NB. the "once" qualifier also tests that the dummy variables aren't +! given an extraneous initializer. +! { dg-final { scan-tree-dump-times "i1= *42" 1 "original" } } +! { dg-final { scan-tree-dump-times "r1= *\[iI]nf" 1 "original" } } +! { dg-final { scan-tree-dump-times "c1= *\" \"" 1 "original" } } +! { dg-final { scan-tree-dump-times "l1= *1" 1 "original" } } +! { dg-final { scan-tree-dump-times "i2= *42" 1 "original" } } +! { dg-final { scan-tree-dump-times "r2= *\[iI]nf" 1 "original" } } +! { dg-final { scan-tree-dump-times "c2= *\" \"" 1 "original" } } +! { dg-final { scan-tree-dump-times "l2= *1" 1 "original" } } Index: Fortran/gfortran/regression/init_flag_15.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_15.f03 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-finit-derived -finit-integer=1" } +! +! Make sure -finit-derived works on class variables. +! Based on class_result_1.f03 +! + +module points_2i + + implicit none + + type point2i + integer :: x, y + end type + +contains + + subroutine print( point ) + class(point2i) :: point + write(*,'(2i4)') point%x, point%y + end subroutine + + subroutine set_vector( point, rx, ry ) + class(point2i) :: point + integer :: rx, ry + point%x = rx + point%y = ry + end subroutine + + function add_vector( point, vector ) + class(point2i), intent(in) :: point, vector + class(point2i), allocatable :: add_vector + allocate( add_vector ) + add_vector%x = point%x + vector%x + add_vector%y = point%y + vector%y + end function + +end module + + +program init_flag_15 + + use points_2i + implicit none + + type(point2i), target :: point_2i, vector_2i + class(point2i), pointer :: point, vector + type(point2i) :: vsum + integer :: i + + point => point_2i ! = (1, 1) due to -finit-integer + vector => vector_2i + call set_vector(vector, 2, 2) + vsum = add_vector(point, vector) + + call print(point) + call print(vector) + call print(vsum) + + if (vsum%x .ne. 3 .or. vsum%y .ne. 3) then + STOP 1 + endif + +end program Index: Fortran/gfortran/regression/init_flag_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_16.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-finit-derived" } +! +! PR fortran/82886 +! +! Test a regression which caused an ICE when -finit-derived was given without +! other -finit-* flags, especially for derived-type components with potentially +! hidden basic integer components. +! + +program pr82886 + + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + type t + type(c_ptr) :: my_c_ptr + end type + +contains + + subroutine sub0() bind(c) + type(t), target :: my_f90_type + my_f90_type%my_c_ptr = c_null_ptr + end subroutine + +end Index: Fortran/gfortran/regression/init_flag_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_17.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-finit-derived -finit-local-zero -fdump-tree-original" } +! +! PR fortran/82972 +! +! Make sure we do not ICE when generating initializers for c_ptr and c_funptr +! components of derived types (and make sure they are properly initialized to +! zero). +! + +program init_flag_17 + use iso_c_binding + implicit none + + type :: ty + type(c_ptr) :: ptr ! = c_null_ptr + type(c_funptr) :: fptr ! = c_null_funptr + end type + + type(ty) :: t + + print *, t%ptr + print *, t%fptr + +end program + +! { dg-final { scan-tree-dump "\.ptr=0" "original" } } +! { dg-final { scan-tree-dump "\.fptr=0" "original" } } Index: Fortran/gfortran/regression/init_flag_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_18.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-finit-derived" } +! +! PR fortran/83183 +! +! Test a regression where -finit-derived recursed infinitely generating +! initializers for allocatable components of the same derived type. +! + +program pr83183 + type :: linked_list + type(linked_list), allocatable :: link + integer :: value + end type + type(linked_list) :: test + allocate(test % link) + print *, test%value + print *, test%link%value +end program Index: Fortran/gfortran/regression/init_flag_19.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_19.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-finit-derived -finit-local-zero -fdump-tree-original" } +! +! Test initializers for BT_CLASS components/variables with -finit-derived. +! + +implicit none + +type :: ty1 + integer :: ival + real :: rval +end type + +type :: ty2 + type(ty1) :: bt + type(ty1), allocatable :: bt_alloc + type(ty1), pointer :: bt_ptr + class(ty1), allocatable :: class_alloc + class(ty1), pointer :: class_ptr +end type + +type(ty2) basic +class(ty1), allocatable :: calloc + +print *, basic%bt%ival +print *, calloc%ival + +end + +! { dg-final { scan-tree-dump-times "\.ival *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "\.rval *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "\.bt_ptr *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "\.bt_alloc *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "\.class_alloc(?: *= *\{)?\._data *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "\.class_ptr(?: *= *\{)?\._data *= *0" 1 "original" } } +! { dg-final { scan-tree-dump-times "calloc(?: *= *\{)?\._data *= *0" 1 "original" } } Index: Fortran/gfortran/regression/init_flag_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-finit-integer=1 -finit-logical=true -finit-real=zero" } + +program init_flag_2 + call real_test + call logical_test + call int_test + call complex_test +end program init_flag_2 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine real_test + real r1 + real r2(10) + dimension r3(10,10) + if (r1 /= 0.0) STOP 1 + if (r2(2) /= 0.0) STOP 2 + if (r3(5,5) /= 0.0) STOP 3 + if (r4 /= 0.0) STOP 4 +end subroutine real_test + +subroutine logical_test + logical l1 + logical l2(2) + if (l1 .neqv. .true.) STOP 5 + if (l2(2) .neqv. .true.) STOP 6 +end subroutine logical_test + +subroutine int_test + integer i1 + integer i2(10) + dimension i3(10,10) + if (i1 /= 1) STOP 7 + if (i2(2) /= 1) STOP 8 + if (i3(5,5) /= 1) STOP 9 + if (i4 /= 1) STOP 10 +end subroutine int_test + +subroutine complex_test + complex c1 + complex c2(20,20) + if (c1 /= (0.0,0.0)) STOP 11 + if (c2(1,1) /= (0.0,0.0)) STOP 12 +end subroutine complex_test Index: Fortran/gfortran/regression/init_flag_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_20.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fbackslash -finit-local-zero -fno-init-local-zero -fdump-tree-original" } +! +! PR fortran/87919 +! +! Make sure -fno-init-local-zero disables -finit-local-zero. +! + +include 'init_flag_1.f90' + +! Make sure no initialization code is generated. +! { dg-final { scan-tree-dump-times "r\[1-4] *= *\[0\{]" 0 "original" } } +! { dg-final { scan-tree-dump-times "l\[12] *= *\[0\{]" 0 "original" } } +! { dg-final { scan-tree-dump-times "i\[1-4] *= *\[0\{]" 0 "original" } } +! { dg-final { scan-tree-dump-times "memmove *\[(]\[^,]*c\[1-4]" 0 "original" } } Index: Fortran/gfortran/regression/init_flag_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_3.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-finit-integer=-1 -finit-logical=false -finit-real=nan" } +! { dg-add-options ieee } + +program init_flag_3 + call real_test + call logical_test + call int_test + call complex_test +end program init_flag_3 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine real_test + real r1 + real r2(10) + dimension r3(10,10) + if (r1 .eq. r1) STOP 1 + if (r2(2) .eq. r2(2)) STOP 2 + if (r3(5,5) .eq. r3(5,5)) STOP 3 + if (r4 .eq. r4) STOP 4 +end subroutine real_test + +subroutine logical_test + logical l1 + logical l2(2) + if (l1 .neqv. .false.) STOP 5 + if (l2(2) .neqv. .false.) STOP 6 +end subroutine logical_test + +subroutine int_test + integer i1 + integer i2(10) + dimension i3(10,10) + if (i1 /= -1) STOP 7 + if (i2(2) /= -1) STOP 8 + if (i3(5,5) /= -1) STOP 9 + if (i4 /= -1) STOP 10 +end subroutine int_test + +subroutine complex_test + complex c1 + complex c2(20,20) + if (c1 .eq. c1) STOP 11 + if (c2(1,1) .eq. c2(1,1)) STOP 12 +end subroutine complex_test Index: Fortran/gfortran/regression/init_flag_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_4.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-finit-real=inf" } +! { dg-add-options ieee } + +program init_flag_4 + call real_test +end program init_flag_4 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine real_test + real r1 + real r2(10) + dimension r3(10,10) + if (r1 .le. 0 .or. r1 .ne. 2*r1) STOP 1 + if (r2(2) .le. 0 .or. r2(2) .ne. 2*r2(2)) STOP 2 + if (r3(5,5) .le. 0 .or. r3(5,5) .ne. 2*r3(5,5)) STOP 3 + if (r4 .le. 0 .or. r4 .ne. 2*r4) STOP 4 +end subroutine real_test Index: Fortran/gfortran/regression/init_flag_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_5.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-finit-real=-inf" } +! { dg-add-options ieee } + +program init_flag_5 + call real_test +end program init_flag_5 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine real_test + real r1 + real r2(10) + dimension r3(10,10) + if (r1 .ge. 0 .or. r1 .ne. 2*r1) STOP 1 + if (r2(2) .ge. 0 .or. r2(2) .ne. 2*r2(2)) STOP 2 + if (r3(5,5) .ge. 0 .or. r3(5,5) .ne. 2*r3(5,5)) STOP 3 + if (r4 .ge. 0 .or. r4 .ne. 2*r4) STOP 4 +end subroutine real_test Index: Fortran/gfortran/regression/init_flag_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_6.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-finit-character=32" } + +program init_flag_6 + call char_test +end program init_flag_6 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine char_test + character*1 c1 + character*8 c2, c3(5) + character c4(10) + if (c1 /= ' ') STOP 1 + if (c2 /= ' ') STOP 2 + if (c3(1) /= ' ') STOP 3 + if (c3(5) /= ' ') STOP 4 + if (c4(5) /= ' ') STOP 5 +end subroutine char_test + Index: Fortran/gfortran/regression/init_flag_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_7.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-finit-integer=101" } + +program init_flag_7 + call save_test1 (.true.) + call save_test1 (.false.) + call save_test2 (.true.) + call save_test2 (.false.) +end program init_flag_7 + +! Test some initializations for both implicitly and +! explicitly declared local variables. +subroutine save_test1 (first) + logical first + integer :: i1 = -100 + integer i2 + integer i3 + save i2 + if (first) then + if (i1 .ne. -100) STOP 1 + if (i2 .ne. 101) STOP 2 + if (i3 .ne. 101) STOP 3 + else + if (i1 .ne. 1001) STOP 4 + if (i2 .ne. 1002) STOP 5 + if (i3 .ne. 101) STOP 6 + end if + i1 = 1001 + i2 = 1002 + i3 = 1003 +end subroutine save_test1 + +subroutine save_test2 (first) + logical first + integer :: i1 = -100 + integer i2 + save + if (first) then + if (i1 .ne. -100) STOP 7 + if (i2 .ne. 101) STOP 8 + else + if (i1 .ne. 1001) STOP 9 + if (i2 .ne. 1002) STOP 10 + end if + i1 = 1001 + i2 = 1002 +end subroutine save_test2 Index: Fortran/gfortran/regression/init_flag_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -finit-local-zero" } +! +! PR fortran/51800 +! +! Contributed by Mario Baumann +! + SUBROUTINE FOO( N, A ) + IMPLICIT NONE + INTEGER :: N + INTEGER :: A(1:N) + INTEGER :: J + INTEGER :: DUMMY(1:N) + DO J=1,N + DUMMY(J) = 0 + A(J) = DUMMY(J) + END DO + END SUBROUTINE FOO Index: Fortran/gfortran/regression/init_flag_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/init_flag_9.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-finit-character=89" } +! +! PR fortran/51800 +! + +subroutine foo(n) + character(len=n) :: str +! print *, str + if (str /= repeat ('Y', n)) STOP 1 +end subroutine foo + +call foo(3) +call foo(10) +end Index: Fortran/gfortran/regression/initialization_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_1.f90 @@ -0,0 +1,37 @@ +!==================initialization_1.f90====================== + +! { dg-do compile } +! Tests fix for PR25018 in which an ICE resulted from using a +! variable in a parameter initialization expression. In the course +! of developing the fix, various other constraints and limitations +! were tested. +! +! Contributed by Paul Thomas +! +module const +! The next line is the original error + real(8), parameter :: g = - sqrt(2._8) * Gf ! { dg-error "not been declared or is a variable" } +contains + subroutine foo(ch1, x, y) + character(*) :: ch1 + +! This is OK because it is a restricted expression. + character(len(ch1)) :: ch2 + + real(8) :: x (1:2, *) + real(8) :: y (0:,:) + integer :: i + real :: z(2, 2) + +! However, this gives a warning because it is an initialization expression. + integer :: l1 = len (ch1) ! { dg-error "Assumed or deferred character length variable" } + +! These are warnings because they are gfortran extensions. + integer :: m3 = size (x, 1) ! { dg-error "Assumed size array" } + integer :: m4(2) = shape (z) + +! This does not depend on non-constant properties. + real(8) :: big = huge (x) + + end subroutine foo +end module const Index: Fortran/gfortran/regression/initialization_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_10.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! PR fortran/32867 - nested initialization expression not simplified +! +! Testcase contributed by H. J. Lu +! + +MODULE Readdata_mod +IMPLICIT NONE +Private +Public Parser + integer, parameter :: nkeywords = 2 +character(80), PARAMETER, dimension(1:nkeywords) :: keywords = & +(/'PROBLEMSIZE ', & + 'NFTRANS_TD '/) + +CONTAINS +SUBROUTINE Parser(nx, ny, keyword) +integer, intent(inout) :: nx, ny +character(80), intent(inout) :: keyword + +select case (keyword) + case (trim(keywords(1))) ! PROBLEMSIZE + nx = 1 + case (trim(keywords(2))) !'NFTRANS_TD' + ny = 1 +end select + +END SUBROUTINE Parser +END MODULE Readdata_mod Index: Fortran/gfortran/regression/initialization_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_11.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR fortran/32903 +! +program test + implicit none + type data_type + integer :: i=2 + end type data_type + type(data_type) :: d + d%i = 4 + call set(d) + if(d%i /= 2) then + print *, 'Expect: 2, got: ', d%i + STOP 1 + end if +contains + subroutine set(x1) + type(data_type),intent(out):: x1 + end subroutine set +end program test Index: Fortran/gfortran/regression/initialization_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_12.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! PR fortran/32945 - ICE in init expressions +! +! Contributed by Florian Ladstaedter +! + +MODULE EGOPS_Utilities +CONTAINS + FUNCTION dirname(fullfilename) + Character(LEN=*), Intent(In) :: fullfilename + Character(LEN=LEN(fullfilename)) :: dirname + dirname = '' + END FUNCTION +END MODULE EGOPS_Utilities + +MODULE AtmoIono + CHARACTER(LEN=10), PARAMETER :: ComputeDryAtmModel = 'Dry Atm. �' + + type AtmModel + character (len=len(ComputeDryAtmModel)) :: moistDryStr + end type AtmModel +END MODULE AtmoIono + +module AtmoIonoSphere + use EGOPS_Utilities + use AtmoIono +end module AtmoIonoSphere Index: Fortran/gfortran/regression/initialization_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_13.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/33178 +! +! Initialization expressions: +! Fortran 95: Elemental functions w/ integer/character arguments +! Fortran 2003: restriction lifted +! +integer :: a = sign(1,1) ! Ok F95 +real :: b = sign(1.,1.) ! { dg-error "Fortran 2003: Elemental function as initialization expression" } +end Index: Fortran/gfortran/regression/initialization_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_14.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! PR 20851 +! Dummy arguments are disallowed in initialization expressions in +! elemental functions except as arguments to the intrinsic functions +! BIT_SIZE, KIND, LEN, or to the numeric inquiry functions listed +! in 13.11.8 F95, likewise not allowed in F2003, now allowed in F2008. +MODULE TT +INTEGER M +CONTAINS + ELEMENTAL REAL FUNCTION two(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(N) :: scr ! Now valid under F2008 + END FUNCTION + + ELEMENTAL REAL FUNCTION twopointfive(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(MAX(N,2)) :: scr ! Now valid under F2008 + end FUNCTION twopointfive + + REAL FUNCTION three(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(N) :: scr ! this time it's valid + END FUNCTION + + ELEMENTAL REAL FUNCTION four(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(bit_size(N)) :: scr ! another valid variant + END FUNCTION + + ELEMENTAL REAL FUNCTION gofourit(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(MIN(HUGE(N),1)) :: scr ! another valid variant + END FUNCTION + + ELEMENTAL REAL FUNCTION fourplusone(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(M) :: scr ! another valid variant + END FUNCTION + + ELEMENTAL REAL FUNCTION five(X) + real, intent(in) :: x + CHARACTER(LEN=PRECISION(X)) :: C ! valid again + END FUNCTION +END MODULE +END Index: Fortran/gfortran/regression/initialization_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_15.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! Test by Dominique d'Humieres (PR 33957) +function bug(i) result(c) + integer, pointer :: i + character(len=merge(1,2, associated(i))) :: c + c = "" +end function bug Index: Fortran/gfortran/regression/initialization_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_16.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95 -Wall" } +! +! PR fortran/34495 +! +! Check for invalid Fortran 95 initialization expressions +! +program main + implicit none + real, parameter :: r1 = real(33) ! { dg-error "Fortran 2003: Function 'real' as initialization expression" } + real, parameter :: r2 = dble(33) ! { dg-error "Fortran 2003: Function 'dble' as initialization expression" } + complex, parameter :: z = cmplx(33,33)! { dg-error "Fortran 2003: Function 'cmplx' as initialization expression" } + real, parameter :: r4 = sngl(3.d0) ! { dg-error "Fortran 2003: Function 'sngl' as initialization expression" } + real, parameter :: r5 = float(33) ! { dg-error "Fortran 2003: Function 'float' as initialization expression" } +end program main Index: Fortran/gfortran/regression/initialization_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_17.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/34514 +! +! Initialization and typespec changes. +! +integer :: n = 5, m = 7 +parameter (n = 42) ! { dg-error "Initializing already initialized variable" } +dimension :: m(3) ! { dg-error "after its initialization" } +end Index: Fortran/gfortran/regression/initialization_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_18.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95 -Wall" } +! +! PR fortran/34915 +! Testcase contributed by Al Greynolds via comp.lang.fortran. +! + + character(*),dimension(3),parameter :: a=(/'a() ','b(,) ','c(,,)'/) + integer,dimension(3),parameter :: l=len_trim(a) +end Index: Fortran/gfortran/regression/initialization_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_19.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! The following program fails with 4.3.0 +! but works with 4.4.0. See: +! +! http://gcc.gnu.org/ml/fortran/2008-05/msg00199.html +! +module c +type d + integer :: i=-1 +end type d +end module c + +module s +use c +contains +subroutine g + type(d) :: a + ! Without the following line it passes with 4.3.0: + print *, a%i + if(a%i /= -1) STOP 1 + a%i=0 +end subroutine g +end module s + +program t +use c +use s + +call g +call g + +end program t Index: Fortran/gfortran/regression/initialization_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Vector subscripts, ranks and shapes of initialization expressions (PRs 29393, +! 29630 and 29679) +program test + + implicit none + integer :: i, j + integer, parameter :: a(4,4,4) = reshape([ (i,i=1,64) ], [4,4,4]) + integer, parameter :: v(4) = [4, 1, 3, 2] + + integer :: b1(3,3) = a(1:3, 2, 2:4) + integer :: b2(1,3) = a(2:2, 4, [1,4,3]) + integer :: b2b(3) = a([1,4,3], 2, 4) + integer :: b3(4) = a(1, v, 3) + integer :: b4(3,3) = a(v([2,4,3]), 2, [2,3,4]) + + if (any(b1 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) STOP 1 + if (any(b2 /= reshape([14, 62, 46], [1,3]))) STOP 2 + if (any(b2b /= [53, 56, 55])) STOP 3 + if (any(b3 /= [45, 33, 41, 37])) STOP 4 + if (any(b4 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) STOP 5 +end program test Index: Fortran/gfortran/regression/initialization_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_20.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Test for PR19925 +! +program pr19925 + implicit none + integer j + integer, parameter :: n = 100000 + integer, parameter :: i(n)=(/(j,j=1,n)/) ! { dg-error "number of elements" } + print *, i(5) ! { dg-error "has no IMPLICIT type" } +end program pr19925 Index: Fortran/gfortran/regression/initialization_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_21.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fmax-array-constructor=100000" } +! Test for PR19925 +! +program pr19925 + implicit none + integer j + integer, parameter :: n = 100000 + integer, parameter :: i(n) = (/ (j, j=1, n) /) + print *, i(5) +end program pr19925 Index: Fortran/gfortran/regression/initialization_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_22.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! tests the fix for PR39292, where the intitialization expression +! did not simplify and caused an ICE in gfc_conv_array_initializer. +! +! Contributed by Richard Guenther +! + integer :: n + real, dimension(2) :: a = (/ ( (float(n))**(1.0), n=1,2) /) + if (any (a .ne. (/ ( (float(n))**(1.0), n=1,2) /))) STOP 1 +end Index: Fortran/gfortran/regression/initialization_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_23.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 40875: The error was missed and an ICE ensued. +! +! Contributed by Michael Richmond +! + MODULE cdf_aux_mod + PUBLIC + TYPE :: one_parameter + CHARACTER :: name + END TYPE one_parameter + CHARACTER, PARAMETER :: the_alpha = one_parameter('c') ! { dg-error "Cannot convert TYPE" } + CHARACTER, PARAMETER :: the_beta = (/one_parameter('c')/) ! { dg-error "Incompatible ranks" } + END MODULE cdf_aux_mod Index: Fortran/gfortran/regression/initialization_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_24.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR43747 ICE in find_array_section, at fortran/expr.c:1551 +! Test case by Dominique d'Humieres +INTEGER, PARAMETER ::N=65536 +INTEGER, PARAMETER ::I(N)=(/(MOD(K,2),K=1,N)/)!{ dg-error "number of elements" } +INTEGER, PARAMETER ::M(N)=I(N:1:-1) ! { dg-error "Syntax error in argument" } +print *, I(1), M(1), I(N), M(N) +END + Index: Fortran/gfortran/regression/initialization_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_25.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/35779 - unrelated error message +! Tescase contributed by +! Dick Hendrickson +! +! Initial patch was reverted as it broke nested loops (see initialization_26.f90). +! + +! INTEGER :: J1 +! INTEGER,PARAMETER :: I2(10) = (/(J1,J1=its_bad,1,-1)/) ! { dg - error "does not reduce" } +END Index: Fortran/gfortran/regression/initialization_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_26.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! Verify that the outer do-loop counter 'j' is accepted as +! as end-expression of the inner loop. +! + + integer i, j + integer, parameter :: n = size( [( [(i*j,i=1,j)], j=1,2)] ) +end Index: Fortran/gfortran/regression/initialization_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_27.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/45489 +! +! Check that non-referenced variables are default +! initialized if they are INTENT(OUT) or function results. +! Only the latter (i.e. "x=f()") was not working before +! PR 45489 was fixed. +! +program test_init + implicit none + integer, target :: tgt + type A + integer, pointer:: p => null () + integer:: i=3 + end type A + type(A):: x, y(3) + x=f() + if (associated(x%p) .or. x%i /= 3) STOP 1 + y(1)%p => tgt + y%i = 99 + call sub1(3,y) + if (associated(y(1)%p) .or. any(y(:)%i /= 3)) STOP 2 + y(1)%p => tgt + y%i = 99 + call sub2(y) + if (associated(y(1)%p) .or. any(y(:)%i /= 3)) STOP 3 +contains + function f() result (fr) + type(A):: fr + end function f + subroutine sub1(n,x) + integer :: n + type(A), intent(out) :: x(n:n+2) + end subroutine sub1 + subroutine sub2(x) + type(A), intent(out) :: x(:) + end subroutine sub2 +end program test_init Index: Fortran/gfortran/regression/initialization_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_28.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR fortran/50163 +! +! Contributed by Philip Mason +! +character(len=2) :: xx ='aa' +integer :: iloc=index(xx,'bb') ! { dg-error "has not been declared or is a variable" } +end Index: Fortran/gfortran/regression/initialization_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_29.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/38718 +! + implicit none + real(kind=8), parameter :: r = kind(0) + 0.2 + complex(kind=8), parameter :: c = (r, -9.3) + integer, parameter :: k = nint(dreal(c)) + integer, parameter :: l = nint(realpart(c)) + integer(kind=k) :: i + integer(kind=l) :: j + i = 42 + j = 42 + print *, k, i, j, r + end Index: Fortran/gfortran/regression/initialization_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Check that bounds are checked when using vector subscripts in initialization +! expressions. (PR 29630) +program test + + implicit none + integer :: i, j + integer, parameter :: a(4,4,4) = reshape([ (i,i=1,64) ], [4,4,4]) + integer, parameter :: v(4) = [5, 1, -4, 2] + + integer :: b2(3) = a(2, 4, [1,7,3]) ! { dg-error "out of bounds" } + integer :: b3(4) = a(1, v, 3) ! { dg-error "out of bounds" } +end program test Index: Fortran/gfortran/regression/initialization_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_30.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR 20851 +! Dummy arguments are disallowed in initialization expressions in +! elemental functions except as arguments to the intrinsic functions +! BIT_SIZE, KIND, LEN, or to the numeric inquiry functions listed +! in 13.11.8 +MODULE TT +INTEGER M +CONTAINS + ELEMENTAL REAL FUNCTION two(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(N) :: scr ! { dg-error "Dummy argument 'n' not allowed in expression" } + END FUNCTION + + ELEMENTAL REAL FUNCTION twopointfive(N) + INTEGER, INTENT(IN) :: N + INTEGER, DIMENSION(MAX(N,2)) :: scr ! { dg-error "Dummy argument 'n' not allowed in expression" } + end FUNCTION twopointfive +END MODULE +END Index: Fortran/gfortran/regression/initialization_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_4.f90 @@ -0,0 +1,7 @@ +! PR 29441 : No error was given for disallowed function in +! initialization expression, even if -std=f95 was used +! { dg-do compile } +! { dg-options "-std=f95" } +real, parameter :: pi = 4.0*Atan(1.0) ! { dg-error "Fortran 2003: Elemental function as initialization expression" } +real, parameter :: three = 27.0**(1.0/3.0) ! { dg-error "Noninteger exponent in an initialization expression" } +end Index: Fortran/gfortran/regression/initialization_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_5.f90 @@ -0,0 +1,7 @@ +! initialization expression, now allowed in Fortran 2003 +! PR fortran/29962 +! { dg-do run } +! { dg-options "-std=f2003 " } + real, parameter :: three = 27.0**(1.0/3.0) + if(abs(three-3.0)>epsilon(three)) STOP 1 +end Index: Fortran/gfortran/regression/initialization_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_6.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options -O2 } +! Tests the fix for PRs29507 and 31404, where elemental functions in +! initialization expressions could not be simplified with array arguments. +! +! Contributed by Steve Kargl +! and Vivek Rao +! + real, parameter :: a(2,2) = reshape ((/1.0, 2.0, 3.0, 4.0/), (/2,2/)) + real, parameter :: b(2,2) = sin (a) + character(8), parameter :: oa(1:3)=(/'nint() ', 'log10() ', 'sqrt() '/) + integer, parameter :: ob(1:3) = index(oa, '(') + character(6), parameter :: ch(3) = (/"animal", "person", "mantee"/) + character(1), parameter :: ch2(3) = (/"n", "r", "t"/) + integer, parameter :: i(3) = index (ch, ch2) + integer :: ic(1) = len_trim((/"a"/)) + + if (any (reshape (b, (/4/)) .ne. (/(sin(real(k)), k = 1,4)/))) STOP 1 + if (any (ob .ne. (/5,6,5/))) STOP 2 ! Original PR29507 + if (any (i .ne. (/2,3,4/))) STOP 3 + if (ic(1) .ne. 1) STOP 4 ! Original PR31404 +end Index: Fortran/gfortran/regression/initialization_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_7.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/31253 -- ICE on invlid initialization expression +! Contributed by: Mikael Morin +! + +subroutine probleme(p) + real(kind=8), dimension(:) :: p + integer :: nx = size(p, 1) ! { dg-error "Assumed-shape array" } + integer :: nix + + nix = nx +end subroutine Index: Fortran/gfortran/regression/initialization_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_8.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/31639 -- ICE on invalid initialization expression + +function f() + integer :: i = irand() ! { dg-error "not permitted in an initialization expression" } + f = i +end function Index: Fortran/gfortran/regression/initialization_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/initialization_9.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/31639 +! Contributed by Martin Michlmayr + + integer function xstrcmp(s1) + character*(*), intent(in) :: s1 + integer :: n1 = len(s1) ! { dg-error "Assumed or deferred character length variable" } + n1 = 1 + return + end function xstrcmp Index: Fortran/gfortran/regression/inline_matmul_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_1.f90 @@ -0,0 +1,152 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs" } +! PR 37131 - check basic functionality of inlined matmul, making +! sure that the library is not called, with and without reallocation. + +program main + implicit none + integer, parameter :: offset = -2 + real, dimension(3,2) :: a + real, dimension(2,4) :: b + real, dimension(3,4) :: c + real, dimension(3,4) :: cres + real, dimension(:,:), allocatable :: c_alloc + integer, parameter :: a1_lower_p = 1 + offset, a1_upper_p = size(a,1) + offset + integer, parameter :: a2_lower_p = 1 + offset, a2_upper_p = size(a,2) + offset + integer, parameter :: b1_lower_p = 1 + offset, b1_upper_p = size(b,1) + offset + integer, parameter :: b2_lower_p = 1 + offset, b2_upper_p = size(b,2) + offset + integer, parameter :: c1_lower_p = 1 + offset, c1_upper_p = size(c,1) + offset + integer, parameter :: c2_lower_p = 1 + offset, c2_upper_p = size(c,2) + offset + real, dimension(a1_lower_p:a1_upper_p, a2_lower_p:a2_upper_p) :: ap + real, dimension(b1_lower_p:b1_upper_p, b2_lower_p:b2_upper_p) :: bp + real, dimension(c1_lower_p:c1_upper_p, c2_lower_p:c2_upper_p) :: cp + real, dimension(4,8,4) :: f, fresult + integer :: eight = 8, two = 2 + + type foo + real :: a + integer :: i + end type foo + + type(foo), dimension(3,2) :: afoo + type(foo), dimension(2,4) :: bfoo + type(foo), dimension(3,4) :: cfoo + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + data fresult / & + 0., 0., 195., 0., 0., 17., 0., 0., 0., -23.,-304., 0., 0., 0., 0., 0., & + 0., 0., 384., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 2., 0., 275., 0., -3., 29., 0., 0., 5., -31.,-428., 0., 0., 0., 0., 0., & + 0., 0., 548., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + -7., 0., 347., 0., 11., 37., 0., 0., -13., -39.,-540., 0., 0., 0., 0., 0., & + 0., 0., 692., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 411., 0., 0., 41., 0., 0., 0., -47.,-640., 0., 0., 0., 0., 0., & + 0., 0., 816., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ + + integer :: a1 = size(a,1), a2 = size(a,2) + integer :: b1 = size(b,1), b2 = size(b,2) + integer :: c1 = size(c,1), c2 = size(c,2) + + integer :: a1_lower, a1_upper, a2_lower, a2_upper + integer :: b1_lower, b1_upper, b2_lower, b2_upper + integer :: c1_lower, c1_upper, c2_lower, c2_upper + + a1_lower = 1 + offset ; a1_upper = a1 + offset + a2_lower = 1 + offset ; a2_upper = a2 + offset + b1_lower = 1 + offset ; b1_upper = b1 + offset + b2_lower = 1 + offset ; b2_upper = b2 + offset + c1_lower = 1 + offset ; c1_upper = c1 + offset + c2_lower = 1 + offset ; c2_upper = c2 + offset + + c = matmul(a,b) + if (sum(abs(c-cres))>1e-4) STOP 1 + + c_alloc = matmul(a,b) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 2 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 3 + deallocate(c_alloc) + + allocate(c_alloc(4,4)) + c_alloc = matmul(a,b) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 4 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 5 + deallocate(c_alloc) + + allocate(c_alloc(3,3)) + c_alloc = matmul(a,b) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 6 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 7 + + c_alloc = 42. + c_alloc(:,:) = matmul(a,b) + if (sum(abs(c_alloc-cres))>1e-4) STOP 8 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 9 + + deallocate(c_alloc) + + ap = a + bp = b + cp = matmul(ap, bp) + if (sum(abs(cp-cres)) > 1e-4) STOP 10 + + f = 0 + f(1,1:3,2:3) = a + f(2,2:3,:) = b + c = matmul(f(1,1:3,2:3), f(2,2:3,:)) + if (sum(abs(c-cres))>1e-4) STOP 11 + + f(3,1:eight:2,:) = matmul(a, b) + if (sum(abs(f(3,1:eight:2,:)-cres))>1e-4) STOP 12 + + afoo%a = a + bfoo%a = b + cfoo%a = matmul(afoo%a, bfoo%a) + + if (sum(abs(cfoo%a-cres)) > 1e-4) STOP 13 + + block + real :: aa(a1, a2), bb(b1, b2), cc(c1, c2) + real :: am(a1_lower:a1_upper, a2_lower:a2_upper) + real :: bm(b1_lower:b1_upper, b2_lower:b2_upper) + real :: cm(c1_lower:c1_upper, c2_lower:c2_upper) + + aa = a + bb = b + am = a + bm = b + + cc = matmul(aa,bb) + if (sum(cc-cres)>1e-4) STOP 14 + c_alloc = matmul(aa,bb) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 15 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 16 + c_alloc = 42. + deallocate(c_alloc) + + allocate(c_alloc(4,4)) + c_alloc = matmul(aa,bb) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 17 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 18 + deallocate(c_alloc) + + allocate(c_alloc(3,3)) + c_alloc = matmul(aa,bb) ! { dg-warning "Code for reallocating the allocatable array" } + if (sum(abs(c_alloc-cres))>1e-4) STOP 19 + if (any([size(c_alloc,1), size(c_alloc,2)] /= [3,4])) STOP 20 + deallocate(c_alloc) + + cm = matmul(am, bm) + if (sum(abs(cm-cres)) > 1e-4) STOP 21 + + cm = 42. + + cm(:,:) = matmul(a,bm) + if (sum(abs(cm-cres)) > 1e-4) STOP 22 + + end block + +end program main + +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_10.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 66111 - this used to ICE with matmul inlining. +! Original test case by Mikael Morin. + +implicit none + integer, parameter :: n = 4 + integer, dimension(n, n) :: a, b, c + integer, dimension(n*n) :: p, res, res2 + integer, dimension(n) :: v + + integer :: i + + p = [ +59, -53, +47, -43, & + -37, +31, -29, +23, & + +19, -17, +13, -11, & + - 7, + 5, - 3, + 2 ] + a = reshape(p, shape(a)) + b = reshape([(i, i=1, size(a))], shape(b)) + v = [ 3, 1, 2, 4] + c = matmul(a, b) + res = [ + 14, - 22, + 16, - 22, & + +150, -158, +128, -138, & + +286, -294, +240, -254, & + +422, -430, +352, -370 ] + !print *,c + if (any(c /= reshape(res, shape(c)))) STOP 1 + c(:,v) = matmul(a, b) + if (any(c(:,v) /= reshape(res, shape(c)))) STOP 2 + c(v,:) = matmul(a, b) + if (any(c(v,:) /= reshape(res, shape(c)))) STOP 3 + + c = matmul(a(:,v),b(v,:)) + if (any(c /= reshape(res, shape(c)))) STOP 4 +end Index: Fortran/gfortran/regression/inline_matmul_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_11.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-additional-options "-ffrontend-optimize -fdump-tree-optimized" } +! PR fortran/66176 - inline conjg for matml. +program main + complex, dimension(3,2) :: a + complex, dimension(2,4) :: b, b2 + complex, dimension(3,4) :: c,c2 + complex, dimension(3,4) :: res1, res2, res3 + + data a/(2.,-3.),(-5.,-7.),(11.,-13.),(-17.,-19.),(23.,-29.),(-31.,-37.) / + data b/(41.,-43.),(-47.,-53.),(59.,-61.),(-67.,-71.),(73.,-79.),& + & (-83.,-89.),(97.,-101.), (-103.,-107.)/ + + data res1 / (-255.,1585.),(-3124.,72.),(-612.,2376.),(-275.,2181.), & + & (-4322.,202.),(-694.,3242.),(-371.,2713.),( -5408.,244.),(-944.,4012.),& + & (-391.,3283.),(-6664.,352.),(-1012.,4756.)/ + + data res2 / (2017.,-45.),(552.,2080.),(4428.,36.),(2789.,11.),(650.,2858.),& + & (6146.,182.),(3485.,3.),(860.,3548.),(7696.,232.),(4281.,49.),& + & (956.,4264.),(9532.,344.)/ + + c = matmul(a,b) + if (any(res1 /= c)) STOP 1 + b2 = conjg(b) + c = matmul(a,conjg(b2)) + if (any(res1 /= c)) STOP 2 + c = matmul(a,conjg(b)) + if (any(res2 /= c)) STOP 3 + c = matmul(conjg(a), b) + if (any(conjg(c) /= res2)) STOP 4 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_12.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 69154 - inlined matmul used to cause an ICE inside a WHERE. +MODULE m_numeric_tools + INTEGER, PARAMETER :: dp=8 +CONTAINS +subroutine llsfit_svd(xx,yy,sigma,nfuncs,funcs,chisq,par,var,cov,info) + real(dp),intent(in) :: xx(:),yy(:),sigma(:) + real(dp),dimension(SIZE(xx)) :: bb,sigm1 + real(dp) :: tmp(nfuncs) + real(dp),allocatable :: work(:),Vt(:,:),U(:,:),S(:) + real(dp),dimension(3,3) :: a, b, c + WHERE (S>TOL_*MAXVAL(S)) + tmp=MATMUL(bb,U)/S + END WHERE + call random_number(a) + call random_number(b) + c = matmul(a,b) +end subroutine llsfit_svd + +END MODULE m_numeric_tools +! { dg-final { scan-tree-dump-times "matmul_r8" 1 "original" } } Index: Fortran/gfortran/regression/inline_matmul_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_13.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original -Wrealloc-lhs" } +! PR 66094: Check functionality for MATMUL(A, TRANSPSE(B)) +module x +contains + subroutine mm1(a,b,c) + real, dimension(:,:), intent(in) :: a, b + real, dimension(:,:), intent(out) :: c + c = -42. + c = matmul(a, transpose(b)) + end subroutine mm1 +end module x + +program main + use x + implicit none + integer, parameter :: n = 3, m=4, cnt=2 + real, dimension(n,cnt) :: a + real, dimension(m,cnt) :: b + real, dimension(n,m) :: c, cres + real, dimension(:,:), allocatable :: calloc + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres / -225., 356., -396., 227., -360., 392., & + -229., 364., -388., 267., -424., 456./ + + c = matmul(a,transpose(b)) + if (sum(c-cres)>1e-4) STOP 1 + call mm1 (a, b, c) + if (sum(c-cres)>1e-4) STOP 2 + + ! Unallocated + calloc = matmul(a,transpose(b)) ! { dg-warning "Code for reallocating the allocatable array" } + if (any(shape(c) /= shape(calloc))) STOP 3 + if (sum(calloc-cres)>1e-4) STOP 4 + deallocate(calloc) + + ! Allocated to wrong shape + allocate (calloc(10,10)) + calloc = matmul(a,transpose(b)) ! { dg-warning "Code for reallocating the allocatable array" } + if (any(shape(c) /= shape(calloc))) STOP 5 + if (sum(calloc-cres)>1e-4) STOP 6 + deallocate(calloc) + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "original" } } Index: Fortran/gfortran/regression/inline_matmul_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_14.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-options "-O -ffrontend-optimize -fdump-tree-optimized" } +! PR 79930 - missed optimization by not inlining matmul in expressions. + +module foo + implicit none +contains + subroutine test1 + ! Test with fixed dimensions + real, dimension(3,2) :: a1 + real, dimension(2,4) :: b1 + real, dimension(3,4) :: cres1 + real, dimension(3,3) :: a2 + real, dimension(3) :: v1, v2 + real :: r + character(len=9*18) :: r1, r2 + real(kind=8), dimension(3,3) :: a3, b3, c3, d3, res3 + + data a1 / 2., -3., 5., -7., 11., -13./ + data b1 /17., -23., 29., -31., 37., -39., 41., -47./ + data cres1 /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + + data a2 / 2., -3., 5., -7., 11., -13., 17., -23., 29./ + data v1 /-31., 37., -41./ + data v2 /43., -47., 53./ + + data a3/-2.d0, 3.d0, 5.d0, -7.d0, -11.d0, 13.d0, 17.d0, -19.d0, -23.d0/ + data b3/29.d0, -31.d0, 37.d0, -41.d0, 43.d0, -47.d0, 53.d0, -59.d0, 61.d0/ + data c3/-67.d0,71.d0, 73.d0, -79.d0, -83.d0, 89.d0, 97.d0, -101.d0, 103.d0/ + data d3/107.d0, 109.d0, 113.d0, 127.d0, 131.d0, 137.d0, 139.d0, 149.d0, 151.d0/ + data res3/48476106.d0, -12727087.d0, -68646789.d0, 58682206.d0, -15428737.d0, -83096539.d0,& + & 65359710.d0, -17176589.d0, -92551887.d0/ + + write (unit=r1, fmt='(12F12.5)') matmul(a1,b1) + write (unit=r2, fmt='(12F12.5)') cres1 + if (r1 /= r2) STOP 1 + + r = dot_product(matmul(a2,v1),v2) + if (abs(r+208320) > 1) STOP 2 + + write (unit=r1,fmt='(1P,9E18.10)') matmul(matmul(a3,b3),matmul(c3,d3)) + write (unit=r2,fmt='(1P,9E18.10)') res3 + if (r1 /= r2) STOP 3 + + end subroutine test1 + + subroutine test2 + ! Test with dimensions not known at compile-time + real, dimension(:,:), allocatable :: a1 + real, dimension(:,:), allocatable :: b1 + real, dimension(3,4) :: cres1 + real, dimension(:,:), allocatable :: a2 + real, dimension(:), allocatable :: v1, v2 + real :: r + character(len=9*18) :: r1, r2 + real(kind=8), dimension(3,3) :: a3, b3, c3, d3, res3 + data cres1 /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + data res3/48476106.d0, -12727087.d0, -68646789.d0, 58682206.d0, -15428737.d0, -83096539.d0,& + & 65359710.d0, -17176589.d0, -92551887.d0/ + + a1 = reshape([ 2., -3., 5., -7., 11., -13.], [3,2]) + b1 = reshape([17., -23., 29., -31., 37., -39., 41., -47.],[2,4]) + + a2 = reshape([2., -3., 5., -7., 11., -13., 17., -23., 29.],[3,3]); + v1 = [-31., 37., -41.] + v2 = [43., -47., 53.] + + a3 = reshape([-2.d0, 3.d0, 5.d0, -7.d0, -11.d0, 13.d0, 17.d0, -19.d0, -23.d0], [3,3]) + b3 = reshape([29.d0, -31.d0, 37.d0, -41.d0, 43.d0, -47.d0, 53.d0, -59.d0, 61.d0], [3,3]) + c3 = reshape([-67.d0,71.d0, 73.d0, -79.d0, -83.d0, 89.d0, 97.d0, -101.d0, 103.d0], [3,3]) + d3 = reshape([107.d0, 109.d0, 113.d0, 127.d0, 131.d0, 137.d0, 139.d0, 149.d0, 151.d0],[3,3]) + + write (unit=r1, fmt='(12F12.5)') matmul(a1,b1) + write (unit=r2, fmt='(12F12.5)') cres1 + if (r1 /= r2) STOP 4 + + r = dot_product(matmul(a2,v1),v2) + if (abs(r+208320) > 1) STOP 5 + + write (unit=r1,fmt='(1P,9E18.10)') matmul(matmul(a3,b3),matmul(c3,d3)) + write (unit=r2,fmt='(1P,9E18.10)') res3 + if (r1 /= r2) STOP 6 + + end subroutine test2 + +end module foo + +program main + use foo + implicit none + call test1 + call test2 +! call test3 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_15.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-shouldfail "dimension of array B incorrect in MATMUL intrinsic" } +! { dg-options "-O -finline-matmul-limit=100 -fcheck=bounds" } +program main + real, dimension(:,:), allocatable :: a + real, dimension(:), allocatable :: b + allocate (a(2,2), b(3)) + call random_number(a) + call random_number(b) + print *,matmul(a,b) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1" } Index: Fortran/gfortran/regression/inline_matmul_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_16.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs -finline-matmul-limit=1000 -O" } +! PR 66094: Check functionality for MATMUL(TRANSPOSE(A),B)) for two-dimensional arrays +program main + implicit none + integer, parameter :: n = 3, m=4, cnt=2 + real, dimension(cnt,n) :: a + real, dimension(cnt,m) :: b + real, dimension(n,m) :: c, cres + real, dimension(:,:), allocatable :: calloc + integer :: in, im, icnt + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /103., 246., 486., 151., 362., 722., & + 191., 458., 914., 223., 534., 1062./ + + c = matmul(transpose(a),b) + if (sum(c-cres)>1e-4) STOP 1 + if (sum(c-cres)>1e-4) STOP 2 + + ! Unallocated + calloc = matmul(transpose(a),b) ! { dg-warning "Code for reallocating the allocatable array" } + if (any(shape(c) /= shape(calloc))) STOP 3 + if (sum(calloc-cres)>1e-4) STOP 4 + deallocate(calloc) + + ! Allocated to wrong shape + allocate (calloc(10,10)) + calloc = matmul(transpose(a),b) ! { dg-warning "Code for reallocating the allocatable array" } + if (any(shape(c) /= shape(calloc))) STOP 5 + if (sum(calloc-cres)>1e-4) STOP 6 + deallocate(calloc) + + ! cycle through a few test cases... + do in=2,10 + do im = 2,10 + do icnt = 2,10 + block + real, dimension(icnt,in) :: a2 + real, dimension(icnt,im) :: b2 + real, dimension(in,im) :: c2,cr + integer :: i,j,k + call random_number(a2) + call random_number(b2) + c2 = 0 + do i=1,size(a2,2) + do j=1, size(b2,2) + do k=1, size(a2,1) + c2(i,j) = c2(i,j) + a2(k,i) * b2(k,j) + end do + end do + end do + cr = matmul(transpose(a2), b2) + if (any(abs(c2-cr) > 1e-4)) STOP 7 + end block + end do + end do + end do +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_17.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-optimized -finline-matmul-limit=1000" } +module x + implicit none +contains + function afunc() + real, dimension(3,3) :: afunc + afunc = reshape([ 2., 3., 5., 7., 11., 13., 17., 19., 23. ], [3,3]) + end function afunc + + function bfunc() + real, dimension(3,3) :: bfunc + bfunc = reshape([29., 31., 37., 41., 43., 47., 53., 59., 61., 67.],[3,3]) + end function bfunc +end module x + +program main + use x + implicit none + real, dimension(3,3), parameter :: & + & aval = reshape([ 2., 3., 5., 7., 11., 13., 17., 19., 23. ], [3,3]), & + & bval = reshape([29., 31., 37., 41., 43., 47., 53., 59., 61., 67.],[3,3]) + integer, dimension(3) :: ind + real, dimension(3,3) :: a, b,c,d, ri + data ri /120430., 187861., 151737., 161022., 251139., 202847., 212566., 331537., 267781./ + data d/904., 1131., 1399., 1182., 1489., 1845., 1556., 1967., 2435. / + a = aval + b = bval + c = matmul(a,b) + a = matmul(a,b) + if (any(a-c /= 0)) STOP 1 + a = aval + b = bval + b = matmul(a,b) + if (any(b-c /= 0)) STOP 2 + b = bval + a = matmul(aval, b) + if (any(a-c /= 0)) STOP 3 + ind = [1, 3, 2] + c = matmul(a(ind,:),b) + if (any(c-ri /= 0)) STOP 4 + c = matmul(afunc(),b) + if (any(c-d /= 0)) STOP 5 + a = afunc() + c = matmul(a, bfunc()) + if (any(c-d /= 0)) STOP 6 +end program main +! { dg-final { scan-tree-dump-not "matmul_r4" "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_18.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-O -finline-matmul-limit=100 -fdump-tree-optimized" } +! PR 80975 - this did not zero the result array in the library version; +! make sure this also doesn't happen in the inline version. +program bogus_matmul + implicit none + real :: M(3,0), v(0), w(3) + + w = 7 + w = matmul(M,v) + if( any(w .ne. 0) ) then + STOP 1 + end if +end program bogus_matmul +! { dg-final { scan-tree-dump-times "matmul_r4" 0 "optimized" } } + Index: Fortran/gfortran/regression/inline_matmul_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_19.f90 @@ -0,0 +1,34 @@ + ! { dg-do run } + ! { dg-options "-ffrontend-optimize" } + ! PR 81974 - this used to cause an ICE. + + implicit none + COMPLEX(kind=kind(0d0)), DIMENSION(3, 3) :: R + REAL(kind=kind(0d0)), DIMENSION(3, 3) :: M,a,b + complex(8), dimension(3,3) :: res, c + integer :: i, j, k + c = 0 + call random_number(m) + call random_number(a) + call random_number(b) + r = cmplx(a, b, 8) + do k=1,3 + do j=1,3 + do i=1,3 + c(k,j) = c(k,j) + conjg(r(i,k)) * m(i,j) + end do + end do + end do + res = MATMUL(TRANSPOSE(CONJG(R)), M) + if (any(abs(res-c) >= 1e-6)) STOP 1 + c = 0 + do k=1,3 + do j=1,3 + do i=1,3 + c(i,k) = c(i,k) + m(i,j) * conjg(r(k,j)) + end do + end do + end do + res = matmul(m, transpose(conjg(r))) + if (any(abs(res-c) >= 1e-6)) STOP 2 + END Index: Fortran/gfortran/regression/inline_matmul_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_2.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -finline-matmul-limit=0 -fdump-tree-original" } +! PR 37131 - no inlining with -finline-matmul-limit=0 +program main + real, dimension(3,2) :: a + real, dimension(2,4) :: b + real, dimension(3,4) :: c + real, dimension(3,4) :: cres + real, dimension(:,:), allocatable :: calloc + integer :: a1 = size(a,1), a2 = size(a,2) + integer :: b1 = size(b,1), b2 = size(b,2) + integer :: c1 = size(c,1), c2 = size(c,2) + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + c = matmul(a,b) + if (sum(c-cres)>1e-4) STOP 1 + + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 2 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 3 + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 4 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 5 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 6 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 7 + deallocate(calloc) + + block + real :: aa(a1, a2), bb(b1, b2), cc(c1, c2) + aa = a + bb = b + + cc = matmul(aa,bb) + if (sum(cc-cres)>1e-4) STOP 8 + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 9 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 10 + calloc = 42. + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 11 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 12 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 13 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 14 + deallocate(calloc) + end block + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 8 "original" } } Index: Fortran/gfortran/regression/inline_matmul_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_20.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-additional-options "-fno-realloc-lhs -ffrontend-optimize" } +! This used to segfault at runtime. +! Original test case by Harald Anlauf. +program gfcbug142 + implicit none + real, allocatable :: b(:,:) + integer :: n = 5 + character(len=20) :: line + allocate (b(n,n)) + call random_number (b) + write (unit=line,fmt='(2I5)') shape (matmul (b, transpose (b))) + if (line /= ' 5 5') STOP 1 +end program gfcbug142 Index: Fortran/gfortran/regression/inline_matmul_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_21.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-ffrontend-optimize" } +! PR 84133 - this used to ICE. Original test case by +! Gerhard Steinmetz. + +program p + real :: x(2,2) = 1.0 + real :: z(2,2) + associate (y => matmul(x,x)) + z = y + end associate + print *, z +end + + Index: Fortran/gfortran/regression/inline_matmul_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_22.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-additional-options "-ffrontend-optimize" } +! PR 84270 - this used to be rejected. +! Test case by Michael Weinert + +module fp_precision + + integer, parameter :: fp = selected_real_kind(13) + +end module fp_precision + + subroutine lhcal(nrot,orth,ngpts,vgauss,vr_0) + + use fp_precision ! floating point precision + + implicit none + +!---> rotation matrices and rotations (input) + integer, intent(in) :: nrot +! real(kind=fp), intent(in) :: orth(3,3,nrot) ! fine at all -O + real(kind=fp), intent(in) :: orth(3,3,*) + +!---> gaussian integration points + integer, intent(in) :: ngpts + real(kind=fp), intent(in) :: vgauss(3,*) + +!---> output results + real(kind=fp), intent(out) :: vr_0(3) + + real(kind=fp) :: v(3),vr(3) + integer :: n,nn + + vr_0 = 0 + do nn=1,ngpts + v(:) = vgauss(:,nn) +!---> apply rotations + do n=2,nrot + vr = matmul( orth(:,:,n), v ) + vr_0 = vr_0 + vr + enddo + enddo + + return + end subroutine lhcal Index: Fortran/gfortran/regression/inline_matmul_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_23.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-Og -ffrontend-optimize -fcheck=bounds -fdump-tree-optimized" } +! Check that bounds checking is done only before the matrix +! multiplication. + +module y +contains + subroutine x(a,b,c) + real, dimension(:,:) :: a, b, c + c = matmul(a,b) + end subroutine x +end module y +! { dg-final { scan-tree-dump-times "_runtime_error" 3 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_24.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! +! PR fortran/87597 +! +! Contributed by gallmeister +! +! Before, for the inlined matmul, +! gamma5 was converted to an EXPR_ARRAY with lbound = 1 +! instead of the lbound = 0 as declared; leading to +! an off-by-one problem. +! +program testMATMUL + implicit none + complex, dimension(0:3,0:3), parameter :: gamma5 = reshape((/ 0., 0., 1., 0., & + 0., 0., 0., 1., & + 1., 0., 0., 0., & + 0., 1., 0., 0. /),(/4,4/)) + complex, dimension(0:3,0:3) :: A, B, D + integer :: i + + A = 0.0 + do i=0,3 + A(i,i) = i*1.0 + end do + + B = cmplx(7,-9) + B = matmul(A,gamma5) + + D = reshape([0, 0, 2, 0, & + 0, 0, 0, 3, & + 0, 0, 0, 0, & + 0, 1, 0, 0], [4, 4]) + write(*,*) B(0,:) + write(*,*) B(1,:) + write(*,*) B(2,:) + write(*,*) B(3,:) + if (any(B /= D)) then + call abort() + end if +end program testMATMUL +! { dg-final { scan-tree-dump-times "gamma5\\\[__var_1_do \\* 4 \\+ __var_2_do\\\]|gamma5\\\[NON_LVALUE_EXPR <__var_1_do> \\* 4 \\+ NON_LVALUE_EXPR <__var_2_do>\\\]" 1 "original" } } Index: Fortran/gfortran/regression/inline_matmul_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_25.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! PR fortran/99839 - ICE in inline_matmul_assign + +program p + real :: x(3, 3) = 1.0 + class(*), allocatable :: z(:, :) + z = matmul(x, x) +end Index: Fortran/gfortran/regression/inline_matmul_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_3.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-O3 -finline-matmul-limit=2 -fdump-tree-optimized" } +! PR 37131 - all calls to matmul should be kept +program main + real, dimension(3,2) :: a + real, dimension(2,4) :: b + real, dimension(3,4) :: c + real, dimension(3,4) :: cres + real, dimension(:,:), allocatable :: calloc + integer :: a1 = size(a,1), a2 = size(a,2) + integer :: b1 = size(b,1), b2 = size(b,2) + integer :: c1 = size(c,1), c2 = size(c,2) + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + c = matmul(a,b) + if (sum(c-cres)>1e-4) STOP 1 + + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 2 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 3 + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 4 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 5 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 6 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 7 + deallocate(calloc) + + block + real :: aa(a1, a2), bb(b1, b2), cc(c1, c2) + aa = a + bb = b + + cc = matmul(aa,bb) + if (sum(cc-cres)>1e-4) STOP 8 + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 9 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 10 + calloc = 42. + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 11 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 12 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 13 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 14 + deallocate(calloc) + end block + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 8 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_4.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options "-O3 -finline-matmul-limit=10 -fdump-tree-optimized -fdump-tree-original" } +! PR 37131 - all calls to matmul should be optimized away with -O3 +! and the high limit. +program main + real, dimension(3,2) :: a + real, dimension(2,4) :: b + real, dimension(3,4) :: c + real, dimension(3,4) :: cres + real, dimension(:,:), allocatable :: calloc + integer :: a1 = size(a,1), a2 = size(a,2) + integer :: b1 = size(b,1), b2 = size(b,2) + integer :: c1 = size(c,1), c2 = size(c,2) + + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., 692., 411., -640., 816./ + c = matmul(a,b) + if (sum(c-cres)>1e-4) STOP 1 + + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 2 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 3 + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 4 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 5 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(a,b) + if (sum(calloc-cres)>1e-4) STOP 6 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 7 + deallocate(calloc) + + block + real :: aa(a1, a2), bb(b1, b2), cc(c1, c2) + aa = a + bb = b + + cc = matmul(aa,bb) + if (sum(cc-cres)>1e-4) STOP 8 + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 9 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 10 + calloc = 42. + deallocate(calloc) + + allocate(calloc(4,4)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 11 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 12 + deallocate(calloc) + + allocate(calloc(3,3)) + calloc = matmul(aa,bb) + if (sum(calloc-cres)>1e-4) STOP 13 + if (any([size(calloc,1), size(calloc,2)] /= [3,4])) STOP 14 + deallocate(calloc) + end block + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 4 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/inline_matmul_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_5.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +program main + + real, dimension(2,2) :: a,b,c + + data a /2., 4., 8., 16. / + data b /3., 9., 27., 81./ + + c = matmul(a,b) + a = matmul(a,b) + if (any(a /= c)) STOP 1 +end program main Index: Fortran/gfortran/regression/inline_matmul_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_6.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 37131 - check rank1/rank2 and rank2/rank1 cases for inline matmul. + +module foo + implicit none +contains + subroutine a1b2(a,b,c) + real, dimension(:), intent(in) :: a + real, dimension(:,:), intent(in) :: b + real, dimension(:), intent(out) :: c + + c = matmul(a,b) + end subroutine a1b2 + + subroutine a2b1(a,b,c) + real, dimension(:,:), intent(in) :: a + real, dimension(:), intent(in) :: b + real, dimension(:), intent(out) :: c + + c = matmul(a,b) + end subroutine a2b1 +end module foo + +program main + use foo + implicit none + real, dimension(3) :: a1 + real, dimension(3,2) :: b1 + real, dimension(2) :: c1 + + real, dimension(3,2) :: a2 + real, dimension(2) :: b2 + real, dimension(3) :: c2 + + data a1 /17., -23., 29./ + data b1 / 2., -3., 5., -7., 11., -13./ + + data b2/-2.,5./ + + a2 = -b1 + call a1b2(a1,b1,c1) + if (any(abs(c1 - (/248., -749./)) > 1e-3)) STOP 1 + call a2b1(a2,b2,c2) + if (any(abs(c2 - (/39., -61., 75./)) > 1e-3)) STOP 2 +end program main + +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "original" } } Index: Fortran/gfortran/regression/inline_matmul_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_7.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } + +program main + implicit none + real(kind=8), ALLOCATABLE :: a(:,:), b(:,:), v1(:), v2(:) + real(kind=8), dimension(3,3) :: v1res, v2res + integer :: n, i + + data v1res/ 442.d0, -492.d0, 586.d0, & + -4834.d0, 5694.d0, -7066.d0, & + 13042.d0, -15450.d0, 19306.d0 / + + data v2res/ 5522.d0, -6310.d0, 7754.d0, & + -7794.d0, 8982.d0, -11034.d0, & + 10490.d0, -12160.d0, 14954.d0 / + n = 3 + + ALLOCATE(a(N,N),b(N,N),v1(N), v2(N)) + + a = reshape([((-1)**i*(-i-5)*(i+3)+5,i=1,n**2)], shape(a)) + b = reshape([((-1)**i*(-i-1)*(i-2),i=1,n**2)], shape(a)) + + DO i=1,N + v1 = MATMUL(a,b(:,i)) + if (any(abs(v1-v1res(:,i)) > 1e-10)) STOP 1 + + v2 = MATMUL(a,b(i,:)) + if (any(abs(v2-v2res(:,i)) > 1e-10)) STOP 2 + + ENDDO + +END program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "original" } } Index: Fortran/gfortran/regression/inline_matmul_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_8.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 66041 - this used to ICE with an incomplete fix for the PR. +program main + implicit none + real, dimension(1,-2:0) :: a1 + real, dimension(3,2) :: b1 + real, dimension(2) :: c1 + + data a1 /17., -23., 29./ + data b1 / 2., -3., 5., -7., 11., -13./ + + c1 = matmul(a1(1,:), b1) + if (any (c1-[248., -749.] /= 0.)) STOP 1 +end program main + +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "original" } } Index: Fortran/gfortran/regression/inline_matmul_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_matmul_9.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-optimized" } +! PR 66041 - this used to ICE with an incomplete fix for the PR. +program main + implicit none + type :: t + real :: c + end type t + type(t), dimension(1,-2:0) :: a1 + real, dimension(3,2) :: b1 + real, dimension(2) :: c1 + real, dimension(1,2) :: c2 + + data a1%c /17., -23., 29./ + data b1 / 2., -3., 5., -7., 11., -13./ + + c1 = matmul(a1(1,:)%c, b1) + if (any (c1-[248., -749.] /= 0.)) STOP 1 + + c2 = matmul(a1%c, b1) + if (any (c2-reshape([248., -749.],shape(c2)) /= 0.)) STOP 2 +end program main + +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/inline_product_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_product_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -O -fdump-tree-original" } +! +! PR fortran/43829 +! Scalarization of reductions. +! Test that product is properly inlined. + +! For more extended tests, see inline_sum_1.f90 + + implicit none + + + integer :: i + + integer, parameter :: q = 2 + integer, parameter :: nx=3, ny=2*q, nz=5 + integer, parameter, dimension(nx,ny,nz) :: p = & + & reshape ((/ (i, i=1,size(p)) /), shape(p)) + + + integer, dimension(nx,ny,nz) :: a + integer, dimension(nx, nz) :: ay + + a = p + + ay = product(a,2) + +end +! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 0 "original" } } +! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 0 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_product_" 0 "original" } } Index: Fortran/gfortran/regression/inline_sum_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_1.f90 @@ -0,0 +1,193 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -O -fdump-tree-original" } +! +! PR fortran/43829 +! Scalarization of reductions. +! Test that sum is properly inlined. + +! This is the compile time test only; for the runtime test see inline_sum_2.f90 +! We can't test for temporaries on the run time test directly, as it tries +! several optimization options among which -Os, and sum inlining is disabled +! at -Os. + + + implicit none + + + integer :: i, j, k + + integer, parameter :: q = 2 + integer, parameter :: nx=3, ny=2*q, nz=5 + integer, parameter, dimension(nx,ny,nz) :: p = & + & reshape ((/ (i**2, i=1,size(p)) /), shape(p)) + + integer, parameter, dimension( ny,nz) :: px = & + & reshape ((/ (( & + & nx*( nx*j+nx*ny*k+1)*( nx*j+nx*ny*k+1+ (nx-1)) & + & + nx*(nx-1)*(2*nx-1)/6, & + & j=0,ny-1), k=0,nz-1) /), shape(px)) + + integer, parameter, dimension(nx, nz) :: py = & + & reshape ((/ (( & + & ny*(i +nx*ny*k+1)*(i +nx*ny*k+1+nx *(ny-1)) & + & +(nx )**2*ny*(ny-1)*(2*ny-1)/6, & + & i=0,nx-1), k=0,nz-1) /), shape(py)) + + integer, parameter, dimension(nx,ny ) :: pz = & + & reshape ((/ (( & + & nz*(i+nx*j +1)*(i+nx*j +1+nx*ny*(nz-1)) & + & +(nx*ny)**2*nz*(nz-1)*(2*nz-1)/6, & + & i=0,nx-1), j=0,ny-1) /), shape(pz)) + + + integer, dimension(nx,ny,nz) :: a + integer, dimension( ny,nz) :: ax + integer, dimension(nx, nz) :: ay + integer, dimension(nx,ny ) :: az + + logical, dimension(nx,ny,nz) :: m, true + + + integer, dimension(nx,ny) :: b + + integer, dimension(nx,nx) :: onesx + integer, dimension(ny,ny) :: onesy + integer, dimension(nz,nz) :: onesz + + + a = p + m = reshape((/ ((/ .true., .false. /), i=1,size(m)/2) /), shape(m)) + true = reshape((/ (.true., i=1,size(true)) /), shape(true)) + + onesx = reshape((/ ((1, j=1,i),(0,j=1,nx-i),i=1,size(onesx,2)) /), shape(onesx)) + onesy = reshape((/ ((1, j=1,i),(0,j=1,ny-i),i=1,size(onesy,2)) /), shape(onesy)) + onesz = reshape((/ ((1, j=1,i),(0,j=1,nz-i),i=1,size(onesz,2)) /), shape(onesz)) + + ! Correct results in simple cases + ax = sum(a,1) + if (any(ax /= px)) STOP 1 + + ay = sum(a,2) + if (any(ay /= py)) STOP 2 + + az = sum(a,3) + if (any(az /= pz)) STOP 3 + + + ! Masks work + if (any(sum(a,1,.false.) /= 0)) STOP 4 + if (any(sum(a,2,.true.) /= py)) STOP 5 + if (any(sum(a,3,m) /= merge(pz,0,m(:,:,1)))) STOP 6 + if (any(sum(a,2,m) /= merge(sum(a(:, ::2,:),2),& + sum(a(:,2::2,:),2),& + m(:,1,:)))) STOP 7 + + + ! It works too with array constructors ... + if (any(sum( & + reshape((/ (i*i,i=1,size(a)) /), shape(a)), & + 1, & + true) /= ax)) STOP 8 + + ! ... and with vector subscripts + if (any(sum( & + a((/ (i,i=1,nx) /), & + (/ (i,i=1,ny) /), & + (/ (i,i=1,nz) /)), & + 1) /= ax)) STOP 9 + + if (any(sum( & + a(sum(onesx(:,:),1), & ! unnecessary { dg-warning "Creating array temporary" } + sum(onesy(:,:),1), & ! unnecessary { dg-warning "Creating array temporary" } + sum(onesz(:,:),1)), & ! unnecessary { dg-warning "Creating array temporary" } + 1) /= ax)) STOP 10 + + + ! Nested sums work + if (sum(sum(sum(a,1),1),1) /= sum(a)) STOP 11 + if (sum(sum(sum(a,1),2),1) /= sum(a)) STOP 12 + if (sum(sum(sum(a,3),1),1) /= sum(a)) STOP 13 + if (sum(sum(sum(a,3),2),1) /= sum(a)) STOP 14 + + if (any(sum(sum(a,1),1) /= sum(sum(a,2),1))) STOP 15 + if (any(sum(sum(a,1),2) /= sum(sum(a,3),1))) STOP 16 + if (any(sum(sum(a,2),2) /= sum(sum(a,3),2))) STOP 17 + + + ! Temps are unavoidable here (function call's argument or result) + ax = sum(neid3(a),1) ! { dg-warning "Creating array temporary" } + ! Sums as part of a bigger expr work + if (any(1+sum(eid(a),1)+ax+sum( & + neid3(a), & ! { dg-warning "Creating array temporary" } + 1)+1 /= 3*ax+2)) STOP 18 + if (any(1+eid(sum(a,2))+ay+ & + neid2( & ! { dg-warning "Creating array temporary" } + sum(a,2) & ! { dg-warning "Creating array temporary" } + )+1 /= 3*ay+2)) STOP 19 + if (any(sum(eid(sum(a,3))+az+2* & + neid2(az) & ! { dg-warning "Creating array temporary" } + ,1)+1 /= 4*sum(az,1)+1)) STOP 20 + + if (any(sum(transpose(sum(a,1)),1)+sum(az,1) /= sum(ax,2)+sum(sum(a,3),1))) STOP 21 + + + ! Creates a temp when needed. + a(1,:,:) = sum(a,1) ! unnecessary { dg-warning "Creating array temporary" } + if (any(a(1,:,:) /= ax)) STOP 22 + + b = p(:,:,1) + call set(b(2:,1), sum(b(:nx-1,:),2)) ! { dg-warning "Creating array temporary" } + if (any(b(2:,1) /= ay(1:nx-1,1))) STOP 23 + + b = p(:,:,1) + call set(b(:,1), sum(b,2)) ! unnecessary { dg-warning "Creating array temporary" } + if (any(b(:,1) /= ay(:,1))) STOP 24 + + b = p(:,:,1) + call tes(sum(eid(b(:nx-1,:)),2), b(2:,1)) ! { dg-warning "Creating array temporary" } + if (any(b(2:,1) /= ay(1:nx-1,1))) STOP 25 + + b = p(:,:,1) + call tes(eid(sum(b,2)), b(:,1)) ! unnecessary { dg-warning "Creating array temporary" } + if (any(b(:,1) /= ay(:,1))) STOP 26 + +contains + + elemental function eid (x) + integer, intent(in) :: x + integer :: eid + + eid = x + end function eid + + function neid2 (x) + integer, intent(in) :: x(:,:) + integer :: neid2(size(x,1),size(x,2)) + + neid2 = x + end function neid2 + + function neid3 (x) + integer, intent(in) :: x(:,:,:) + integer :: neid3(size(x,1),size(x,2),size(x,3)) + + neid3 = x + end function neid3 + + elemental subroutine set (o, i) + integer, intent(in) :: i + integer, intent(out) :: o + + o = i + end subroutine set + + elemental subroutine tes (i, o) + integer, intent(in) :: i + integer, intent(out) :: o + + o = i + end subroutine tes +end +! { dg-final { scan-tree-dump-times "struct array.._integer\\(kind=4\\) atmp" 13 "original" } } +! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 13 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_sum_" 0 "original" } } Index: Fortran/gfortran/regression/inline_sum_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + +! PR fortran/43829 +! Scalarization of reductions. +! Test that inlined sum is correct. + +! We can't check for the absence of temporary arrays generated on the run-time +! testcase, as inlining is disabled at -Os, so it will fail in that case. +! Thus, the test is splitted into two independant files, one checking for +! the absence of temporaries, and one (this one) checking that the code +! generated remains valid at all optimization levels. +include 'inline_sum_1.f90' Index: Fortran/gfortran/regression/inline_sum_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/51250 +! Wrong loop shape for SUM when arguments are library-allocated arrays. +! +! Original testcase provided by Harald Anlauf + +program gfcbug115 + implicit none + integer :: n_obstype = 2 + integer :: nboxes = 1 + integer :: nprocs = 1 + integer :: nbox, j + integer, allocatable :: nbx(:,:), pes(:) + + allocate (pes(nboxes)) + allocate (nbx(n_obstype,nboxes)) + nbx(:,:) = 1 + do j = 1, nboxes + pes(j) = modulo (j-1, nprocs) + end do + if (any(nbx /= 1)) STOP 1 + do j = 0, nprocs-1 + if (.not. all(spread (pes==j,dim=1,ncopies=n_obstype))) STOP 2 + ! The two following tests used to fail + if (any(shape(sum(nbx,dim=2,mask=spread (pes==j,dim=1,ncopies=n_obstype))) & + /= (/ 2 /))) STOP 3 + if (any(sum (nbx,dim=2,mask=spread (pes==j,dim=1,ncopies=n_obstype)) & + /= (/ 1, 1 /))) STOP 4 + end do +end program gfcbug115 Index: Fortran/gfortran/regression/inline_sum_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/53732 +! this was leading to an internal "mismatching comparison operand types" +! error. +! +! Original testcase by minzastro +! Fixed by Dominique Dhumieres + +program test +implicit none + +real(8) arr(4,4,4,4) + +arr(:,:,:,:) = 1d0 + +arr(1,:,:,:) = sum(arr, dim=1, mask=(arr(:,:,:,:) > 0d0)) + +end program test Index: Fortran/gfortran/regression/inline_sum_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_5.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/57798 +! The call to sum used to be inlined into a loop with an uninitialized bound +! +! Original testcase by Stephan Kramer + +program test + implicit none + + call sub(2, 11) + + contains + + function func(m, n) + integer, intent(in):: m,n + real, dimension(m, n):: func + + func = 1.0 + + end function func + + subroutine sub(m, n) + integer, intent(in):: m, n + real, dimension(m,n):: y + + y = 1.0 + if (any(sum(y*func(m,n), dim=1) /= m)) STOP 1 + + end subroutine sub + +end program test + Index: Fortran/gfortran/regression/inline_sum_bounds_check_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_bounds_check_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + + integer, parameter :: nx = 3, ny = 4 + + integer :: i, j, too_big + + integer, parameter, dimension(nx,ny) :: p = & + reshape((/ (i*i, i=1,size(p)) /), shape(p)) + + integer, dimension(nx,ny) :: a + + integer, dimension(:), allocatable :: b + + allocate(b(nx)) + + a = p + too_big = ny + 1 + + b = sum(a(:,1:too_big),2) + end +! { dg-shouldfail "outside of expected range" } Index: Fortran/gfortran/regression/inline_sum_bounds_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_sum_bounds_check_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + + integer, parameter :: nx = 3, ny = 4 + + integer :: i, j, too_big + + integer, parameter, dimension(nx,ny) :: p = & + reshape((/ (i*i, i=1,size(p)) /), shape(p)) + + integer, dimension(nx,ny) :: a + + integer, dimension(:), allocatable :: c + + + allocate(c(ny)) + + a = p + too_big = nx + 1 + + c = sum(a(1:too_big,:),2) + end +! { dg-shouldfail "outside of expected range" } Index: Fortran/gfortran/regression/inline_transpose_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inline_transpose_1.f90 @@ -0,0 +1,236 @@ +! { dg-do run } +! { dg-options "-finline-matmul-limit=0 -fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" } + + implicit none + + integer :: i, j + + integer, parameter :: nx=3, ny=4 + integer, parameter, dimension(nx,ny) :: p = & + & reshape ((/ (i**2, i=1,size(p)) /), shape(p)) + integer, parameter, dimension(ny,nx) :: q = & + & reshape ((/ (((nx*(i-1)+j)**2, i=1,ny), j=1,nx) /), (/ ny, nx /)) + + integer, parameter, dimension(nx,nx) :: r = & + & reshape ((/ (i*i, i=1,size(r)) /), shape(r)) + integer, parameter, dimension(nx,nx) :: s = & + & reshape ((/ (((nx*(i-1)+j)**2, i=1,nx), j=1,nx) /), (/ nx, nx /)) + + + + integer, dimension(nx,ny) :: a, b + integer, dimension(ny,nx) :: c + integer, dimension(nx,nx) :: e, f, g + + character(144) :: u, v + + a = p + + c = transpose(a) + if (any(c /= q)) STOP 1 + + write(u,*) transpose(a) + write(v,*) q + if (u /= v) STOP 2 + + + e = r + f = s + + g = transpose(e+f) + if (any(g /= r + s)) STOP 3 + + write(u,*) transpose(e+f) + write(v,*) r + s + if (u /= v) STOP 4 + + + e = transpose(e) ! { dg-warning "Creating array temporary" } + if (any(e /= s)) STOP 5 + + write(u,*) transpose(transpose(e)) + write(v,*) s + if (u /= v) STOP 6 + + + e = transpose(e+f) ! { dg-warning "Creating array temporary" } + if (any(e /= 2*r)) STOP 7 + + write(u,*) transpose(transpose(e+f))-f + write(v,*) 2*r + if (u /= v) STOP 8 + + + a = foo(transpose(c)) + if (any(a /= p+1)) STOP 9 + + write(u,*) foo(transpose(c)) ! { dg-warning "Creating array temporary" } + write(v,*) p+1 + if (u /= v) STOP 10 + + + c = transpose(foo(a)) ! Unnecessary { dg-warning "Creating array temporary" } + if (any(c /= q+2)) STOP 11 + + write(u,*) transpose(foo(a)) ! { dg-warning "Creating array temporary" } + write(v,*) q+2 + if (u /= v) STOP 12 + + + e = foo(transpose(e)) ! { dg-warning "Creating array temporary" } + if (any(e /= 2*s+1)) STOP 13 + + write(u,*) transpose(foo(transpose(e))-1) ! { dg-warning "Creating array temporary" } + write(v,*) 2*s+1 + if (u /= v) STOP 14 + + + e = transpose(foo(e)) ! { dg-warning "Creating array temporary" } + if (any(e /= 2*r+2)) STOP 15 + + write(u,*) transpose(foo(transpose(e)-1)) ! 2 temps { dg-warning "Creating array temporary" } + write(v,*) 2*r+2 + if (u /= v) STOP 16 + + + a = bar(transpose(c)) + if (any(a /= p+4)) STOP 17 + + write(u,*) bar(transpose(c)) + write(v,*) p+4 + if (u /= v) STOP 18 + + + c = transpose(bar(a)) + if (any(c /= q+6)) STOP 19 + + write(u,*) transpose(bar(a)) + write(v,*) q+6 + if (u /= v) STOP 20 + + + e = bar(transpose(e)) ! { dg-warning "Creating array temporary" } + if (any(e /= 2*s+4)) STOP 21 + + write(u,*) transpose(bar(transpose(e)))-2 + write(v,*) 2*s+4 + if (u /= v) STOP 22 + + + e = transpose(bar(e)) ! { dg-warning "Creating array temporary" } + if (any(e /= 2*r+6)) STOP 23 + + write(u,*) transpose(transpose(bar(e))-2) + write(v,*) 2*r+6 + if (u /= v) STOP 24 + + + if (any(a /= transpose(transpose(a)))) STOP 25! optimized away + + write(u,*) a + write(v,*) transpose(transpose(a)) + if (u /= v) STOP 26 + + + b = a * a + + if (any(transpose(a+b) /= transpose(a)+transpose(b))) STOP 27! optimized away + + write(u,*) transpose(a+b) + write(v,*) transpose(a) + transpose(b) + if (u /= v) STOP 28 + + + if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) STOP 29! 2 temps { dg-warning "Creating array temporary" } + + write(u,*) transpose(matmul(a,c)) ! { dg-warning "Creating array temporary" } + write(v,*) matmul(transpose(c), transpose(a)) ! { dg-warning "Creating array temporary" } + if (u /= v) STOP 30 + + + if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) STOP 31! 2 temps { dg-warning "Creating array temporary" } + + write(u,*) transpose(matmul(e,a)) ! { dg-warning "Creating array temporary" } + write(v,*) matmul(transpose(a), transpose(e)) ! { dg-warning "Creating array temporary" } + if (u /= v) STOP 32 + + + call baz (transpose(a)) + + + call toto1 (a, transpose (c)) + if (any (a /= 2 * p + 12)) STOP 33 + + call toto1 (e, transpose (e)) ! { dg-warning "Creating array temporary" } + if (any (e /= 4 * s + 12)) STOP 34 + + + call toto2 (c, transpose (a)) + if (any (c /= 2 * q + 13)) STOP 35 + + call toto2 (e, transpose(e)) ! { dg-warning "Creating array temporary" } + if (any (e /= 4 * r + 13)) STOP 36 + + call toto2 (e, transpose(transpose(e))) ! { dg-warning "Creating array temporary" } + if (any (e /= 4 * r + 14)) STOP 37 + + + call toto3 (e, transpose(e)) + if (any (e /= 4 * r + 14)) STOP 38 + + + call titi (nx, e, transpose(e)) ! { dg-warning "Creating array temporary" } + if (any (e /= 4 * s + 17)) STOP 39 + + contains + + function foo (x) + integer, intent(in) :: x(:,:) + integer :: foo(size(x,1), size(x,2)) + foo = x + 1 + end function foo + + elemental function bar (x) + integer, intent(in) :: x + integer :: bar + bar = x + 2 + end function bar + + subroutine baz (x) + integer, intent(in) :: x(:,:) + end subroutine baz + + elemental subroutine toto1 (x, y) + integer, intent(out) :: x + integer, intent(in) :: y + x = y + y + end subroutine toto1 + + subroutine toto2 (x, y) + integer, dimension(:,:), intent(out) :: x + integer, dimension(:,:), intent(in) :: y + x = y + 1 + end subroutine toto2 + + subroutine toto3 (x, y) + integer, dimension(:,:), intent(in) :: x, y + end subroutine toto3 + +end + +subroutine titi (n, x, y) + integer :: n, x(n,n), y(n,n) + x = y + 3 +end subroutine titi + +! No call to transpose +! { dg-final { scan-tree-dump-times "_gfortran_transpose" 0 "original" } } +! +! 24 temporaries +! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 24 "original" } } +! +! 2 tests optimized out +! { dg-final { scan-tree-dump-times "_gfortran_stop" 39 "original" } } +! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_stop" 37 "optimized" } } +! +! cleanup Index: Fortran/gfortran/regression/inquire-complex.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire-complex.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 23428: Inquire(iolength) used to give the wrong result. +program main + implicit none + integer s4, s8 + + complex(kind=8) c8 + complex(kind=4) c4 + + inquire (iolength=s4) c4 + inquire (iolength=s8) c8 + if (s4 /= 8 .or. s8 /= 16) STOP 1 + +end program main Index: Fortran/gfortran/regression/inquire.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! check to see that you cannot open a direct access file +! for sequential i/o. +! derived from NIST test fm910.for + IMPLICIT NONE + CHARACTER*10 D4VK + OPEN(UNIT=7, ACCESS='DIRECT',RECL=132,STATUS='SCRATCH') + INQUIRE(UNIT=7,SEQUENTIAL=D4VK) + CLOSE(UNIT=7,STATUS='DELETE') + IF (D4VK.NE.'NO') STOP 1 + END Index: Fortran/gfortran/regression/inquire_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_10.f90 @@ -0,0 +1,19 @@ +! { dg-do run { target { ! newlib } } } + character(len=800) :: cwd + integer :: unit + + call getcwd(cwd) + + open(file='cseq', unit=23) + inquire(file='cseq',number=unit) + if (unit /= 23) STOP 1 + inquire(file=trim(cwd) // '/cseq',number=unit) + if (unit /= 23) STOP 2 + + close(unit=23, status = 'delete') + + inquire(file='foo/../cseq2',number=unit) + if (unit >= 0) STOP 3 + inquire(file='cseq2',number=unit) + if (unit >= 0) STOP 4 +end Index: Fortran/gfortran/regression/inquire_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_11.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 33055 Runtime error in INQUIRE unit existance with -fdefault-integer-8 +! Test case from PR33217 prepared by Jerry DeLisle +MODULE print_it +CONTAINS + SUBROUTINE i() + LOGICAL :: qexist + INQUIRE (UNIT=1, EXIST=qexist) + END SUBROUTINE i +END MODULE print_it Index: Fortran/gfortran/regression/inquire_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_12.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR34722 ICE: left-over "@iostat" variable polutes namespace +program gamsanal +implicit none +character :: tmp +integer iodict +logical dicexist +inquire(unit=iodict, exist=dicexist) +end + +subroutine inventnames() +implicit none +end subroutine \ No newline at end of file Index: Fortran/gfortran/regression/inquire_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_13.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR34795 inquire statement , direct= specifier incorrectly returns YES +! Test case from PR, modified by Jerry DeLisle +! F95 Standard 9.6, R923 +integer (kind=4) small, x +integer (kind=8) large +inquire (iolength=small) x +inquire (iolength=large) x ! { dg-error "requires default INTEGER" } +end Index: Fortran/gfortran/regression/inquire_pre.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_pre.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! PR93234 Inquire by UNIT on preopened unit failed on ROUND= and SIGN= +program inquire_browse +implicit none +integer :: ios +character(len=256) :: message + !============================================================================================== + character(len=20) :: name ; namelist/inquire/name + integer :: unit ; namelist/inquire/unit + integer :: id ; namelist/inquire/id + !============================================================================================== + integer :: recl ; namelist/inquire/recl + integer :: nextrec ; namelist/inquire/nextrec + integer :: pos ; namelist/inquire/pos + integer :: size ; namelist/inquire/size + !============================================================================================== + ! ACCESS = SEQUENTIAL | DIRECT | STREAM + character(len=20) :: access ; namelist/inquire/access + character(len=20) :: sequential ; namelist/inquire/sequential + character(len=20) :: stream ; namelist/inquire/stream + character(len=20) :: direct ; namelist/inquire/direct + ! ACTION = READ | WRITE | READWRITE + character(len=20) :: action ; namelist/inquire/action + character(len=20) :: read ; namelist/inquire/read + character(len=20) :: write ; namelist/inquire/write + character(len=20) :: readwrite ; namelist/inquire/readwrite + ! FORM = FORMATTED | UNFORMATTED + cHaracter(len=20) :: form ; namelist/inquire/form + character(len=20) :: formatted ; namelist/inquire/formatted + character(len=20) :: unformatted ; namelist/inquire/unformatted + ! POSITION = ASIS | REWIND | APPEND + character(len=20) :: position ; namelist/inquire/position + !============================================================================================== + character(len=20) :: blank ; namelist/inquire/blank + character(len=20) :: decimal ; namelist/inquire/decimal + character(len=20) :: sign ; namelist/inquire/sign + character(len=20) :: round ; namelist/inquire/round + character(len=20) :: delim ; namelist/inquire/delim + character(len=20) :: encoding ; namelist/inquire/encoding + character(len=20) :: pad ; namelist/inquire/pad + !============================================================================================== + logical :: named ; namelist/inquire/named + logical :: opened ; namelist/inquire/opened + logical :: exist ; namelist/inquire/exist + integer :: number ; namelist/inquire/number + logical :: pending ; namelist/inquire/pending + character(len=20) :: asynchronous ; namelist/inquire/asynchronous + !============================================================================================== + unit=5 + !!include "setunit_and_open.inc" + inquire(unit=unit,sign=sign) + inquire(unit=unit,round=round) + inquire(unit=unit, & + & recl=recl,nextrec=nextrec,pos=pos,size=size, & + & name=name,position=position, & + & form=form,formatted=formatted,unformatted=unformatted, & + & access=access,sequential=sequential,direct=direct,stream=stream, & + & action=action,read=read,write=write,readwrite=readwrite, & + & blank=blank,decimal=decimal,delim=delim,encoding=encoding,pad=pad, & + & named=named,opened=opened,exist=exist,number=number,pending=pending,asynchronous=asynchronous, & + & iostat=ios,err=999,iomsg=message) +999 continue + if(ios.eq.0)then + !write(*,nml=inquire,delim='none') + else + stop 1 + endif +end program inquire_browse Index: Fortran/gfortran/regression/inquire_recl_f2018.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_recl_f2018.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! PR 53796 INQUIRE(RECL=...) +program inqrecl + implicit none + integer(8) :: r + integer :: r4 + ! F2018 (N2137) 12.10.2.26: recl for unconnected should be -1 + inquire(10, recl=r) + if (r /= -1) then + STOP 1 + end if + + ! Formatted sequential + open(10, status="scratch") + inquire(10, recl=r) + inquire(10, recl=r4) + close(10) + if (r /= huge(0_8) - huge(0_4) - 1) then + STOP 2 + end if + if (r4 /= huge(0)) then + STOP 3 + end if + + ! Formatted sequential with recl= specifier + open(10, status="scratch", recl=100) + inquire(10, recl=r) + close(10) + if (r /= 100) then + STOP 4 + end if + + ! Formatted stream + ! F2018 (N2137) 12.10.2.26: If unit is connected + ! for stream access, recl should be assigned the value -2. + open(10, status="scratch", access="stream") + inquire(10, recl=r) + close(10) + if (r /= -2) then + STOP 5 + end if + + ! Also inquire by filename for a non-opened unit is considered + ! unconnected similar to the first test. + inquire(file='unconnectedfile.txt', recl=r) + if (r /= -1) then + stop 6 + end if +end program inqrecl Index: Fortran/gfortran/regression/inquire_size.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquire_size.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR43409 I/O: INQUIRE for SIZE does not work. +integer :: i +character(30) :: aname = "noname" +logical :: is_named + +open(25, file="testfile_inquire_size", status="replace", access="stream", form="unformatted") +do i=1,100 + write(25) i, "abcdefghijklmnopqrstuvwxyz" +enddo +! Gfortran implicitly flushes the buffer when doing a file size +! inquire on an open file. +! flush(25) + +inquire(unit=25, named=is_named, name=aname, size=i) +if (.not.is_named) STOP 1 +if (aname /= "testfile_inquire_size") STOP 2 +if (i /= 3000) STOP 3 + +inquire(file="testfile_inquire_size", size=i) +if (.not.is_named) STOP 4 +if (aname /= "testfile_inquire_size") STOP 5 +if (i /= 3000) STOP 6 + +close(25, status="delete") +inquire(file="testfile_inquire_size", size=i) +if (i /= -1) STOP 7 +end + + Index: Fortran/gfortran/regression/inquiry_type_ref_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_1.f08 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Test the implementation of inquiry part references (PR40196). +! "Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)" +! +! Contributed by Tobias Burnus +! +module m + complex, target :: z + character (:), allocatable :: str + real, pointer :: r => z%re + real, pointer :: i => z%im + type :: mytype + complex :: z = ( 10.0, 11.0 ) + character(6) :: str + end type +end module + + use m + + type(mytype) :: der + integer :: j + character (len=der%str%len) :: str1 + complex, parameter :: zc = ( 99.0, 199.0 ) + REAL, parameter :: rc = zc%re + REAL, parameter :: ic = zc%im + + z = (2.0,4.0) + str = "abcd" + +! Check the pointer initializations + if (r .ne. real (z)) stop 1 + if (i .ne. imag (z)) stop 2 + +! Check the use of inquiry part_refs on lvalues and rvalues. + z%im = 4.0 * z%re + +! Check that the result is OK. + if (z%re .ne. real (z)) stop 3 + if (abs (z*im - 4.0 * real (z)) .lt. 1e-6) stop 4 + +! Check a double inquiry part_ref. + if (z%im%kind .ne. kind (z)) stop 5 + +! Test on deferred character length. + if (str%kind .ne. kind (str)) stop 6 + if (str%len .ne. len (str)) stop 7 + +! Check the use in specification expressions. + if (len (der%str) .ne. LEN (str1)) stop 8 + if (rc .ne. real (zc)) stop 9 + if (ic .ne. aimag (zc)) stop 10 + +end + Index: Fortran/gfortran/regression/inquiry_type_ref_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! Test the implementation of inquiry part references (PR40196): +! Check the standards are correctly adhered to. +! +! Contributed by Tobias Burnus +! +program main + character(4) :: a + complex :: z + integer :: i + a%len = 2 ! { dg-error "Fortran 2003: LEN part_ref" } + i = a%kind ! { dg-error "Fortran 2003: KIND part_ref" } + print *, z%re ! { dg-error "Fortran 2008: RE or IM part_ref" } + print *, z%im ! { dg-error "Fortran 2008: RE or IM part_ref" } +end Index: Fortran/gfortran/regression/inquiry_type_ref_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! Test the implementation of inquiry part references (PR40196): +! Check errors on invalid code. +! +! Contributed by Tobias Burnus +! +program main + type :: t + complex :: z + character(6) :: a + end type + character(4) :: a + character(:), allocatable :: b + real :: z + integer :: i + type(t) :: s + b = "abcdefg" + a%kind = 2 ! { dg-error "Assignment to a constant expression" } + b%len = 2 ! { dg-error "parameter inquiry" } + i = a%kind ! OK + i = b%len ! OK + print *, z%re ! { dg-error "must be applied to a COMPLEX expression" } + print *, z%im ! { dg-error "must be applied to a COMPLEX expression" } + i%re = 2.0 ! { dg-error "must be applied to a COMPLEX expression" } + print *, i%len ! { dg-error "must be applied to a CHARACTER expression" } + print *, s%kind ! { dg-error "is not a member" } + print *, s%z%kind ! OK + print *, s%a%len ! OK +end Index: Fortran/gfortran/regression/inquiry_type_ref_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for PR87881. +! + complex(8) :: zi = (0,-1_8) + character(2) :: chr ='ab' + if (zi%re%kind .ne. kind (real (zi))) stop 1 + if (chr%len%kind .ne. kind (len (chr))) stop 2 + +! After simplification there should only be the delarations for 'zi' and 'chr' + +! { dg-final { scan-tree-dump-times "zi" 1 "original" } } +! { dg-final { scan-tree-dump-times "chr" 1 "original" } } +end Index: Fortran/gfortran/regression/inquiry_type_ref_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_5.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test the fix for pr92753 +! +! Contributed by Gerhardt Steinmetz +! +module m + type t + character(3) :: c + end type + type u + complex :: z + end type + type(t), parameter :: x = t ('abc') + integer, parameter :: l = x%c%len ! Used to ICE + + type(u), parameter :: z = u ((42.0,-42.0)) +end +program p + use m + call s (x%c%len) ! ditto + + if (int (z%z%re) .ne. 42) stop 1 ! Produced wrong code and + if (int (z%z%re) .ne. -int (z%z%im)) stop 2 ! runtime seg fault +contains + subroutine s(n) + if (n .ne. l) stop 3 + end +end Index: Fortran/gfortran/regression/inquiry_type_ref_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/inquiry_type_ref_6.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! Test the fix for PR93581 and the implementation of note 9.7 of F2018. +! The latter requires that the result of the LEN inquiry be a scalar +! even for array expressions. +! +! Contributed by Gerhard Steinmetz +! +program p + complex, target :: z(2) = [(1.0, 2.0),(3.0, 4.0)] + character(:), allocatable, target :: c(:) + real, pointer :: r(:) + character(:), pointer :: s(:) + + r => z%re + if (any (r .ne. real (z))) stop 1 + r => z%im + if (any (r .ne. imag (z))) stop 2 + + allocate (c, source = ['abc','def']) + s(-2:-1) => c(1:2) + if (s%len .ne. len (c)) stop 3 +end Index: Fortran/gfortran/regression/int_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_1.f90 @@ -0,0 +1,173 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! +! 13.7.53 INT(A [, KIND]) +! +! Description. Convert to integer type. +! Class. Elemental function. +! Arguments. +! A shall be of type integer, real, or complex, +! or a boz-literal-constant . +! KIND (optional) shall be a scalar integer initialization expression. +! +! Result Characteristics. Integer. If KIND is present, the kind type +! parameter is that specified by the value of KIND; otherwise, the +! kind type parameter is that of default integer type. +! +! Result Value. +! +! Case (1): If A is of type integer, INT (A) = A. +! +! Case (2): If A is of type real, there are two cases: +! (a) if |A| < 1, INT (A) has the value 0 +! (b) if |A| .ge. 1, INT (A) is the integer whose magnitude is the +! largest integer that does not exceed the magnitude of A and +! whose sign is the same as the sign of A. +! +! Case (3): If A is of type complex, INT(A) = INT(REAL(A, KIND(A))). +! +! Case (4): If A is a boz-literal-constant, it is treated as if it were +! an int-literal-constant with a kind-param that specifies the +! representation method with the largest decimal exponent range +! supported by the processor. +! +! Example. INT (�3.7) has the value �3. +! +module mykinds + integer, parameter :: ik1 = selected_int_kind(2) + integer, parameter :: ik2 = selected_int_kind(4) + integer, parameter :: ik4 = selected_int_kind(9) + integer, parameter :: ik8 = selected_int_kind(18) + integer, parameter :: sp = selected_real_kind(6,30) + integer, parameter :: dp = selected_real_kind(15,300) + integer, parameter :: ck = kind('a') +end module mykinds + +program test_int + + use mykinds + + integer(ik1) i1 + integer(ik2) i2 + integer(ik4) i4 + integer(ik8) i8 + real(sp) r4 + real(dp) r8 + complex(sp) c4 + complex(dp) c8 + ! + ! Case 1 + ! + i1 = int(-3) + i2 = int(-3) + i4 = int(-3) + i8 = int(-3) + if (i1 /= -3_ik1 .or. i2 /= -3_ik2) STOP 1 + if (i4 /= -3_ik4 .or. i8 /= -3_ik8) STOP 2 + + i1 = int(5, ik1) + i2 = int(i1, ik2) + i4 = int(i1, ik4) + i8 = int(i1, ik8) + if (i1 /= 5_ik1 .or. i2 /= 5_ik2) STOP 3 + if (i4 /= 5_ik4 .or. i8 /= 5_ik8) STOP 4 + + i8 = int(10, ik8) + i1 = int(i8, ik1) + i2 = int(i8, ik2) + i4 = int(i8, ik4) + if (i1 /= 10_ik1 .or. i2 /= 10_ik2) STOP 5 + if (i4 /= 10_ik4 .or. i8 /= 10_ik8) STOP 6 + ! + ! case 2(b) + ! + r4 = -3.7_sp + i1 = int(r4, ik1) + i2 = int(r4, ik2) + i4 = int(r4, ik4) + i8 = int(r4, ik8) + if (i1 /= -3_ik1 .or. i2 /= -3_ik2) STOP 7 + if (i4 /= -3_ik4 .or. i8 /= -3_ik8) STOP 8 + + r8 = -3.7_dp + i1 = int(r8, ik1) + i2 = int(r8, ik2) + i4 = int(r8, ik4) + i8 = int(r8, ik8) + if (i1 /= -3_ik1 .or. i2 /= -3_ik2) STOP 9 + if (i4 /= -3_ik4 .or. i8 /= -3_ik8) STOP 10 + ! + ! Case 2(a) + ! + r4 = -3.7E-1_sp + i1 = int(r4, ik1) + i2 = int(r4, ik2) + i4 = int(r4, ik4) + i8 = int(r4, ik8) + if (i1 /= 0_ik1 .or. i2 /= 0_ik2) STOP 11 + if (i4 /= 0_ik4 .or. i8 /= 0_ik8) STOP 12 + + r8 = -3.7E-1_dp + i1 = int(r8, ik1) + i2 = int(r8, ik2) + i4 = int(r8, ik4) + i8 = int(r8, ik8) + if (i1 /= 0_ik1 .or. i2 /= 0_ik2) STOP 13 + if (i4 /= 0_ik4 .or. i8 /= 0_ik8) STOP 14 + ! + ! Case 3 + ! + c4 = (-3.7E-1_sp,3.7E-1_sp) + i1 = int(c4, ik1) + i2 = int(c4, ik2) + i4 = int(c4, ik4) + i8 = int(c4, ik8) + if (i1 /= 0_ik1 .or. i2 /= 0_ik2) STOP 15 + if (i4 /= 0_ik4 .or. i8 /= 0_ik8) STOP 16 + + c8 = (-3.7E-1_dp,3.7E-1_dp) + i1 = int(c8, ik1) + i2 = int(c8, ik2) + i4 = int(c8, ik4) + i8 = int(c8, ik8) + if (i1 /= 0_ik1 .or. i2 /= 0_ik2) STOP 17 + if (i4 /= 0_ik4 .or. i8 /= 0_ik8) STOP 18 + + c4 = (-3.7_sp,3.7_sp) + i1 = int(c4, ik1) + i2 = int(c4, ik2) + i4 = int(c4, ik4) + i8 = int(c4, ik8) + if (i1 /= -3_ik1 .or. i2 /= -3_ik2) STOP 19 + if (i4 /= -3_ik4 .or. i8 /= -3_ik8) STOP 20 + + c8 = (3.7_dp,3.7_dp) + i1 = int(c8, ik1) + i2 = int(c8, ik2) + i4 = int(c8, ik4) + i8 = int(c8, ik8) + if (i1 /= 3_ik1 .or. i2 /= 3_ik2) STOP 21 + if (i4 /= 3_ik4 .or. i8 /= 3_ik8) STOP 22 + ! + ! Case 4 + ! + i1 = int(b'0011', ik1) + i2 = int(b'0011', ik2) + i4 = int(b'0011', ik4) + i8 = int(b'0011', ik8) + if (i1 /= 3_ik1 .or. i2 /= 3_ik2) STOP 23 + if (i4 /= 3_ik4 .or. i8 /= 3_ik8) STOP 24 + i1 = int(o'0011', ik1) + i2 = int(o'0011', ik2) + i4 = int(o'0011', ik4) + i8 = int(o'0011', ik8) + if (i1 /= 9_ik1 .or. i2 /= 9_ik2) STOP 25 + if (i4 /= 9_ik4 .or. i8 /= 9_ik8) STOP 26 + i1 = int(z'0011', ik1) + i2 = int(z'0011', ik2) + i4 = int(z'0011', ik4) + i8 = int(z'0011', ik8) + if (i1 /= 17_ik1 .or. i2 /= 17_ik2) STOP 27 + if (i4 /= 17_ik4 .or. i8 /= 17_ik8) STOP 28 + +end program test_int Index: Fortran/gfortran/regression/int_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_2.f90 @@ -0,0 +1,27 @@ +! PR fortran/32823 +! { dg-do compile } + +module token_module + + integer, parameter :: INT8 = SELECTED_INT_KIND(16) + integer, parameter :: REAL8 = SELECTED_REAL_KIND(12) + +contains + subroutine token_allreduce_i8_v(dowhat, array, result, length) + + + character(*), intent(in) :: dowhat + integer, intent(in) :: length + integer(INT8), intent(in) :: array(*) + integer(INT8), intent(inout) :: result(*) + + + real(REAL8) :: copy_r8(length), result_r8(length) + + + result(1:length) = int(result_r8(1:length), INT8) + + + end subroutine token_allreduce_i8_v + +end module token_module Index: Fortran/gfortran/regression/int_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +subroutine bug1 + integer, parameter :: ik1 = 1, ik2 = 2 + integer, parameter :: i = kind(int((0.,0.), kind=ik1)) + integer, parameter :: j = kind(int((0.,0.), kind=ik2)) + integer, parameter :: k = kind(int(0., kind=ik1)) + integer, parameter :: l = kind(int(0., kind=ik2)) + integer, parameter :: m = kind(int(0, kind=ik1)) + integer, parameter :: n = kind(int(0, kind=ik2)) +end subroutine bug1 Index: Fortran/gfortran/regression/int_conv_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_conv_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-std=gnu" } + integer(kind=2) :: i2, k2, l2 + integer(kind=8) :: i8 + real :: x + complex :: z + + i2 = huge(i2) / 3 + i8 = int8(i2) + k2 = int2(i2) + l2 = int2(i8) + + if (i8 /= i2 .or. k2 /= i2 .or. l2 /= i2 ) STOP 1 + + x = i2 + i8 = int8(x) + k2 = int2(x) + if (i8 /= i2 .or. k2 /= i2) STOP 2 + + z = i2 + (0.,-42.) + i8 = int8(z) + k2 = int2(z) + if (i8 /= i2 .or. k2 /= i2) STOP 3 + + end Index: Fortran/gfortran/regression/int_conv_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_conv_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/37930 +program test + implicit none + integer i + i = transfer(-1,1.0) ! { dg-error "Conversion" } +end program test Index: Fortran/gfortran/regression/int_range_io_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/int_range_io_1.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! PR 52428 Read IO of integers near the end of range. Note that we +! support the two's complement representation even though the Fortran +! numerical model has a symmetric range. (The -fno-range-check option +! is needed to allow the -2147483648 literal.) +program int_range + implicit none + character(25) :: inputline = "-2147483648" + integer(4) :: test + integer :: st + + read(inputline,100) test +100 format(1i11) + if (test /= -2147483648) STOP 1 + inputline(1:1) = " " + read(inputline, 100, iostat=st) test + if (st == 0) STOP 2 + inputline(11:11) = "7" + read(inputline, 100) test + if (test /= 2147483647) STOP 3 + + ! Same as above but with list-formatted IO + inputline = "-2147483648" + read(inputline, *) test + if (test /= -2147483648) STOP 4 + inputline(1:1) = " " + read(inputline, *, iostat=st) test + if (st == 0) STOP 5 + inputline(11:11) = "7" + read(inputline, *) test + if (test /= 2147483647) STOP 6 + +end program int_range Index: Fortran/gfortran/regression/integer_exponentiation_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! { dg-add-options ieee } +! PR 30981 - this used to go into an endless loop during execution. +program test + a = 3.0 + b = a**(-2147483647_4-1_4) ! { dg-warning "Integer outside symmetric range" } +end program test Index: Fortran/gfortran/regression/integer_exponentiation_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_2.f90 @@ -0,0 +1,258 @@ +! { dg-do run } +! { dg-options "" } +! Test various exponentations +! initially designed for patch to PR31120 + +program test + call run_me (1.0, 1, (1.0,0.0)) + call run_me (-1.1, -1, (0.0,-1.0)) + call run_me (42.0, 12, (1.0,7.0)) +end program test + +! This subroutine is for runtime tests +subroutine run_me(a, i, z) + implicit none + + real, intent(in) :: a + integer, intent(in) :: i + complex, intent(in) :: z + + call check_equal_i (i**0, 1) + call check_equal_i (i**1, i) + call check_equal_i (i**2, i*i) + call check_equal_i (i**3, i*(i**2)) + + ! i has default integer kind. + call check_equal_i (int(i**0_8,kind=kind(i)), 1) + call check_equal_i (int(i**1_8,kind=kind(i)), i) + call check_equal_i (int(i**2_8,kind=kind(i)), i*i) + call check_equal_i (int(i**3_8,kind=kind(i)), i*i*i) + + call check_equal_r (a**0.0, 1.0) + call check_equal_r (a**1.0, a) + call check_equal_r (a**2.0, a*a) + call check_equal_r (a**3.0, a*(a**2)) + call check_equal_r (a**(-1.0), 1/a) + call check_equal_r (a**(-2.0), (1/a)*(1/a)) + + call check_equal_r (a**0, 1.0) + call check_equal_r (a**1, a) + call check_equal_r (a**2, a*a) + call check_equal_r (a**3, a*(a**2)) + call check_equal_r (a**(-1), 1/a) + call check_equal_r (a**(-2), (1/a)*(1/a)) + + call check_equal_r (a**0_8, 1.0) + call check_equal_r (a**1_8, a) + call check_equal_r (a**2_8, a*a) + call check_equal_r (a**3_8, a*(a**2)) + call check_equal_r (a**(-1_8), 1/a) + call check_equal_r (a**(-2_8), (1/a)*(1/a)) + + call check_equal_c (z**0.0, (1.0,0.0)) + call check_equal_c (z**1.0, z) + call check_equal_c (z**2.0, z*z) + call check_equal_c (z**3.0, z*(z**2)) + call check_equal_c (z**(-1.0), 1/z) + call check_equal_c (z**(-2.0), (1/z)*(1/z)) + + call check_equal_c (z**(0.0,0.0), (1.0,0.0)) + call check_equal_c (z**(1.0,0.0), z) + call check_equal_c (z**(2.0,0.0), z*z) + call check_equal_c (z**(3.0,0.0), z*(z**2)) + call check_equal_c (z**(-1.0,0.0), 1/z) + call check_equal_c (z**(-2.0,0.0), (1/z)*(1/z)) + + call check_equal_c (z**0, (1.0,0.0)) + call check_equal_c (z**1, z) + call check_equal_c (z**2, z*z) + call check_equal_c (z**3, z*(z**2)) + call check_equal_c (z**(-1), 1/z) + call check_equal_c (z**(-2), (1/z)*(1/z)) + + call check_equal_c (z**0_8, (1.0,0.0)) + call check_equal_c (z**1_8, z) + call check_equal_c (z**2_8, z*z) + call check_equal_c (z**3_8, z*(z**2)) + call check_equal_c (z**(-1_8), 1/z) + call check_equal_c (z**(-2_8), (1/z)*(1/z)) + + +contains + + subroutine check_equal_r (a, b) + real, intent(in) :: a, b + if (abs(a - b) > 1.e-5 * abs(b)) STOP 1 + end subroutine check_equal_r + + subroutine check_equal_c (a, b) + complex, intent(in) :: a, b + if (abs(a - b) > 1.e-5 * abs(b)) STOP 2 + end subroutine check_equal_c + + subroutine check_equal_i (a, b) + integer, intent(in) :: a, b + if (a /= b) STOP 3 + end subroutine check_equal_i + +end subroutine run_me + +! subroutine foo is used for compilation test only +subroutine foo(a) + implicit none + + real, intent(in) :: a + integer :: i + complex :: z + + ! Integer + call gee_i(i**0_1) + call gee_i(i**1_1) + call gee_i(i**2_1) + call gee_i(i**3_1) + call gee_i(i**(-1_1)) + call gee_i(i**(-2_1)) + call gee_i(i**(-3_1)) + call gee_i(i**huge(0_1)) + call gee_i(i**(-huge(0_1))) + call gee_i(i**(-huge(0_1)-1_1)) + + call gee_i(i**0_2) + call gee_i(i**1_2) + call gee_i(i**2_2) + call gee_i(i**3_2) + call gee_i(i**(-1_2)) + call gee_i(i**(-2_2)) + call gee_i(i**(-3_2)) + call gee_i(i**huge(0_2)) + call gee_i(i**(-huge(0_2))) + call gee_i(i**(-huge(0_2)-1_2)) + + call gee_i(i**0_4) + call gee_i(i**1_4) + call gee_i(i**2_4) + call gee_i(i**3_4) + call gee_i(i**(-1_4)) + call gee_i(i**(-2_4)) + call gee_i(i**(-3_4)) + call gee_i(i**huge(0_4)) + call gee_i(i**(-huge(0_4))) + call gee_i(i**(-huge(0_4)-1_4)) + + call gee_i8(i**0_8) + call gee_i8(i**1_8) + call gee_i8(i**2_8) + call gee_i8(i**3_8) + call gee_i8(i**(-1_8)) + call gee_i8(i**(-2_8)) + call gee_i8(i**(-3_8)) + call gee_i8(i**huge(0_8)) + call gee_i8(i**(-huge(0_8))) + call gee_i8(i**(-huge(0_8)-1_8)) + + ! Real + call gee_r(a**0_1) + call gee_r(a**1_1) + call gee_r(a**2_1) + call gee_r(a**3_1) + call gee_r(a**(-1_1)) + call gee_r(a**(-2_1)) + call gee_r(a**(-3_1)) + call gee_r(a**huge(0_1)) + call gee_r(a**(-huge(0_1))) + call gee_r(a**(-huge(0_1)-1_1)) + + call gee_r(a**0_2) + call gee_r(a**1_2) + call gee_r(a**2_2) + call gee_r(a**3_2) + call gee_r(a**(-1_2)) + call gee_r(a**(-2_2)) + call gee_r(a**(-3_2)) + call gee_r(a**huge(0_2)) + call gee_r(a**(-huge(0_2))) + call gee_r(a**(-huge(0_2)-1_2)) + + call gee_r(a**0_4) + call gee_r(a**1_4) + call gee_r(a**2_4) + call gee_r(a**3_4) + call gee_r(a**(-1_4)) + call gee_r(a**(-2_4)) + call gee_r(a**(-3_4)) + call gee_r(a**huge(0_4)) + call gee_r(a**(-huge(0_4))) + call gee_r(a**(-huge(0_4)-1_4)) + + call gee_r(a**0_8) + call gee_r(a**1_8) + call gee_r(a**2_8) + call gee_r(a**3_8) + call gee_r(a**(-1_8)) + call gee_r(a**(-2_8)) + call gee_r(a**(-3_8)) + call gee_r(a**huge(0_8)) + call gee_r(a**(-huge(0_8))) + call gee_r(a**(-huge(0_8)-1_8)) + + ! Complex + call gee_z(z**0_1) + call gee_z(z**1_1) + call gee_z(z**2_1) + call gee_z(z**3_1) + call gee_z(z**(-1_1)) + call gee_z(z**(-2_1)) + call gee_z(z**(-3_1)) + call gee_z(z**huge(0_1)) + call gee_z(z**(-huge(0_1))) + call gee_z(z**(-huge(0_1)-1_1)) + + call gee_z(z**0_2) + call gee_z(z**1_2) + call gee_z(z**2_2) + call gee_z(z**3_2) + call gee_z(z**(-1_2)) + call gee_z(z**(-2_2)) + call gee_z(z**(-3_2)) + call gee_z(z**huge(0_2)) + call gee_z(z**(-huge(0_2))) + call gee_z(z**(-huge(0_2)-1_2)) + + call gee_z(z**0_4) + call gee_z(z**1_4) + call gee_z(z**2_4) + call gee_z(z**3_4) + call gee_z(z**(-1_4)) + call gee_z(z**(-2_4)) + call gee_z(z**(-3_4)) + call gee_z(z**huge(0_4)) + call gee_z(z**(-huge(0_4))) + call gee_z(z**(-huge(0_4)-1_4)) + + call gee_z(z**0_8) + call gee_z(z**1_8) + call gee_z(z**2_8) + call gee_z(z**3_8) + call gee_z(z**(-1_8)) + call gee_z(z**(-2_8)) + call gee_z(z**(-3_8)) + call gee_z(z**huge(0_8)) + call gee_z(z**(-huge(0_8))) + call gee_z(z**(-huge(0_8)-1_8)) +end subroutine foo + +subroutine gee_i(i) + integer :: i +end subroutine gee_i + +subroutine gee_i8(i) + integer(kind=8) :: i +end subroutine gee_i8 + +subroutine gee_r(r) + real :: r +end subroutine gee_r + +subroutine gee_z(c) + complex :: c +end subroutine gee_z Index: Fortran/gfortran/regression/integer_exponentiation_3.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_3.F90 @@ -0,0 +1,201 @@ +! { dg-options "" } +! { dg-options "-ffloat-store" { target { { i?86-*-* x86_64-*-* } && ilp32 } } } +! +! +module mod_check + implicit none + + interface check + module procedure check_i8 + module procedure check_i4 + module procedure check_r8 + module procedure check_r4 + module procedure check_c8 + module procedure check_c4 + end interface check + + interface acheck + module procedure acheck_c8 + module procedure acheck_c4 + end interface acheck + +contains + + subroutine check_i8 (a, b) + integer(kind=8), intent(in) :: a, b + if (a /= b) STOP 1 + end subroutine check_i8 + + subroutine check_i4 (a, b) + integer(kind=4), intent(in) :: a, b + if (a /= b) STOP 2 + end subroutine check_i4 + + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (a /= b) STOP 3 + end subroutine check_r8 + + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (a /= b) STOP 4 + end subroutine check_r4 + + subroutine check_c8 (a, b) + complex(kind=8), intent(in) :: a, b + if (a /= b) STOP 5 + end subroutine check_c8 + + subroutine check_c4 (a, b) + complex(kind=4), intent(in) :: a, b + if (a /= b) STOP 6 + end subroutine check_c4 + + subroutine acheck_c8 (a, b) + complex(kind=8), intent(in) :: a, b + if (abs(a-b) > 1.d-9 * min(abs(a),abs(b))) STOP 7 + end subroutine acheck_c8 + + subroutine acheck_c4 (a, b) + complex(kind=4), intent(in) :: a, b + if (abs(a-b) > 1.e-5 * min(abs(a),abs(b))) STOP 8 + end subroutine acheck_c4 + +end module mod_check + +program test + use mod_check + implicit none + + integer(kind=4) :: i4 + integer(kind=8) :: i8 + real(kind=4) :: r4 + real(kind=8) :: r8 + complex(kind=4) :: c4 + complex(kind=8) :: c8 + +#define TEST(base,exp,var) var = base; call check((var)**(exp),(base)**(exp)) +#define ATEST(base,exp,var) var = base; call acheck((var)**(exp),(base)**(exp)) + +!!!!! INTEGER BASE !!!!! + TEST(0,0,i4) + TEST(0_8,0_8,i8) + TEST(1,0,i4) + TEST(1_8,0_8,i8) + TEST(-1,0,i4) + TEST(-1_8,0_8,i8) + TEST(huge(0_4),0,i4) + TEST(huge(0_8),0_8,i8) + TEST(-huge(0_4)-1,0,i4) + TEST(-huge(0_8)-1_8,0_8,i8) + + TEST(1,1,i4) + TEST(1_8,1_8,i8) + TEST(1,2,i4) + TEST(1_8,2_8,i8) + TEST(1,-1,i4) + TEST(1_8,-1_8,i8) + TEST(1,-2,i4) + TEST(1_8,-2_8,i8) + TEST(1,huge(0),i4) + TEST(1_8,huge(0_8),i8) + TEST(1,-huge(0)-1,i4) + TEST(1_8,-huge(0_8)-1_8,i8) + + TEST(-1,1,i4) + TEST(-1_8,1_8,i8) + TEST(-1,2,i4) + TEST(-1_8,2_8,i8) + TEST(-1,-1,i4) + TEST(-1_8,-1_8,i8) + TEST(-1,-2,i4) + TEST(-1_8,-2_8,i8) + TEST(-1,huge(0),i4) + TEST(-1_8,huge(0_8),i8) + TEST(-1,-huge(0)-1,i4) + TEST(-1_8,-huge(0_8)-1_8,i8) + + TEST(2,9,i4) + TEST(2_8,9_8,i8) + TEST(-2,9,i4) + TEST(-2_8,9_8,i8) + TEST(2,-9,i4) + TEST(2_8,-9_8,i8) + TEST(-2,-9,i4) + TEST(-2_8,-9_8,i8) + +!!!!! REAL BASE !!!!! + TEST(0.0,0,r4) + TEST(0.0,1,r4) + TEST(0.0,huge(0),r4) + TEST(0.0,0_8,r4) + TEST(0.0,1_8,r4) + TEST(0.0,huge(0_8),r4) + + TEST(1.0,0,r4) + TEST(1.0,1,r4) + TEST(1.0,-1,r4) + TEST(1.0,huge(0),r4) + TEST(1.0,-huge(0)-1,r4) + TEST(1.0,0_8,r4) + TEST(1.0,1_8,r4) + TEST(1.0,-1_8,r4) + TEST(1.0,huge(0_8),r4) + TEST(1.0,-huge(0_8)-1_8,r4) + + TEST(-1.0,0,r4) + TEST(-1.0,1,r4) + TEST(-1.0,-1,r4) + TEST(-1.0,huge(0),r4) + TEST(-1.0,-huge(0)-1,r4) + TEST(-1.0,0_8,r4) + TEST(-1.0,1_8,r4) + TEST(-1.0,-1_8,r4) + TEST(-1.0,huge(0_8),r4) + TEST(-1.0,-huge(0_8)-1_8,r4) + + TEST(2.0,0,r4) + TEST(2.0,1,r4) + TEST(2.0,-1,r4) + TEST(2.0,3,r4) + TEST(2.0,-3,r4) + TEST(2.0,0_8,r4) + TEST(2.0,1_8,r4) + TEST(2.0,-1_8,r4) + TEST(2.0,3_8,r4) + TEST(2.0,-3_8,r4) + + TEST(nearest(1.0,-1.0),0,r4) + TEST(nearest(1.0,-1.0),huge(0_4),r4) ! { dg-warning "Arithmetic underflow" } + TEST(nearest(1.0,-1.0),0_8,r4) + TEST(nearest(1.0_8,-1.0),huge(0_8),r8) ! { dg-warning "Arithmetic underflow" } + + TEST(nearest(1.0,-1.0),107,r4) + TEST(nearest(1.0,1.0),107,r4) + +!!!!! COMPLEX BASE !!!!! + TEST((1.0,0.2),0,c4) + TEST((1.0,0.2),1,c4) + TEST((1.0,0.2),2,c4) + ATEST((1.0,0.2),9,c4) + ATEST((1.0,0.2),-1,c4) + ATEST((1.0,0.2),-2,c4) + ATEST((1.0,0.2),-9,c4) + + TEST((0.0,0.2),0,c4) + TEST((0.0,0.2),1,c4) + TEST((0.0,0.2),2,c4) + ATEST((0.0,0.2),9,c4) + ATEST((0.0,0.2),-1,c4) + ATEST((0.0,0.2),-2,c4) + ATEST((0.0,0.2),-9,c4) + + TEST((1.0,0.),0,c4) + TEST((1.0,0.),1,c4) + TEST((1.0,0.),2,c4) + TEST((1.0,0.),9,c4) + ATEST((1.0,0.),-1,c4) + ATEST((1.0,0.),-2,c4) + ATEST((1.0,0.),-9,c4) + +end program test Index: Fortran/gfortran/regression/integer_exponentiation_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_4.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "" } +program test + implicit none + +!!!!!! INTEGER BASE !!!!!! + print *, 0**0 + print *, 0**1 + print *, 0**(-1) ! { dg-error "Division by zero" } + print *, 0**(huge(0)) + print *, 0**(-huge(0)-1) ! { dg-error "Division by zero" } + print *, 0**(2_8**32) + print *, 0**(-(2_8**32)) ! { dg-error "Division by zero" } + + print *, 1**huge(0) + print *, 1**(-huge(0)-1) + print *, 1**huge(0_8) + print *, 1**(-huge(0_8)-1_8) + print *, (-1)**huge(0) + print *, (-1)**(-huge(0)-1) + print *, (-1)**huge(0_8) + print *, (-1)**(-huge(0_8)-1_8) + + print *, 2**huge(0) ! { dg-error "Arithmetic overflow|exceeds the range" } + print *, 2**huge(0_8) ! { dg-error "Arithmetic overflow|exceeds the range" } + print *, (-2)**huge(0) ! { dg-error "Arithmetic overflow|exceeds the range" } + print *, (-2)**huge(0_8) ! { dg-error "Arithmetic overflow|exceeds the range" } + + print *, 2**(-huge(0)-1) + print *, 2**(-huge(0_8)-1_8) + print *, (-2)**(-huge(0)-1) + print *, (-2)**(-huge(0_8)-1_8) + +!!!!!! REAL BASE !!!!!! + print *, 0.0**(-1) ! { dg-error "Arithmetic overflow" } + print *, 0.0**(-huge(0)-1) ! { dg-error "Arithmetic overflow" } + print *, 2.0**huge(0) ! { dg-error "Arithmetic overflow" } + print *, nearest(1.0,-1.0)**(-huge(0)) ! { dg-error "Arithmetic overflow" } + +!!!!!! COMPLEX BASE !!!!!! + print *, (2.0,-4.3)**huge(0) ! { dg-error "Arithmetic overflow" } + print *, (2.0,-4.3)**huge(0_8) ! { dg-error "Arithmetic overflow" } + print *, (2.0,-4.3)**(-huge(0)) + print *, (2.0,-4.3)**(-huge(0_8)) + +end program test Index: Fortran/gfortran/regression/integer_exponentiation_5.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_5.F90 @@ -0,0 +1,74 @@ +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } +module mod_check + implicit none + + interface check + module procedure check_i8 + module procedure check_i4 + module procedure check_r8 + module procedure check_r4 + module procedure check_c8 + module procedure check_c4 + end interface check + +contains + + subroutine check_i8 (a, b) + integer(kind=8), intent(in) :: a, b + if (a /= b) STOP 1 + end subroutine check_i8 + + subroutine check_i4 (a, b) + integer(kind=4), intent(in) :: a, b + if (a /= b) STOP 2 + end subroutine check_i4 + + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (a /= b) STOP 3 + end subroutine check_r8 + + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (a /= b) STOP 4 + end subroutine check_r4 + + subroutine check_c8 (a, b) + complex(kind=8), intent(in) :: a, b + if (a /= b) STOP 5 + end subroutine check_c8 + + subroutine check_c4 (a, b) + complex(kind=4), intent(in) :: a, b + if (a /= b) STOP 6 + end subroutine check_c4 + +end module mod_check + +program test + use mod_check + implicit none + + integer(kind=4) :: i4 + integer(kind=8) :: i8 + real(kind=4) :: r4 + real(kind=8) :: r8 + complex(kind=4) :: c4 + complex(kind=8) :: c8 + +#define TEST(base,exp,var) var = base; call check((var)**(exp),(base)**(exp)) + +!!!!! INTEGER BASE !!!!! + TEST(3,23,i4) + TEST(-3,23,i4) + TEST(3_8,43_8,i8) + TEST(-3_8,43_8,i8) + +!!!!! REAL BASE !!!!! + TEST(0.0,-1,r4) + TEST(0.0,-huge(0)-1,r4) + TEST(2.0,huge(0),r4) + TEST(nearest(1.0,-1.0),-huge(0),r4) + +end program test Index: Fortran/gfortran/regression/integer_exponentiation_6.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_6.F90 @@ -0,0 +1,4 @@ +! { dg-options "-fno-range-check" } +program test + write (*,*) (2_8 ** 64009999_8) / 2 +end program test Index: Fortran/gfortran/regression/integer_exponentiation_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_exponentiation_7.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-Winteger-division" } +program main + print *,10**(-3) ! { dg-warning "Negative exponent of integer has zero result" } +end program main Index: Fortran/gfortran/regression/integer_plus.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/integer_plus.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR83560 list-directed formatting of INTEGER is missing plus on output +! when output open with SIGN='PLUS' +character(64) :: astring +i=789 +open(unit=10, status='scratch', sign='plus') +write(10,*) i +rewind(10) +read(10,*) astring +close (10) +if (astring.ne.'+789') STOP 1 +end Index: Fortran/gfortran/regression/intent_decl_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_decl_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 85088: improve diagnostic for bad INTENT declaration +! +! Contributed by Janus Weil + +subroutine s(x, y, z) + integer, intent(int) :: x ! { dg-error "Bad INTENT specification" } + integer, intent :: y ! { dg-error "Bad INTENT specification" } + integer, inten :: z ! { dg-error "Invalid character" } +end Index: Fortran/gfortran/regression/intent_optimize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! +! Check whether the "does_not_exist" subroutine has been +! optimized away, i.e. check that "foo"'s intent(IN) gets +! honoured. +! +! PR fortran/43665 +! +interface + subroutine foo(x) + integer, intent(in) :: x + end subroutine foo +end interface + +integer :: y + +y = 5 +call foo(y) +if (y /= 5) call does_not_exist () +end + +! { dg-final { scan-tree-dump-times "does_not_exist" 0 "optimized" } } Index: Fortran/gfortran/regression/intent_optimize_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_10.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/41453 +! Check that the INTENT(OUT) attribute causes in the case of non-polymorphic derived type arguments: +! - one clobber to be emitted in the caller before calls to FOO in the *.original dump, +! - no clobber to be emitted in the caller before calls to BAR in the *.original dump, +! - the initialization constants to be optimized away in the *.optimized dump. + +module x + implicit none + type :: t + integer :: c + end type t + type, extends(t) :: u + integer :: d + end type u +contains + subroutine foo(a) + type(t), intent(out) :: a + a = t(42) + end subroutine foo + subroutine bar(b) + class(t), intent(out) :: b + b%c = 24 + end subroutine bar +end module x + +program main + use x + implicit none + type(t) :: tc + type(u) :: uc, ud + class(t), allocatable :: te, tf + + tc = t(123456789) + call foo(tc) + if (tc%c /= 42) stop 1 + + uc = u(987654321, 0) + call foo(uc%t) + if (uc%c /= 42) stop 2 + if (uc%d /= 0) stop 3 + + ud = u(11223344, 0) + call bar(ud) + if (ud%c /= 24) stop 4 + + te = t(55667788) + call foo(te) + if (te%c /= 42) stop 5 + + tf = t(99887766) + call bar(tf) + if (tf%c /= 24) stop 6 + +end program main + +! We don't support class descriptors, neither derived type components, so there is a clobber for tc only; +! no clobber for uc, ud, te, tf. +! { dg-final { scan-tree-dump-times "CLOBBER" 1 "original" } } +! { dg-final { scan-tree-dump "tc = {CLOBBER};" "original" } } + +! There is a clobber for tc, so we should manage to optimize away the associated initialization constant (but not other +! initialization constants). +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_optimize_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-O -fno-inline -fdump-tree-optimized -fdump-tree-original" } +! PR fortran/41453 +! Check that there is one clobber in the *.original tree, plus that +! the constant 123456789 has been removed due to the INTENT(OUT). + +module x +implicit none +contains + subroutine foo(a) + integer, intent(out) :: a + a = 42 + end subroutine foo +end module x + +program main + use x + implicit none + integer :: a + a = 123456789 + call foo(a) + print *,a +end program main + +! { dg-final { scan-tree-dump-times "123456789" 0 "optimized" } } +! { dg-final { scan-tree-dump-times "CLOBBER" 1 "original" } } Index: Fortran/gfortran/regression/intent_optimize_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-O2" } +! PR99169 - Segfault passing allocatable scalar into intent(out) dummy argument + +program p + implicit none + integer, allocatable :: i + allocate (i) + call set (i) + if (i /= 5) stop 1 +contains + subroutine set (i) + integer, intent(out) :: i + i = 5 + end subroutine set +end program p Index: Fortran/gfortran/regression/intent_optimize_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "CLOBBER" 2 "original" } } +! +! PR fortran/106817 +! Check that for an actual argument whose dummy is INTENT(OUT), +! the clobber that is emitted in the caller before a procedure call +! happens after any expression depending on the argument value has been +! evaluated. +! + +module m + implicit none +contains + subroutine copy1(out, in) + integer, intent(in) :: in + integer, intent(out) :: out + out = in + end subroutine copy1 + subroutine copy2(in, out) + integer, intent(in) :: in + integer, intent(out) :: out + out = in + end subroutine copy2 +end module m + +program p + use m + implicit none + integer :: a, b + + ! Clobbering of a should happen after a+1 has been evaluated. + a = 3 + call copy1(a, a+1) + if (a /= 4) stop 1 + + ! Clobbering order does not depend on the order of arguments. + ! It should also come last with reversed arguments. + b = 12 + call copy2(b+1, b) + if (b /= 13) stop 2 + +end program p Index: Fortran/gfortran/regression/intent_optimize_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/105012 +! Check that the INTENT(OUT) attribute causes one clobber to be emitted in +! the caller before the call to Y in the *.original dump, and the +! initialization constant to be optimized away in the *.optimized dump, +! despite the non-explicit interface if the subroutine with the INTENT(OUT) +! is declared in the same file. + +SUBROUTINE Y (Z) + integer, intent(out) :: Z + Z = 42 +END SUBROUTINE Y +PROGRAM TEST + integer :: X + X = 123456789 + CALL Y (X) + if (X.ne.42) STOP 1 +END PROGRAM + +! { dg-final { scan-tree-dump-times "CLOBBER" 1 "original" } } +! { dg-final { scan-tree-dump "x = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_optimize_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_6.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/41453 +! Check that the INTENT(OUT) attribute causes one clobber to be emitted in +! the caller before each call to FOO in the *.original dump, and the +! initialization constant to be optimized away in the *.optimized dump, +! in the case of an argument passed by reference to the caller. + +module x +implicit none +contains + subroutine foo(a) + integer(kind=4), intent(out) :: a + a = 42 + end subroutine foo + subroutine bar(b) + integer(kind=4) :: b + b = 123456789 + call foo(b) + end subroutine bar +end module x + +program main + use x + implicit none + integer(kind=4) :: c + call bar(c) + if (c /= 42) stop 1 +end program main + +! { dg-final { scan-tree-dump-times "CLOBBER" 1 "original" } } +! { dg-final { scan-tree-dump "\\*\\\(integer\\\(kind=4\\\) \\*\\\) b = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_optimize_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_7.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/41453 +! Check that the INTENT(OUT) attribute causes one clobber to be emitted in +! the caller before each call to FOO in the *.original dump, and the +! initialization constants to be optimized away in the *.optimized dump, +! in the case of SAVE variables. + +module x +implicit none +contains + subroutine foo(a) + integer, intent(out) :: a + a = 42 + end subroutine foo +end module x + +program main + use x + implicit none + integer :: c = 0 + + ! implicit SAVE attribute + c = 123456789 + call foo(c) + if (c /= 42) stop 1 + + ! explicit SAVE attribute + call check_save_explicit + +contains + subroutine check_save_explicit + integer, save :: d + d = 987654321 + call foo(d) + if (d /= 42) stop 2 + end subroutine check_save_explicit +end program main + +! { dg-final { scan-tree-dump-times "CLOBBER" 2 "original" } } +! { dg-final { scan-tree-dump "c = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump "d = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } +! { dg-final { scan-tree-dump-not "987654321" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_optimize_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_8.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/41453 +! Check that the INTENT(OUT) attribute causes one clobber to be emitted in +! the caller before each call to FOO in the *.original dump, and the +! initialization constants to be optimized away in the *.optimized dump, +! in the case of associate variables. + +module x +implicit none +contains + subroutine foo(a) + integer, intent(out) :: a + a = 42 + end subroutine foo +end module x + +program main + use x + implicit none + integer :: c1, c2 + + c1 = 123456789 + associate (d1 => c1) + call foo(d1) + if (d1 /= 42) stop 1 + end associate + if (c1 /= 42) stop 2 + + c2 = 0 + associate (d2 => c2) + d2 = 987654321 + call foo(d2) + if (d2 /= 42) stop 3 + end associate + if (c2 /= 42) stop 4 + +end program main + +! { dg-final { scan-tree-dump-times "CLOBBER" 2 "original" } } +! { dg-final { scan-tree-dump "d1 = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump "\\*d2 = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } +! { dg-final { scan-tree-dump-not "987654321" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_optimize_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_optimize_9.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline -fno-ipa-modref -fdump-tree-optimized -fdump-tree-original" } +! +! PR fortran/41453 +! Check that the INTENT(OUT) attribute causes one clobber to be emitted in +! the caller before each call to FOO in the *.original dump, and the +! initialization constants to be optimized away in the *.optimized dump, +! in the case of scalar allocatables and pointers. + +module x +implicit none +contains + subroutine foo(a) + integer, intent(out) :: a + a = 42 + end subroutine foo +end module x + +program main + use x + implicit none + integer, allocatable :: ca + integer, target :: ct + integer, pointer :: cp + + allocate(ca) + ca = 123456789 + call foo(ca) + if (ca /= 42) stop 1 + deallocate(ca) + + ct = 987654321 + cp => ct + call foo(cp) + if (ct /= 42) stop 2 +end program main + +! { dg-final { scan-tree-dump-times "CLOBBER" 2 "original" } } +! { dg-final { scan-tree-dump "\\*ca = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump "\\*cp = {CLOBBER};" "original" } } +! { dg-final { scan-tree-dump-not "123456789" "optimized" { target __OPTIMIZE__ } } } +! { dg-final { scan-tree-dump-not "987654321" "optimized" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/intent_out_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Tests the fix for PRs 18578, 18579 and their repeats 20857 and 20885. +! Contributed by Paul Thomas + real, parameter :: a =42.0 + real :: b + call foo(b + 2.0) ! { dg-error "variable definition context" } + call foo(a) ! { dg-error "variable definition context" } + call bar(b + 2.0) ! { dg-error "variable definition context" } + call bar(a) ! { dg-error "variable definition context" } +contains + subroutine foo(a) + real, intent(out) :: a + a = 0.0 + end subroutine foo + subroutine bar(a) + real, intent(INout) :: a + a = 0.0 + end subroutine bar +end Index: Fortran/gfortran/regression/intent_out_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_10.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR 87395 - this used to ICE +module mo + integer, save :: x +contains + subroutine foo + x = 42 + call bar(x) + contains + subroutine bar(y) + integer, intent(out) :: y + end subroutine bar + end subroutine foo +end module mo Index: Fortran/gfortran/regression/intent_out_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_11.f90 @@ -0,0 +1,309 @@ +! { dg-do compile } +! { dg-options "-cpp -fcoarray=lib" } +! PR 87397 - this used to generate an ICE. + +! Coarray Distributed Transpose Test +! +! Copyright (c) 2012-2014, Sourcery, Inc. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! * Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! * Neither the name of the Sourcery, Inc., nor the +! names of its contributors may be used to endorse or promote products +! derived from this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +! DISCLAIMED. IN NO EVENT SHALL SOURCERY, INC., BE LIABLE FOR ANY +! DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +! ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! +! Robodoc header: +!****m* dist_transpose/run_size +! NAME +! run_size +! SYNOPSIS +! Encapsulate problem state, wall-clock timer interface, integer broadcasts, and a data copy. +!****** +!================== test transposes with integer x,y,z values =============================== +module run_size + use iso_fortran_env + implicit none + + integer(int64), codimension[*] :: nx, ny, nz + integer(int64), codimension[*] :: my, mx, first_y, last_y, first_x, last_x + integer(int64) :: my_node, num_nodes + real(real64), codimension[*] :: tran_time + + +contains + +!****s* run_size/broadcast_int +! NAME +! broadcast_int +! SYNOPSIS +! Broadcast a scalar coarray integer from image 1 to all other images. +!****** + subroutine broadcast_int( variable ) + integer(int64), codimension[*] :: variable + integer(int64) :: i + if( my_node == 1 ) then + do i = 2, num_nodes; variable[i] = variable; end do + end if + end subroutine broadcast_int + +subroutine copy3( A,B, n1, sA1, sB1, n2, sA2, sB2, n3, sA3, sB3 ) + implicit none + complex, intent(in) :: A(0:*) + complex, intent(out) :: B(0:*) + integer(int64), intent(in) :: n1, sA1, sB1 + integer(int64), intent(in) :: n2, sA2, sB2 + integer(int64), intent(in) :: n3, sA3, sB3 + integer(int64) i,j,k + + do k=0,n3-1 + do j=0,n2-1 + do i=0,n1-1 + B(i*sB1+j*sB2+k*sB3) = A(i*sA1+j*sA2+k*sA3) + end do + end do + end do +end subroutine copy3 + +end module run_size + +!****e* dist_transpose/coarray_distributed_transpose +! NAME +! coarray_distributed_transpose +! SYNOPSIS +! This program tests the transpose routines used in Fourier-spectral simulations of homogeneous turbulence. +! The data is presented to the physics routines as groups of y-z or x-z planes distributed among the images. +! The (out-of-place) transpose routines do the x <--> y transposes required and consist of transposes within +! data blocks (intra-image) and a transpose of the distribution of these blocks among the images (inter-image). +! +! Two methods are tested here: +! RECEIVE: receive block from other image and transpose it +! SEND: transpose block and send it to other image +! +! This code is the coarray analog of mpi_distributed_transpose. +!****** + +program coarray_distributed_transpose + !(*********************************************************************************************************** + ! m a i n p r o g r a m + !***********************************************************************************************************) + use run_size + implicit none + + complex, allocatable :: u(:,:,:,:)[:] ! u(nz,4,first_x:last_x,ny)[*] !(*-- ny = my * num_nodes --*) + complex, allocatable :: ur(:,:,:,:)[:] !ur(nz,4,first_y:last_y,nx/2)[*] !(*-- nx/2 = mx * num_nodes --*) + complex, allocatable :: bufr_X_Y(:,:,:,:) + complex, allocatable :: bufr_Y_X(:,:,:,:) + integer(int64) :: x, y, z, msg_size, iter + + num_nodes = num_images() + my_node = this_image() + + if( my_node == 1 ) then + !write(6,*) "nx,ny,nz : "; read(5,*) nx, ny, nz + nx=32; ny=32; nz=32 + call broadcast_int( nx ); call broadcast_int( ny ); call broadcast_int( nz ); + end if + sync all !-- other nodes wait for broadcast! + + + if ( mod(ny,num_nodes) == 0) then; my = ny / num_nodes + else; write(6,*) "node ", my_node, " ny not multiple of num_nodes"; error stop + end if + + if ( mod(nx/2,num_nodes) == 0) then; mx = nx/2 / num_nodes + else; write(6,*) "node ", my_node, "nx/2 not multiple of num_nodes"; error stop + end if + + first_y = (my_node-1)*my + 1; last_y = (my_node-1)*my + my + first_x = (my_node-1)*mx + 1; last_x = (my_node-1)*mx + mx + + allocate ( u(nz , 4 , first_x:last_x , ny) [*] ) !(*-- y-z planes --*) + allocate ( ur(nz , 4 , first_y:last_y , nx/2)[*] ) !(*-- x-z planes --*) + allocate ( bufr_X_Y(nz,4,mx,my) ) + allocate ( bufr_Y_X(nz,4,my,mx) ) + + msg_size = nz*4*mx*my !-- message size (complex data items) + +!--------- initialize data u (mx y-z planes per image) ---------- + + do x = first_x, last_x + do y = 1, ny + do z = 1, nz + u(z,1,x,y) = x + u(z,2,x,y) = y + u(z,3,x,y) = z + end do + end do + end do + + tran_time = 0 + do iter = 1, 2 !--- 2 transform pairs per second-order time step + +!--------- transpose data u -> ur (mx y-z planes to my x-z planes per image) -------- + + ur = 0 + + call transpose_X_Y + +!--------- test data ur (my x-z planes per image) ---------- + + do x = 1, nx/2 + do y = first_y, last_y + do z = 1, nz + if ( real(ur(z,1,y,x)) /= x .or. real(ur(z,2,y,x)) /= y .or. real(ur(z,3,y,x)) /= z )then + write(6,fmt="(A,i3,3(6X,A,f7.3,i4))") "transpose_X_Y failed: image ", my_node & + , " X ",real(ur(z,1,y,x)),x, " Y ",real(ur(z,2,y,x)),y, " Z ", real(ur(z,3,y,x)),z + stop + end if + end do + end do + end do + +!--------- transpose data ur -> u (my x-z planes to mx y-z planes per image) -------- + + u = 0 + call transpose_Y_X + +!--------- test data u (mx y-z planes per image) ---------- + + do x = first_x, last_x + do y = 1, ny + do z = 1, nz + if ( real(u(z,1,x,y)) /= x .or. real(u(z,2,x,y)) /= y .or. real(u(z,3,x,y)) /= z )then + write(6,fmt="(A,i3,3(6X,A,f7.3,i4))") "transpose_Y_X failed: image ", my_node & + , " X ",real(u(z,1,x,y)),x, " Y ",real(u(z,2,x,y)),y, " Z ", real(u(z,3,x,y)),z + stop + end if + end do + end do + end do + end do + + sync all + if( my_node == 1 ) write(6,fmt="(A,f8.3)") "test passed: tran_time ", tran_time + + deallocate ( bufr_X_Y ); deallocate ( bufr_Y_X ) + +!========================= end of main executable ============================= + +contains + +!------------- out-of-place transpose data_s --> data_r ---------------------------- + + subroutine transpose_X_Y + + use run_size + implicit none + + integer(int64) :: i,stage + real(real64) :: tmp + + sync all !-- wait for other nodes to finish compute + call cpu_time(tmp) + tran_time = tran_time - tmp + + call copy3 ( u(1,1,first_x,1+(my_node-1)*my) & !-- intra-node transpose + , ur(1,1,first_y,1+(my_node-1)*mx) & !-- no inter-node transpose needed + , nz*3, 1_8, 1_8 & !-- note: only 3 of 4 words needed + , mx, nz*4, nz*4*my & + , my, nz*4*mx, nz*4 ) + +#define RECEIVE +#ifdef RECEIVE + + do stage = 1, num_nodes-1 + i = 1 + mod( my_node-1+stage, num_nodes ) + bufr_X_Y(:,:,:,:) = u(:,:,:,1+(my_node-1)*my:my_node*my)[i] !-- inter-node transpose to buffer + call copy3 ( bufr_X_Y, ur(1,1,first_y,1+(i-1)*mx) & !-- intra-node transpose from buffer + , nz*3, 1_8, 1_8 & !-- note: only 3 of 4 words needed + , mx, nz*4, nz*4*my & + , my, nz*4*mx, nz*4 ) + end do + +#else + + do stage = 1, num_nodes-1 + i = 1 + mod( my_node-1+stage, num_nodes ) + call copy3 ( u(1,1,first_x,1+(i-1)*my), bufr_Y_X & !-- intra-node transpose to buffer + , nz*3, 1_8, 1_8 & + , mx, nz*4, nz*4*my & + , my, nz*4*mx, nz*4 ) + ur(:,:,:,1+(my_node-1)*mx:my_node*mx)[i] = bufr_Y_X(:,:,:,:) !-- inter-node transpose from buffer + end do + +#endif + + sync all !-- wait for other nodes to finish transpose + call cpu_time(tmp) + tran_time = tran_time + tmp + + end subroutine transpose_X_Y + +!------------- out-of-place transpose data_r --> data_s ---------------------------- + +subroutine transpose_Y_X + use run_size + implicit none + + integer(int64) :: i, stage + real(real64) :: tmp + + sync all !-- wait for other nodes to finish compute + call cpu_time(tmp) + tran_time = tran_time - tmp + + call copy3 ( ur(1,1,first_y,1+(my_node-1)*mx) & !-- intra-node transpose + , u(1,1,first_x,1+(my_node-1)*my) & !-- no inter-node transpose needed + , nz*4, 1_8, 1_8 & !-- note: all 4 words needed + , my, nz*4, nz*4*mx & + , mx, nz*4*my, nz*4 ) + +#define RECEIVE +#ifdef RECEIVE + + do stage = 1, num_nodes-1 + i = 1 + mod( my_node-1+stage, num_nodes ) + bufr_Y_X(:,:,:,:) = ur(:,:,:,1+(my_node-1)*mx:my_node*mx)[i] !-- inter-node transpose to buffer + call copy3 ( bufr_Y_X, u(1,1,first_x,1+(i-1)*my) & !-- intra-node transpose from buffer + , nz*4, 1_8, 1_8 & + , my, nz*4, nz*4*mx & + , mx, nz*4*my, nz*4 ) + end do + +#else + + do stage = 1, num_nodes-1 + i = 1 + mod( my_node-1+stage, num_nodes ) + call copy3 ( ur(1,1,first_y,1+(i-1)*mx), bufr_X_Y & !-- intra-node transpose from buffer + , nz*4, 1_8, 1_8 & + , my, nz*4, nz*4*mx & + , mx, nz*4*my, nz*4 ) + u(:,:,:,1+(my_node-1)*my:my_node*my)[i] = bufr_X_Y(:,:,:,:) !-- inter-node transpose from buffer + end do + +#endif + + sync all !-- wait for other nodes to finish transpose + call cpu_time(tmp) + tran_time = tran_time + tmp + + end subroutine transpose_Y_X + + +end program coarray_distributed_transpose Index: Fortran/gfortran/regression/intent_out_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_12.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR fortran/87401 - this used to segfault at runtime. +! Test case by Janus Weil. + +program assoc_intent_out + + implicit none + + real :: r + + associate(o => r) + call sub(o) + end associate + +contains + + subroutine sub(out) + real, intent(out) :: out + out = 0.0 + end subroutine + +end + Index: Fortran/gfortran/regression/intent_out_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_13.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR 88364 -- too much was clobbered on call. +module pr88364 + implicit none + type t + integer :: b = -1 + integer :: c = 2 + end type t +contains + subroutine f1 (x) + integer, intent(out) :: x + x = 5 + end subroutine f1 + subroutine f2 () + type(t) :: x + call f1 (x%b) + if (x%b .ne. 5 .or. x%c .ne. 2) stop 1 + end subroutine f2 +end module pr88364 + use pr88364 + call f2 +end Index: Fortran/gfortran/regression/intent_out_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_14.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR fortran/102287 - optional allocatable DT array arguments (intent out) + +module m + type t + integer, allocatable :: a + end type t +contains + subroutine a (x, v) + type(t), optional, allocatable, intent(out) :: x(:) + type(t), optional, intent(out) :: v(:) + call b (x, v) + end subroutine a + + subroutine b (y, w) + type(t), optional, allocatable, intent(out) :: y(:) + type(t), optional, intent(out) :: w(:) + end subroutine b +end module m + +program p + use m + call a () +end Index: Fortran/gfortran/regression/intent_out_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_15.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/105012 +! The following case was triggering an ICE because of a clobber +! on the DERFC function decl instead of its result. + +module error_function +integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real +contains +SUBROUTINE CALERF_r8(ARG, RESULT, JINT) + integer, parameter :: rk = r8 + real(rk), intent(in) :: arg + real(rk), intent(out) :: result + IF (Y .LE. THRESH) THEN + END IF +end SUBROUTINE CALERF_r8 +FUNCTION DERFC(X) + integer, parameter :: rk = r8 ! 8 byte real + real(rk), intent(in) :: X + real(rk) :: DERFC + CALL CALERF_r8(X, DERFC, JINT) +END FUNCTION DERFC +end module error_function + +! { dg-final { scan-tree-dump-times "CLOBBER" 1 "original" } } +! { dg-final { scan-tree-dump "__result_derfc = {CLOBBER};" "original" } } Index: Fortran/gfortran/regression/intent_out_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Tests the fix for PR33554, in which the default initialization +! of temp, in construct_temp, caused a segfault because it was +! being done before the array offset and lower bound were +! available. +! +! Contributed by Harald Anlauf +! +module gfcbug72 + implicit none + + type t_datum + character(len=8) :: mn = 'abcdefgh' + end type t_datum + + type t_temp + type(t_datum) :: p + end type t_temp + +contains + + subroutine setup () + integer :: i + type (t_temp), pointer :: temp(:) => NULL () + + do i=1,2 + allocate (temp (2)) + call construct_temp (temp) + if (any (temp % p% mn .ne. 'ijklmnop')) STOP 1 + deallocate (temp) + end do + end subroutine setup + !-- + subroutine construct_temp (temp) + type (t_temp), intent(out) :: temp (:) + if (any (temp % p% mn .ne. 'abcdefgh')) STOP 2 + temp(:)% p% mn = 'ijklmnop' + end subroutine construct_temp +end module gfcbug72 + +program test + use gfcbug72 + implicit none + call setup () +end program test Index: Fortran/gfortran/regression/intent_out_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_3.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/34662 +! The INTENT error was not detected. +! Test case contributed by Joost VandeVondele. +! +MODULE M1 + TYPE T1 + INTEGER :: I(3) + END TYPE T1 + TYPE(T1), PARAMETER :: D1=T1((/1,2,3/)) +CONTAINS + SUBROUTINE S1(J) + INTEGER, INTENT(INOUT) :: J + END SUBROUTINE S1 +END MODULE M1 +USE M1 +CALL S1(D1%I(3)) ! { dg-error "variable definition context" } +END Index: Fortran/gfortran/regression/intent_out_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/34689 +! +! The following (cf. libgomp.fortran/appendix-a/a.33.3.f90) +! was rejected because the intent check missed a FL_FUNCTION +! for the result variable. +! +function test() + implicit none + integer :: test + interface + subroutine foo(a) + integer, intent(inout) :: a + end subroutine foo + end interface + call foo(test) +end function test Index: Fortran/gfortran/regression/intent_out_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_5.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/41479 +! +! Contributed by Juergen Reuter. +! +program main + type :: container_t + integer :: n = 42 + ! if the following line is omitted, the problem disappears + integer, dimension(:), allocatable :: a + end type container_t + + type(container_t) :: container + + if (container%n /= 42) STOP 1 + if (allocated(container%a)) STOP 2 + container%n = 1 + allocate(container%a(50)) + call init (container) + if (container%n /= 42) STOP 3 + if (allocated(container%a)) STOP 4 +contains + subroutine init (container) + type(container_t), intent(out) :: container + end subroutine init +end program main Index: Fortran/gfortran/regression/intent_out_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_6.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR fortran/41850 +! +module test_module + implicit none +contains + subroutine sub2(a) + implicit none + real,allocatable,intent(out),optional :: a(:) + if(present(a)) then + if(allocated(a)) STOP 1 + allocate(a(1)) + a(1) = 5 + end if + end subroutine sub2 + subroutine sub1(a) + implicit none + real,allocatable,intent(out),optional :: a(:) +! print *,'in sub1' + call sub2(a) + if(present(a)) then + if(a(1) /= 5) STOP 2 + end if + end subroutine sub1 +end module test_module + +program test + use test_module + implicit none + real, allocatable :: x(:) + allocate(x(1)) + call sub1() + x = 8 + call sub1(x) + if(x(1) /= 5) STOP 3 +end program Index: Fortran/gfortran/regression/intent_out_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_7.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/53643 +! +type t + integer, allocatable :: comp +end type t +contains + subroutine foo(x,y) + class(t), allocatable, intent(out) :: x(:) + class(t), intent(out) :: y(:) + end subroutine + subroutine foo2(x,y) + class(t), allocatable, intent(out) :: x + class(t), intent(out) :: y + end subroutine + subroutine bar(x,y) + class(t), intent(out) :: x(:)[*] + class(t), intent(out) :: y[*] + end subroutine + subroutine bar2(x,y) + type(t), intent(out) :: x(:)[*] + type(t), intent(out) :: y[*] + end subroutine +end Index: Fortran/gfortran/regression/intent_out_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_8.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR 53655: [F03] "default initializer" warnings +! +! Contributed by Tobias Burnus + +type t +end type t + +contains + + subroutine foo(x) ! { dg-warning "defined but not used" } + type(t), intent(out) :: x + end subroutine + +end Index: Fortran/gfortran/regression/intent_out_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_out_9.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 80121: Memory leak with derived-type intent(out) argument +! +! Contributed by Andrew Wood + +PROGRAM p + IMPLICIT NONE + TYPE t1 + INTEGER, ALLOCATABLE :: i(:) + END TYPE + call leak + CONTAINS + SUBROUTINE s1(e) + TYPE(t1), ALLOCATABLE, INTENT(OUT) :: e(:) + ALLOCATE( e(1) ) + ALLOCATE( e(1)%i(2) ) + END SUBROUTINE + SUBROUTINE leak + TYPE(t1), ALLOCATABLE :: e(:) + CALL s1(e) + CALL s1(e) + END SUBROUTINE +END PROGRAM + +! { dg-final { scan-tree-dump-times "__builtin_free" 6 "original" } } Index: Fortran/gfortran/regression/intent_used_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intent_used_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for the regression caused by the patch for PR20869 +! which itself is tested and described by intrinsic_external_1.f90 +! +! reported to the fortran list by Dominique Dhumieres dominiq@lps.ens.fr + +MODULE global + INTERFACE + SUBROUTINE foo(i, j) + IMPLICIT NONE + INTEGER :: j + integer, DIMENSION(j,*) :: i ! This constituted usage of j and so triggered.... + INTENT (IN) j ! Would give "Cannot change attributes of symbol at (1) after it has been used" + INTENT (INOUT) i + END SUBROUTINE foo + END INTERFACE +END MODULE global Index: Fortran/gfortran/regression/interface_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! This program would segfault without the patch for PR fortran/24005. +module y + ! + ! If private statement is removed, then we get a bunch of errors + ! + private f + ! + ! If we rename 'f' in module y to say 'g', then gfortran correctly + ! identifies ambiguous as being ambiguous. + ! + interface ambiguous + module procedure f + end interface + + contains + + real function f(a) + real a + f = a + end function + +end module y + +module z + + use y ! { dg-warning "in generic interface" } + + interface ambiguous + module procedure f + end interface + + contains + + real function f(a) ! { dg-warning "in generic interface" } + real a + f = a + end function + +end module z Index: Fortran/gfortran/regression/interface_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_10.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! PR fortran/30683 +! Code contributed by Salvatore Filippone. +! +module class_fld + integer, parameter :: int_ = 1 + integer, parameter :: bnd_ = 2 + type fld + integer :: size(2) + end type fld + ! + ! This interface is extending the SIZE intrinsic procedure, + ! which led to a segmentation fault when trying to resolve + ! the intrinsic symbol name. + ! + interface size + module procedure get_fld_size + end interface +contains + function get_fld_size(f) + integer :: get_fld_size(2) + type(fld), intent(in) :: f + get_fld_size(int_) = f%size(int_) + get_fld_size(bnd_) = f%size(bnd_) + end function get_fld_size +end module class_fld + +module class_s_fld + use class_fld + type s_fld + type(fld) :: base + real(kind(1.d0)), pointer :: x(:) => null() + end type s_fld + interface x_ + module procedure get_s_fld_x + end interface +contains + function get_s_fld_x(fld) + real(kind(1.d0)), pointer :: get_s_fld_x(:) + type(s_fld), intent(in) :: fld + get_s_fld_x => fld%x + end function get_s_fld_x +end module class_s_fld + +module class_s_foo +contains + subroutine solve_s_foo(phi,var) + use class_s_fld + type(s_fld), intent(inout) :: phi + real(kind(1.d0)), intent(out), optional :: var + integer :: nsz + real(kind(1.d0)), pointer :: x(:) + x => x_(phi) + nsz=size(x) + end subroutine solve_s_foo +end module class_s_foo Index: Fortran/gfortran/regression/interface_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_11.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Tests the fix for PR30883 in which interface functions and +! their results did not get an implicit type. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + IMPLICIT NONE +CONTAINS + SUBROUTINE S1(F1, F2, G1, G2) + INTERFACE + FUNCTION F1(i, a) + END FUNCTION F1 + FUNCTION F2(i, a) + implicit complex (a-z) + END FUNCTION F2 + END INTERFACE + INTERFACE + FUNCTION g1(i, a) result(z) + END FUNCTION g1 + FUNCTION g2(i, a) result(z) + implicit complex (a-z) + END FUNCTION g2 + END INTERFACE + END SUBROUTINE S1 +END MODULE + +END Index: Fortran/gfortran/regression/interface_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_12.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! Test the fix for PR31293. +! +! File: interface4.f90 +! http://home.comcast.net/%7Ekmbtib/Fortran_stuff/interface4.f90 +! Public domain 2004 James Van Buskirk +! Second attempt to actually create function with LEN +! given by specification expression via function name, +! and SIZE given by specification expression via +! result name. + +! g95 12/18/04: Error: Circular specification in variable 'r'. +! ISO/IEC 1539-1:1997(E) section 512.5.2.2: +! "If RESULT is specified, the name of the result variable +! of the function is result-name, its characteristics +! (12.2.2) are those of the function result, and..." +! Also from the same section: +! The type and type parameters (if any) of the result of the +! function subprogram may be specified by a type specification +! in the FUNCTION statement or by the name of the result variable +! appearing in a type statement in the declaration part of the +! function subprogram. It shall not be specified both ways." +! Also in section 7.1.6.2: +! "A restricted expression is one in which each operation is +! intrinsic and each primary is +! ... +! (7) A reference to an intrinsic function that is +! ... +! (c) the character inquiry function LEN, +! ... +! and where each primary of the function is +! ... +! (b) a variable whose properties inquired about are not +! (i) dependent on the upper bound of the last +! dimension of an assumed-shape array. +! (ii) defined by an expression that is not a +! restricted expression +! (iii) definable by an ALLOCATE or pointer +! assignment statement." +! So I think there is no problem with the specification of +! the function result attributes; g95 flunks. + +! CVF 6.6C3: Error: This name does not have a type, and must +! have an explicit type. [R] +! Clearly R has a type here: the type and type parameters of +! the function result; CVF flunks. + +! LF95 5.70f: Type parameters or bounds of variable r may +! not be inquired. +! Again, the type parameters, though not the bounds, of +! variable r may in fact be inquired; LF95 flunks. + +module test1 + implicit none + contains + character(f (x)) function test2 (x) result(r) + implicit integer (x) + dimension r(modulo (len (r) - 1, 3) + 1) + integer, intent(in) :: x + interface + pure function f (x) + integer, intent(in) :: x + integer f + end function f + end interface + integer i + + do i = 1, len (r) + r(:)(i:i) = achar (mod (i, 32) + iachar ('@')) + end do + end function test2 +end module test1 + +program test + use test1 + implicit none + character(21) :: chr (3) + chr = "ABCDEFGHIJKLMNOPQRSTU" + + if (len (test2 (10)) .ne. 21) STOP 1 + if (any (test2 (10) .ne. chr)) STOP 2 +end program test + +pure function f (x) + integer, intent(in) :: x + integer f + + f = 2*x+1 +end function f Index: Fortran/gfortran/regression/interface_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_13.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR32612 gfortran - incorrectly flags error on interface module +! Test case is that of the reporters + module files_module + implicit none + integer, parameter :: REAL8 = SELECTED_REAL_KIND(12) + save + private + interface my_sio_file_read_common + module procedure my_sio_file_read_common ! This was rejected before + end interface + contains + subroutine my_sio_file_read_all_i4(serial, data, data_lengths, error) + logical, intent(in) :: serial + integer, intent(out) :: data(*) + integer, intent(in) :: data_lengths(0:*) + integer, intent(out) :: error + call my_sio_file_read_common(data_lengths, error, data_i4 = data) + end subroutine my_sio_file_read_all_i4 + subroutine my_sio_file_read_common(data_lengths, error, & + data_i4, & + data_r8) + integer, intent(in) :: data_lengths(0:*) + integer, intent(out) :: error + integer, intent(out), optional :: data_i4(*) + real(REAL8), intent(out), optional :: data_r8(*) + error=0 + data_i4(1)=0 + data_r8(1)=0 + end subroutine my_sio_file_read_common + end module files_module Index: Fortran/gfortran/regression/interface_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_14.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! Checks the fix for a regression PR32526, which was caused by +! the patch for PR31494. The problem here was that the symbol +! 'new' was determined to be ambiguous. +! +! Contributed by Michael Richmond +! + module P_Class + implicit none + private :: init_Personnel + interface new + module procedure init_Personnel + end interface + contains + subroutine init_Personnel(this) + integer, intent (in) :: this + print *, "init personnel", this + end subroutine init_Personnel + end module P_Class + + module S_Class + use P_Class + implicit none + private :: init_Student + type Student + private + integer :: personnel = 1 + end type Student + interface new + module procedure init_Student + end interface + contains + subroutine init_Student(this) + type (Student), intent (in) :: this + call new(this%personnel) + end subroutine init_Student + end module S_Class + + module T_Class + use P_Class + implicit none + private :: init_Teacher + type Teacher + private + integer :: personnel = 2 + end type Teacher + interface new + module procedure init_Teacher + end interface + contains + subroutine init_Teacher(this) + type (Teacher), intent (in) :: this + call new(this%personnel) + end subroutine init_Teacher + end module T_Class + + module poly_Class + use S_Class + use T_Class + end module poly_Class + + module D_Class + use poly_Class + end module D_Class + + use D_Class + type (Teacher) :: a + type (Student) :: b + call new (a) + call new (b) + end Index: Fortran/gfortran/regression/interface_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_15.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-c -std=f95" } +! Testcase from PR fortran/25094 +! Contributed by Joost VandeVondele + +MODULE M1 + TYPE T1 + INTEGER :: I + END TYPE T1 + INTERFACE I + MODULE PROCEDURE F1 + END INTERFACE + PRIVATE ! :: T1,F1 + PUBLIC :: I +CONTAINS + INTEGER FUNCTION F1(D) ! { dg-error "PUBLIC interface" } + TYPE(T1) :: D + F1 = D%I + END FUNCTION +END MODULE Index: Fortran/gfortran/regression/interface_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_16.f90 @@ -0,0 +1,98 @@ +! { dg-do compile } +! This tests the fix for PR32634, in which the generic interface +! in foo_pr_mod was given the original rather than the local name. +! This meant that the original name had to be used in the calll +! in foo_sub. +! +! Contributed by Salvatore Filippone + +module foo_base_mod + type foo_dmt + real(kind(1.d0)), allocatable :: rv(:) + integer, allocatable :: iv1(:), iv2(:) + end type foo_dmt + type foo_zmt + complex(kind(1.d0)), allocatable :: rv(:) + integer, allocatable :: iv1(:), iv2(:) + end type foo_zmt + type foo_cdt + integer, allocatable :: md(:) + integer, allocatable :: hi(:), ei(:) + end type foo_cdt +end module foo_base_mod + +module bar_prt + use foo_base_mod, only : foo_dmt, foo_zmt, foo_cdt + type bar_dbprt + type(foo_dmt), allocatable :: av(:) + real(kind(1.d0)), allocatable :: d(:) + type(foo_cdt) :: cd + end type bar_dbprt + type bar_dprt + type(bar_dbprt), allocatable :: bpv(:) + end type bar_dprt + type bar_zbprt + type(foo_zmt), allocatable :: av(:) + complex(kind(1.d0)), allocatable :: d(:) + type(foo_cdt) :: cd + end type bar_zbprt + type bar_zprt + type(bar_zbprt), allocatable :: bpv(:) + end type bar_zprt +end module bar_prt + +module bar_pr_mod + use bar_prt + interface bar_pwrk + subroutine bar_dppwrk(pr,x,y,cd,info,trans,work) + use foo_base_mod + use bar_prt + type(foo_cdt),intent(in) :: cd + type(bar_dprt), intent(in) :: pr + real(kind(0.d0)),intent(inout) :: x(:), y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(kind(0.d0)),intent(inout), optional, target :: work(:) + end subroutine bar_dppwrk + subroutine bar_zppwrk(pr,x,y,cd,info,trans,work) + use foo_base_mod + use bar_prt + type(foo_cdt),intent(in) :: cd + type(bar_zprt), intent(in) :: pr + complex(kind(0.d0)),intent(inout) :: x(:), y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(kind(0.d0)),intent(inout), optional, target :: work(:) + end subroutine bar_zppwrk + end interface +end module bar_pr_mod + +module foo_pr_mod + use bar_prt, & + & foo_dbprt => bar_dbprt,& + & foo_zbprt => bar_zbprt,& + & foo_dprt => bar_dprt,& + & foo_zprt => bar_zprt + use bar_pr_mod, & + & foo_pwrk => bar_pwrk +end module foo_pr_mod + +Subroutine foo_sub(a,pr,b,x,eps,cd,info) + use foo_base_mod + use foo_pr_mod + Implicit None +!!$ parameters + Type(foo_dmt), Intent(in) :: a + Type(foo_dprt), Intent(in) :: pr + Type(foo_cdt), Intent(in) :: cd + Real(Kind(1.d0)), Intent(in) :: b(:) + Real(Kind(1.d0)), Intent(inout) :: x(:) + Real(Kind(1.d0)), Intent(in) :: eps + integer, intent(out) :: info +!!$ Local data + Real(Kind(1.d0)), allocatable, target :: aux(:),wwrk(:,:) + Real(Kind(1.d0)), allocatable :: p(:), f(:) + info = 0 + Call foo_pwrk(pr,p,f,cd,info,work=aux) ! This worked if bar_pwrk was called! + return +End Subroutine foo_sub Index: Fortran/gfortran/regression/interface_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_17.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Tests the fix for PR32727, which was a regression caused +! by the fix for PR32634 +! +! Contributed by Joost VandeVondele +! +MODULE kinds + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 ) +END MODULE kinds + +MODULE util + USE kinds, ONLY: dp + INTERFACE sort + MODULE PROCEDURE sort2 + END INTERFACE +CONTAINS + SUBROUTINE sort2 ( ) + END SUBROUTINE sort2 +END MODULE util + +MODULE graphcon + USE util, ONLY: sort +END MODULE graphcon Index: Fortran/gfortran/regression/interface_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_18.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Public procedures with private types for the dummies +! is valid F2003, but invalid per Fortran 95, Sect. 5.2.3 +! See interface_15.f90 for the F95 test case. +! + module mytype_application + implicit none + private + public :: mytype_test + type :: mytype_type + integer :: i=0 + end type mytype_type + contains + subroutine mytype_test( mytype ) + type(mytype_type), intent(in out) :: mytype + end subroutine mytype_test + end module mytype_application Index: Fortran/gfortran/regression/interface_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_19.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none +contains + subroutine sub(a) + optional :: a + character(25) :: temp + interface + function a(x) + real(kind=8):: a + real(kind=8):: x + intent(in) :: x + end function a + end interface + if(present(a)) then + write(temp,'(f16.10)')a(4.0d0) + if (trim(temp) /= ' -0.6536436209') STOP 1 + endif + end subroutine sub +end module m + +use m +implicit none +intrinsic dcos +call sub() +call sub(dcos) +end Index: Fortran/gfortran/regression/interface_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_2.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! PR fortran/24545 +MODULE Compare_Float_Numbers + + IMPLICIT NONE + + INTERFACE Compare_Float + MODULE PROCEDURE Compare_Float_Single + END INTERFACE Compare_Float + + INTERFACE OPERATOR (.EqualTo.) + MODULE PROCEDURE Is_Equal_To_Single + END INTERFACE OPERATOR (.EqualTo.) + +CONTAINS + + FUNCTION Is_Equal_To_Single(x, y) RESULT(Equal_To) + REAL(4), INTENT(IN) :: x, y + LOGICAL :: Equal_To + Equal_To = .true. + END FUNCTION Is_Equal_To_Single + + FUNCTION Compare_Float_Single(x, y) RESULT(Compare) + REAL(4), INTENT(IN) :: x, y + LOGICAL :: Compare + Compare = .true. + END FUNCTION Compare_Float_Single + +END MODULE Compare_Float_Numbers Index: Fortran/gfortran/regression/interface_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_20.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none +contains + subroutine sub(a) + interface + function a() + real :: a + end function a + end interface + print *, a() + end subroutine sub +end module m +use m +implicit none +intrinsic cos +call sub(cos) ! { dg-error "wrong number of arguments" } +end Index: Fortran/gfortran/regression/interface_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_21.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none +contains + subroutine sub(a) + interface + function a(x) + real :: a, x + intent(in) :: x + end function a + end interface + print *, a(4.0) + end subroutine sub +end module m + +use m +implicit none +EXTERNAL foo ! implicit interface is undefined +call sub(foo) ! { dg-error "is not a function" } +end Index: Fortran/gfortran/regression/interface_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_22.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! This is a check for error recovery: we used to ICE in various places, or +! emit bogus error messages (PR 25252) +! +module foo + interface bar + module procedure X, Y, ! { dg-error "Syntax error in MODULE PROCEDURE statement" } + end interface bar +end module + +module g + interface i + module procedure sint => sreal ! { dg-error "Syntax error in MODULE PROCEDURE statement" } + end interface i +end module g + +module gswap + type points + real :: x, y + end type points + interface swap + module procedure sreal, schar, sint => sreal ! { dg-error "Syntax error in MODULE PROCEDURE statement" } + end interface swap +end module gswap Index: Fortran/gfortran/regression/interface_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_23.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! This tests the fix for PR36325, which corrected for the fact that a +! specific or generic INTERFACE statement implies the EXTERNAL attibute. +! +! Contributed by Janus Weil + +module a + interface + subroutine foo + end subroutine + end interface + external foo ! { dg-error "Duplicate EXTERNAL attribute" } +end module + +module b + interface + function sin (x) + real :: sin, x + end function + end interface + intrinsic sin ! { dg-error "EXTERNAL attribute conflicts with INTRINSIC attribute" } +end module + +! argument checking was not done for external procedures with explicit interface +program c + interface + subroutine bar(x) + real :: x + end subroutine + end interface + call bar() ! { dg-error "Missing actual argument" } +end program Index: Fortran/gfortran/regression/interface_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_24.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! +! This tests the fix for PR36361: If a function was declared in an INTERFACE +! statement, no attributes may be declared outside of the INTERFACE body. +! +! Contributed by Janus Weil + +module m1 + interface + real function f1() + end function + end interface + dimension :: f1(4) ! { dg-error "outside its INTERFACE body" } +end module + + +module m2 + dimension :: f2(4) + interface + real function f2() ! { dg-error "outside its INTERFACE body" } + !end function + end interface +end module + + +! valid +module m3 + interface + real function f3() + dimension :: f3(4) + end function + end interface +end module + + +module m4 + interface + function f4() ! { dg-error "cannot have a deferred shape" } + real :: f4(:) + end function + end interface + allocatable :: f4 ! { dg-error "outside of INTERFACE body" } +end module + + +module m5 + allocatable :: f5(:) + interface + function f5() ! { dg-error "outside its INTERFACE body" } + !real f5(:) + !end function + end interface +end module + + +!valid +module m6 + interface + function f6() + real f6(:) + allocatable :: f6 + end function + end interface +end module Index: Fortran/gfortran/regression/interface_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_25.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! Tests the fix for PR39295, in which the check of the interfaces +! at lines 25 and 42 failed because opfunc1 is identified as a +! function by usage, whereas opfunc2 is not. +! +! Contributed by Jon Hurst +! +MODULE funcs +CONTAINS + INTEGER FUNCTION test1(a,b,opfunc1) + INTEGER :: a,b + INTEGER, EXTERNAL :: opfunc1 + test1 = opfunc1( a, b ) + END FUNCTION test1 + INTEGER FUNCTION sumInts(a,b) + INTEGER :: a,b + sumInts = a + b + END FUNCTION sumInts +END MODULE funcs + +PROGRAM test + USE funcs + INTEGER :: rs + INTEGER, PARAMETER :: a = 2, b = 1 + rs = recSum( a, b, test1, sumInts ) + write(*,*) "Results", rs +CONTAINS + RECURSIVE INTEGER FUNCTION recSum( a,b,UserFunction,UserOp ) RESULT( res ) + IMPLICIT NONE + INTEGER :: a,b + INTERFACE + INTEGER FUNCTION UserFunction(a,b,opfunc2) + INTEGER :: a,b + INTEGER, EXTERNAL :: opfunc2 + END FUNCTION UserFunction + END INTERFACE + INTEGER, EXTERNAL :: UserOp + + res = UserFunction( a,b, UserOp ) + + if( res .lt. 10 ) then + res = recSum( a, res, UserFunction, UserOp ) + end if + END FUNCTION recSum +END PROGRAM test Index: Fortran/gfortran/regression/interface_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_26.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! Tests the fix for PR39295, in which the check of the interfaces +! at lines 26 and 43 failed because opfunc1 is identified as a +! function by usage, whereas opfunc2 is not. This testcase checks +! that TKR is stll OK in these cases. +! +! Contributed by Jon Hurst +! +MODULE funcs +CONTAINS + INTEGER FUNCTION test1(a,b,opfunc1) + INTEGER :: a,b + INTEGER, EXTERNAL :: opfunc1 + test1 = opfunc1( a, b ) + END FUNCTION test1 + INTEGER FUNCTION sumInts(a,b) + INTEGER :: a,b + sumInts = a + b + END FUNCTION sumInts +END MODULE funcs + +PROGRAM test + USE funcs + INTEGER :: rs + INTEGER, PARAMETER :: a = 2, b = 1 + rs = recSum( a, b, test1, sumInts ) ! { dg-error "Type mismatch in argument" } + write(*,*) "Results", rs +CONTAINS + RECURSIVE INTEGER FUNCTION recSum( a,b,UserFunction,UserOp ) RESULT( res ) + IMPLICIT NONE + INTEGER :: a,b + INTERFACE + INTEGER FUNCTION UserFunction(a,b,opfunc2) + INTEGER :: a,b + REAL, EXTERNAL :: opfunc2 + END FUNCTION UserFunction + END INTERFACE + INTEGER, EXTERNAL :: UserOp + + res = UserFunction( a,b, UserOp ) ! { dg-error "Type mismatch in function result" } + + if( res .lt. 10 ) then + res = recSum( a, res, UserFunction, UserOp ) + end if + END FUNCTION recSum +END PROGRAM test Index: Fortran/gfortran/regression/interface_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_27.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 40039: Procedures as actual arguments: Check intent of arguments +! +! Contributed by Janus Weil + +module m + +contains + +subroutine a(x,f) + real :: x + interface + real function f(y) + real,intent(in) :: y + end function + end interface + print *,f(x) +end subroutine + +real function func(z) + real,intent(inout) :: z + func = z**2 +end function + +subroutine caller + interface + real function p(y) + real,intent(in) :: y + end function + end interface + pointer :: p + + call a(4.3,func) ! { dg-error "INTENT mismatch in argument" } + p => func ! { dg-error "INTENT mismatch in argument" } +end subroutine + +end module Index: Fortran/gfortran/regression/interface_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_28.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR 36947: Attributes not fully checked comparing actual vs dummy procedure +! +! Original test case by Walter Spector +! Modified by Janus Weil + +module testsub + contains + subroutine test(sub) + interface + subroutine sub(x) + integer, intent(in), optional:: x + end subroutine + end interface + call sub() + end subroutine +end module + +module sub + contains + subroutine subActual(x) + ! actual subroutine's argment is different in intent + integer, intent(inout),optional:: x + end subroutine + subroutine subActual2(x) + ! actual subroutine's argment is missing OPTIONAL + integer, intent(in):: x + end subroutine +end module + +program interfaceCheck + use testsub + use sub + + integer :: a + + call test(subActual) ! { dg-error "INTENT mismatch in argument" } + call test(subActual2) ! { dg-error "OPTIONAL mismatch in argument" } +end program Index: Fortran/gfortran/regression/interface_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_29.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR 36947: Attributes not fully checked comparing actual vs dummy procedure +! +! Contributed by Tobias Burnus + +module m +interface foo + module procedure one, two +end interface foo +contains +subroutine one(op,op2) + interface + subroutine op(x, y) + complex, intent(in) :: x(:) + complex, intent(out) :: y(:) + end subroutine op + subroutine op2(x, y) + complex, intent(in) :: x(:) + complex, intent(out) :: y(:) + end subroutine op2 + end interface +end subroutine one +subroutine two(ops,i,j) + interface + subroutine op(x, y) + complex, intent(in) :: x(:) + complex, intent(out) :: y(:) + end subroutine op + end interface + real :: i,j +end subroutine two +end module m + +module test +contains +subroutine bar() + use m + call foo(precond_prop,prop2) +end subroutine bar + subroutine precond_prop(x, y) + complex, intent(in) :: x(:) + complex, intent(out) :: y(:) + end subroutine + subroutine prop2(x, y) + complex, intent(in) :: x(:) + complex, intent(out) :: y(:) + end subroutine +end module test Index: Fortran/gfortran/regression/interface_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! Tests the fix for PR20880, which was due to failure to the failure +! to detect the USE association of a nameless interface for a +! procedure with the same name as the encompassing scope. +! +! Contributed by Joost VandeVondele +! +! Modified for PR fortran/34657 +! +module test_mod +interface + subroutine my_sub (a) + real a + end subroutine +end interface +interface + function my_fun (a) + real a, my_fun + end function +end interface +end module + +module test_mod2 +interface + function my_fun (a) + real a, my_fun + end function +end interface +end module + + +! This is the original PR, excepting that the error requires the symbol +! to be referenced. +subroutine my_sub (a) + use test_mod ! { dg-error "is also the name of the current program unit" } + real a + call my_sub (a) ! { dg-error "ambiguous reference" } + print *, a +end subroutine + +integer function my_fun (a) + use test_mod ! { dg-error "is also the name of the current program unit" } + real a + print *, a + my_fun = 1 ! { dg-error "ambiguous reference" } +end function + +! This was found whilst investigating => segfault +subroutine thy_sub (a) + interface + subroutine thy_sub (a) ! { dg-error "enclosing procedure" } + real a + end subroutine + end interface + real a + print *, a +end subroutine + +subroutine thy_fun (a) + use test_mod + use test_mod2 ! OK because there is no reference to my_fun + print *, a +end subroutine thy_fun + +subroutine his_fun (a) + use test_mod + use test_mod2 + print *, my_fun (a) ! { dg-error "ambiguous reference" } +end subroutine his_fun Index: Fortran/gfortran/regression/interface_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_30.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR39850: Too strict checking for procedures as actual argument +! +! Original test case by Tobias Burnus +! Modified by Janus Weil + +real function func() + print *,"func" + func = 42.0 +end function func + +program test + external func1,func2,func3,func4 ! subroutine or implicitly typed real function + call sub1(func1) + call sub2(func2) + call sub1(func3) + call sub2(func3) ! { dg-error "is not a subroutine" } + call sub2(func4) + call sub1(func4) ! { dg-error "is not a function" } +contains + subroutine sub1(a1) + interface + real function a1() + end function + end interface + print *, a1() + end subroutine sub1 + subroutine sub2(a2) + interface + subroutine a2 + end subroutine + end interface + call a2() + end subroutine +end + Index: Fortran/gfortran/regression/interface_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_31.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! PR42684 (42680) Ice with Interface. +MODULE mod1 + IMPLICIT NONE + TYPE ta + INTEGER i + END TYPE ta + INTERFACE OPERATOR(+) + MODULE PROCEDURE add_a + END INTERFACE OPERATOR(+) +CONTAINS + FUNCTION add_a(lhs, rhs) RESULT(r) + TYPE(ta), INTENT(IN) :: lhs + TYPE(ta), INTENT(IN) :: rhs + TYPE(ta) :: r + !**** + r%i = lhs%i + rhs%i + END FUNCTION add_a +END MODULE mod1 + +MODULE mod2 + IMPLICIT NONE + TYPE tb + INTEGER j + END TYPE tb + INTERFACE OPERATOR(+) + MODULE PROCEDURE add_b + END INTERFACE OPERATOR(+) +CONTAINS + SUBROUTINE other_proc() + USE mod1 ! Causes ICE + END SUBROUTINE other_proc + FUNCTION add_b(lhs, rhs) RESULT(r) + TYPE(tb), INTENT(IN) :: lhs + TYPE(tb), INTENT(IN) :: rhs + TYPE(tb) :: r + !**** + r%j = lhs%j + rhs%j + END FUNCTION add_b +END MODULE mod2 Index: Fortran/gfortran/regression/interface_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_32.f90 @@ -0,0 +1,80 @@ +! { dg-do compile } +module m1 + implicit none + + type, abstract :: vector_class + end type vector_class +end module m1 +!--------------------------------------------------------------- +module m2 + use m1 + implicit none + + type, abstract :: inner_product_class + contains + procedure(dot), deferred :: dot_v_v + procedure(dot), deferred :: dot_g_g + procedure(sub), deferred :: D_times_v + procedure(sub), deferred :: D_times_g + end type inner_product_class + + abstract interface + function dot (this,a,b) + import :: inner_product_class + import :: vector_class + class(inner_product_class), intent(in) :: this + class(vector_class), intent(in) :: a,b + real :: dot + end function + subroutine sub (this,a) + import :: inner_product_class + import :: vector_class + class(inner_product_class), intent(in) :: this + class(vector_class), intent(inout) :: a + end subroutine + end interface +end module m2 +!--------------------------------------------------------------- +module m3 + use :: m1 + use :: m2 + implicit none + private + public :: gradient_class + + type, abstract, extends(vector_class) :: gradient_class + class(inner_product_class), pointer :: my_inner_product => NULL() + contains + procedure, non_overridable :: inquire_inner_product + procedure(op_g_v), deferred :: to_vector + end type gradient_class + + abstract interface + subroutine op_g_v(this,v) + import vector_class + import gradient_class + class(gradient_class), intent(in) :: this + class(vector_class), intent(inout) :: v + end subroutine + end interface +contains + function inquire_inner_product (this) + class(gradient_class) :: this + class(inner_product_class), pointer :: inquire_inner_product + + inquire_inner_product => this%my_inner_product + end function inquire_inner_product +end module m3 +!--------------------------------------------------------------- +module m4 + use m3 + use m2 + implicit none +contains + subroutine cg (g_initial) + class(gradient_class), intent(in) :: g_initial + + class(inner_product_class), pointer :: ip_save + ip_save => g_initial%inquire_inner_product() + end subroutine cg +end module m4 Index: Fortran/gfortran/regression/interface_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_33.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR fortran/33117, PR fortran/46478 +! Procedures of a generic interface must be either +! all SUBROUTINEs or all FUNCTIONs. +! + +! +! PR fortran/33117 +! +module m1 + interface gen + subroutine sub() ! { dg-error "all SUBROUTINEs or all FUNCTIONs" } + end subroutine sub + function bar() + real :: bar + end function bar + end interface gen +end module + +! +! PR fortran/46478 +! +MODULE m2 + INTERFACE new_name + MODULE PROCEDURE func_name + MODULE PROCEDURE subr_name + END INTERFACE +CONTAINS + LOGICAL FUNCTION func_name() ! { dg-error "all SUBROUTINEs or all FUNCTIONs" } + END FUNCTION + SUBROUTINE subr_name() + END SUBROUTINE +END MODULE Index: Fortran/gfortran/regression/interface_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_34.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/47042 +! +! Contribued by Jerry DeLisle +! + +program bug + +contains +function get_cstring () + character :: get_cstring + character, pointer :: ptmp + character, allocatable :: atmp + + get_cstring = ptmp(i) ! { dg-error "must have an explicit function interface" } + get_cstring = atmp(i) ! { dg-error "must have an explicit function interface" } +end function + +function get_cstring2 () + EXTERNAL :: ptmp, atmp + character :: get_cstring2 + character, pointer :: ptmp + character, allocatable :: atmp + + get_cstring2 = atmp(i) ! { dg-error "must have an explicit function interface" } + + ! The following is regarded as call to a procedure pointer, + ! which is in principle valid: + get_cstring2 = ptmp(i) +end function + +end program Index: Fortran/gfortran/regression/interface_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_35.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/48112 (module_m) +! PR fortran/48279 (sidl_string_array, s_Hard) +! +! Contributed by mhp77@gmx.at (module_m) +! and Adrian Prantl (sidl_string_array, s_Hard) +! + +module module_m + interface test + function test1( ) result( test ) + integer :: test + end function test1 + end interface test +end module module_m + +! ----- + +module sidl_string_array + type sidl_string_1d + end type sidl_string_1d + interface set + module procedure & + setg1_p + end interface +contains + subroutine setg1_p(array, index, val) + type(sidl_string_1d), intent(inout) :: array + end subroutine setg1_p +end module sidl_string_array + +module s_Hard + use sidl_string_array + type :: s_Hard_t + integer(8) :: dummy + end type s_Hard_t + interface set_d_interface + end interface + interface get_d_string + module procedure get_d_string_p + end interface + contains ! Derived type member access functions + type(sidl_string_1d) function get_d_string_p(s) + type(s_Hard_t), intent(in) :: s + end function get_d_string_p + subroutine set_d_objectArray_p(s, d_objectArray) + end subroutine set_d_objectArray_p +end module s_Hard + +subroutine initHard(h, ex) + use s_Hard + type(s_Hard_t), intent(inout) :: h + call set(get_d_string(h), 0, 'Three') ! { dg-error "There is no specific subroutine for the generic" } +end subroutine initHard + +! ----- + + interface get + procedure get1 + end interface + + integer :: h + call set1 (get (h)) + +contains + + subroutine set1 (a) + integer, intent(in) :: a + end subroutine + + integer function get1 (s) ! { dg-error "Fortran 2008: Internal procedure .get1. in generic interface .get." } + integer :: s + end function + +end Index: Fortran/gfortran/regression/interface_36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_36.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/48800 +! +! Contributed by Daniel Carrera +! + pure function runge_kutta_step(t, r_, dr, h) result(res) + real, intent(in) :: t, r_(:), h + real, dimension(:), allocatable :: k1, k2, k3, k4, res + integer :: N + + interface + pure function dr(t, r_) ! { dg-error "cannot have a deferred shape" } + real, intent(in) :: t, r_(:) + real :: dr(:) + end function + end interface + + N = size(r_) + allocate(k1(N),k2(N),k3(N),k4(N),res(N)) + + k1 = dr(t, r_) + k2 = dr(t + h/2, r_ + k1*h/2) + k3 = dr(t + h/2, r_ + k2*h/2) + k4 = dr(t + h , r_ + k3*h) + + res = r_ + (k1 + 2*k2 + 2*k3 + k4) * h/6 + end function Index: Fortran/gfortran/regression/interface_37.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_37.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/39290 +! Subroutine/function ambiguity in generics. +! + interface q + subroutine qr(f) ! { dg-error "Ambiguous interfaces" } + implicit real(f) + external f + end subroutine + subroutine qc(f) ! { dg-error "Ambiguous interfaces" } + implicit complex(f) + external f + end subroutine + end interface q + end Index: Fortran/gfortran/regression/interface_38.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_38.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR69397 +program p + interface f + procedure f1 ! { dg-error "neither function nor subroutine" } + !... more + end interface + integer, allocatable :: z + print *, f(z) ! { dg-error "no specific function" } +contains + integer function f2 (x) + integer, allocatable :: x + f2 = 1 + end +end + Index: Fortran/gfortran/regression/interface_39.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_39.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR68442 +module m + interface gkind + procedure g + end interface +contains + subroutine f(x) + character(kind=gkind()) :: x ! { dg-error "must be an intrinsic" } + end + integer function g() + g = 1 + end +end Index: Fortran/gfortran/regression/interface_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_4.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Tests the fix for the interface bit of PR29975, in which the +! interfaces bl_copy were rejected as ambiguous, even though +! they import different specific interfaces. +! +! Contributed by Joost VandeVondele and +! simplified by Tobias Burnus +! +SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + c = "recopy" +END SUBROUTINE RECOPY + +MODULE f77_blas_extra +PUBLIC :: BL_COPY +INTERFACE BL_COPY + MODULE PROCEDURE SDCOPY +END INTERFACE BL_COPY +CONTAINS + SUBROUTINE SDCOPY(N, c) + INTEGER, INTENT(IN) :: N + character(6) :: c + c = "sdcopy" + END SUBROUTINE SDCOPY +END MODULE f77_blas_extra + +MODULE f77_blas_generic +INTERFACE BL_COPY + SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + END SUBROUTINE RECOPY +END INTERFACE BL_COPY +END MODULE f77_blas_generic + +program main + USE f77_blas_extra + USE f77_blas_generic + character(6) :: chr + call bl_copy(1, chr) + if (chr /= "sdcopy") STOP 1 + call bl_copy(1.0, chr) + if (chr /= "recopy") STOP 2 +end program main Index: Fortran/gfortran/regression/interface_40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_40.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/78814 +! Code contributed by Gerhard Steinmetz +program p + class(*) :: x ! { dg-error " must be dummy, allocatable or pointer" } + print *, f(x) ! { dg-error "Explicit interface required" } +end + Index: Fortran/gfortran/regression/interface_41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_41.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/85001 +! Contributed by Gerhard Steinmetz. +program p + type t + end type + call s +contains + real function f(x) + class(t) :: x + dimension :: x(:) + f = 1.0 + end + subroutine s + type(t) :: x(2) + real :: z + z = f(x) + end +end Index: Fortran/gfortran/regression/interface_42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_42.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1" } +! PR fortran/84922 +! Original code contributed by William Clodius. +module copy + + interface + module subroutine foo_da(da, copy) ! { dg-error "(1)" } + integer, intent(in) :: da(:) + integer, allocatable, intent(out) :: copy(:) + end subroutine foo_da + end interface + + contains + + subroutine foo_da(da, copy) ! { dg-error "defined in interface body|PROCEDURE attribute conflicts with PROCEDURE attribute" } + integer, intent(in) :: da(:) + integer, allocatable, intent(out) :: copy(:) + allocate( copy( size(da) ) ) + copy = da + end subroutine foo_da + +end module copy +! { dg-prune-output "compilation terminated" } Index: Fortran/gfortran/regression/interface_43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_43.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/84922 +! This should compile without error. +module foom + + implicit none + + interface foo + module procedure foo_sngl + module procedure foo_dble + end interface foo + + contains + + subroutine foo_sngl(n, f, g, h) + integer n + real f, g, h + end subroutine foo_sngl + + subroutine foo_dble(n, f, g, h) + integer n + double precision f, g, h + end subroutine foo_dble + +end module foom Index: Fortran/gfortran/regression/interface_44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_44.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 92964 - this used to ICE. +! Original test case by Arseny Solokha +type(e6) function dn() ! { dg-error "The type for function" } + call sub(dn) +end function dn Index: Fortran/gfortran/regression/interface_45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_45.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 92863 - this used to ICE +! Test case by Arseny Solokha. + +type(l1) function mp() ! { dg-error "type for function" } + call sub(mp) ! { dg-error "Type mismatch" } +end function mp + +function bi(ry) + call sub(ry) ! { dg-error "Type mismatch" } +end function bi Index: Fortran/gfortran/regression/interface_46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_46.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR 94090 - this used to cause an ICE. +! Test case by José Rui Faustino de Sousa. +function cntf(a) result(s) + implicit none + + integer, intent(in) :: a(:) + + integer :: s(3) + + s = [1, 2, 3] + return +end function cntf + +program ice_p + + implicit none + + interface + function cntf(a) result(s) ! { dg-error "Rank mismatch in function result" } + implicit none + integer, intent(in) :: a(:) + integer :: s ! (3) <- Ups! + end function cntf + end interface + + integer, parameter :: n = 9 + + integer :: arr(n) + + integer :: s(3) + + s = cntf(arr) + stop + +end program ice_p Index: Fortran/gfortran/regression/interface_47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_47.f90 @@ -0,0 +1,19 @@ +! PR fortran/27318 +! { dg-do compile } +! This tests for mismatch between the interface for a global +! procedure and the procedure itself. + +module test +implicit none +interface + subroutine hello(n) ! { dg-warning "INTENT mismatch" } + integer :: n + end subroutine hello +end interface +end module test + +subroutine hello(n) ! { dg-warning "INTENT mismatch" } + integer, intent(in) :: n + integer :: i + do i = 1,n; print *, 'hello'; end do +end subroutine hello Index: Fortran/gfortran/regression/interface_48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_48.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR 96073 - this used to cause an ICE. +! Test case by Jürgen Reuter. + +module m + implicit none + private + + interface + subroutine GetXminM (set, xmin) + integer, intent(in) :: set + real, intent(out) :: xmin + end subroutine GetXminM + end interface + interface + subroutine foo(a) ! { dg-warning "Type mismatch" } + integer, intent(in) :: a + end subroutine foo + end interface + +contains + + subroutine s () + real :: xmin + integer :: set + external :: GetXminM, foo + call GetXminM (set, xmin) + call foo(1.0) ! { dg-warning "Type mismatch" } + end subroutine s + +end module m Index: Fortran/gfortran/regression/interface_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_5.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! Tests the fix for the interface bit of PR29975, in which the +! interfaces bl_copy were rejected as ambiguous, even though +! they import different specific interfaces. In this testcase, +! it is verified that ambiguous specific interfaces are caught. +! +! Contributed by Joost VandeVondele and +! simplified by Tobias Burnus +! +SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + print *, n + c = "recopy" +END SUBROUTINE RECOPY + +MODULE f77_blas_extra +PUBLIC :: BL_COPY +INTERFACE BL_COPY + MODULE PROCEDURE SDCOPY +END INTERFACE BL_COPY +CONTAINS + SUBROUTINE SDCOPY(N, c) + REAL, INTENT(IN) :: N + character(6) :: c + print *, n + c = "sdcopy" + END SUBROUTINE SDCOPY +END MODULE f77_blas_extra + +MODULE f77_blas_generic +INTERFACE BL_COPY + SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + END SUBROUTINE RECOPY +END INTERFACE BL_COPY +END MODULE f77_blas_generic + +subroutine i_am_ok + USE f77_blas_extra ! { dg-warning "ambiguous interfaces" } + USE f77_blas_generic + character(6) :: chr + chr = "" + if (chr /= "recopy") STOP 1 +end subroutine i_am_ok + +program main + USE f77_blas_extra ! { dg-error "Ambiguous interfaces" } + USE f77_blas_generic ! { dg-error "Ambiguous interfaces" } + character(6) :: chr + chr = "" + call bl_copy(1.0, chr) + if (chr /= "recopy") STOP 2 +end program main Index: Fortran/gfortran/regression/interface_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from the fortran 2003 standard C11.2. +! +! The standard specifies that the optional arguments should be +! ignored in the counting of like type/kind, so the specific +! procedures below are invalid, even though actually unambiguous. +! +INTERFACE BAD8 + SUBROUTINE S8A(X,Y,Z) ! { dg-error "Ambiguous interfaces" } + REAL,OPTIONAL :: X + INTEGER :: Y + REAL :: Z + END SUBROUTINE S8A + SUBROUTINE S8B(X,Z,Y) ! { dg-error "Ambiguous interfaces" } + INTEGER,OPTIONAL :: X + INTEGER :: Z + REAL :: Y + END SUBROUTINE S8B +END INTERFACE BAD8 +real :: a, b +integer :: i, j +call bad8(x,i,b) +end Index: Fortran/gfortran/regression/interface_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_7.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from the fortran 2003 standard C11.2. +! +! The interface is invalid although it is unambiguous because the +! standard explicitly does not require recursion into the formal +! arguments of procedures that themselves are interface arguments. +! +module xx + INTERFACE BAD9 + SUBROUTINE S9A(X) + REAL :: X + END SUBROUTINE S9A + SUBROUTINE S9B(X) ! { dg-error "Ambiguous interfaces" } + INTERFACE + FUNCTION X(A) + REAL :: X,A + END FUNCTION X + END INTERFACE + END SUBROUTINE S9B + SUBROUTINE S9C(X) ! { dg-error "Ambiguous interfaces" } + INTERFACE + FUNCTION X(A) + REAL :: X + INTEGER :: A + END FUNCTION X + END INTERFACE + END SUBROUTINE S9C + END INTERFACE BAD9 +end module xx Index: Fortran/gfortran/regression/interface_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_8.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from comp.lang.fortran 3rd December 2006. +! +! Although the generic procedure is not referenced and it would +! normally be permissible for it to be ambiguous, the USE, ONLY +! statement is effectively a reference and is invalid. +! +module mod1 + interface generic + subroutine foo(a) + real :: a + end subroutine + end interface generic +end module mod1 + +module mod2 + interface generic + subroutine bar(a) + real :: a + end subroutine + end interface generic +end module mod2 + +program main + use mod1, only: generic ! { dg-warning "has ambiguous interfaces" } + use mod2 +end program main Index: Fortran/gfortran/regression/interface_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_9.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Test of the patch for PR30096, in which gfortran incorrectly. +! compared local with host associated interfaces. +! +! Based on contribution by Harald Anlauf +! +module module1 + interface inverse + module procedure A, B + end interface +contains + function A (X) result (Y) + real :: X, Y + Y = 1.0 + end function A + function B (X) result (Y) + integer :: X, Y + Y = 3 + end function B +end module module1 + +module module2 + interface inverse + module procedure C + end interface +contains + function C (X) result (Y) + real :: X, Y + Y = 2.0 + end function C +end module module2 + +program gfcbug48 + use module1, only : inverse + call sub () + if (inverse(1.0_4) /= 1.0_4) STOP 1 + if (inverse(1_4) /= 3_4) STOP 2 +contains + subroutine sub () + use module2, only : inverse + if (inverse(1.0_4) /= 2.0_4) STOP 3 + if (inverse(1_4) /= 3_4) STOP 4 + end subroutine sub +end program gfcbug48 Index: Fortran/gfortran/regression/interface_abstract_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_abstract_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +module mod_interf_abstract +implicit none +abstract interface :: one ! { dg-error "Syntax error in ABSTRACT INTERFACE statement" } +end interface ! { dg-error "Expecting END MODULE statement" } + +abstract interface + subroutine two() bind(C) + end subroutine two + subroutine three() bind(C,name="three") ! { dg-error "NAME not allowed on BIND.C. for ABSTRACT INTERFACE" } + end subroutine three ! { dg-error "Expecting END INTERFACE statement" } + subroutine real() ! { dg-error "cannot be the same as an intrinsic type" } + end subroutine real +end interface + +contains + + subroutine sub() bind(C,name="subC") + end subroutine + +end module mod_interf_abstract Index: Fortran/gfortran/regression/interface_abstract_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_abstract_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +abstract interface ! { dg-error "Fortran 2003: ABSTRACT INTERFACE" } + subroutine two() + end subroutine two +end interface ! { dg-error "Expecting END PROGRAM statement" } +end Index: Fortran/gfortran/regression/interface_abstract_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_abstract_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! test for C1204 of Fortran 2003 standard: +! module procedure not allowed in abstract interface +module m + abstract interface + module procedure p ! { dg-error "must be in a generic module interface" } + end interface +contains + subroutine p() + end subroutine +end module m Index: Fortran/gfortran/regression/interface_abstract_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_abstract_4.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 41873: Bogus Error: ABSTRACT INTERFACE must not be referenced... +! +! Contributed by Harald Anlauf + + implicit none + + type, abstract :: abstype + contains + procedure(f), nopass, deferred :: f_bound + procedure(s), nopass, deferred :: s_bound + end type + + abstract interface + real function f () + end function + end interface + + abstract interface + subroutine s + end subroutine + end interface + +contains + + subroutine cg (c) + class(abstype) :: c + print *, f() ! { dg-error "must not be referenced" } + call s ! { dg-error "must not be referenced" } + print *, c%f_bound () + call c%s_bound () + end subroutine + +end Index: Fortran/gfortran/regression/interface_abstract_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_abstract_5.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 71861: [7/8/9 Regression] [F03] ICE in write_symbol(): bad module symbol +! +! Contributed by Gerhard Steinmetz + +module m1 + intrinsic abs + abstract interface + function abs(x) ! { dg-error "ABSTRACT attribute conflicts with INTRINSIC attribute" } + real :: abs, x + end + end interface +end + +module m2 + abstract interface + function abs(x) + real :: abs, x + end + end interface + intrinsic abs ! { dg-error "ABSTRACT attribute conflicts with INTRINSIC attribute" } +end + +module m3 + abstract interface + function f(x) + real :: f, x + end + end interface + intrinsic f ! { dg-error "ABSTRACT attribute conflicts with INTRINSIC attribute" } +end Index: Fortran/gfortran/regression/interface_assignment_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_1.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! Checks the fix for PR31205, in which temporaries were not +! written for the interface assignment and the parentheses below. +! +! Contributed by Joost VandeVondele +! +MODULE TT + TYPE data_type + INTEGER :: I=2 + END TYPE data_type + INTERFACE ASSIGNMENT (=) + MODULE PROCEDURE set + END INTERFACE +CONTAINS + PURE SUBROUTINE set(x1,x2) + TYPE(data_type), INTENT(IN) :: x2 + TYPE(data_type), INTENT(OUT) :: x1 + CALL S1(x1,x2) + END SUBROUTINE + PURE SUBROUTINE S1(x1,x2) + TYPE(data_type), INTENT(IN) :: x2 + TYPE(data_type), INTENT(OUT) :: x1 + x1%i=x2%i + END SUBROUTINE +END MODULE + +USE TT +TYPE(data_type) :: D,E + +D%I=4 +D=D + +E%I=4 +CALL set(E,(E)) + +IF (D%I.NE.4) STOP 1 +IF (4.NE.E%I) STOP 2 +END Index: Fortran/gfortran/regression/interface_assignment_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Checks the fix for PR32842, in which the interface assignment +! below caused a segfault. This testcase is reduced from vst_2.f95 +! in the iso_varying_string testsuite, from Lawrie Schonfelder +! +! Contributed by Tobias Burnus +! +module iso_varying_string + implicit none + integer, parameter :: GET_BUFFER_LEN = 256 + type varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + interface assignment(=) + module procedure op_assign_VS_CH + end interface assignment(=) +contains + elemental subroutine op_assign_VS_CH (var, expr) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: expr + var = var_str(expr) + end subroutine op_assign_VS_CH + elemental function var_str (chr) result (string) + character(LEN=*), intent(in) :: chr + type(varying_string) :: string + integer :: length + integer :: i_char + length = LEN(chr) + ALLOCATE(string%chars(length)) + forall(i_char = 1:length) + string%chars(i_char) = chr(i_char:i_char) + end forall + end function var_str +end module iso_varying_string + +PROGRAM VST_2 + USE ISO_VARYING_STRING + IMPLICIT NONE + CHARACTER(LEN=5) :: char_arb(2) + CHARACTER(LEN=1) :: char_elm(10) + equivalence (char_arb, char_elm) + type(VARYING_STRING) :: str_ara(2) + char_arb(1)= "Hello" + char_arb(2)= "World" + str_ara = char_arb + if (any (str_ara(1)%chars(1:5) .ne. char_elm(1:5))) STOP 1 + if (any (str_ara(2)%chars(1:5) .ne. char_elm(6:10))) STOP 2 +END PROGRAM VST_2 Index: Fortran/gfortran/regression/interface_assignment_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_3.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Checks the fix for PR34008, in which INTENT(INOUT) was disallowed +! for the first argument of assign_m, whereas both INOUT and OUT +! should be allowed. +! +! Contributed by Harald Anlauf +! +module mo_memory + implicit none + type t_mi + logical :: alloc = .false. + end type t_mi + type t_m + type(t_mi) :: i ! meta data + real, pointer :: ptr (:,:,:,:) => NULL () + end type t_m + + interface assignment (=) + module procedure assign_m + end interface +contains + elemental subroutine assign_m (y, x) + !--------------------------------------- + ! overwrite intrinsic assignment routine + !--------------------------------------- + type (t_m), intent(inout) :: y + type (t_m), intent(in) :: x + y% i = x% i + if (y% i% alloc) y% ptr = x% ptr + end subroutine assign_m +end module mo_memory + +module gfcbug74 + use mo_memory, only: t_m, assignment (=) + implicit none + type t_atm + type(t_m) :: m(42) + end type t_atm +contains + subroutine assign_atm_to_atm (y, x) + type (t_atm), intent(inout) :: y + type (t_atm), intent(in) :: x + integer :: i +! do i=1,42; y% m(i) = x% m(i); end do ! Works + y% m = x% m ! ICE + end subroutine assign_atm_to_atm +end module gfcbug74 Index: Fortran/gfortran/regression/interface_assignment_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_4.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 40743: [4.5 Regression] ICE when compiling iso_varying_string.f95 at revision 149591 +! +! Reduced from http://www.fortran.com/iso_varying_string.f95 +! Contributed by Janus Weil + + implicit none + + type :: varying_string + end type + + interface assignment(=) + procedure op_assign_VS_CH + end interface + +contains + + subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + end subroutine + + subroutine split_VS + type(varying_string) :: string + call split_CH(string) + end subroutine + + subroutine split_CH (string) + type(varying_string) :: string + string = "" + end subroutine + +end + Index: Fortran/gfortran/regression/interface_assignment_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_5.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR 42677: [4.5 Regression] Bogus Error: Ambiguous interfaces '...' in intrinsic assignment operator +! +! Contributed by Harald Anlauf + +module mod1 + implicit none + type t_m + integer :: i = 0 + end type t_m +!------------------------------------------------------------------------------ + interface assignment (=) + module procedure assign_m + end interface +!------------------------------------------------------------------------------ +contains + subroutine assign_m (y, x) + type(t_m) ,intent(inout) :: y + type(t_m) ,intent(in) :: x + end subroutine assign_m +end module mod1 +!============================================================================== +module mod2 + use mod1, only: t_m, assignment(=) + implicit none + type t_atm + integer :: k + end type t_atm +!------------------------------------------------------------------------------ + interface assignment(=) + module procedure assign_to_atm + end interface +!------------------------------------------------------------------------------ + interface + pure subroutine delete_m (x) + use mod1 + type(t_m) ,intent(in) :: x + end subroutine delete_m + end interface +!------------------------------------------------------------------------------ +contains + subroutine assign_to_atm (atm, r) + type(t_atm) ,intent(inout) :: atm + integer ,intent(in) :: r + end subroutine assign_to_atm +end module mod2 + Index: Fortran/gfortran/regression/interface_assignment_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_6.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by Janus Weil + +module inteface_assignment_6 + + type :: t + end type + + ! this was rejected as ambiguous, but is valid in F08 + interface assignment(=) + procedure testAlloc + procedure testPtr + end interface + +contains + + subroutine testAlloc(obj, val) + type(t), allocatable, intent(out) :: obj + integer, intent(in) :: val + end subroutine + + subroutine testPtr(obj, val) + type(t), pointer, intent(out) :: obj + integer, intent(in) :: val + end subroutine + +end Index: Fortran/gfortran/regression/interface_assignment_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_assignment_7.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! PR 96843 - this was wrongly rejected. +! Test case by William Clodius. + +module test_shape_mismatch +! Implements zero based bitsets of size up to HUGE(0_INT32). +! The current code uses 32 bit integers to store the bits and uses all 32 bits. +! The code assumes two's complement integers, and treats negative integers as +! having the sign bit set. + + use, intrinsic :: & + iso_fortran_env, only: & + bits_kind => int32, & + block_kind => int64, & + int8, & + dp => real64 + + implicit none + + private + + integer, parameter :: & + block_size = bit_size(0_block_kind), & + block_shift = int( ceiling( log( real(block_size, dp) )/log(2._dp) ) ) + + public :: bits_kind +! Public constant + + public :: bitset_t +! Public type + + public :: & + assignment(=) + + type, abstract :: bitset_t + private + integer(bits_kind) :: num_bits + + end type bitset_t + + + type, extends(bitset_t) :: bitset_large + private + integer(block_kind), private, allocatable :: blocks(:) + + end type bitset_large + + interface assign + + pure module subroutine assign_log8_large( self, alogical ) +!! Used to define assignment from an array of type LOG for bitset_t + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: alogical(:) + end subroutine assign_log8_large + + end interface assign + +contains + + pure module subroutine assign_log8_large( self, alogical ) +! Used to define assignment from an array of type LOG for bitset_t + type(bitset_large), intent(out) :: self + logical(int8), intent(in) :: alogical(:) + + integer(bits_kind) :: blocks + integer(bits_kind) :: log_size + integer(bits_kind) :: index + + log_size = size( alogical, kind=bits_kind ) + self % num_bits = log_size + if ( log_size == 0 ) then + blocks = 0 + + else + blocks = (log_size-1)/block_size + 1 + + end if + allocate( self % blocks( blocks ) ) + self % blocks(:) = 0 + + return + end subroutine assign_log8_large + +end module test_shape_mismatch Index: Fortran/gfortran/regression/interface_derived_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_derived_type_1.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! Test the fix for PR20903, in which derived types could be host associated within +! interface bodies. +! +! Contributed by Joost VandeVondele +! +module test + implicit none + type fcnparms + integer :: i + end type fcnparms +contains + subroutine sim_1(func1,params) + interface + function func1(fparams) + type(fcnparms) :: fparams ! { dg-error "is being used before it is defined" } + real :: func1 + end function func1 + end interface + type(fcnparms) :: params + end subroutine sim_1 + + subroutine sim_2(func2,params) + interface + function func2(fparams) ! This is OK because of the derived type decl. + type fcnparms + integer :: i + end type fcnparms + type(fcnparms) :: fparams + real :: func2 + end function func2 + end interface + type(fcnparms) :: params ! This is OK, of course + end subroutine sim_2 +end module test + +module type_decl + implicit none + type fcnparms + integer :: i + end type fcnparms +end module type_decl + +subroutine sim_3(func3,params) + use type_decl + interface + function func3(fparams) + use type_decl + type(fcnparms) :: fparams ! This is OK - use associated + real :: func3 + end function func3 + end interface + type(fcnparms) :: params ! -ditto- +end subroutine sim_3 Index: Fortran/gfortran/regression/interface_operator_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_operator_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/66106 +! +! Original code from Gerhard Steinmetz +! +program p + interface operator ( .gt. ) + end interface operator ! { dg-error "END INTERFACE OPERATOR" } +end program p ! { dg-error "END INTERFACE" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/interface_operator_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_operator_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/66106 +! +! Original code from Gerhard Steinmetz +! +program p + interface operator ( .gt. ) + end interface operator (.lt.) ! { dg-error "END INTERFACE OPERATOR" } +end program p ! { dg-error "END INTERFACE" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/interface_operator_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_operator_3.f90 @@ -0,0 +1,141 @@ +! { dg-do compile } +! PR fortran/65454 - accept both old and new-style relational operators + +module m + implicit none + private :: t1 + type t1 + integer :: i + end type t1 + interface operator (==) + module procedure :: my_cmp + end interface + interface operator (/=) + module procedure :: my_cmp + end interface + interface operator (<=) + module procedure :: my_cmp + end interface + interface operator (<) + module procedure :: my_cmp + end interface + interface operator (>=) + module procedure :: my_cmp + end interface + interface operator (>) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t1), intent(in) :: a, b + logical :: c + c = a%i == b%i + end function my_cmp +end module m + +module m_os + implicit none + private :: t2 + type t2 + integer :: i + end type t2 + interface operator (.eq.) + module procedure :: my_cmp + end interface + interface operator (.ne.) + module procedure :: my_cmp + end interface + interface operator (.le.) + module procedure :: my_cmp + end interface + interface operator (.lt.) + module procedure :: my_cmp + end interface + interface operator (.ge.) + module procedure :: my_cmp + end interface + interface operator (.gt.) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t2), intent(in) :: a, b + logical :: c + c = a%i .eq. b%i + end function my_cmp +end module m_os + +! new style only +module m1 + use m, only: operator(==), operator(/=) + use m, only: operator(<=), operator(<) + use m, only: operator(>=), operator(>) +end module m1 + +! old -> new style +module m2 + use m_os, only: operator(==), operator(/=) + use m_os, only: operator(<=), operator(<) + use m_os, only: operator(>=), operator(>) +end module m2 + +! new -> old style +module m3 + use m, only: operator(.eq.), operator(.ne.) + use m, only: operator(.le.), operator(.lt.) + use m, only: operator(.ge.), operator(.gt.) +end module m3 + +! old style only +module m4 + use m_os, only: operator(.eq.), operator(.ne.) + use m_os, only: operator(.le.), operator(.lt.) + use m_os, only: operator(.ge.), operator(.gt.) +end module m4 + +! new -> all styles +module m5 + use m, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m5 + +! old -> all styles +module m6 + use m_os, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m_os, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m_os, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m6 + +! all -> all styles +module m7 + use m, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) + use m_os, only: operator(.eq.), operator(.ne.), operator(==), operator(/=) + use m_os, only: operator(.le.), operator(.lt.), operator(<=), operator(<) + use m_os, only: operator(.ge.), operator(.gt.), operator(>=), operator(>) +end module m7 + +module m_eq + implicit none + private :: t3 + type t3 + integer :: i + end type t3 + interface operator (==) + module procedure :: my_cmp + end interface +contains + elemental function my_cmp (a, b) result (c) + type(t3), intent(in) :: a, b + logical :: c + c = a%i == b%i + end function my_cmp +end module m_eq + +module m8 + use m_eq, only: operator(==), operator(.eq.) + use m_eq, only: operator(/=) ! { dg-error "operator ./=. referenced" } + use m_eq, only: operator(.ne.) ! { dg-error "operator .\.ne\.. referenced" } +end module m8 Index: Fortran/gfortran/regression/interface_proc_end.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interface_proc_end.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/34763 +! Before, gfortran did not allow for the "END" in +! the interface, which is no module procedure. +! +! Test case contributed by Dick Hendrickson +! + module n + contains + subroutine n_interface + INTERFACE + SUBROUTINE NGSXDY(TLS1,TLS2) + REAL :: TLS1,TLS2 + END ! OK + END INTERFACE + end subroutine + end module Index: Fortran/gfortran/regression/internal_dummy_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_dummy_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Tests the fix for 20861, in which internal procedures were permitted to +! be dummy arguments. +! +! Contributed by Joost VandeVondele +! +CALL DD(TT) ! { dg-error "Fortran 2008: Internal procedure 'tt' is used as actual argument" } +CONTAINS +SUBROUTINE DD(F) + INTERFACE + SUBROUTINE F(X) + REAL :: X + END SUBROUTINE F + END INTERFACE +END SUBROUTINE DD +SUBROUTINE TT(X) + REAL :: X +END SUBROUTINE +END Index: Fortran/gfortran/regression/internal_dummy_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_dummy_2.f08 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! PR fortran/34162 +! Internal procedures as actual arguments (like restricted closures). +! Check it works basically. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + ABSTRACT INTERFACE + FUNCTION returnValue () + INTEGER :: returnValue + END FUNCTION returnValue + + SUBROUTINE doSomething () + END SUBROUTINE doSomething + END INTERFACE + +CONTAINS + + FUNCTION callIt (proc) + PROCEDURE(returnValue) :: proc + INTEGER :: callIt + + callIt = proc () + END FUNCTION callIt + + SUBROUTINE callSub (proc) + PROCEDURE(doSomething) :: proc + + CALL proc () + END SUBROUTINE callSub + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + INTEGER :: a + + a = 42 + IF (callIt (myA) /= 42) STOP 1 + + CALL callSub (incA) + IF (a /= 43) STOP 2 + +CONTAINS + + FUNCTION myA () + INTEGER :: myA + myA = a + END FUNCTION myA + + SUBROUTINE incA () + a = a + 1 + END SUBROUTINE incA + +END PROGRAM main Index: Fortran/gfortran/regression/internal_dummy_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_dummy_3.f08 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! PR fortran/34162 +! Internal procedures as actual arguments (like restricted closures). +! More challenging test involving recursion. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + ABSTRACT INTERFACE + FUNCTION returnValue () + INTEGER :: returnValue + END FUNCTION returnValue + END INTERFACE + + PROCEDURE(returnValue), POINTER :: first + +CONTAINS + + RECURSIVE SUBROUTINE test (level, current, previous) + INTEGER, INTENT(IN) :: level + PROCEDURE(returnValue), OPTIONAL :: previous, current + + IF (PRESENT (current)) THEN + IF (current () /= level - 1) STOP 1 + END IF + + IF (PRESENT (previous)) THEN + IF (previous () /= level - 2) STOP 2 + END IF + + IF (level == 1) THEN + first => myLevel + END IF + IF (first () /= 1) STOP 3 + + IF (level == 10) RETURN + + IF (PRESENT (current)) THEN + CALL test (level + 1, myLevel, current) + ELSE + CALL test (level + 1, myLevel) + END IF + + CONTAINS + + FUNCTION myLevel () + INTEGER :: myLevel + myLevel = level + END FUNCTION myLevel + + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + CALL test (1) +END PROGRAM main Index: Fortran/gfortran/regression/internal_dummy_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_dummy_4.f08 @@ -0,0 +1,56 @@ +! { dg-do run } +! PR fortran/34133 +! PR fortran/34162 +! +! Test of using internal bind(C) procedures as +! actual argument. Bind(c) on internal procedures and +! internal procedures are actual argument are +! Fortran 2008 (draft) extension. +! +module test_mod + use iso_c_binding + implicit none +contains + subroutine test_sub(a, arg, res) + interface + subroutine a(x) bind(C) + import + integer(c_int), intent(inout) :: x + end subroutine a + end interface + integer(c_int), intent(inout) :: arg + integer(c_int), intent(in) :: res + call a(arg) + if(arg /= res) STOP 1 + end subroutine test_sub + subroutine test_func(a, arg, res) + interface + integer(c_int) function a(x) bind(C) + import + integer(c_int), intent(in) :: x + end function a + end interface + integer(c_int), intent(in) :: arg + integer(c_int), intent(in) :: res + if(a(arg) /= res) STOP 2 + end subroutine test_func +end module test_mod + +program main + use test_mod + implicit none + integer :: a + a = 33 + call test_sub (one, a, 7*33) + a = 23 + call test_func(two, a, -123*23) +contains + subroutine one(x) bind(c) + integer(c_int),intent(inout) :: x + x = 7*x + end subroutine one + integer(c_int) function two(y) bind(c) + integer(c_int),intent(in) :: y + two = -123*y + end function two +end program main Index: Fortran/gfortran/regression/internal_io_unf.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_io_unf.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/34654 +! +! Disallow unformatted write to internal unit. +! Test case was contributed by Joost VandeVondele. +! +implicit none +CHARACTER :: a(3) +WRITE(a) 0 ! { dg-error "Unformatted I/O not allowed with internal unit" } +END Index: Fortran/gfortran/regression/internal_pack_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_1.f90 @@ -0,0 +1,136 @@ +! { dg-do run } +! Test that the internal pack and unpack routines work OK +! for different data types + +program main + integer(kind=1), dimension(3) :: i1 + integer(kind=2), dimension(3) :: i2 + integer(kind=4), dimension(3) :: i4 + integer(kind=8), dimension(3) :: i8 + real(kind=4), dimension(3) :: r4 + real(kind=8), dimension(3) :: r8 + complex(kind=4), dimension(3) :: c4 + complex(kind=8), dimension(3) :: c8 + type i8_t + sequence + integer(kind=8) :: v + end type i8_t + type(i8_t), dimension(3) :: d_i8 + + i1 = (/ -1, 1, -3 /) + call sub_i1(i1(1:3:2)) + if (any(i1 /= (/ 3, 1, 2 /))) STOP 1 + + i2 = (/ -1, 1, -3 /) + call sub_i2(i2(1:3:2)) + if (any(i2 /= (/ 3, 1, 2 /))) STOP 2 + + i4 = (/ -1, 1, -3 /) + call sub_i4(i4(1:3:2)) + if (any(i4 /= (/ 3, 1, 2 /))) STOP 3 + + i8 = (/ -1, 1, -3 /) + call sub_i8(i8(1:3:2)) + if (any(i8 /= (/ 3, 1, 2 /))) STOP 4 + + r4 = (/ -1.0, 1.0, -3.0 /) + call sub_r4(r4(1:3:2)) + if (any(r4 /= (/ 3.0, 1.0, 2.0/))) STOP 5 + + r8 = (/ -1.0_8, 1.0_8, -3.0_8 /) + call sub_r8(r8(1:3:2)) + if (any(r8 /= (/ 3.0_8, 1.0_8, 2.0_8/))) STOP 6 + + c4 = (/ (-1.0_4, 0._4), (1.0_4, 0._4), (-3.0_4, 0._4) /) + call sub_c4(c4(1:3:2)) + if (any(real(c4) /= (/ 3.0_4, 1.0_4, 2.0_4/))) STOP 7 + if (any(aimag(c4) /= 0._4)) STOP 8 + + c8 = (/ (-1.0_4, 0._4), (1.0_4, 0._4), (-3.0_4, 0._4) /) + call sub_c8(c8(1:3:2)) + if (any(real(c8) /= (/ 3.0_4, 1.0_4, 2.0_4/))) STOP 9 + if (any(aimag(c8) /= 0._4)) STOP 10 + + d_i8%v = (/ -1, 1, -3 /) + call sub_d_i8(d_i8(1:3:2)) + if (any(d_i8%v /= (/ 3, 1, 2 /))) STOP 11 + +end program main + +subroutine sub_i1(i) + integer(kind=1), dimension(2) :: i + if (i(1) /= -1) STOP 12 + if (i(2) /= -3) STOP 13 + i(1) = 3 + i(2) = 2 +end subroutine sub_i1 + +subroutine sub_i2(i) + integer(kind=2), dimension(2) :: i + if (i(1) /= -1) STOP 14 + if (i(2) /= -3) STOP 15 + i(1) = 3 + i(2) = 2 +end subroutine sub_i2 + +subroutine sub_i4(i) + integer(kind=4), dimension(2) :: i + if (i(1) /= -1) STOP 16 + if (i(2) /= -3) STOP 17 + i(1) = 3 + i(2) = 2 +end subroutine sub_i4 + +subroutine sub_i8(i) + integer(kind=8), dimension(2) :: i + if (i(1) /= -1) STOP 18 + if (i(2) /= -3) STOP 19 + i(1) = 3 + i(2) = 2 +end subroutine sub_i8 + +subroutine sub_r4(r) + real(kind=4), dimension(2) :: r + if (r(1) /= -1.) STOP 20 + if (r(2) /= -3.) STOP 21 + r(1) = 3. + r(2) = 2. +end subroutine sub_r4 + +subroutine sub_r8(r) + real(kind=8), dimension(2) :: r + if (r(1) /= -1._8) STOP 22 + if (r(2) /= -3._8) STOP 23 + r(1) = 3._8 + r(2) = 2._8 +end subroutine sub_r8 + +subroutine sub_c8(r) + implicit none + complex(kind=8), dimension(2) :: r + if (r(1) /= (-1._8,0._8)) STOP 24 + if (r(2) /= (-3._8,0._8)) STOP 25 + r(1) = 3._8 + r(2) = 2._8 +end subroutine sub_c8 + +subroutine sub_c4(r) + implicit none + complex(kind=4), dimension(2) :: r + if (r(1) /= (-1._4,0._4)) STOP 26 + if (r(2) /= (-3._4,0._4)) STOP 27 + r(1) = 3._4 + r(2) = 2._4 +end subroutine sub_c4 + +subroutine sub_d_i8(i) + type i8_t + sequence + integer(kind=8) :: v + end type i8_t + type(i8_t), dimension(2) :: i + if (i(1)%v /= -1) STOP 28 + if (i(2)%v /= -3) STOP 29 + i(1)%v = 3 + i(2)%v = 2 +end subroutine sub_d_i8 Index: Fortran/gfortran/regression/internal_pack_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_10.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Test the fix for PR43180, in which patch which reduced the use of +! internal_pack/unpack messed up the passing of ru(1)%c as the actual +! argument at line 23 in this testcase. +! +! Contributed by Harald Anlauf +! further reduced by Tobias Burnus +! +module mo_obs_rules + type t_set + integer :: use = 42 + end type t_set + type t_rules + character(len=40) :: comment + type(t_set) :: c (1) + end type t_rules + type (t_rules), save :: ru (1) +contains + subroutine get_rule (c) + type(t_set) :: c (:) + ru(1)%c(:)%use = 99 + if (any (c(:)%use .ne. 42)) STOP 1 + call set_set_v (ru(1)%c, c) + if (any (c(:)%use .ne. 99)) STOP 2 + contains + subroutine set_set_v (src, dst) + type(t_set), intent(in) :: src(1) + type(t_set), intent(inout) :: dst(1) + if (any (src%use .ne. 99)) STOP 3 + if (any (dst%use .ne. 42)) STOP 4 + dst = src + end subroutine set_set_v + end subroutine get_rule +end module mo_obs_rules + +program test + use mo_obs_rules + type(t_set) :: c (1) + call get_rule (c) +end program test Index: Fortran/gfortran/regression/internal_pack_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_11.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! Test the fix for PR43173, where unnecessary calls to internal_pack/unpack +! were being produced below. These references are contiguous and so do not +! need a temporary. +! +! Contributed Tobias Burnus +! + REAL, allocatable :: ot(:) + integer :: time_steps + + call foo (ot) ! OK, no temporary + call foo (ot(0:5:1)) ! Was an unnecessary temporary + call foo (ot(0:time_steps)) ! Was an unnecessary temporary + end +! { dg-final { scan-tree-dump-times "unpack" 0 "original" } } Index: Fortran/gfortran/regression/internal_pack_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_12.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! Test the fix for PR43243, where unnecessary calls to internal_pack/unpack +! were being produced below. These references are contiguous and so do not +! need a temporary. In addition, the final call to 'bar' required a pack/unpack +! which had been missing since r156680, at least. +! +! Contributed Tobias Burnus +! +module m + type t + integer, allocatable :: a(:) + integer, pointer :: b(:) + integer :: c(5) + end type t +end module m + +subroutine foo(a,d,e,n) + use m + implicit none + integer :: n + type(t) :: a + type(t), allocatable :: d(:) + type(t), pointer :: e(:) + call bar( a%a) ! OK - no array temp needed + call bar( a%c) ! OK - no array temp needed + + call bar( a%a(1:n)) ! Missed: No pack needed + call bar( a%b(1:n)) ! OK: pack needed + call bar( a%c(1:n)) ! Missed: No pack needed + + call bar(d(1)%a(1:n)) ! Missed: No pack needed + call bar(d(1)%b(1:n)) ! OK: pack needed + call bar(d(1)%c(1:n)) ! Missed: No pack needed + + call bar(e(1)%a(1:n)) ! Missed: No pack needed + call bar(e(1)%b(1:n)) ! OK: pack needed + call bar(e(1)%c(1:n)) ! Missed: No pack needed +end subroutine foo + +use m +implicit none +integer :: i +integer, target :: z(6) +type(t) :: y + +z = [(i, i=1,6)] +y%b => z(::2) +call bar(y%b) ! Missed: Pack needed +end + +subroutine bar(x) + integer :: x(1:*) + print *, x(1:3) + if (any (x(1:3) /= [1,3,5])) STOP 1 +end subroutine bar +! { dg-final { scan-tree-dump-times "unpack" 4 "original" } } Index: Fortran/gfortran/regression/internal_pack_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_13.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type +! +! Contributed by Tobias Burnus + +implicit none +type t +integer :: i +end type t +type(t), target :: tgt(4,4) +type(t), pointer :: p(:,:) +integer :: i,j,k + +k = 1 +do i = 1, 4 + do j = 1, 4 + tgt(i,j)%i = k + k = k+1 + end do +end do + +p => tgt(::2,::2) +print *,p%i +call bar(p) + +contains + + subroutine bar(x) + type(t) :: x(*) + print *,x(1:4)%i + if (any (x(1:4)%i /= [1, 9, 3, 11])) STOP 1 + end subroutine +end Index: Fortran/gfortran/regression/internal_pack_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_14.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 55072: [4.6/4.7/4.8 Regression] Missing internal_pack leads to wrong code with derived type +! +! Contributed by Janus Weil + +program GiBUU_neutrino_bug + + Type particle + integer :: ID + End Type + + type(particle), dimension(1:2,1:2) :: OutPart + + OutPart(1,:)%ID = 1 + OutPart(2,:)%ID = 2 + + call s1(OutPart(1,:)) + +contains + + subroutine s1(j) + type(particle) :: j(:) + print *,j(:)%ID + call s2(j) + end subroutine + + subroutine s2(k) + type(particle) :: k(1:2) + print *,k(:)%ID + if (any (k(1:2)%ID /= [1, 1])) STOP 1 + end subroutine + +end Index: Fortran/gfortran/regression/internal_pack_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_15.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! PR 57023 +! This used to cause wrong packing because a(1:n,1:n) was +! assumed to be a full array. +module mymod + implicit none +contains + subroutine foo1(a,n) + integer, dimension(n,n), intent(inout) :: a + integer :: n + n = n - 1 + call baz(a(1:n,1:n),n) ! { dg-warning "array temporary" } + end subroutine foo1 + + subroutine foo2(a,n) + integer, dimension(n,n), intent(inout) :: a + integer :: n + call decrement(n) + call baz(a(1:n,1:n),n) ! { dg-warning "array temporary" } + end subroutine foo2 + + subroutine foo3(a,n) + integer, dimension(n,n), intent(inout) :: a + integer :: n, m + m = n - 1 + call baz(a(1:m,1:m),m) ! { dg-warning "array temporary" } + end subroutine foo3 + + subroutine foo4(a,n) + integer, dimension(n,n), intent(inout) :: a + integer, intent(in) :: n + a(1:n,1:n) = 1 + end subroutine foo4 + + subroutine baz(a,n) + integer, dimension(n,n), intent(inout) :: a + integer, intent(in) :: n + a = 1 + end subroutine baz + + subroutine decrement(n) + integer, intent(inout) :: n + n = n - 1 + end subroutine decrement + +end module mymod + +program main + use mymod + implicit none + integer, dimension(5,5) :: a, b + integer :: n + + b = 0 + b(1:4,1:4) = 1 + + n = 5 + a = 0 + call foo1(a,n) + if (any(a /= b)) STOP 1 + + n = 5 + a = 0 + call foo2(a,n) + if (any(a /= b)) STOP 2 + + n = 5 + a = 0 + call foo3(a,n) + if (any(a /= b)) STOP 3 + + n = 5 + a = 0 + call foo4(a,n) + if (any(a /= 1)) STOP 4 +end program main Index: Fortran/gfortran/regression/internal_pack_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_16.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-additional-options "-O0 -fdump-tree-original" } +! PR 59345 - pack/unpack was not needed here. +SUBROUTINE S1(A) + REAL :: A(3) + CALL S2(-A) +END SUBROUTINE +! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/internal_pack_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_17.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-O0 -fdump-tree-original" } +! PR 59345 - pack/unpack was not needed here. +! Original test case by Joost VandeVondele +SUBROUTINE S1(A) + INTERFACE + FUNCTION CONTIGUOUS_F1() RESULT(res) + INTEGER :: res(5) + END FUNCTION + END INTERFACE + CALL S2(CONTIGUOUS_F1()) +END SUBROUTINE + +SUBROUTINE S3(A) + INTERFACE + FUNCTION CONTIGOUOS_F2() RESULT(res) + INTEGER, ALLOCATABLE :: res(:) + END FUNCTION + END INTERFACE + PROCEDURE(CONTIGOUOS_F2), POINTER :: A + CALL S2(A()) +END SUBROUTINE +! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/internal_pack_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_18.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-O0 -fdump-tree-original" } +! PR 57992 - this was packed/unpacked unnecessarily. +! Original case by Tobias Burnus. +subroutine test + interface + function f2() + integer, pointer, contiguous :: f2(:) + end function f2 + end interface + + call bar(f2()) +end subroutine test +! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/internal_pack_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_19.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Os -fdump-tree-original" } +! Check that internal_pack is called with -Os. +module x + implicit none +contains + subroutine bar(a, n) + integer, intent(in) :: n + integer, intent(in), dimension(n) :: a + print *,a + end subroutine bar +end module x + +program main + use x + implicit none + integer, parameter :: n = 10 + integer, dimension(n) :: a + integer :: i + a = [(i,i=1,n)] + call bar(a(n:1:-1),n) +end program main +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } Index: Fortran/gfortran/regression/internal_pack_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_2.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Test that the internal pack and unpack routines work OK +! for our large real type. + +program main + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(kind=k), dimension(3) :: rk + complex(kind=k), dimension(3) :: ck + + rk = (/ -1.0_k, 1.0_k, -3.0_k /) + call sub_rk(rk(1:3:2)) + if (any(rk /= (/ 3.0_k, 1.0_k, 2.0_k/))) STOP 1 + + ck = (/ (-1.0_k, 0._k), (1.0_k, 0._k), (-3.0_k, 0._k) /) + call sub_ck(ck(1:3:2)) + if (any(real(ck) /= (/ 3.0_k, 1.0_k, 2.0_k/))) STOP 2 + if (any(aimag(ck) /= 0._k)) STOP 3 + +end program main + +subroutine sub_rk(r) + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(kind=k), dimension(2) :: r + if (r(1) /= -1._k) STOP 4 + if (r(2) /= -3._k) STOP 5 + r(1) = 3._k + r(2) = 2._k +end subroutine sub_rk + +subroutine sub_ck(r) + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + complex(kind=k), dimension(2) :: r + if (r(1) /= (-1._k,0._k)) STOP 6 + if (r(2) /= (-3._k,0._k)) STOP 7 + r(1) = 3._k + r(2) = 2._k +end subroutine sub_ck Index: Fortran/gfortran/regression/internal_pack_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_20.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +! Check that internal_pack is not called with -O. +module x + implicit none +contains + subroutine bar(a, n) + integer, intent(in) :: n + integer, intent(in), dimension(n) :: a + print *,a + end subroutine bar +end module x + +program main + use x + implicit none + integer, parameter :: n = 10 + integer, dimension(n) :: a + integer :: i + a = [(i,i=1,n)] + call bar(a(n:1:-1),n) +end program main +! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } } Index: Fortran/gfortran/regression/internal_pack_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_21.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! Test handling of the optional argument. + +MODULE M1 + INTEGER, PARAMETER :: dp=KIND(0.0D0) +CONTAINS + SUBROUTINE S1(a) + REAL(dp), DIMENSION(45), INTENT(OUT), & + OPTIONAL :: a + if (present(a)) STOP 1 + END SUBROUTINE S1 + SUBROUTINE S2(a) + REAL(dp), DIMENSION(:, :), INTENT(OUT), & + OPTIONAL :: a + CALL S1(a) + END SUBROUTINE +END MODULE M1 + +USE M1 +CALL S2() +END +! { dg-final { scan-tree-dump-times "arg_ptr" 5 "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/internal_pack_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_22.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original -O" } +! Check that absent and present dummy arguments work with +! packing when handing them down to an old-fashioned argument. + +module x + implicit none +contains + subroutine foo (a,b) + real, dimension(:), intent(inout), optional :: a, b + if (present(a)) stop 1 + if (.not. present(b)) stop 2 + call bar (a, b) + end subroutine foo + + subroutine bar (a,b) + real, dimension(2), intent(inout), optional :: a, b + real :: tmp + if (present(a)) stop 3 + if (.not. present(b)) stop 4 + tmp = b(2) + b(2) = b(1) + b(1) = tmp + end subroutine bar +end module x + +program main + use x + implicit none + real, dimension(2) :: b + b(1) = 1. + b(2) = 42. + call foo(b=b) + if (b(1) /= 42. .or. b(2) /= 1.) stop 5 +end program main +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/internal_pack_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_23.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR fortran/90539 - this used to cause an ICE. + +module t2 + implicit none +contains + subroutine foo(a) + real, dimension(*) :: a + if (a(1) /= 1.0 .or. a(2) /= 2.0) stop 1 + end subroutine foo +end module t2 + +module t1 + use t2 + implicit none +contains + subroutine bar(a) + real, dimension(:) :: a + if (a(1) /= 1.0 .or. a(2) /= 2.0) stop 1 + call foo(a) + end subroutine bar +end module t1 + +program main + use t1 + call bar([1.0, 2.0]) +end program main Index: Fortran/gfortran/regression/internal_pack_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_24.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-additional-options "-O -fdump-tree-optimized" } +module y + implicit none +contains + subroutine foo(a,b,c,d,e,f) + real, dimension(1), intent(inout) :: a, b, c, d, e, f + if (any([a,b,c,d,e,f] /= [1,2,3,4,5,6])) stop 1 + a = -a + b = -b + c = -c + d = -d + e = -e + f = -f + end subroutine foo +end module y +module x + use y + implicit none +contains + subroutine bar(a) + real, dimension(:) :: a + integer :: n1, n3, n5 + n1 = 1 + n3 = 3 + n5 = 5 + call foo(a(n1:n1), a(n1+1:n1+1), a(n3:n3), a(n3+1:n3+1), a(n5:n5), a(n5+1:n5+1)) + end subroutine bar +end module x + +program main + use x + real, dimension(6) :: a,b + b = [1,2,3,4,5,6] + a = b + call bar(a) + if (any(a /= -b)) stop 2 +end program main +! { dg-final { scan-tree-dump-not "contiguous" "optimized" } } Index: Fortran/gfortran/regression/internal_pack_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_25.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fno-inline-arg-packing -O -fdump-tree-original" } +! PR fortran/92738, middle-end/91512 +! Check that -fno-inline-pack does indeed suppress inline packing. +module x + implicit none +contains + subroutine foo(x) + real, dimension(:), intent(inout) :: x + call bar (x, size(x)) + end subroutine foo + subroutine bar (x, n) + integer, intent(in) :: n + real, dimension(n) :: x + x = -x + end subroutine bar +end module x +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 1 "original" } } Index: Fortran/gfortran/regression/internal_pack_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Test that the internal pack and unpack routines work OK +! for our large integer type. + +program main + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + integer(kind=k), dimension(3) :: ik + + ik = (/ -1, 1, -3 /) + call sub_ik(ik(1:3:2)) + if (any(ik /= (/ 3, 1, 2 /))) STOP 1 +end program main + +subroutine sub_ik(i) + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + integer(kind=k), dimension(2) :: i + if (i(1) /= -1) STOP 2 + if (i(2) /= -3) STOP 3 + i(1) = 3 + i(2) = 2 +end subroutine sub_ik Index: Fortran/gfortran/regression/internal_pack_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_4.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/36132 +! +! Before invalid memory was accessed because an absent, optional +! argument was packed before passing it as absent actual. +! Getting it to crash is difficult, but valgrind shows the problem. +! +MODULE M1 + INTEGER, PARAMETER :: dp=KIND(0.0D0) +CONTAINS + SUBROUTINE S1(a) + REAL(dp), DIMENSION(45), INTENT(OUT), & + OPTIONAL :: a + if (present(a)) STOP 1 + END SUBROUTINE S1 + SUBROUTINE S2(a) + REAL(dp), DIMENSION(:, :), INTENT(OUT), & + OPTIONAL :: a + CALL S1(a) + END SUBROUTINE +END MODULE M1 + +USE M1 +CALL S2() +END Index: Fortran/gfortran/regression/internal_pack_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_5.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/36909 +! +! Check that no unneeded internal_unpack is +! called (INTENT(IN)!). +! +program test + implicit none + integer :: a(3,3) + call foo(a(1,:)) +contains + subroutine foo(x) + integer,intent(in) :: x(3) + end subroutine foo +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 0 "original" } } Index: Fortran/gfortran/regression/internal_pack_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_6.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! Test the fix for PR41113 and PR41117, in which unnecessary calls +! to internal_pack and internal_unpack were being generated. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + TYPE T1 + REAL :: data(10) = [(i, i = 1, 10)] + END TYPE T1 +CONTAINS + SUBROUTINE S1(data, i, chksum) + REAL, DIMENSION(*) :: data + integer :: i, j + real :: subsum, chksum + subsum = 0 + do j = 1, i + subsum = subsum + data(j) + end do + if (abs(subsum - chksum) > 1e-6) STOP 1 + END SUBROUTINE S1 +END MODULE + +SUBROUTINE S2 + use m1 + TYPE(T1) :: d + + real :: data1(10) = [(i, i = 1, 10)] + REAL :: data(-4:5,-4:5) = reshape ([(real(i), i = 1, 100)], [10,10]) + +! PR41113 + CALL S1(d%data, 10, sum (d%data)) + CALL S1(data1, 10, sum (data1)) + +! PR41117 + DO i=-4,5 + CALL S1(data(:,i), 10, sum (data(:,i))) + ENDDO + +! With the fix for PR41113/7 this is the only time that _internal_pack +! was called. The final part of the fix for PR43072 put paid to it too. + DO i=-4,5 + CALL S1(data(-2:,i), 8, sum (data(-2:,i))) + ENDDO + DO i=-4,4 + CALL S1(data(:,i:i+1), 20, sum (reshape (data(:,i:i+1), [20]))) + ENDDO + DO i=-4,5 + CALL S1(data(2,i), 1, data(2,i)) + ENDDO +END SUBROUTINE S2 + + call s2 +end +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 0 "original" } } Index: Fortran/gfortran/regression/internal_pack_6a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_6a.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! Test the fix for PR41113 and PR41117, in which unnecessary calls +! to internal_pack and internal_unpack were being generated. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + TYPE T1 + REAL :: data(10) = [(i, i = 1, 10)] + END TYPE T1 +CONTAINS + SUBROUTINE S1(data, i, chksum) + REAL, DIMENSION(*) :: data + integer :: i, j + real :: subsum, chksum + subsum = 0 + do j = 1, i + subsum = subsum + data(j) + end do + if (abs(subsum - chksum) > 1e-6) STOP 1 + END SUBROUTINE S1 +END MODULE + +SUBROUTINE S2 + use m1 + TYPE(T1) :: d + + real :: data1(10) = [(i, i = 1, 10)] + REAL :: data(-4:5,-4:5) = reshape ([(real(i), i = 1, 100)], [10,10]) + +! PR41113 + CALL S1(d%data, 10, sum (d%data)) + CALL S1(data1, 10, sum (data1)) + +! PR41117 + DO i=-4,5 + CALL S1(data(:,i), 10, sum (data(:,i))) + ENDDO + +! With the fix for PR41113/7 this is the only time that _internal_pack +! was called. The final part of the fix for PR43072 put paid to it too. + DO i=-4,5 + CALL S1(data(-2:,i), 8, sum (data(-2:,i))) + ENDDO + DO i=-4,4 + CALL S1(data(:,i:i+1), 20, sum (reshape (data(:,i:i+1), [20]))) + ENDDO + DO i=-4,5 + CALL S1(data(2,i), 1, data(2,i)) + ENDDO +END SUBROUTINE S2 + + call s2 +end + Index: Fortran/gfortran/regression/internal_pack_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_7.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! { dg-require-visibility "" } +! +! Test the fix for PR43072, in which unnecessary calls to +! internal PACK/UNPACK were being generated. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + PRIVATE + REAL, PARAMETER :: c(2)=(/(i,i=1,2)/) +CONTAINS + ! WAS OK + SUBROUTINE S0 + real :: r + r=0 + r=S2(c) + r=S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR + END SUBROUTINE S0 + ! WAS NOT OK + SUBROUTINE S1 + real :: r + r=0 + r=r+S2(c) + r=r+S2((/(real(i),i=1,2)/)) ! See comment #1 of the PR + END SUBROUTINE S1 + + FUNCTION S2(c) + REAL, INTENT(IN) :: c(2) + s2=0 + END FUNCTION S2 +END MODULE M1 +! { dg-final { scan-tree-dump-times "pack" 0 "original" } } Index: Fortran/gfortran/regression/internal_pack_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_8.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Test the fix for PR43111, in which necessary calls to +! internal PACK/UNPACK were not being generated because +! of an over agressive fix to PR41113/7. +! +! Contributed by Joost VandeVondele +! +SUBROUTINE S2(I) + INTEGER :: I(4) + !write(6,*) I + IF (ANY(I.NE.(/3,5,7,9/))) STOP 1 +END SUBROUTINE S2 + +MODULE M1 + TYPE T1 + INTEGER, POINTER, DIMENSION(:) :: data + END TYPE T1 +CONTAINS + SUBROUTINE S1() + TYPE(T1) :: d + INTEGER, TARGET, DIMENSION(10) :: scratch=(/(i,i=1,10)/) + INTEGER :: i=2 + d%data=>scratch(1:9:2) +! write(6,*) d%data(i:) + CALL S2(d%data(i:)) + END SUBROUTINE S1 +END MODULE M1 + +USE M1 +CALL S1 +END Index: Fortran/gfortran/regression/internal_pack_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_pack_9.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! During the discussion of the fix for PR43072, in which unnecessary +! calls to internal PACK/UNPACK were being generated, the following, +! further unnecessary temporaries or PACk/UNPACK were found. +! +! Contributed by Tobias Burnus +! +! Case 1: Substring encompassing the whole string +subroutine foo2 + implicit none + external foo_char + character(len=20) :: str(2) = '1234567890' + call foo_char (str(:)(1:20)) ! This is still not fixed. +end + +! Case 2: Contiguous array section +subroutine bar + implicit none + external foo + integer :: a(3,3,3) + call foo(a(:,:,:)) ! OK, no temporary + call foo(a(:,:,1)) ! OK, no temporary + call foo(a(:,2,2)) ! Used unnecessarily a temporary -FIXED + call foo(a(2,:,1)) ! OK, creates a temporary(1) +end + +! Case 3: Stride 1 section. +subroutine foobar + implicit none + external foo + integer :: A(10,10) + call foo(A(3:7,4)) ! Used unnecessarily a temporary - FIXED + call foo(A(:,3:7)) ! OK (no temporary) + call foo(A(1:10,3:7)) ! OK (no temporary) + call foo(A(4,3:7)) ! temporary OK(2) + call foo(A(:,3:7:-1)) ! temporary(3) OK because of stride +end +! { dg-final { scan-tree-dump-times "unpack" 3 "original" } } Index: Fortran/gfortran/regression/internal_readwrite_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_readwrite_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR 34565 - internal writes with negative strides +! didn't work. +program main + implicit none + integer :: i + integer :: lo, up, st + character(len=2) :: c (5) + integer, dimension(5) :: n + c = (/ 'a', 'b', 'c', 'd', 'e' /) + write (unit=c(5:1:-2),fmt="(A)") '5','3', '1' + write (unit=c(2:4:2),fmt="(A)") '2', '4' + read (c(5:1:-1),fmt="(I2)") (n(i), i=5,1,-1) + if (any(n /= (/ (i,i=1,5) /))) STOP 1 +end program main Index: Fortran/gfortran/regression/internal_readwrite_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_readwrite_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 34565 - intenal writes with negative strides. This +! test case tries out a negative stride in a higher +! dimension. +program main + implicit none + integer :: i + integer, parameter :: n1=2, n2=3, n3=5 + character(len=n1*n2*n3*2) :: line + character(len=2), dimension(n1,n2,n3):: c + write (unit=c(:,n2:1:-1,:),fmt="(I2)") (i,i=1,n1*n2*n3) + line = transfer(c,mold=line) + if (line /=" 5 6 3 4 1 21112 910 7 8171815161314232421221920293027282526") STOP 1 +end program main Index: Fortran/gfortran/regression/internal_readwrite_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_readwrite_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 52724 - this used to generate a "Bad integer" error. +program main + implicit none + integer :: i + character(len=100,kind=4) :: buffer, a + buffer = 4_"123" + read(buffer,*) i + write (a,'(I3)') i + if (a /= 4_"123") STOP 1 +end program main Index: Fortran/gfortran/regression/internal_readwrite_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_readwrite_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR 83436 - this used to cause an error. +! Original test case by Daan van Vugt. +module mod_random_seed + implicit none +contains + !> Read an int from /dev/urandom + subroutine read_urandom_int(seed, ierr) + implicit none + integer, intent(out) :: seed + integer, intent(out) :: ierr + integer :: un + character(len=80) :: restart_file + write(restart_file,'(A,A)') 'jorek', '_restart.h5' + + open(newunit=un, file="/dev/urandom", access="stream", & + form="unformatted", action="read", status="old", iostat=ierr) + if (ierr == 0) then + read(un) seed + close(un) + end if + end subroutine read_urandom_int +end module mod_random_seed + +program test_random_seed + use mod_random_seed + implicit none + integer :: seed, ierr + call read_urandom_int(seed, ierr) +end program test_random_seed Index: Fortran/gfortran/regression/internal_references_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_references_1.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! This tests the patch for PRs 24327, 25024 & 25625, which +! are all connected with references to internal procedures. +! This is a composite of the PR testcases; and each is +! labelled by PR. +! +! Contributed by Paul Thomas +! +! PR25625 - would neglect to point out that there were 2 subroutines p. +module m + implicit none +contains + + subroutine p (i) ! { dg-error "(1)" } + integer :: i + end subroutine + + subroutine p (i) ! { dg-error "is already defined" } + integer :: i ! { dg-error "Unexpected data declaration statement in CONTAINS section" } + end subroutine ! { dg-error "Expecting END MODULE statement" } +end module +! +! PR25124 - would happily ignore the declaration of foo in the main program. +program test +real :: foo, x +x = bar () ! This is OK because it is a regular reference. +x = foo () +contains + function foo () ! { dg-error "explicit interface from a previous" } + foo = 1.0 ! { dg-error "Unexpected assignment statement in CONTAINS section" } + end function foo ! { dg-error "Expecting END PROGRAM statement" } + function bar () + bar = 1.0 + end function bar +end program test + Index: Fortran/gfortran/regression/internal_references_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_references_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! This tests the fix for the regression caused by the internal references +! patc, which is tested by internal_references_1.f90. Reported as PR25901. +! +! Based on test cases provided by Toon Moene +! and by Martin Reinecke +module aap + interface s + module procedure sub,sub1 + end interface +contains + subroutine sub1(i) + integer i + real a + call sub(a) ! For the original test, this "defined" the procedure. + end subroutine sub1 + subroutine sub(a) ! Would give an error on "already defined" here + real a + end subroutine sub +end module aap Index: Fortran/gfortran/regression/internal_write_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/internal_write_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-shouldfail "End of file" } +program main + character(len=20) :: line + integer, dimension(4) :: n + n = 1 + write(line,'(2I2)') n +end program main +! { dg-output "Fortran runtime error: End of file" } Index: Fortran/gfortran/regression/interop_params.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/interop_params.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +module interop_params +use, intrinsic :: iso_c_binding + +type my_f90_type + integer :: i + real :: x +end type my_f90_type + +contains + subroutine test_0(my_f90_int) bind(c) ! { dg-warning "may not be C interoperable" } + use, intrinsic :: iso_c_binding + integer, value :: my_f90_int + end subroutine test_0 + + subroutine test_1(my_f90_real) bind(c) + real(c_int), value :: my_f90_real ! { dg-warning "is for type INTEGER" } + end subroutine test_1 + + subroutine test_2(my_type) bind(c) ! { dg-error "is not C interoperable" } + use, intrinsic :: iso_c_binding + type(my_f90_type) :: my_type + end subroutine test_2 +end module interop_params Index: Fortran/gfortran/regression/intrinsic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-c -Wall" } +! +! PR fortran/20373 +! cf. also PR fortran/40041 + +subroutine valid + intrinsic :: abs ! ok, intrinsic function + intrinsic :: cpu_time ! ok, intrinsic subroutine +end subroutine + +subroutine warnings + ! the follow three are ok in general, but ANY + ! type is ignored, even the correct one + real, intrinsic :: sin ! { dg-warning "is ignored" } + + real :: asin ! { dg-warning "is ignored" } + intrinsic :: asin + + intrinsic :: tan ! { dg-warning "is ignored" } + real :: tan + + ! wrong types here + integer, intrinsic :: cos ! { dg-warning "is ignored" } + + integer :: acos ! { dg-warning "is ignored" } + intrinsic :: acos + + ! ordering shall not matter + intrinsic :: atan ! { dg-warning "is ignored" } + integer :: atan +end subroutine + +subroutine errors + intrinsic :: foo ! { dg-error "does not exist" } + real, intrinsic :: bar ! { dg-error "does not exist" } + + real, intrinsic :: mvbits ! { dg-error "shall not have a type" } +end subroutine Index: Fortran/gfortran/regression/intrinsic_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 39861/39864 +! +! Test cases provided by Dominique d'Humieres +! and Michael Richmond . + +module vector_calculus + intrinsic :: dot_product, sqrt + +contains + + function len(r) + real, dimension(:), intent(in) :: r + real :: len + len = sqrt(dot_product(r,r)) + end function len + + FUNCTION next_state() + INTRINSIC :: RESHAPE + INTEGER, PARAMETER :: trantb(1,1) = RESHAPE((/1,2/), shape=(/1,1/)) + next_state = trantb(1, 1) + END FUNCTION next_state + +end module vector_calculus Index: Fortran/gfortran/regression/intrinsic_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-c -Wall" } +! +! PR fortran/40041 +! cf. also PR fortran/20373 + +subroutine valid_one + REAL :: a + INTEGER :: n + INTRINSIC ABS, MAX + a(n) = MAX(ABS(2),ABS(3),n) +end subroutine + +subroutine valid_two + IMPLICIT NONE + REAL :: a + INTEGER :: n + INTRINSIC ABS, MAX + a(n) = MAX(ABS(2),ABS(3),n) +end subroutine + +subroutine warnings_one + REAL :: a + INTEGER :: n + REAL :: ABS ! { dg-warning "Type specified for intrinsic function" } + REAL :: MAX ! { dg-warning "Type specified for intrinsic function" } + INTRINSIC ABS, MAX + a(n) = MAX(ABS(2),ABS(3),n) +end subroutine + +subroutine warnings_two + IMPLICIT NONE + REAL :: a + INTEGER :: n + INTRINSIC ABS ! { dg-warning "Type specified for intrinsic function" } + INTRINSIC MAX ! { dg-warning "Type specified for intrinsic function" } + REAL :: ABS + REAL :: MAX + a(n) = MAX(ABS(2),ABS(3),n) +end subroutine Index: Fortran/gfortran/regression/intrinsic_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_3.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR 39876: module procedure name that collides with the GNU intrinsic +! +! Contributed by Alexei Matveev + +module p + implicit none + + contains + + subroutine test() + implicit none + print *, avg(erfc) + end subroutine test + + function avg(f) + implicit none + double precision :: avg + interface + double precision function f(x) + implicit none + double precision, intent(in) :: x + end function f + end interface + avg = ( f(1.0D0) + f(2.0D0) ) / 2 + end function avg + + function erfc(x) + implicit none + double precision, intent(in) :: x + double precision :: erfc + erfc = x + end function erfc + +end module p Index: Fortran/gfortran/regression/intrinsic_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR 40995: [4.5 Regression] Spurious "Type specified for intrinsic function...ignored" message +! +! Contributed by Mat Cross + +subroutine sub(n,x) + intrinsic abs + integer n, x(abs(n)) +end + Index: Fortran/gfortran/regression/intrinsic_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fimplicit-none" } +! +! PR 41121: [4.5 Regression] compile-time error when building BLAS with -fimplicit-none +! +! Original test case: http://www.netlib.org/blas/dgbmv.f +! Reduced by Joost VandeVondele + + INTRINSIC MIN + INTEGER :: I,J + print *,MIN(I,J) +END + Index: Fortran/gfortran/regression/intrinsic_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fimplicit-none" } +! +! PR 45748: [4.5/4.6 Regression] -fimplicit-none failures when using intrinsic MAX +! +! Contributed by Themos Tsikas + +SUBROUTINE BUG(WORK) + INTRINSIC MAX + DOUBLE PRECISION WORK(MAX(2,3)) +END Index: Fortran/gfortran/regression/intrinsic_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_7.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/46411 +! +! MOVE_ALLOC and other non-elemental but pure +! procedures where regarded as impure. +! + +pure subroutine test() + integer, allocatable :: a, b + allocate(a,b) + call move_alloc(a,b) +end subroutine test Index: Fortran/gfortran/regression/intrinsic_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_8.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/52452 +! +! Contributed by Roger Ferrer Ibanez +! +PROGRAM test_etime + IMPLICIT NONE + INTRINSIC :: etime + REAL(4) :: tarray(1:2) + REAL(4) :: result + + CALL etime(tarray, result) +END PROGRAM test_etime + +subroutine test_etime2 + IMPLICIT NONE + INTRINSIC :: etime + REAL(4) :: tarray(1:2) + REAL(4) :: result + + result = etime(tarray) +END subroutine test_etime2 Index: Fortran/gfortran/regression/intrinsic_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_9.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! PR fortran/92754 +! +! Contributed by G. Steinmetz +! + +program p + integer :: max + block + character :: x = max('a','b') + !print *, x + if (x /= 'b') stop 1 + end block +end Index: Fortran/gfortran/regression/intrinsic_actual_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_actual_1.f @@ -0,0 +1,49 @@ +! { dg-do compile } +! Tests the fix for PR27554, where the actual argument reference +! to abs would not be recognised as being to an intrinsic +! procedure and would produce junk in the assembler. +! +! Contributed by Francois-Xavier Coudert +! + subroutine foo (proc, z) + external proc + real proc, z + if ((proc(z) .ne. abs (z)) .and. + & (proc(z) .ne. alog10 (abs(z)))) STOP 1 + return + end + + external cos + interface + function sin (a) + real a, sin + end function sin + end interface + + + intrinsic alog10 + real x + x = 100. +! The reference here would prevent the actual arg from being seen +! as an intrinsic procedure in the call to foo. + x = -abs(x) + call foo(abs, x) +! The intrinsic function can be locally over-ridden by an interface + call foo(sin, x) +! or an external declaration. + call foo(cos, x) +! Just make sure with another intrinsic but this time not referenced. + call foo(alog10, -x) + end + + function sin (a) + real a, sin + sin = -a + return + end + + function cos (a) + real a, cos + cos = -a + return + end Index: Fortran/gfortran/regression/intrinsic_actual_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_actual_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Tests the fix for PR29387, in which array valued arguments of +! LEN and ASSOCIATED would cause an ICE. +! +! Contributed by Francois-Xavier Coudert +! + integer :: ans + TYPE T1 + INTEGER, POINTER :: I=>NULL() + END TYPE T1 + type(T1), pointer :: tar(:) + + character(20) res + + j = 10 + PRINT *, LEN(SUB(8)), ans + PRINT *, LEN(SUB(j)), ans +! print *, len(SUB(j + 2)//"a"), ans ! This still fails (no charlen). + print *, len(bar(2)), ans + + IF(.NOT.ASSOCIATED(F1(10))) STOP 1 + deallocate (tar) + +CONTAINS + + FUNCTION SUB(I) + CHARACTER(LEN=I) :: SUB(1) + ans = LEN(SUB(1)) + SUB = "" + END FUNCTION + + FUNCTION BAR(I) + CHARACTER(LEN=I*10) :: BAR(1) + ans = LEN(BAR) + BAR = "" + END FUNCTION + + FUNCTION F1(I) RESULT(R) + TYPE(T1), DIMENSION(:), POINTER :: R + INTEGER :: I + ALLOCATE(tar(I)) + R => tar + END FUNCTION F1 +END Index: Fortran/gfortran/regression/intrinsic_actual_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_actual_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Tests the fix for PR30237 in which alternate returns in intrinsic +! actual arglists were quietly ignored. +! +! Contributed by Brooks Moses +! +program ar1 + interface random_seed + subroutine x (a, *) + integer a + end subroutine x + end interface random_seed + + real t1(2) + call cpu_time(*20) ! { dg-error "not permitted" } + call cpu_time(*20, t1(1)) ! { dg-error "Too many arguments" } +! This specific version is permitted by the generic interface. + call random_seed(i, *20) +! The new error gets overwritten but the diagnostic is clear enough. + call random_seed(i, *20, *30) ! { dg-error "not consistent" } + stop +20 write(*,*) t1 +30 stop +end Index: Fortran/gfortran/regression/intrinsic_actual_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_actual_4.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Tests the fix for PR27900, in which an ICE would be caused because +! the actual argument LEN had no type. +! +! Contributed by Klaus Ramst�ck +! + subroutine sub (proc, chr) + external proc + integer proc + character*(*) chr + if (proc (chr) .ne. 6) STOP 1 + end subroutine sub + + implicit none + integer i + intrinsic len + i = len ("123") + call sub (len, "abcdef") + end Index: Fortran/gfortran/regression/intrinsic_argument_conformance_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_argument_conformance_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +program main + real :: av(2), bv(4) + real :: a(2,2) + logical :: lo(3,2) + print *,dot_product(av, bv) ! { dg-error "Different shape" } + print *,pack(a, lo) ! { dg-error "Different shape" } + print *,merge(av, bv, lo(1,:)) ! { dg-error "Different shape" } + print *,matmul(bv,a) ! { dg-error "Different shape" } +end program main Index: Fortran/gfortran/regression/intrinsic_argument_conformance_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_argument_conformance_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Some CSHIFT, EOSHIFT and UNPACK conformance tests +! +program main + implicit none + real, dimension(1) :: a1, b1, c1 + real, dimension(1,1) :: a2, b2, c2 + real, dimension(1,0) :: a, b, c + real :: tempn(1), tempv(5) + real,allocatable :: foo(:) + allocate(foo(0)) + tempn = 2.0 + + a1 = 0 + a2 = 0 + c1 = 0 + a2 = 0 + + b1 = cshift (a1,1) + b1 = cshift (a1,(/1/)) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,1) + b2 = eoshift (a1,c1(1)) ! { dg-error "must be INTEGER" } + b1 = eoshift (a1,(/1/)) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,1,boundary=c1) ! { dg-error "must be a scalar" } + b1 = eoshift (a1,(/1/), boundary=c2) ! { dg-error "must be a scalar" } + + b2 = cshift (a2,1) + b2 = cshift (a2,(/1/)) + b2 = cshift (a2,reshape([1],[1,1])) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,1) + b2 = eoshift (a2,c1) ! { dg-error "must be INTEGER" } + b2 = eoshift (a2,(/1/)) + b2 = eoshift (a2,reshape([1],[1,1]), boundary=c1) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,1,boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" } + b2 = eoshift (a2,(/1/), boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" } + + b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "invalid shape in dimension" } + + if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) STOP 1 ! { dg-error "must be a scalar" } + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) STOP 2 ! { dg-error "must be a scalar" } + + if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) STOP 3 ! { dg-error "must have identical shape" } + if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) STOP 4 ! { dg-error "must have identical shape" } +end program main Index: Fortran/gfortran/regression/intrinsic_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_bounds_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 54633 - this used to be rejected +program main + integer :: x(minval((/1/),mask=(/.TRUE./))) + integer, parameter :: m = minval((/1/)) + integer :: y(minval((/1/),mask=(/.TRUE./))) +end Index: Fortran/gfortran/regression/intrinsic_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_char_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Tests the fix for PR35932, in which the KIND argument of CHAR +! was not converted and this screwed up the scalarizer. +! +! Contributed by Dick Hendrickson +! +program FA0005 + + CHARACTER(1) CDA1(10) + character(10) CDA10 + INTEGER :: IDA(10) = [(i, i = 97,106)] + + CDA1 = CHAR ( IDA, KIND("A" )) !failed + if (transfer (CDA1, CDA10) /= "abcdefghij") STOP 1 + CDA1 = CHAR ( IDA ) !worked + if (transfer (CDA1, CDA10) /= "abcdefghij") STOP 2 +END Index: Fortran/gfortran/regression/intrinsic_cmplx.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_cmplx.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/40727 +program test + integer, parameter :: sp = kind(1.e0), dp = kind(1.d0) + complex(sp) :: s + complex(dp) :: d + s = cmplx(0.e0, cmplx(0.e0,0.e0)) ! { dg-error "either REAL or INTEGER" } + d = dcmplx(0.d0, cmplx(0.d0,0.d0)) ! { dg-error "either REAL or INTEGER" } +end program test Index: Fortran/gfortran/regression/intrinsic_external_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_external_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/20869 +! Note 12.11 "A name shall not appear in both an EXTERNAL and an +! INTRINSIC statement in the same scoping unit. +program u + intrinsic :: nint + external :: nint ! { dg-error "EXTERNAL attribute conflicts with INTRINSIC attribute" } +end program u Index: Fortran/gfortran/regression/intrinsic_ifunction_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_ifunction_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR 35995 - ifunction.m4 and ifunction_logical.m4 had a bug +! where zero-sized arguments were not handled correctly. +! Test case provided by Dick Hendrickson, amended by +! Thomas Koenig. + + program try_gf0026_etc + + call gf0026( 0, 1) + call foo ( 0, 1) + + end program + + SUBROUTINE GF0026(nf0,nf1) + LOGICAL LDA(9) + INTEGER IDA(NF0,9), iii(9) + + lda = (/ (i/2*2 .eq. I, i=1,9) /) + LDA = ALL ( IDA .NE. -1000, 1) + if (.not. all(lda)) STOP 1 + if (.not. all(ida .ne. -1000)) STOP 2 + + lda = (/ (i/2*2 .eq. I, i=1,9) /) + LDA = any ( IDA .NE. -1000, 1) + print *, lda !expect FALSE + if (any(lda)) STOP 3 + print *, any(ida .ne. -1000) !expect FALSE + if (any(ida .ne. -1000)) STOP 4 + + iii = 137 + iii = count ( IDA .NE. -1000, 1) + if (any(iii /= 0)) STOP 5 + if (count(ida .ne. -1000) /= 0) STOP 6 + + END SUBROUTINE + + subroutine foo (nf0, nf1) + integer, dimension(9):: res, iii + integer, dimension(nf0,9) :: ida + res = (/ (-i, i=1,9) /) + res = product (ida, 1) + if (any(res /= 1)) STOP 7 + end subroutine foo Index: Fortran/gfortran/regression/intrinsic_ifunction_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_ifunction_2.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 48066 - this used to segfault. +program p + real(8) :: empty(0, 3), square(0) + logical :: lempty(0, 3), lsquare(0) + square = sum(empty * empty, 2) + lsquare = any(lempty .and. lempty, 2) +end Index: Fortran/gfortran/regression/intrinsic_intent_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_intent_1.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } + +! PR fortran/45474 +! Definability checks for INTENT([IN]OUT) and intrinsics. + +! Contributed by Tobias Burnus, burnus@gcc.gnu.org. + +call execute_command_line("date", .true.,(1),1,'aa') ! { dg-error "variable definition context" } +call execute_command_line("date", .true.,1,(1),'aa') ! { dg-error "variable definition context" } +call execute_command_line("date", .true.,1,1,('aa')) ! { dg-error "variable definition context" } +end Index: Fortran/gfortran/regression/intrinsic_intkinds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_intkinds_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Test assorted intrinsics for integer kinds 1 and 2 +program main + integer(kind=1), dimension(2,2) :: a + integer(kind=2), dimension(2,2) :: b + integer(kind=1), dimension(2) :: r1 + integer(kind=2), dimension(2) :: r2 + logical, dimension(2,2) :: ma + ma = .false. + a = reshape((/ 1_1, 2_1, 3_1, 4_1/), shape(a)) + b = reshape((/ 1_2, 2_2, 3_2, 4_2/), shape(b)) + if (any(sum(a,dim=2) /= (/ 4, 6 /))) STOP 1 + if (any(sum(b,dim=2) /= (/ 4, 6 /))) STOP 2 + if (any(product(a,dim=2) /= (/ 3, 8 /))) STOP 3 + if (any(product(b,dim=2) /= (/ 3, 8 /))) STOP 4 + if (any(matmul(a,a) /= reshape ( (/ 7, 10, 15, 22 /), shape(a)))) STOP 5 + if (any(matmul(b,b) /= reshape ( (/ 7, 10, 15, 22 /), shape(b)))) STOP 6 + if (any(maxval(a,dim=2,mask=ma) /= -128)) STOP 7 + if (any(maxval(b,dim=2,mask=ma) /= -32768)) STOP 8 +end program main Index: Fortran/gfortran/regression/intrinsic_modulo_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_modulo_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! testcase from PR 19032 adapted for testsuite +! Our implementation of modulo was wrong for P = 1 and P = -1, +! both in the real and the integer case +program main + integer, parameter :: n=16 + real, dimension(n) :: ar, br, modulo_result, floor_result + integer, dimension(n) :: ai, bi , imodulo_result, ifloor_result + + ai(1:4) = 5 + ai(5:8) = -5 + ai(9:12) = 1 + ai(13:16) = -1 + bi(1:4) = (/ 3,-3, 1, -1/) + bi(5:8) = bi(1:4) + bi(9:12) = bi(1:4) + bi(13:16) = bi(1:4) + ar = ai + br = bi + modulo_result = modulo(ar,br) + imodulo_result = modulo(ai,bi) + floor_result = ar-floor(ar/br)*br + ifloor_result = nint(real(ai-floor(real(ai)/real(bi))*bi)) + + do i=1,n + if (modulo_result(i) /= floor_result(i) ) then +! print "(A,4F5.0)" ,"real case failed: ", & +! ar(i),br(i), modulo_result(i), floor_result(i) + STOP 1 + end if + if (imodulo_result(i) /= ifloor_result(i)) then +! print "(A,4I5)", "int case failed: ", & +! ai(i), bi(i), imodulo_result(i), ifloor_result(i) + STOP 2 + end if + end do +end program main Index: Fortran/gfortran/regression/intrinsic_numeric_arg.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_numeric_arg.f @@ -0,0 +1,9 @@ +! this test checks for a non-numeric argument to an +! intrinsic function (of which ABS() is one of many). +! { dg-do compile } + LOGICAL Z + CHARACTER A + REAL R + R = ABS(Z) ! { dg-error " must have a numeric type" } + R = ABS(A) ! { dg-error " must have a numeric type" } + END Index: Fortran/gfortran/regression/intrinsic_optional_char_arg_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_optional_char_arg_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } + +! PR fortran/36403 +! Check that string lengths of optional arguments are added to the library-call +! even if those arguments are missing. + +PROGRAM main + IMPLICIT NONE + + CHARACTER(len=1) :: vect(4) + CHARACTER(len=1) :: matrix(2, 2) + + matrix(1, 1) = "" + matrix(2, 1) = "a" + matrix(1, 2) = "b" + matrix(2, 2) = "" + vect = (/ "w", "x", "y", "z" /) + + ! Call the affected intrinsics + vect = EOSHIFT (vect, 2) + vect = PACK (matrix, matrix /= "") + matrix = RESHAPE (vect, (/ 2, 2 /)) + +END PROGRAM main + +! All library function should be called with *two* trailing arguments "1" for +! the string lengths of both the main array and the optional argument: +! { dg-final { scan-tree-dump "_eoshift\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_reshape\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_pack\[0-9_\]+char \\(\[&a-zA-Z0-9._, \]+, 1, 0\\)" "original" } } Index: Fortran/gfortran/regression/intrinsic_pack_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_1.f90 @@ -0,0 +1,115 @@ +! { dg-do run } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer :: i + real(kind=4), dimension(3,3) :: r4 + real(kind=4), dimension(9) :: vr4 + real(kind=4), dimension(9) :: rr4 + real(kind=8), dimension(3,3) :: r8 + real(kind=8), dimension(9) :: vr8 + real(kind=8), dimension(9) :: rr8 + complex(kind=4), dimension(3,3) :: c4 + complex(kind=4), dimension(9) :: vc4 + complex(kind=4), dimension(9) :: rc4 + complex(kind=8), dimension(3,3) :: c8 + complex(kind=8), dimension(9) :: vc8 + complex(kind=8), dimension(9) :: rc8 + integer(kind=1), dimension(3,3) :: i1 + integer(kind=1), dimension(9) :: vi1 + integer(kind=1), dimension(9) :: ri1 + integer(kind=2), dimension(3,3) :: i2 + integer(kind=2), dimension(9) :: vi2 + integer(kind=2), dimension(9) :: ri2 + integer(kind=4), dimension(3,3) :: i4 + integer(kind=4), dimension(9) :: vi4 + integer(kind=4), dimension(9) :: ri4 + integer(kind=8), dimension(3,3) :: i8 + integer(kind=8), dimension(9) :: vi8 + integer(kind=8), dimension(9) :: ri8 + + type i1_t + integer(kind=1) :: v + end type i1_t + type(i1_t), dimension(3,3) :: d_i1 + type(i1_t), dimension(9) :: d_vi1 + type(i1_t), dimension(9) :: d_ri1 + + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension(3,3) :: d_i4 + type(i4_t), dimension(9) :: d_vi4 + type(i4_t), dimension(9) :: d_ri4 + + d_vi1%v = (/(i+10,i=1,9)/) + d_i1%v = reshape((/1_1, -1_1, 2_1, -2_1, 3_1, -3_1, 4_1, & + & -4_1, 5_1/), shape(i1)) + d_ri1 = pack(d_i1,d_i1%v>0,d_vi1) + if (any(d_ri1%v /= (/1_1, 2_1, 3_1, 4_1, 5_1, 16_1, 17_1, 18_1, 19_1/))) & + & STOP 1 + + d_vi4%v = (/(i+10,i=1,9)/) + d_i4%v = reshape((/1_4, -1_4, 2_4, -2_4, 3_4, -3_4, 4_4, & + & -4_4, 5_4/), shape(d_i4)) + d_ri4 = pack(d_i4,d_i4%v>0,d_vi4) + if (any(d_ri4%v /= (/1_4, 2_4, 3_4, 4_4, 5_4, 16_4, 17_4, 18_4, 19_4/))) & + & STOP 2 + + vr4 = (/(i+10,i=1,9)/) + r4 = reshape((/1.0_4, -3.0_4, 2.1_4, -4.21_4, 1.2_4, 0.98_4, -1.2_4, & + & -7.1_4, -9.9_4, 0.3_4 /), shape(r4)) + rr4 = pack(r4,r4>0,vr4) + if (any(rr4 /= (/ 1.0_4, 2.1_4, 1.2_4, 0.98_4, 15._4, 16._4, 17._4, & + & 18._4, 19._4 /))) STOP 3 + + vr8 = (/(i+10,i=1,9)/) + r8 = reshape((/1.0_8, -3.0_8, 2.1_8, -4.21_8, 1.2_8, 0.98_8, -1.2_8, & + & -7.1_8, -9.9_8, 0.3_8 /), shape(r8)) + rr8 = pack(r8,r8>0,vr8) + if (any(rr8 /= (/ 1.0_8, 2.1_8, 1.2_8, 0.98_8, 15._8, 16._8, 17._8, & + & 18._8, 19._8 /))) STOP 4 + + vc4 = (/(i+10,i=1,9)/) + c4 = reshape((/1.0_4, -3.0_4, 2.1_4, -4.21_4, 1.2_4, 0.98_4, -1.2_4, & + & -7.1_4, -9.9_4, 0.3_4 /), shape(c4)) + rc4 = pack(c4,real(c4)>0,vc4) + if (any(real(rc4) /= (/ 1.0_4, 2.1_4, 1.2_4, 0.98_4, 15._4, 16._4, 17._4, & + & 18._4, 19._4 /))) STOP 5 + if (any(aimag(rc4) /= 0)) STOP 6 + + vc8 = (/(i+10,i=1,9)/) + c8 = reshape((/1.0_4, -3.0_4, 2.1_4, -4.21_4, 1.2_4, 0.98_4, -1.2_4, & + & -7.1_4, -9.9_4, 0.3_4 /), shape(c8)) + rc8 = pack(c8,real(c8)>0,vc8) + if (any(real(rc8) /= (/ 1.0_4, 2.1_4, 1.2_4, 0.98_4, 15._4, 16._4, 17._4, & + & 18._4, 19._4 /))) STOP 7 + if (any(aimag(rc8) /= 0)) STOP 8 + + vi1 = (/(i+10,i=1,9)/) + i1 = reshape((/1_1, -1_1, 2_1, -2_1, 3_1, -3_1, 4_1, -4_1, 5_1/), shape(i1)) + ri1 = pack(i1,i1>0,vi1) + if (any(ri1 /= (/1_1, 2_1, 3_1, 4_1, 5_1, 16_1, 17_1, 18_1, 19_1/))) & + & STOP 9 + + vi2 = (/(i+10,i=1,9)/) + i2 = reshape((/1_2, -1_2, 2_2, -2_2, 3_2, -3_2, 4_2, -4_2, 5_2/), shape(i2)) + ri2 = pack(i2,i2>0,vi2) + if (any(ri2 /= (/1_2, 2_2, 3_2, 4_2, 5_2, 16_2, 17_2, 18_2, 19_2/))) & + & STOP 10 + + vi4 = (/(i+10,i=1,9)/) + i4 = reshape((/1_4, -1_4, 2_4, -2_4, 3_4, -3_4, 4_4, -4_4, 5_4/), shape(i4)) + ri4 = pack(i4,i4>0,vi4) + if (any(ri4 /= (/1_4, 2_4, 3_4, 4_4, 5_4, 16_4, 17_4, 18_4, 19_4/))) & + & STOP 11 + + vi8 = (/(i+10,i=1,9)/) + i8 = reshape((/1_8, -1_8, 2_8, -2_8, 3_8, -3_8, 4_8, -4_8, 5_8/), shape(i8)) + ri8 = pack(i8,i8>0,vi8) + if (any(ri8 /= (/1_8, 2_8, 3_8, 4_8, 5_8, 16_8, 17_8, 18_8, 19_8/))) & + & STOP 12 + + +end program main Index: Fortran/gfortran/regression/intrinsic_pack_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + integer :: i + real(kind=k), dimension(3,3) :: rk + real(kind=k), dimension(9) :: vrk + real(kind=k), dimension(9) :: rrk + complex(kind=k), dimension(3,3) :: ck + complex(kind=k), dimension(9) :: vck + complex(kind=k), dimension(9) :: rck + + vrk = (/(i+10,i=1,9)/) + rk = reshape((/1.0_k, -3.0_k, 2.1_k, -4.21_k, 1.2_k, 0.98_k, -1.2_k, & + & -7.1_k, -9.9_k, 0.3_k /), shape(rk)) + rrk = pack(rk,rk>0,vrk) + if (any(rrk /= (/ 1.0_k, 2.1_k, 1.2_k, 0.98_k, 15._k, 16._k, 17._k, & + & 18._k, 19._k /))) STOP 1 + + vck = (/(i+10,i=1,9)/) + ck = reshape((/1.0_k, -3.0_k, 2.1_k, -4.21_k, 1.2_k, 0.98_k, -1.2_k, & + & -7.1_k, -9.9_k, 0.3_k /), shape(ck)) + rck = pack(ck,real(ck)>0,vck) + if (any(real(rck) /= (/ 1.0_k, 2.1_k, 1.2_k, 0.98_k, 15._k, 16._k, 17._k, & + & 18._k, 19._k /))) STOP 2 + if (any(aimag(rck) /= 0)) STOP 3 + +end program main Index: Fortran/gfortran/regression/intrinsic_pack_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Take the pack intrinsic through its paces, with all types that are +! normally accessible. +program main + implicit none + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + integer :: i + integer(kind=k), dimension(3,3) :: ik + integer(kind=k), dimension(9) :: vik + integer(kind=k), dimension(9) :: rik + + vik = (/(i+10,i=1,9)/) + ik = reshape((/1_k, -1_k, 2_k, -2_k, 3_k, -3_k, 4_k, -4_k, 5_k/), shape(ik)) + rik = pack(ik,ik>0,vik) + if (any(rik /= (/1_k, 2_k, 3_k, 4_k, 5_k, 16_k, 17_k, 18_k, 19_k/))) & + & STOP 1 + + +end program main Index: Fortran/gfortran/regression/intrinsic_pack_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_4.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! PR 35990 - some empty array sections caused pack to crash. +! Test case contributed by Dick Hendrickson, adjusted and +! extended by Thomas Koenig. + program try_gf1048 + + call gf1048a( 10, 8, 7, 1, 0, .true.) + call gf1048b( 10, 8, 7, 1, 0, .true.) + call gf1048c( 10, 8, 7, 1, 0, .true.) + call gf1048d( 10, 8, 7, 1, 0, .true.) + call P_inta ( 10, 8, 7, 1, 0, .true.) + call P_intb ( 10, 8, 7, 1, 0, .true.) + call P_intc ( 10, 8, 7, 1, 0, .true.) + call P_intd ( 10, 8, 7, 1, 0, .true.) + end program + + SUBROUTINE GF1048a(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + CHARACTER(9) BDA(10) + CHARACTER(9) BDA1(10) + BDA( 8:7) = PACK(BDA1( 10: 1), NF_TRUE) + END SUBROUTINE + + SUBROUTINE GF1048b(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + CHARACTER(9) BDA(10) + CHARACTER(9) BDA1(nf10) + BDA(NF8:NF7) = PACK(BDA1(NF8:NF7), NF_TRUE) + END SUBROUTINE + + SUBROUTINE GF1048c(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + CHARACTER(9) BDA(10) + CHARACTER(9) BDA1(10) + BDA(NF8:NF7) = PACK(BDA1(NF10:NF1), NF_TRUE) + END SUBROUTINE + + SUBROUTINE GF1048d(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + CHARACTER(9) BDA(10) + CHARACTER(9) BDA1(nf10) + BDA(NF8:NF7) = PACK(BDA1(NF10:NF1), NF_TRUE) + END SUBROUTINE + + SUBROUTINE P_INTa(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + INTEGER BDA(10) + INTEGER BDA1(10) + BDA( 8:7) = PACK(BDA1( 10: 1), NF_TRUE) + END SUBROUTINE + + SUBROUTINE P_INTb(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + INTEGER BDA(10) + INTEGER BDA1(nf10) + BDA(NF8:NF7) = PACK(BDA1(NF8:NF7), NF_TRUE) + END SUBROUTINE + + SUBROUTINE P_INTc(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + INTEGER BDA(10) + INTEGER BDA1(10) + BDA(NF8:NF7) = PACK(BDA1(NF10:NF1), NF_TRUE) + END SUBROUTINE + + SUBROUTINE P_INTd(nf10,nf8,nf7,nf1,nf0,nf_true) + logical nf_true + INTEGER BDA(10) + INTEGER BDA1(nf10) + BDA(NF8:NF7) = PACK(BDA1(NF10:NF1), NF_TRUE) + END SUBROUTINE + Index: Fortran/gfortran/regression/intrinsic_pack_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_5.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! PR 41478: Corrupted memory using PACK for derived-types with allocated components +! PR 42268: [4.4/4.5 Regression] derived type segfault with pack +! +! Original test case by Juergen Reuter +! Modified by Janus Weil + +type :: container_t + integer:: entry = -1 +end type container_t +type(container_t), dimension(1) :: a1, a2 +a2(1)%entry = 1 +a1 = pack (a2, mask = [.true.]) +if (a1(1)%entry/=1) STOP 1 +end Index: Fortran/gfortran/regression/intrinsic_pack_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_pack_6.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! PR libfortran/103634 - Runtime crash with PACK on zero-sized arrays +! Exercise PACK intrinsic for cases when it calls pack_internal + +program p + implicit none + type t + real :: r(24) = -99. + end type + type(t), allocatable :: new(:), old(:), vec(:) + logical, allocatable :: mask(:) + integer :: n, m +! m = 1 ! works + m = 0 ! failed with SIGSEGV in pack_internal + do m = 0, 2 + print *, m + allocate (old(m), mask(m), vec(m)) + if (m > 0) vec(m)% r(1) = 42 + mask(:) = .true. + n = count (mask) + allocate (new(n)) + + mask(:) = .false. + if (size (pack (old, mask)) /= 0) stop 1 + mask(:) = .true. + if (size (pack (old, mask)) /= m) stop 2 + new(:) = pack (old, mask) ! this used to segfault for m=0 + + mask(:) = .false. + if (size (pack (old, mask, vector=vec)) /= m) stop 3 + new(:) = t() + new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0 + if (m > 0) then + if ( new( m )% r(1) /= 42) stop 4 + if (any (new(:m-1)% r(1) /= -99)) stop 5 + end if + + if (m > 0) mask(m) = .true. + if (size (pack (old, mask, vector=vec)) /= m) stop 6 + new(:) = t() + new(:) = pack (old, mask, vector=vec) ! this used to segfault for m=0 + if (m > 0) then + if (new(1)% r(1) /= -99) stop 7 + end if + if (m > 1) then + if (new(m)% r(1) /= 42) stop 8 + end if + + if (size (pack (old(:0), mask(:0), vector=vec)) /= m) stop 9 + new(:) = t() + new(:) = pack (old(:0), mask(:0), vector=vec) ! did segfault for m=0 + if (m > 0) then + if (new(m)% r(1) /= 42) stop 10 + end if + deallocate (old, mask, new, vec) + end do +end Index: Fortran/gfortran/regression/intrinsic_param_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_param_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-additional-options "-std=f95" } +! PR 54633 - this used to be accepted +program main + integer, parameter :: m = minval((/1/)) ! { dg-error "Transformational function" } +end Index: Fortran/gfortran/regression/intrinsic_product_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_product_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR 35993 - some intrinsics with mask = .false. didn't set +! the whole return array for multi-dimensional arrays. +! Test case adapted from Dick Hendrickson. + + program try + + call ga3019( 1, 2, 3, 4) + end program + + SUBROUTINE GA3019(nf1,nf2,nf3,nf4) + INTEGER IDA(NF2,NF3) + INTEGER IDA1(NF2,NF4,NF3) + + ida1 = 3 + + ida = -3 + IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, NF1 .LT. 0) !fails + if (any(ida /= 1)) STOP 1 + + ida = -3 + IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, .false. ) !fails + if (any(ida /= 1)) STOP 2 + + ida = -3 + IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, ida1 .eq. 137 ) !works + if (any(ida /= 1)) STOP 3 + + END SUBROUTINE Index: Fortran/gfortran/regression/intrinsic_shadow_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_shadow_1.f03 @@ -0,0 +1,55 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wintrinsic-shadow" } + +! PR fortran/33141 +! Check that the expected warnings are emitted if a user-procedure has the same +! name as an intrinsic, but only if it is matched by the current -std=*. + +MODULE testmod + IMPLICIT NONE + +CONTAINS + + ! ASIN is an intrinsic + REAL FUNCTION asin (arg) ! { dg-warning "shadow the intrinsic" } + IMPLICIT NONE + REAL :: arg + END FUNCTION asin + + ! ASINH is one but not in F2003 + REAL FUNCTION asinh (arg) ! { dg-bogus "shadow the intrinsic" } + IMPLICIT NONE + REAL :: arg + END FUNCTION asinh + +END MODULE testmod + +! ACOS is an intrinsic +REAL FUNCTION acos (arg) ! { dg-warning "of an intrinsic" } + IMPLICIT NONE + REAL :: arg +END FUNCTION acos + +! ACOSH not for F2003 +REAL FUNCTION acosh (arg) ! { dg-bogus "of an intrinsic" } + IMPLICIT NONE + REAL :: arg +END FUNCTION acosh + +! A subroutine with the same name as an intrinsic subroutine +SUBROUTINE random_number (arg) ! { dg-warning "of an intrinsic" } + IMPLICIT NONE + REAL, INTENT(OUT) :: arg +END SUBROUTINE random_number + +! But a subroutine with the name of an intrinsic function is ok. +SUBROUTINE atan (arg) ! { dg-bogus "of an intrinsic" } + IMPLICIT NONE + REAL :: arg +END SUBROUTINE atan + +! As should be a function with the name of an intrinsic subroutine. +REAL FUNCTION random_seed () ! { dg-bogus "of an intrinsic" } +END FUNCTION random_seed + +! We do only compile, so no main program needed. Index: Fortran/gfortran/regression/intrinsic_shadow_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_shadow_2.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wintrinsic-shadow -fall-intrinsics" } + +! PR fortran/33141 +! Check that the expected warnings are emitted if a user-procedure has the same +! name as an intrinsic, with -fall-intrinsics even regardless of std=*. + +MODULE testmod + IMPLICIT NONE + +CONTAINS + + ! ASINH is one but not in F2003 + REAL FUNCTION asinh (arg) ! { dg-warning "shadow the intrinsic" } + IMPLICIT NONE + REAL :: arg + END FUNCTION asinh + +END MODULE testmod + +! ACOSH not for F2003 +REAL FUNCTION acosh (arg) ! { dg-warning "of an intrinsic" } + IMPLICIT NONE + REAL :: arg +END FUNCTION acosh + +! We do only compile, so no main program needed. Index: Fortran/gfortran/regression/intrinsic_shadow_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_shadow_3.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Wno-intrinsic-shadow -fall-intrinsics" } + +! PR fortran/33141 +! Check that the "intrinsic shadow" warnings are not emitted if the warning +! is negated. + +MODULE testmod + IMPLICIT NONE + +CONTAINS + + REAL FUNCTION asin (arg) ! { dg-bogus "shadow the intrinsic" } + IMPLICIT NONE + REAL :: arg + END FUNCTION asin + +END MODULE testmod + +REAL FUNCTION acos (arg) ! { dg-bogus "of an intrinsic" } + IMPLICIT NONE + REAL :: arg +END FUNCTION acos + +! We do only compile, so no main program needed. Index: Fortran/gfortran/regression/intrinsic_shadow_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_shadow_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/54199 +! +subroutine test() +contains + real function fraction(x) ! { dg-warning "'fraction' declared at .1. may shadow the intrinsic of the same name. In order to call the intrinsic, explicit INTRINSIC declarations may be required." } + real :: x + fraction = x + end function fraction +end subroutine test Index: Fortran/gfortran/regression/intrinsic_short-long.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_short-long.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Checking for removal of SHORT and LONG intrinsics. +! + real,parameter :: a=3.1415927 + integer :: i + + i=SHORT(a) ! { dg-error "has been removed" } + i=LONG(a) ! { dg-error "has been removed" } + + end Index: Fortran/gfortran/regression/intrinsic_sign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_sign_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! At one point, SIGN() evaluated its first argument twice. +! Contributed by Brooks Moses +program sign1 + integer :: i + i = 1 + if (sign(foo(i), 1) /= 1) STOP 1 + i = 1 + if (sign(foo(i), -1) /= -1) STOP 2 +contains + integer function foo(i) + integer :: i + foo = i + i = i + 1 + end function +end Index: Fortran/gfortran/regression/intrinsic_sign_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_sign_2.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! Testcase for SIGN() with integer arguments +! Check that: +! + SIGN() evaluates its arguments only once +! + SIGN() works on large values +! + SIGN() works with parameter arguments +! Contributed by FX Coudert +program sign1 + implicit none + integer(kind=1), parameter :: one1 = 1_1, mone1 = -1_1 + integer(kind=2), parameter :: one2 = 1_2, mone2 = -1_2 + integer(kind=4), parameter :: one4 = 1_4, mone4 = -1_4 + integer(kind=8), parameter :: one8 = 1_8, mone8 = -1_8 + integer(kind=1) :: i1, j1 + integer(kind=2) :: i2, j2 + integer(kind=4) :: i4, j4 + integer(kind=8) :: i8, j8 + integer :: i = 1 + + i1 = huge(0_1) ; j1 = -huge(0_1) + if (sign(i1, j1) /= j1) STOP 1 + if (sign(j1, i1) /= i1) STOP 2 + if (sign(i1,one1) /= i1 .or. sign(j1,one1) /= i1) STOP 3 + if (sign(i1,mone1) /= j1 .or. sign(j1,mone1) /= j1) STOP 4 + + i2 = huge(0_2) ; j2 = -huge(0_2) + if (sign(i2, j2) /= j2) STOP 5 + if (sign(j2, i2) /= i2) STOP 6 + if (sign(i2,one2) /= i2 .or. sign(j2,one2) /= i2) STOP 7 + if (sign(i2,mone2) /= j2 .or. sign(j2,mone2) /= j2) STOP 8 + + i4 = huge(0_4) ; j4 = -huge(0_4) + if (sign(i4, j4) /= j4) STOP 9 + if (sign(j4, i4) /= i4) STOP 10 + if (sign(i4,one4) /= i4 .or. sign(j4,one4) /= i4) STOP 11 + if (sign(i4,mone4) /= j4 .or. sign(j4,mone4) /= j4) STOP 12 + + i8 = huge(0_8) ; j8 = -huge(0_8) + if (sign(i8, j8) /= j8) STOP 13 + if (sign(j8, i8) /= i8) STOP 14 + if (sign(i8,one8) /= i8 .or. sign(j8,one8) /= i8) STOP 15 + if (sign(i8,mone8) /= j8 .or. sign(j8,mone8) /= j8) STOP 16 + + if (sign(foo(i), 1) /= 1) STOP 1 + if (sign(foo(i), -1) /= -2) STOP 2 + if (sign(42, foo(i)) /= 42) STOP 3 + if (sign(42, -foo(i)) /= -42) STOP 4 + if (i /= 5) STOP 5 + + if (sign(bar(), 1) /= 1) STOP 6 + if (sign(bar(), -1) /= -2) STOP 7 + if (sign(17, bar()) /= 17) STOP 8 + if (sign(17, -bar()) /= -17) STOP 9 + if (bar() /= 5) STOP 10 + +contains + + integer function foo(i) + integer :: i + foo = i + i = i + 1 + end function + + integer function bar() + integer, save :: i = 0 + i = i + 1 + bar = i + end function +end Index: Fortran/gfortran/regression/intrinsic_signal.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_signal.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/49690 +! +! Reduced test case, based on the one of Debian bug #631204 +! + +subroutine ctrlc_ast + common /xinterrupt/ interrupted + logical interrupted + interrupted = .true. +end subroutine ctrlc_ast + +subroutine set_ctrl_c(ctrlc_ast) + external ctrlc_ast + intrinsic signal + integer old_handle + common /xinterrupt/ interrupted + logical interrupted + old_handler = signal(2, ctrlc_ast) +end subroutine set_ctrl_c Index: Fortran/gfortran/regression/intrinsic_size.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_size.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Argument checking; dim and kind have to be scalar +! +! PR fortran/33297 +! + integer array(5), i1, i2 + print *, size(array,(/i1,i2/)) ! { dg-error "must be a scalar" } + print *, size(array,i1,(/i1,i2/)) ! { dg-error "must be a scalar" } + end Index: Fortran/gfortran/regression/intrinsic_size_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_size_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/51904 +! +! Contributed by David Sagan. +! + +call qp_draw_polyline_basic([1.0,2.0]) +contains +subroutine qp_draw_polyline_basic (x) + implicit none + real :: x(:), f + integer :: i + f = 0 + print *, size(f*x) +end subroutine +end Index: Fortran/gfortran/regression/intrinsic_size_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_size_3.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/55852 +! +! Contributed by A. Kasahara +! +program bug + implicit none + + Real, allocatable:: a(:) + integer(2) :: iszs + + allocate(a(1:3)) + + iszs = ubound((a), 1)! Was ICEing +! print*, ubound((a), 1) ! Was ICEing +! print*, ubound(a, 1) ! OK +! print*, lbound((a), 1) ! OK +! print*, lbound(a, 1) ! OK + + stop +end program bug + +! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(a.dim.0..ubound - a.dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } } Index: Fortran/gfortran/regression/intrinsic_size_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_size_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Test the fix for PR55362; the error below was missed and an ICE ensued. +! +! ! Contributed by Dominique d'Humieres +! +program ice_test + implicit none + write(*,*) 'message: ', & + size(Error_Msg),Error_Msg() ! { dg-error "must be an array" } + write(*,*) 'message: ', & + size(Error_Msg ()),Error_Msg() ! OK of course +contains + function Error_Msg() result(ErrorMsg) + character, dimension(:), pointer :: ErrorMsg + character, dimension(1), target :: str = '!' + ErrorMsg => str + end function Error_Msg +end program ice_test Index: Fortran/gfortran/regression/intrinsic_spread_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_spread_1.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +program foo + implicit none + integer(kind=1), dimension (10) :: i_1 + integer(kind=1), dimension (2, 3) :: a_1 + integer(kind=1), dimension (2, 2, 3) :: b_1 + integer(kind=2), dimension (10) :: i_2 + integer(kind=2), dimension (2, 3) :: a_2 + integer(kind=2), dimension (2, 2, 3) :: b_2 + integer(kind=4), dimension (10) :: i_4 + integer(kind=4), dimension (2, 3) :: a_4 + integer(kind=4), dimension (2, 2, 3) :: b_4 + integer(kind=8), dimension (10) :: i_8 + integer(kind=8), dimension (2, 3) :: a_8 + integer(kind=8), dimension (2, 2, 3) :: b_8 + real(kind=4), dimension (10) :: r_4 + real(kind=4), dimension (2, 3) :: ar_4 + real(kind=4), dimension (2, 2, 3) :: br_4 + real(kind=8), dimension (10) :: r_8 + real(kind=8), dimension (2, 3) :: ar_8 + real(kind=8), dimension (2, 2, 3) :: br_8 + complex(kind=4), dimension (10) :: c_4 + complex(kind=4), dimension (2, 3) :: ac_4 + complex(kind=4), dimension (2, 2, 3) :: bc_4 + complex(kind=8), dimension (10) :: c_8 + complex(kind=8), dimension (2, 3) :: ac_8 + complex(kind=8), dimension (2, 2, 3) :: bc_8 + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension (10) :: it_4 + type(i4_t), dimension (2, 3) :: at_4 + type(i4_t), dimension (2, 2, 3) :: bt_4 + type(i4_t) :: iv_4 + + character (len=200) line1, line2, line3 + + a_1 = reshape ((/1_1, 2_1, 3_1, 4_1, 5_1, 6_1/), (/2, 3/)) + b_1 = spread (a_1, 1, 2) + if (any (b_1 .ne. reshape ((/1_1, 1_1, 2_1, 2_1, 3_1, 3_1, 4_1, 4_1, 5_1, 5_1, 6_1, 6_1/), & + (/2, 2, 3/)))) & + STOP 1 + line1 = ' ' + write(line1, 9000) b_1 + line2 = ' ' + write(line2, 9000) spread (a_1, 1, 2) + if (line1 /= line2) STOP 2 + line3 = ' ' + write(line3, 9000) spread (a_1, 1, 2) + 0_1 + if (line1 /= line3) STOP 3 + i_1 = spread(1_1,1,10) + if (any(i_1 /= 1_1)) STOP 4 + + a_2 = reshape ((/1_2, 2_2, 3_2, 4_2, 5_2, 6_2/), (/2, 3/)) + b_2 = spread (a_2, 1, 2) + if (any (b_2 .ne. reshape ((/1_2, 1_2, 2_2, 2_2, 3_2, 3_2, 4_2, 4_2, 5_2, 5_2, 6_2, 6_2/), & + (/2, 2, 3/)))) & + STOP 5 + line1 = ' ' + write(line1, 9000) b_2 + line2 = ' ' + write(line2, 9000) spread (a_2, 1, 2) + if (line1 /= line2) STOP 6 + line3 = ' ' + write(line3, 9000) spread (a_2, 1, 2) + 0_2 + if (line1 /= line3) STOP 7 + i_2 = spread(1_2,1,10) + if (any(i_2 /= 1_2)) STOP 8 + + a_4 = reshape ((/1_4, 2_4, 3_4, 4_4, 5_4, 6_4/), (/2, 3/)) + b_4 = spread (a_4, 1, 2) + if (any (b_4 .ne. reshape ((/1_4, 1_4, 2_4, 2_4, 3_4, 3_4, 4_4, 4_4, 5_4, 5_4, 6_4, 6_4/), & + (/2, 2, 3/)))) & + STOP 9 + line1 = ' ' + write(line1, 9000) b_4 + line2 = ' ' + write(line2, 9000) spread (a_4, 1, 2) + if (line1 /= line2) STOP 10 + line3 = ' ' + write(line3, 9000) spread (a_4, 1, 2) + 0_4 + if (line1 /= line3) STOP 11 + i_4 = spread(1_4,1,10) + if (any(i_4 /= 1_4)) STOP 12 + + a_8 = reshape ((/1_8, 2_8, 3_8, 4_8, 5_8, 6_8/), (/2, 3/)) + b_8 = spread (a_8, 1, 2) + if (any (b_8 .ne. reshape ((/1_8, 1_8, 2_8, 2_8, 3_8, 3_8, 4_8, 4_8, 5_8, 5_8, 6_8, 6_8/), & + (/2, 2, 3/)))) & + STOP 13 + line1 = ' ' + write(line1, 9000) b_8 + line2 = ' ' + write(line2, 9000) spread (a_8, 1, 2) + if (line1 /= line2) STOP 14 + line3 = ' ' + write(line3, 9000) spread (a_8, 1, 2) + 0_8 + if (line1 /= line3) STOP 15 + i_8 = spread(1_8,1,10) + if (any(i_8 /= 1_8)) STOP 16 + + + ar_4 = reshape ((/1._4, 2._4, 3._4, 4._4, 5._4, 6._4/), (/2, 3/)) + br_4 = spread (ar_4, 1, 2) + if (any (br_4 .ne. reshape ((/1._4, 1._4, 2._4, 2._4, 3._4, 3._4, & + & 4._4, 4._4, 5._4, 5._4, 6._4, 6._4/), (/2, 2, 3/)))) STOP 17 + line1 = ' ' + write(line1, 9010) br_4 + line2 = ' ' + write(line2, 9010) spread (ar_4, 1, 2) + if (line1 /= line2) STOP 18 + line3 = ' ' + write(line3, 9010) spread (ar_4, 1, 2) + 0._4 + if (line1 /= line3) STOP 19 + r_4 = spread(1._4,1,10) + if (any(r_4 /= 1._4)) STOP 20 + + + ar_8 = reshape ((/1._8, 2._8, 3._8, 4._8, 5._8, 6._8/), (/2, 3/)) + br_8 = spread (ar_8, 1, 2) + if (any (br_8 .ne. reshape ((/1._8, 1._8, 2._8, 2._8, 3._8, 3._8, & + & 4._8, 4._8, 5._8, 5._8, 6._8, 6._8/), (/2, 2, 3/)))) STOP 21 + line1 = ' ' + write(line1, 9010) br_8 + line2 = ' ' + write(line2, 9010) spread (ar_8, 1, 2) + if (line1 /= line2) STOP 22 + line3 = ' ' + write(line3, 9010) spread (ar_8, 1, 2) + 0._8 + if (line1 /= line3) STOP 23 + r_8 = spread(1._8,1,10) + if (any(r_8 /= 1._8)) STOP 24 + + ac_4 = reshape ((/(1._4,-1._4), (2._4,-2._4), (3._4, -3._4), (4._4, -4._4), & + & (5._4,-5._4), (6._4,-6._4)/), (/2, 3/)) + bc_4 = spread (ac_4, 1, 2) + if (any (real(bc_4) .ne. reshape ((/1._4, 1._4, 2._4, 2._4, 3._4, 3._4, & + & 4._4, 4._4, 5._4, 5._4, 6._4, 6._4/), (/2, 2, 3/)))) STOP 25 + if (any (-aimag(bc_4) .ne. reshape ((/1._4, 1._4, 2._4, 2._4, 3._4, 3._4, & + & 4._4, 4._4, 5._4, 5._4, 6._4, 6._4/), (/2, 2, 3/)))) STOP 26 + line1 = ' ' + write(line1, 9020) bc_4 + line2 = ' ' + write(line2, 9020) spread (ac_4, 1, 2) + if (line1 /= line2) STOP 27 + line3 = ' ' + write(line3, 9020) spread (ac_4, 1, 2) + 0._4 + if (line1 /= line3) STOP 28 + c_4 = spread((1._4,-1._4),1,10) + if (any(c_4 /= (1._4,-1._4))) STOP 29 + + ac_8 = reshape ((/(1._8,-1._8), (2._8,-2._8), (3._8, -3._8), (4._8, -4._8), & + & (5._8,-5._8), (6._8,-6._8)/), (/2, 3/)) + bc_8 = spread (ac_8, 1, 2) + if (any (real(bc_8) .ne. reshape ((/1._8, 1._8, 2._8, 2._8, 3._8, 3._8, & + & 4._8, 4._8, 5._8, 5._8, 6._8, 6._8/), (/2, 2, 3/)))) STOP 30 + if (any (-aimag(bc_8) .ne. reshape ((/1._8, 1._8, 2._8, 2._8, 3._8, 3._8, & + & 4._8, 4._8, 5._8, 5._8, 6._8, 6._8/), (/2, 2, 3/)))) STOP 31 + line1 = ' ' + write(line1, 9020) bc_8 + line2 = ' ' + write(line2, 9020) spread (ac_8, 1, 2) + if (line1 /= line2) STOP 32 + line3 = ' ' + write(line3, 9020) spread (ac_8, 1, 2) + 0._8 + if (line1 /= line3) STOP 33 + c_8 = spread((1._8,-1._8),1,10) + if (any(c_8 /= (1._8,-1._8))) STOP 34 + + + at_4%v = reshape ((/1_4, 2_4, 3_4, 4_4, 5_4, 6_4/), (/2, 3/)) + bt_4 = spread (at_4, 1, 2) + if (any (bt_4%v .ne. reshape ((/1_4, 1_4, 2_4, 2_4, 3_4, 3_4, 4_4, & + & 4_4, 5_4, 5_4, 6_4, 6_4/), (/2, 2, 3/)))) & + STOP 35 + iv_4%v = 123_4 + it_4 = spread(iv_4,1,10) + if (any(it_4%v /= 123_4)) STOP 36 + + +9000 format(12I3) +9010 format(12F7.3) +9020 format(25F7.3) + +end program Index: Fortran/gfortran/regression/intrinsic_spread_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_spread_2.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +program foo + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + + real(kind=k), dimension(10) :: r_k + real(kind=k), dimension (2, 3) :: ar_k + real(kind=k), dimension (2, 2, 3) :: br_k + complex(kind=k), dimension(10) :: c_k + complex(kind=k), dimension (2, 3) :: ac_k + complex(kind=k), dimension (2, 2, 3) :: bc_k + character (len=200) line1, line2, line3 + + ar_k = reshape ((/1._k, 2._k, 3._k, 4._k, 5._k, 6._k/), (/2, 3/)) + br_k = spread (ar_k, 1, 2) + if (any (br_k .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, & + & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) STOP 1 + line1 = ' ' + write(line1, 9010) br_k + line2 = ' ' + write(line2, 9010) spread (ar_k, 1, 2) + if (line1 /= line2) STOP 2 + line3 = ' ' + write(line3, 9010) spread (ar_k, 1, 2) + 0._k + if (line1 /= line3) STOP 3 + r_k = spread(1._k,1,10) + if (any(r_k /= 1._k)) STOP 4 + + ac_k = reshape ((/(1._k,-1._k), (2._k,-2._k), (3._k, -3._k), (4._k, -4._k), & + & (5._k,-5._k), (6._k,-6._k)/), (/2, 3/)) + bc_k = spread (ac_k, 1, 2) + if (any (real(bc_k) .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, & + & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) STOP 5 + if (any (-aimag(bc_k) .ne. reshape ((/1._k, 1._k, 2._k, 2._k, 3._k, 3._k, & + & 4._k, 4._k, 5._k, 5._k, 6._k, 6._k/), (/2, 2, 3/)))) STOP 6 + line1 = ' ' + write(line1, 9020) bc_k + line2 = ' ' + write(line2, 9020) spread (ac_k, 1, 2) + if (line1 /= line2) STOP 7 + line3 = ' ' + write(line3, 9020) spread (ac_k, 1, 2) + 0._k + if (line1 /= line3) STOP 8 + c_k = spread((1._k,-1._k),1,10) + if (any(c_k /= (1._k,-1._k))) STOP 9 + +9010 format(12F7.3) +9020 format(25F7.3) + +end program Index: Fortran/gfortran/regression/intrinsic_spread_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_spread_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } + +program foo + implicit none + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + + integer(kind=k), dimension(10) :: i_k + integer(kind=k), dimension (2, 3) :: a_k + integer(kind=k), dimension (2, 2, 3) :: b_k + character (len=200) line1, line2, line3 + + a_k = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k/), (/2, 3/)) + b_k = spread (a_k, 1, 2) + if (any (b_k .ne. reshape ((/1_k, 1_k, 2_k, 2_k, 3_k, 3_k, 4_k, 4_k, 5_k, 5_k, 6_k, 6_k/), & + (/2, 2, 3/)))) & + STOP 1 + line1 = ' ' + write(line1, 9000) b_k + line2 = ' ' + write(line2, 9000) spread (a_k, 1, 2) + if (line1 /= line2) STOP 2 + line3 = ' ' + write(line3, 9000) spread (a_k, 1, 2) + 0_k + if (line1 /= line3) STOP 3 + i_k = spread(1_k,1,10) + if (any(i_k /= 1_k)) STOP 4 + +9000 format(12I3) + +end program Index: Fortran/gfortran/regression/intrinsic_std_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_1.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-std=f95 -Wintrinsics-std" } + +! +! See intrinsic_std_6.f90 for the dump check. +! + +! PR fortran/33141 +! Check for the expected behavior when an intrinsic function/subroutine is +! called that is not available in the defined standard or that is a GNU +! extension: +! There should be a warning emitted on the call, and the reference should be +! treated like an external call. +! For declaring a non-standard intrinsic INTRINSIC, a hard error should be +! generated, of course. + +SUBROUTINE no_implicit + IMPLICIT NONE + REAL :: asinh ! { dg-warning "Fortran 2008" } + + ! abort is a GNU extension + CALL abort () ! { dg-warning "extension" } + + ! ASINH is an intrinsic of F2008 + ! The warning should be issued in the declaration above where it is declared + ! EXTERNAL. + WRITE (*,*) ASINH (1.) ! { dg-warning "Fortran 2008" } +END SUBROUTINE no_implicit + +SUBROUTINE implicit_type + ! acosh has implicit type + + WRITE (*,*) ACOSH (1.) ! { dg-warning "Fortran 2008" } + WRITE (*,*) ACOSH (1.) ! { dg-bogus "Fortran 2008" } +END SUBROUTINE implicit_type + +SUBROUTINE specification_expression + CHARACTER(KIND=selected_char_kind("ascii")) :: x +! { dg-error "must be an intrinsic function" "" { target "*-*-*" } .-1 } +! { dg-warning "Fortran 2003" "" { target "*-*-*" } .-2 } +END SUBROUTINE specification_expression + +SUBROUTINE intrinsic_decl + IMPLICIT NONE + INTRINSIC :: atanh ! { dg-error "Fortran 2008" } + INTRINSIC :: abort ! { dg-error "extension" } +END SUBROUTINE intrinsic_decl Index: Fortran/gfortran/regression/intrinsic_std_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_2.f90 @@ -0,0 +1,15 @@ +! { dg-do link } +! { dg-options "-std=f95 -Wintrinsics-std -fall-intrinsics" } + +! PR fortran/33141 +! Check that -fall-intrinsics makes all intrinsics available. + +PROGRAM main + IMPLICIT NONE + + ! abort is a GNU extension + CALL abort () ! { dg-bogus "extension" } + + ! ASINH is an intrinsic of F2008 + WRITE (*,*) ASINH (1.) ! { dg-bogus "Fortran 2008" } +END PROGRAM main Index: Fortran/gfortran/regression/intrinsic_std_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_3.f90 @@ -0,0 +1,15 @@ +! { dg-do link } +! { dg-options "-std=gnu -Wintrinsics-std" } + +! PR fortran/33141 +! -std=gnu should allow every intrinsic. + +PROGRAM main + IMPLICIT NONE + + ! abort is a GNU extension + CALL abort () ! { dg-bogus "extension" } + + ! ASINH is an intrinsic of F2008 + WRITE (*,*) ASINH (1.) ! { dg-bogus "Fortran 2008" } +END PROGRAM main Index: Fortran/gfortran/regression/intrinsic_std_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_4.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-std=f95 -Wno-intrinsics-std" } + +! PR fortran/33141 +! Check that calls to intrinsics not in the current standard are "allowed" and +! linked to external procedures with that name. +! Addionally, this checks that -Wno-intrinsics-std turns off the warning. + +SUBROUTINE abort () + IMPLICIT NONE + WRITE (*,*) "Correct" +END SUBROUTINE abort + +REAL FUNCTION asinh (arg) + IMPLICIT NONE + REAL :: arg + + WRITE (*,*) "Correct" + asinh = arg +END FUNCTION asinh + +SUBROUTINE implicit_none + IMPLICIT NONE + REAL :: asinh ! { dg-bogus "Fortran 2008" } + REAL :: x + + ! Both times our version above should be called + CALL abort () ! { dg-bogus "extension" } + x = ASINH (1.) ! { dg-bogus "Fortran 2008" } +END SUBROUTINE implicit_none + +SUBROUTINE implicit_type + ! ASINH has implicit type here + REAL :: x + + ! Our version should be called + x = ASINH (1.) ! { dg-bogus "Fortran 2008" } +END SUBROUTINE implicit_type + +PROGRAM main + ! This should give a total of three "Correct"s + CALL implicit_none () + CALL implicit_type () +END PROGRAM main + +! { dg-output "Correct\.*Correct\.*Correct" } Index: Fortran/gfortran/regression/intrinsic_std_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_5.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/40728 +! + +! bogus error +SUBROUTINE s1 + IMPLICIT NONE + real(4), volatile :: r4 + + r4 = 0.0_4 + r4 = asinh(r4) ! { dg-error "has no IMPLICIT type" } +END SUBROUTINE + + + +! ICE on invalid (ATANH is defined by F2008 only) +SUBROUTINE s2 + IMPLICIT NONE + real :: r + r = 0.4 + print *, atanh(r) ! { dg-error "has no IMPLICIT type" } +END SUBROUTINE Index: Fortran/gfortran/regression/intrinsic_std_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_std_6.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-std=f95 -Wintrinsics-std -fdump-tree-original" } + +! +! See intrinsic_std_1.f90 for more compile-time checks +! + +! PR fortran/33141 +! Check for the expected behavior when an intrinsic function/subroutine is +! called that is not available in the defined standard or that is a GNU +! extension: +! There should be a warning emitted on the call, and the reference should be +! treated like an external call. +! For declaring a non-standard intrinsic INTRINSIC, a hard error should be +! generated, of course. + +SUBROUTINE no_implicit + IMPLICIT NONE + REAL :: asinh ! { dg-warning "Fortran 2008" } + + ! abort is a GNU extension + CALL abort () ! { dg-warning "extension" } + + ! ASINH is an intrinsic of F2008 + ! The warning should be issued in the declaration above where it is declared + ! EXTERNAL. + WRITE (*,*) ASINH (1.) ! { dg-warning "Fortran 2008" } +END SUBROUTINE no_implicit + +SUBROUTINE implicit_type + ! acosh has implicit type + + WRITE (*,*) ACOSH (1.) ! { dg-warning "Fortran 2008" } + WRITE (*,*) ACOSH (1.) ! { dg-bogus "Fortran 2008" } +END SUBROUTINE implicit_type + +! Scan that really external functions are called. +! { dg-final { scan-tree-dump " abort " "original" } } +! { dg-final { scan-tree-dump " asinh " "original" } } +! { dg-final { scan-tree-dump " acosh " "original" } } Index: Fortran/gfortran/regression/intrinsic_subroutine.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_subroutine.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 33229 +implicit none +intrinsic cpu_time ! { dg-error "attribute conflicts with" } +real :: time +print *, CPU_TIME(TIME) ! { dg-error "is not a function" } +end Index: Fortran/gfortran/regression/intrinsic_unpack_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_unpack_1.f90 @@ -0,0 +1,135 @@ +! { dg-do run } +! Program to test the UNPACK intrinsic for the types usually present. +program intrinsic_unpack + implicit none + integer(kind=1), dimension(3, 3) :: a1, b1 + integer(kind=2), dimension(3, 3) :: a2, b2 + integer(kind=4), dimension(3, 3) :: a4, b4 + integer(kind=8), dimension(3, 3) :: a8, b8 + real(kind=4), dimension(3,3) :: ar4, br4 + real(kind=8), dimension(3,3) :: ar8, br8 + complex(kind=4), dimension(3,3) :: ac4, bc4 + complex(kind=8), dimension(3,3) :: ac8, bc8 + type i4_t + integer(kind=4) :: v + end type i4_t + type(i4_t), dimension(3,3) :: at4, bt4 + type(i4_t), dimension(3) :: vt4 + + logical, dimension(3, 3) :: mask + character(len=500) line1, line2 + integer i + + mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& + &.false.,.false.,.true./), (/3, 3/)); + a1 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b1 = unpack ((/2_1, 3_1, 4_1/), mask, a1) + if (any (b1 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 1 + write (line1,'(10I4)') b1 + write (line2,'(10I4)') unpack((/2_1, 3_1, 4_1/), mask, a1) + if (line1 .ne. line2) STOP 2 + b1 = -1 + b1 = unpack ((/2_1, 3_1, 4_1/), mask, 0_1) + if (any (b1 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 3 + + a2 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b2 = unpack ((/2_2, 3_2, 4_2/), mask, a2) + if (any (b2 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 4 + write (line1,'(10I4)') b2 + write (line2,'(10I4)') unpack((/2_2, 3_2, 4_2/), mask, a2) + if (line1 .ne. line2) STOP 5 + b2 = -1 + b2 = unpack ((/2_2, 3_2, 4_2/), mask, 0_2) + if (any (b2 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 6 + + a4 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b4 = unpack ((/2_4, 3_4, 4_4/), mask, a4) + if (any (b4 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 7 + write (line1,'(10I4)') b4 + write (line2,'(10I4)') unpack((/2_4, 3_4, 4_4/), mask, a4) + if (line1 .ne. line2) STOP 8 + b4 = -1 + b4 = unpack ((/2_4, 3_4, 4_4/), mask, 0_4) + if (any (b4 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 9 + + a8 = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b8 = unpack ((/2_8, 3_8, 4_8/), mask, a8) + if (any (b8 .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 10 + write (line1,'(10I4)') b8 + write (line2,'(10I4)') unpack((/2_8, 3_8, 4_8/), mask, a8) + if (line1 .ne. line2) STOP 11 + b8 = -1 + b8 = unpack ((/2_8, 3_8, 4_8/), mask, 0_8) + if (any (b8 .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 12 + + ar4 = reshape ((/1._4, 0._4, 0._4, 0._4, 1._4, 0._4, 0._4, 0._4, 1._4/), & + (/3, 3/)); + br4 = unpack ((/2._4, 3._4, 4._4/), mask, ar4) + if (any (br4 .ne. reshape ((/1._4, 2._4, 0._4, 3._4, 1._4, 0._4, & + 0._4, 0._4, 4._4/), (/3, 3/)))) & + STOP 13 + write (line1,'(9F9.5)') br4 + write (line2,'(9F9.5)') unpack((/2._4, 3._4, 4._4/), mask, ar4) + if (line1 .ne. line2) STOP 14 + br4 = -1._4 + br4 = unpack ((/2._4, 3._4, 4._4/), mask, 0._4) + if (any (br4 .ne. reshape ((/0._4, 2._4, 0._4, 3._4, 0._4, 0._4, & + 0._4, 0._4, 4._4/), (/3, 3/)))) & + STOP 15 + + ar8 = reshape ((/1._8, 0._8, 0._8, 0._8, 1._8, 0._8, 0._8, 0._8, 1._8/), & + (/3, 3/)); + br8 = unpack ((/2._8, 3._8, 4._8/), mask, ar8) + if (any (br8 .ne. reshape ((/1._8, 2._8, 0._8, 3._8, 1._8, 0._8, & + 0._8, 0._8, 4._8/), (/3, 3/)))) & + STOP 16 + write (line1,'(9F9.5)') br8 + write (line2,'(9F9.5)') unpack((/2._8, 3._8, 4._8/), mask, ar8) + if (line1 .ne. line2) STOP 17 + br8 = -1._8 + br8 = unpack ((/2._8, 3._8, 4._8/), mask, 0._8) + if (any (br8 .ne. reshape ((/0._8, 2._8, 0._8, 3._8, 0._8, 0._8, & + 0._8, 0._8, 4._8/), (/3, 3/)))) & + STOP 18 + + ac4 = reshape ((/1._4, 0._4, 0._4, 0._4, 1._4, 0._4, 0._4, 0._4, 1._4/), & + (/3, 3/)); + bc4 = unpack ((/(2._4, 0._4), (3._4, 0._4), (4._4, 0._4)/), mask, ac4) + if (any (real(bc4) .ne. reshape ((/1._4, 2._4, 0._4, 3._4, 1._4, 0._4, & + 0._4, 0._4, 4._4/), (/3, 3/)))) & + STOP 19 + write (line1,'(18F9.5)') bc4 + write (line2,'(18F9.5)') unpack((/(2._4, 0._4), (3._4, 0._4), (4._4,0._4)/), & + mask, ac4) + if (line1 .ne. line2) STOP 20 + + ac8 = reshape ((/1._8, 0._8, 0._8, 0._8, 1._8, 0._8, 0._8, 0._8, 1._8/), & + (/3, 3/)); + bc8 = unpack ((/(2._8, 0._8), (3._8, 0._8), (4._8, 0._8)/), mask, ac8) + if (any (real(bc8) .ne. reshape ((/1._8, 2._8, 0._8, 3._8, 1._8, 0._8, & + 0._8, 0._8, 4._8/), (/3, 3/)))) & + STOP 21 + write (line1,'(18F9.5)') bc8 + write (line2,'(18F9.5)') unpack((/(2._8, 0._8), (3._8, 0._8), (4._8,0._8)/), & + mask, ac8) + if (line1 .ne. line2) STOP 22 + + at4%v = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + vt4%v = (/2_4, 3_4, 4_4/) + bt4 = unpack (vt4, mask, at4) + if (any (bt4%v .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 23 + bt4%v = -1 + bt4 = unpack (vt4, mask, i4_t(0_4)) + if (any (bt4%v .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 24 + +end program Index: Fortran/gfortran/regression/intrinsic_unpack_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_unpack_2.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Program to test the UNPACK intrinsic for large real type +program intrinsic_unpack + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + + real(kind=k), dimension(3,3) :: ark, brk + complex(kind=k), dimension(3,3) :: ack, bck + + logical, dimension(3, 3) :: mask + character(len=500) line1, line2 + integer i + + mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& + &.false.,.false.,.true./), (/3, 3/)); + + ark = reshape ((/1._k, 0._k, 0._k, 0._k, 1._k, 0._k, 0._k, 0._k, 1._k/), & + (/3, 3/)); + brk = unpack ((/2._k, 3._k, 4._k/), mask, ark) + if (any (brk .ne. reshape ((/1._k, 2._k, 0._k, 3._k, 1._k, 0._k, & + 0._k, 0._k, 4._k/), (/3, 3/)))) & + STOP 1 + write (line1,'(9F9.5)') brk + write (line2,'(9F9.5)') unpack((/2._k, 3._k, 4._k/), mask, ark) + if (line1 .ne. line2) STOP 2 + brk = -1._k + brk = unpack ((/2._k, 3._k, 4._k/), mask, 0._k) + if (any (brk .ne. reshape ((/0._k, 2._k, 0._k, 3._k, 0._k, 0._k, & + 0._k, 0._k, 4._k/), (/3, 3/)))) & + STOP 3 + + ack = reshape ((/1._k, 0._k, 0._k, 0._k, 1._k, 0._k, 0._k, 0._k, 1._k/), & + (/3, 3/)); + bck = unpack ((/(2._k, 0._k), (3._k, 0._k), (4._k, 0._k)/), mask, ack) + if (any (real(bck) .ne. reshape ((/1._k, 2._k, 0._k, 3._k, 1._k, 0._k, & + 0._k, 0._k, 4._k/), (/3, 3/)))) & + STOP 4 + write (line1,'(18F9.5)') bck + write (line2,'(18F9.5)') unpack((/(2._k, 0._k), (3._k, 0._k), (4._k,0._k)/), & + mask, ack) + if (line1 .ne. line2) STOP 5 + +end program Index: Fortran/gfortran/regression/intrinsic_unpack_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_unpack_3.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Program to test the UNPACK intrinsic for a long integer type +program intrinsic_unpack + implicit none + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + integer(kind=k), dimension(3, 3) :: ak, bk + logical, dimension(3, 3) :: mask + character(len=100) line1, line2 + integer i + + mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& + &.false.,.false.,.true./), (/3, 3/)); + + ak = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + bk = unpack ((/2_k, 3_k, 4_k/), mask, ak) + if (any (bk .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 1 + write (line1,'(10I4)') bk + write (line2,'(10I4)') unpack((/2_k, 3_k, 4_k/), mask, ak) + if (line1 .ne. line2) STOP 2 + bk = -1 + bk = unpack ((/2_k, 3_k, 4_k/), mask, 0_k) + if (any (bk .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + STOP 3 + +end program Index: Fortran/gfortran/regression/intrinsic_verify_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsic_verify_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! Test the verify intrinsic. We were ignoring the last character. +program prog + character(len=1) :: c1 + character(len=4) :: c4 + c1 = "E" + if (verify(c1, "1") .ne. 1) STOP 1 + c4 = "ABBA" + if (verify(c4, "A") .ne. 2) STOP 2 + if (verify(c4, "A", back = .true.) .ne. 3) STOP 3 + if (verify(c4, "AB") .ne. 0) STOP 4 +end program Index: Fortran/gfortran/regression/intrinsics_kind_argument_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/intrinsics_kind_argument_1.f90 @@ -0,0 +1,56 @@ +! Test various intrinsics who take a kind argument since Fortran 2003 +! +! { dg-do compile } +! +program test + integer, parameter :: k = kind(0) + logical :: l_array(4,5) + character(len=1) :: s + character(len=20) :: t + + l_array = .true. + s = "u" + t = "bartutugee" + + call check (count(l_array, kind=k), 20) + if (any (count(l_array, 2, kind=k) /= 5)) STOP 1 + if (any (count(l_array, kind=k, dim=2) /= 5)) STOP 2 + + call check (iachar (s, k), 117) + call check (iachar (s, kind=k), 117) + call check (ichar (s, k), 117) + call check (ichar (s, kind=k), 117) + + if (achar(107) /= achar(107,1)) STOP 3 + + call check (index (t, s, .true., k), 7) + call check (index (t, s, kind=k, back=.false.), 5) + + if (any (lbound (l_array, kind=k) /= 1)) STOP 4 + call check (lbound (l_array, 1), 1) + call check (lbound (l_array, 1, kind=k), 1) + + if (any (ubound (l_array, kind=k) /= (/4, 5/))) STOP 5 + call check (ubound (l_array, 1), 4) + call check (ubound (l_array, 1, kind=k), 4) + + call check (len(t, k), 20) + call check (len_trim(t, k), 10) + + call check (scan (t, s, .true., k), 7) + call check (scan (t, s, kind=k, back=.false.), 5) + + call check (size (l_array, 1, kind=k), 4) + call check (size (l_array, kind=k), 20) + + call check (verify (t, s, .true., k), 20) + call check (verify (t, s, kind=k, back=.false.), 1) + +contains + + subroutine check(x,y) + integer, intent(in) :: x, y + if (x /= y) STOP 6 + end subroutine check + +end program test Index: Fortran/gfortran/regression/invalid_contains_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/invalid_contains_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR18923 segfault after subroutine name confusion. +module FOO +contains + subroutine FOO ! { dg-error "conflicts with PROCEDURE" } + character(len=selected_int_kind(0)) :: C ! { dg-error "data declaration statement" } + end subroutine ! { dg-error "Expecting END MODULE statement" } +end Index: Fortran/gfortran/regression/invalid_contains_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/invalid_contains_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR18923 segfault after subroutine name confusion. +program foo +contains + subroutine foo(i) ! { dg-error "conflicts with PROCEDURE" } + integer :: i ! { dg-error "data declaration statement" } + character(len=selected_int_kind(i)) :: c ! { dg-error "data declaration statement" } + end subroutine ! { dg-error "Expecting END PROGRAM statement" } +end program foo Index: Fortran/gfortran/regression/invalid_interface_assignment.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/invalid_interface_assignment.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Tests the fix for PR25102, which did not diagnose the aberrant interface +! assignement below. +! +! Contributed by Joost VandeVondele +! +MODULE TT + TYPE data_type + INTEGER :: I + END TYPE data_type + INTERFACE ASSIGNMENT (=) + MODULE PROCEDURE set + END INTERFACE +CONTAINS + PURE SUBROUTINE set(x1,*) ! { dg-error "Alternate return cannot appear" } + TYPE(data_type), INTENT(OUT) :: x1 + x1%i=0 + END SUBROUTINE set +END MODULE Index: Fortran/gfortran/regression/invalid_name.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/invalid_name.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! Tests the fix for PR27698, where names not starting with a letter were +! rejected but not diagnosed with a proper message. +SUBROUTINE _foo ! { dg-error "Invalid character in name" } +END + Index: Fortran/gfortran/regression/invalid_procedure_name.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/invalid_procedure_name.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR25061 procedure name conflict +! Test case from PR. +INTERFACE I1 ! { dg-error "" } + SUBROUTINE S1(I) + END SUBROUTINE S1 + SUBROUTINE S2(R) + END SUBROUTINE S2 +END INTERFACE I1 +CONTAINS + SUBROUTINE I1(I) ! { dg-error "already defined as a generic" } + END SUBROUTINE I1 ! { dg-error "Expecting END PROGRAM statement" } +END + Index: Fortran/gfortran/regression/io_constraints_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_1.f90 @@ -0,0 +1,78 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Part I of the test of the IO constraints patch, which fixes PRs: +! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. +! +! Contributed by Paul Thomas +! +module fails + + 2000 format (1h , 2i6) ! { dg-error "Format statement in module" } + +end module fails + +module global + + integer :: modvar + namelist /NL/ modvar + +contains + + subroutine foo (i) + integer :: i + write (*, 100) i + 100 format (1h , "i=", i6) ! { dg-warning "The H format specifier at ... is a Fortran 95 deleted feature" } + end subroutine foo + +end module global + + use global + integer :: a,b, c(20) + integer(8) :: ierr + character(80) :: buffer(3) + +! Appending to a USE associated namelist is an extension. + + NAMELIST /NL/ a,b ! { dg-error "already is USE associated" } + + a=1 ; b=2 + +!9.2.2.1: + write(c, *) a, b ! { dg-error "array" } +!Was correctly picked up before patch. + write(buffer((/3,1,2/)), *) a, b ! { dg-error "vector subscript" } + +!9.2.2.2 and one of 9.4.1 +!________________________ + + write(6, NML=NL, FMT = '(i6)') ! { dg-error "group name and format" } + write(6, NML=NL, FMT = 200) ! { dg-error "group name and format" } + +!9.4.1 +!_____ +! + +! R912 +!Was correctly picked up before patch. + write(6, NML=NL, iostat = ierr) ! { dg-error "requires default INTEGER" } + +! Constraints +!Was correctly picked up before patch. + write(1, fmt='(i6)', end = 100) a ! { dg-error "END tag" } +!Was correctly picked up before patch. + write(1, fmt='(i6)', eor = 100) a ! { dg-error "EOR tag" } +!Was correctly picked up before patch. + write(1, fmt='(i6)', size = b) a ! { dg-error "SIZE= specifier not allowed" } + + + READ(1, fmt='(i6)', end = 900) a ! { dg-error "not defined" } + READ(1, fmt='(i6)', eor = 900, advance='NO') a ! { dg-error "not defined" } + READ(1, fmt='(i6)', ERR = 900) a ! { dg-error "not defined" } + +!Was correctly picked up before patch. + READ(1, fmt=800) a ! { dg-error "not defined" } + + +100 continue +200 format (2i6) + END Index: Fortran/gfortran/regression/io_constraints_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_10.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/52335 +! + +integer :: lun +character(len=20) :: str + +! VALID Fortran 95: +open(unit=lun,file=str,delim='apostrophe',status='old') +inquire(lun, delim=str) + +! Fortran 2003: +write(*,*, delim='apostrophe') 'a' ! { dg-error "Fortran 2003: DELIM= at .1. not allowed in Fortran 95" } +end Index: Fortran/gfortran/regression/io_constraints_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_11.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! Test our conformance to item 4.9 ("Kind type parameters of integer +! specifiers") of the Fortran 2003 status document at +! ftp://ftp.nag.co.uk/sc22wg5/N1551-N1600/N1579.pdf +! +! The non-default integer variables are allowed since Fortran 2003. +! The non-default logical variables are allowed since Fortran 2008. + + integer(kind=8) :: i, j, k, n + logical(kind=8) :: l1, l2, l3 + + open(10, status="scratch", iostat=i) ! { dg-error "requires default INTEGER" } + + backspace(10, iostat=i) ! { dg-error "requires default INTEGER" } + endfile(10, iostat=i) ! { dg-error "requires default INTEGER" } + rewind(10, iostat=i) ! { dg-error "requires default INTEGER" } + + read(*, '(I2)', iostat=i) k ! { dg-error "requires default INTEGER" } + read(*, '(I2)', advance='no', size=j) k ! { dg-error "requires default INTEGER" } + + inquire(iolength=i) "42" ! { dg-error "requires default INTEGER" } + inquire(10, iostat=i) ! { dg-error "requires default INTEGER" } + inquire(10, number=j) ! { dg-error "requires default INTEGER" } + inquire(10, recl=k) ! { dg-error "requires default INTEGER" } + inquire(10, nextrec=n) ! { dg-error "requires default INTEGER" } + + inquire(10, exist=l1) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, named=l3) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, opened=l2) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, pending=l2) ! { dg-error "Non-default LOGICAL kind" } + + close(10, iostat=i) ! { dg-error "requires default INTEGER" } + +end Index: Fortran/gfortran/regression/io_constraints_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_12.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Test our conformance to item 4.9 ("Kind type parameters of integer +! specifiers") of the Fortran 2003 status document at +! ftp://ftp.nag.co.uk/sc22wg5/N1551-N1600/N1579.pdf +! +! The non-default integer variables are allowed since Fortran 2003. +! The non-default logical variables are allowed since Fortran 2008. + + integer(kind=8) :: i, j, k, n + logical(kind=8) :: l1, l2, l3 + + open(10, status="scratch", iostat=i) + + backspace(10, iostat=i) + endfile(10, iostat=i) + rewind(10, iostat=i) + + read(*, '(I2)', iostat=i) k + read(*, '(I2)', advance='no', size=j) k + + inquire(iolength=i) "42" + inquire(10, iostat=i) + inquire(10, number=j) + inquire(10, recl=k) + inquire(10, nextrec=n) + + inquire(10, exist=l1) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, named=l3) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, opened=l2) ! { dg-error "Non-default LOGICAL kind" } + inquire(10, pending=l2) ! { dg-error "Non-default LOGICAL kind" } + + close(10, iostat=i) + +end Index: Fortran/gfortran/regression/io_constraints_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_13.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! Test our conformance to item 4.9 ("Kind type parameters of integer +! specifiers") of the Fortran 2003 status document at +! ftp://ftp.nag.co.uk/sc22wg5/N1551-N1600/N1579.pdf +! +! The non-default integer variables are allowed since Fortran 2003. +! The non-default logical variables are allowed since Fortran 2008. + + integer(kind=8) :: i, j, k, n + logical(kind=8) :: l1, l2, l3 + + open(10, status="scratch", iostat=i) + + backspace(10, iostat=i) + endfile(10, iostat=i) + rewind(10, iostat=i) + + read(*, '(I2)', iostat=i) k + read(*, '(I2)', advance='no', size=j) k + + inquire(iolength=i) "42" + inquire(10, iostat=i) + inquire(10, number=j) + inquire(10, recl=k) + inquire(10, nextrec=n) + + inquire(10, exist=l1) + inquire(10, named=l3) + inquire(10, opened=l2) + inquire(10, pending=l2) + + close(10, iostat=i) + +end Index: Fortran/gfortran/regression/io_constraints_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_14.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +program pr89782 + character(len=*),parameter :: VALUES(*)=[character(len=10) :: 'NaN','NAN','nan','Inf','INF','inf','Infinity'] + character(len=*),parameter :: VALUE='NaN' + real(4) :: var + do i=1,size(VALUES) + read(VALUES(i),*) float ! { dg-error "character PARAMETER" } + write(VALUES(i),*)float ! { dg-error "character PARAMETER" } + enddo + read(var,*)float ! { dg-error "INTEGER expression or a CHARACTER" } + read(VALUE,*)float ! { dg-error "character PARAMETER" } + write(VALUE,*)float ! { dg-error "character PARAMETER" } +end program pr89782 Index: Fortran/gfortran/regression/io_constraints_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_15.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/87923 +! +program p + open (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" } + open (2, decimal=char(1000,4)) ! { dg-error "must be a character string of default kind" } + open (3, encoding=char(1000,4)) ! { dg-error "must be a character string of default kind" } + open (4, round=char(1000,4)) ! { dg-error "must be a character string of default kind" } + open (5, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" } +end Index: Fortran/gfortran/regression/io_constraints_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_16.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/87923 +! +program p + read (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" } + read (1, delim=char(1000,4)) ! { dg-error "must be a character string of default kind" } + read (1, pad=char(1000,4)) ! { dg-error "must be a character string of default kind" } + read (1, round=char(1000,4)) ! { dg-error "must be a character string of default kind" } + read (1, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" } +end Index: Fortran/gfortran/regression/io_constraints_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_17.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/87923 +! +program p + write (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" } + write (1, delim=char(1000,4)) ! { dg-error "must be a character string of default kind" } + write (1, pad=char(1000,4)) ! { dg-error "must be a character string of default kind" } + write (1, round=char(1000,4)) ! { dg-error "must be a character string of default kind" } + write (1, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" } +end Index: Fortran/gfortran/regression/io_constraints_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_18.f90 @@ -0,0 +1,9 @@ +! { dg-options "-fdec" } +! { dg-do compile } +! +! PR fortran/87923 +! +program p + open (1, carriagecontrol=char(1000,4)) ! { dg-error "must be a character string of default kind" } + open (2, share=char(1000,4)) ! { dg-error "must be a character string of default kind" } +end Index: Fortran/gfortran/regression/io_constraints_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_2.f90 @@ -0,0 +1,75 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Part II of the test of the IO constraints patch, which fixes PRs: +! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862. +! Modified2006-07-08 to check the patch for PR20844. +! +! Contributed by Paul Thomas +! + +module global + + integer :: modvar + namelist /NL/ modvar + +contains + + subroutine foo (i) + integer :: i + write (*, 100) i + 100 format (1h , "i=", i6) ! { dg-warning "H format specifier" } + end subroutine foo + +end module global + + use global + integer :: a,b, c(20) + integer(8) :: ierr + character(80) :: buffer(3) + + +! Appending to a USE associated namelist is an extension. + + NAMELIST /NL/ a,b ! { dg-error "already is USE associated" } + + a=1 ; b=2 + + write(*, NML=NL) z ! { dg-error "followed by IO-list" } +!Was correctly picked up before patch. + print NL, z ! { dg-error "PRINT namelist at \\(1\\) is an extension" } +! +! Not allowed with internal unit +!Was correctly picked up before patch. + write(buffer, NML=NL) ! { dg-error "Internal file at \\(1\\) with namelist" } +!Was correctly picked up before patch. + write(buffer, fmt='(i6)', REC=10) a ! { dg-error "REC tag" } + write(buffer, fmt='(i6)', END=10) a ! { dg-error "END tag" } + +! Not allowed with REC= specifier +!Was correctly picked up before patch. + read(10, REC=10, END=100) ! { dg-error "END tag is not allowed" } + write(*, *, REC=10) ! { dg-error "FMT=" } + +! Not allowed with an ADVANCE=specifier + READ(buffer, fmt='(i6)', advance='YES') a ! { dg-error "internal file" } + READ(1, NML=NL, advance='YES') ! { dg-error "NAMELIST IO is not allowed" } + + READ(1, fmt='(i6)', advance='NO', size = ierr) ! { dg-error "requires default INTEGER" } + + READ(1, advance='YES') ! { dg-error "must appear with an explicit format" } + + write(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "output" } + write(1, fmt='(i6)', advance='YES', eor = 100) a ! { dg-error "output" } + + read(1, fmt='(i6)', advance='YES', size = c(1)) a ! { dg-error "ADVANCE = 'NO'" } + read(1, fmt='(i6)', advance='YES', eor = 100) a ! { dg-error "ADVANCE = 'NO'" } + + READ(1, fmt='(i6)', advance='NO', size = buffer) a ! { dg-error "INTEGER" } +!Was correctly picked up before patch. -correct syntax error + READ(1, fmt='(i6)', advance='YES', size = 10) a ! { dg-error "Invalid value for SIZE specification" } + + READ(1, fmt='(i6)', advance='MAYBE') ! { dg-error "YES or NO" } + +100 continue +200 format (2i6) + END Index: Fortran/gfortran/regression/io_constraints_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_3.f90 @@ -0,0 +1,192 @@ +! Test some restrictions on the specifiers of OPEN and CLOSE statements. +! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr) +! +! { dg-do compile } +! { dg-options "-ffree-line-length-none -pedantic -fmax-errors=50" } + integer,parameter :: mone = -1, zero = 0 + character(len=*),parameter :: foo = "foo" + character(len=20) :: str + integer :: u + +! Test for warnings, when IOSTAT is used + + open(10, iostat=u,access="sequential ") + open(10, iostat=u,access="sequential u") ! { dg-warning "ACCESS specifier in OPEN statement" } + open(10, iostat=u,access=foo) ! { dg-warning "ACCESS specifier in OPEN statement" } + open(10, iostat=u,access="direct") + open(10, iostat=u,access="stream") + open(10, iostat=u,access="append") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + + open(10, iostat=u,action="read") + open(10, iostat=u,action="write") + open(10, iostat=u,action="readwrite") + open(10, iostat=u,action=foo) ! { dg-warning "ACTION specifier in OPEN statement" } + + open(10, iostat=u,blank="ZERO") + open(10, iostat=u,blank="nUlL") + open(10, iostat=u,blank="NULLL") ! { dg-warning "BLANK specifier in OPEN statement" } + + open(10, iostat=u,delim="apostrophe") + open(10, iostat=u,delim="quote") + open(10, iostat=u,delim="none") + open(10, iostat=u,delim="") ! { dg-warning "DELIM specifier in OPEN statement" } + + open(10, iostat=u,form="formatted") + open(10, iostat=u,form="unformatted") + open(10, iostat=u,form="default") ! { dg-warning "FORM specifier in OPEN statement" } + + open(10, iostat=u,pad="yes") + open(10, iostat=u,pad="no") + open(10, iostat=u,pad=foo) ! { dg-warning "PAD specifier in OPEN statement" } + + open(10, iostat=u,position="asis") + open(10, iostat=u,position="rewind") + open(10, iostat=u,position="append") + open(10, iostat=u,position=foo) ! { dg-warning "POSITION specifier in OPEN statement" } + + open(10, iostat=u,recl="ee") ! { dg-error "must be of type INTEGER" } + open(10, iostat=u,recl=0.4) ! { dg-error "must be of type INTEGER" } + open(10, iostat=u,recl=zero) ! { dg-warning "must be positive" } + open(10, iostat=u,recl=mone) ! { dg-warning "must be positive" } + + open(10, iostat=u,status="unknown") + open(10, iostat=u,status="old") + open(10, iostat=u,status=foo) ! { dg-warning "STATUS specifier in OPEN statement" } + + open(10, iostat=u,status="new") ! { dg-warning "no FILE specifier is present" } + open(10, iostat=u,status="replace ") ! { dg-warning "no FILE specifier is present" } + open(10, iostat=u,status="scratch",file=str) ! { dg-warning "cannot have the value SCRATCH if a FILE specifier is present" } + + open(10, iostat=u,form="unformatted",delim="none") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + open(10, iostat=u,form="unformatted",pad="yes") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + open(10, iostat=u,form="unformatted",blank="null") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + + open(10, iostat=u,access="direct",position="append") ! { dg-warning "only allowed for stream or sequential ACCESS" } + + close(10, iostat=u,status="keep") + close(10, iostat=u,status="delete") + close(10, iostat=u,status=foo) ! { dg-warning "STATUS specifier in CLOSE statement" } + close(iostat=u) ! { dg-error "requires a UNIT number" } + + + +! Test for warnings, when an ERR label is specified + + open(10, err=99,access="sequential ") + open(10, err=99,access="sequential u") ! { dg-warning "ACCESS specifier in OPEN statement" } + open(10, err=99,access=foo) ! { dg-warning "ACCESS specifier in OPEN statement" } + open(10, err=99,access="direct") + open(10, err=99,access="stream") + open(10, err=99,access="append") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + + open(10, err=99,action="read") + open(10, err=99,action="write") + open(10, err=99,action="readwrite") + open(10, err=99,action=foo) ! { dg-warning "ACTION specifier in OPEN statement" } + + open(10, err=99,blank="ZERO") + open(10, err=99,blank="nUlL") + open(10, err=99,blank="NULLL") ! { dg-warning "BLANK specifier in OPEN statement" } + + open(10, err=99,delim="apostrophe") + open(10, err=99,delim="quote") + open(10, err=99,delim="none") + open(10, err=99,delim="") ! { dg-warning "DELIM specifier in OPEN statement" } + + open(10, err=99,form="formatted") + open(10, err=99,form="unformatted") + open(10, err=99,form="default") ! { dg-warning "FORM specifier in OPEN statement" } + + open(10, err=99,pad="yes") + open(10, err=99,pad="no") + open(10, err=99,pad=foo) ! { dg-warning "PAD specifier in OPEN statement" } + + open(10, err=99,position="asis") + open(10, err=99,position="rewind") + open(10, err=99,position="append") + open(10, err=99,position=foo) ! { dg-warning "POSITION specifier in OPEN statement" } + + open(10, err=99,recl="ee") ! { dg-error "must be of type INTEGER" } + open(10, err=99,recl=0.4) ! { dg-error "must be of type INTEGER" } + open(10, err=99,recl=zero) ! { dg-warning "must be positive" } + open(10, err=99,recl=mone) ! { dg-warning "must be positive" } + + open(10, err=99,status="unknown") + open(10, err=99,status="old") + open(10, err=99,status=foo) ! { dg-warning "STATUS specifier in OPEN statement" } + + open(10, err=99,status="new") ! { dg-warning "no FILE specifier is present" } + open(10, err=99,status="replace ") ! { dg-warning "no FILE specifier is present" } + open(10, err=99,status="scratch",file=str) ! { dg-warning "cannot have the value SCRATCH if a FILE specifier is present" } + + open(10, err=99,form="unformatted",delim="none") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + open(10, err=99,form="unformatted",pad="yes") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + open(10, err=99,form="unformatted",blank="null") ! { dg-warning "not allowed in OPEN statement for unformatted I/O" } + + open(10, err=99,access="direct",position="append") ! { dg-warning "only allowed for stream or sequential ACCESS" } + + close(10, err=99,status="keep") + close(10, err=99,status="delete") + close(10, err=99,status=foo) ! { dg-warning "STATUS specifier in CLOSE statement" } + + 99 continue + +! Test for errors + + open(10,access="sequential ") + open(10,access="sequential u") ! { dg-error "ACCESS specifier in OPEN statement" } + open(10,access=foo) ! { dg-error "ACCESS specifier in OPEN statement" } + open(10,access="direct") + open(10,access="stream") + open(10,access="append") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + + open(10,action="read") + open(10,action="write") + open(10,action="readwrite") + open(10,action=foo) ! { dg-error "ACTION specifier in OPEN statement" } + + open(10,blank="ZERO") + open(10,blank="nUlL") + open(10,blank="NULLL") ! { dg-error "BLANK specifier in OPEN statement" } + + open(10,delim="apostrophe") + open(10,delim="quote") + open(10,delim="none") + open(10,delim="") ! { dg-error "DELIM specifier in OPEN statement" } + + open(10,form="formatted") + open(10,form="unformatted") + open(10,form="default") ! { dg-error "FORM specifier in OPEN statement" } + + open(10,pad="yes") + open(10,pad="no") + open(10,pad=foo) ! { dg-error "PAD specifier in OPEN statement" } + + open(10,position="asis") + open(10,position="rewind") + open(10,position="append") + open(10,position=foo) ! { dg-error "POSITION specifier in OPEN statement" } + + open(10,recl="ee") ! { dg-error "must be of type INTEGER" } + open(10,recl=0.4) ! { dg-error "must be of type INTEGER" } + open(10,recl=zero) ! { dg-error "must be positive" } + open(10,recl=mone) ! { dg-error "must be positive" } + + open(10,status="unknown") + open(10,status="old") + open(10,status=foo) ! { dg-error "STATUS specifier in OPEN statement" } + + open(10,status="new") ! { dg-error "no FILE specifier is present" } + open(10,status="replace ") ! { dg-error "no FILE specifier is present" } + open(10,status="scratch",file=str) ! { dg-error "cannot have the value SCRATCH if a FILE specifier is present" } + + open(10,form="unformatted",delim="none") ! { dg-error "not allowed in OPEN statement for unformatted I/O" } + open(10,form="unformatted",pad="yes") ! { dg-error "not allowed in OPEN statement for unformatted I/O" } + open(10,form="unformatted",blank="null") ! { dg-error "not allowed in OPEN statement for unformatted I/O" } + + open(10,access="direct",position="append") ! { dg-error "only allowed for stream or sequential ACCESS" } + + close(10,status="keep") + close(10,status="delete") + close(10,status=foo) ! { dg-error "STATUS specifier in CLOSE statement" } +end Index: Fortran/gfortran/regression/io_constraints_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR33268 [patch,fortran] read ('(f3.3)'), a rejected due to the extra (...) + +write(*,('(a)')) 'Hello' +write (*,'(f8.3)'), 3.14 ! { dg-warning "Comma before i/o item list" } +print ('(a)'), "valid" +read ('(f3.3)'), a +read (*, '(f3.3)'), a ! { dg-warning "Comma before i/o item list" } +write ('(a)'), "invalid" ! { dg-error "Invalid form of WRITE statement" } +end Index: Fortran/gfortran/regression/io_constraints_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_5.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR 38425 I/O: POS= compile-time diagnostics +!---------------------------------------------------------- +character(len=30) :: str +open(3,access='stream') + +! C919 (R913) If io-unit is not a file-unit-number, the +! io-control-spec-list shall not contain a REC= specifier +! or a POS= specifier. +write(str,*, pos=4) 5 ! { dg-error "incompatible with internal" } + +! C927 (R913) If a POS= specifier appears, the +! io-control-spec-list shall not contain a REC= specifier. +write(3,pos=5,rec=4) 5 ! { dg-error "POS= is not allowed with REC=" } +write(3,rec=4,pos=5) 5 ! { dg-error "POS= is not allowed with REC=" } + +!Fortran runtime error: REC=specifier not allowed with STREAM access +write(3,rec=4) 5 +!Fortran runtime error: REC=specifier must be positive +write(3,rec=-3) 44 +!Fortran runtime error: POS=specifier must be positive +write(3,pos=-4) 44 +end Index: Fortran/gfortran/regression/io_constraints_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_6.f03 @@ -0,0 +1,38 @@ +! { dg-do compile } + +! PR fortran/45776 +! Variable definition context checks related to IO. + +! Contributed by Daniel Kraft, d@domob.eu. + +module m + implicit none + + integer, protected :: a + character(len=128), protected :: str +end module m + +program main + use :: m + integer, parameter :: b = 42 + integer :: x + character(len=128) :: myStr + + namelist /definable/ x, myStr + namelist /undefinable/ x, a + + ! These are invalid. + read (myStr, *) a ! { dg-error "variable definition context" } + read (myStr, *) x, b ! { dg-error "variable definition context" } + write (str, *) 5 ! { dg-error "variable definition context" } + read (*, nml=undefinable) ! { dg-error "contains the symbol 'a' which may not" } + + ! These are ok. + read (str, *) x + write (myStr, *) a + write (myStr, *) b + print *, a, b + write (*, nml=undefinable) + read (*, nml=definable) + write (*, nml=definable) +end program main Index: Fortran/gfortran/regression/io_constraints_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_7.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } + +! PR fortran/45776 +! Variable definition context checks related to IO. + +! Contributed by Daniel Kraft, d@domob.eu. + +module m + implicit none + integer, protected :: a + character(len=128), protected :: msg +end module m + +program main + use :: m + integer :: x + logical :: bool + + write (*, iostat=a) 42 ! { dg-error "variable definition context" } + write (*, iomsg=msg) 42 ! { dg-error "variable definition context" } + read (*, '(I2)', advance='no', size=a) x ! { dg-error "variable definition context" } + + ! These are ok. + inquire (unit=a) + inquire (file=msg, id=a, pending=bool) + inquire (file=msg) + + ! These not, but list is not extensive. + inquire (unit=1, number=a) ! { dg-error "variable definition context" } + inquire (unit=1, encoding=msg) ! { dg-error "variable definition context" } + inquire (unit=1, formatted=msg) ! { dg-error "variable definition context" } + + open (newunit=a, file="foo") ! { dg-error "variable definition context" } + close (unit=a) +end program main Index: Fortran/gfortran/regression/io_constraints_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_8.f90 @@ -0,0 +1,72 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=100 -Wall" } +! +! PR fortran/48972 +! +! +! All string arguments to I/O statements shall +! be of default-character type. (Except for the +! internal unit.) +! + +character(len=30, kind=4) :: str1 +integer :: i + +OPEN(99, access=4_'direct') ! { dg-error "must be a character string of default kind" } +OPEN(99, action=4_'read') ! { dg-error "must be a character string of default kind" } +OPEN(99, asynchronous=4_'no') ! { dg-error "must be a character string of default kind" } +OPEN(99, blank=4_'null') ! { dg-error "must be a character string of default kind" } +OPEN(99, decimal=4_'comma') ! { dg-error "must be a character string of default kind" } +OPEN(99, delim=4_'quote') ! { dg-error "must be a character string of default kind" } +OPEN(99, encoding=4_'default') ! { dg-error "must be a character string of default kind" } +OPEN(99, file=4_'Test.dat') ! { dg-error "must be a character string of default kind" } +OPEN(99, form=4_'formatted') ! { dg-error "must be a character string of default kind" } +OPEN(99, pad=4_'yes') ! { dg-error "must be a character string of default kind" } +OPEN(99, position=4_'asis') ! { dg-error "must be a character string of default kind" } +OPEN(99, round=4_'down') ! { dg-error "must be a character string of default kind" } +OPEN(99, sign=4_'plus') ! { dg-error "must be a character string of default kind" } +OPEN(99, status=4_'old') ! { dg-error "must be a character string of default kind" } +OPEN(99, IOSTAT=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } + +close(99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } +close(99, status=4_'delete') ! { dg-error "must be a character string of default kind" } + +write(99, '(a)', advance=4_'no')! { dg-error "must be a character string of default kind" } +read (99, *, blank=4_'null') ! { dg-error "must be a character string of default kind" } +write(99, *, decimal=4_'comma') ! { dg-error "must be a character string of default kind" } +write(99, *, delim=4_'quote') ! { dg-error "must be a character string of default kind" } +read (99, *, pad=4_'yes') ! { dg-error "must be a character string of default kind" } +write(99, *, round=4_'down') ! { dg-error "must be a character string of default kind" } +write(99, *, sign=4_'plus') ! { dg-error "must be a character string of default kind" } + +wait(99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } + +endfile (99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } +backspace(99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } +rewind (99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } +flush (99, iostat=i, iomsg=str1) ! { dg-error "must be a character string of default kind" } + +inquire (file=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,access=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,action=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,asynchronous=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,blank=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,decimal=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,delim=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,direct=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,encoding=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,form=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,formatted=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,iomsg=str1, iostat=i) ! { dg-error "must be a character string of default kind" } +inquire (99,name=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,pad=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,position=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,read=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,readwrite=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,round=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,sequential=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,sign=str1) ! { dg-error "must be a character string of default kind" } +!inquire (99,stream=str1) ! Fails due to PR 48976 +inquire (99,unformatted=str1) ! { dg-error "must be a character string of default kind" } +inquire (99,write=str1) ! { dg-error "must be a character string of default kind" } +end Index: Fortran/gfortran/regression/io_constraints_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_constraints_9.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/48972 +! +! All string arguments to I/O statements shall +! be of default-character type. (Except for the +! internal unit.) +! +character(len=20, kind=4) :: str1 + +write(99, str1) 'a' ! { dg-error "must be of type default-kind CHARACTER" } +read(99, fmt=str1) ! { dg-error "must be of type default-kind CHARACTER" } +end Index: Fortran/gfortran/regression/io_err_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_err_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-shouldfail "Compile-time specifier checking" } +! +! Contributed by Dominique Dhumieres +program read + character(50) :: buf='0.D99999' + double precision val + read (UNIT=buf, FMT='(D60.0)', ERR=10) Val + STOP 1 +10 read (UNIT=buf, FMT='(D60.0)') Val +end program read +! { dg-output "At line 10 of file.*" } +! { dg-output "Fortran runtime error: Bad value during floating point read" } + Index: Fortran/gfortran/regression/io_invalid_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_invalid_1.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/20842 +WRITE(UNIT=6,END=999) 0 ! { dg-error "END tag .* not allowed in output statement" } +999 CONTINUE +END Index: Fortran/gfortran/regression/io_real_boz.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_real_boz.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! Test reading/writing of integer, real and character BOZ +! non-integer BOZ are not valid in standard Fortran, however. +! PR fortran/29625 +program real_boz + implicit none + integer(4) :: i,i2 + real(4) :: r,r2 + complex(4) :: z,z2 + character :: c,c2 + character(len=100) :: str,fmt + + i = 43 + r = 325.56 + z = cmplx(14.456, 345342.456) + c ='g' + + write(str,'(b0)') i + write(fmt,'(a,i0,a)') '(b',len_trim(str),')' + read(str,fmt) i2 + if(i /= i2) STOP 1 + + write(str,'(o0)') i + write(fmt,'(a,i0,a)') '(o',len_trim(str),')' + read(str,fmt) i2 + if(i /= i2) STOP 2 + + write(str,'(z0)') i + write(fmt,'(a,i0,a)') '(z',len_trim(str),')' + read(str,fmt) i2 + if(i /= i2) STOP 3 + + + write(str,'(b0)') r + write(fmt,'(a,i0,a)') '(b',len_trim(str),')' + read(str,fmt) r2 + if(r /= r2) STOP 4 + + write(str,'(o0)') r + write(fmt,'(a,i0,a)') '(o',len_trim(str),')' + read(str,fmt) r2 + if(r /= r2) STOP 5 + + write(str,'(z0)') r + write(fmt,'(a,i0,a)') '(z',len_trim(str),')' + read(str,fmt) r2 + if(r /= r2) STOP 6 + + + write(str,'(b0)') c + write(fmt,'(a,i0,a)') '(b',len_trim(str),')' + read(str,fmt) c2 + if(c /= c2) STOP 7 + + write(str,'(o0)') c + write(fmt,'(a,i0,a)') '(o',len_trim(str),')' + read(str,fmt) c2 + if(c /= c2) STOP 8 + + write(str,'(z0)') c + write(fmt,'(a,i0,a)') '(z',len_trim(str),')' + read(str,fmt) c2 + if(c /= c2) STOP 9 + +end program real_boz + Index: Fortran/gfortran/regression/io_real_boz2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_real_boz2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-shouldfail "Real BOZ not allowed" } +! { dg-options "-std=f2003" } +! Test for invalid (F95/F2003) writing of real with octal edit descriptor +! PR fortran/29625 +program real_boz + implicit none + real(4) :: r + character(len=100) :: str + + r = 325.56 + write(str,'(o0)') r +end program real_boz +! { dg-output "At line 12 .*" } +! { dg-output "Expected INTEGER .* in formatted transfer, got REAL" } Index: Fortran/gfortran/regression/io_real_boz_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_real_boz_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-std=f2008" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/51407 +! +! Fortran 2008 allows BOZ edit descriptors for real/complex. +! + real(kind=4) :: x + complex(kind=4) :: z + character(len=64) :: str1 + + x = 1.0_16 + 2.0_16**(-105) + z = cmplx (1.0, 2.0) + + write (str1,'(b32)') x + read (str1,'(b32)') x + write (str1,'(o32)') x + read (str1,'(o32)') x + write (str1,'(z32)') x + read (str1,'(z32)') x + write (str1,'(b0)') x + write (str1,'(o0)') x + write (str1,'(z0)') x + + write (str1,'(2b32)') z + read (str1,'(2b32)') z + write (str1,'(2o32)') z + read (str1,'(2o32)') z + write (str1,'(2z32)') z + read (str1,'(2z32)') z + write (str1,'(2b0)') z + write (str1,'(2o0)') z + write (str1,'(2z0)') z + end Index: Fortran/gfortran/regression/io_real_boz_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_real_boz_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=f2003" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/51407 +! +! Valid in F2008, but in F95/F2003: +! { dg-output "Expected INTEGER for item 1 in formatted transfer, got REAL" } +! { dg-shouldfail "Only F2003: BOZ edit with REAL" } +! + real(kind=16) :: x + character(len=32) :: str1 + x = 1.0_16 + 2.0_16**(-105) + write (str1,'(z32)') x + write (str1,'(z0)') x + end Index: Fortran/gfortran/regression/io_real_boz_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_real_boz_5.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-std=f2008" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/51407 +! +! Invalid in F2008 (accepted with -std=gnu) +! { dg-output "Expected numeric type for item 1 in formatted transfer, got CHARACTER" } +! { dg-shouldfail "Character type in BOZ" } +! + character(len=32) :: str1 + x = 1.0_16 + 2.0_16**(-105) + write (str1,'(z0)') 'X' + end Index: Fortran/gfortran/regression/io_tags_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + + +backspace (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg='') ! { dg-error "Non-variable expression" } +backspace (1, iomsg='no') ! { dg-error "Non-variable expression" } +backspace (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +backspace (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } +backspace (1, iomsg=['no']) ! { dg-error "IOMSG tag at ... must be scalar" } +end Index: Fortran/gfortran/regression/io_tags_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_10.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +write (1, blank='') ! { dg-error "BLANK specifier in WRITE statement at ... has invalid value" } + +write (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in WRITE statement at ... has invalid value" } +write (1, asynchronous='no') +write (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +write (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" } + +write (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank='no') ! { dg-error "BLANK specifier in WRITE statement at ... has invalid value" } +write (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +write (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" } + +write (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim='') ! { dg-error "DELIM specifier in WRITE statement at ... has invalid value" } +write (1, delim='no') ! { dg-error "DELIM specifier in WRITE statement at ... has invalid value" } +write (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +write (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" } + +write (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal='') ! { dg-error "DECIMAL specifier in WRITE statement at ... has invalid value" } +write (1, decimal='no') ! { dg-error "DECIMAL specifier in WRITE statement at ... has invalid value" } +write (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +write (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" } + +write (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg='') ! { dg-error "Non-variable expression" } +write (1, iomsg='no') ! { dg-error "Non-variable expression" } +write (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +write (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } + +write (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad='') ! { dg-error "PAD specifier in WRITE statement at ... has invalid value" } +write (1, pad='no') ! { dg-error "the PAD= specifier at ... must be with an explicit format expression" } +write (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +write (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" } + +write (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round='') ! { dg-error "ROUND specifier in WRITE statement at ... has invalid value" } +write (1, round='no') ! { dg-error "ROUND specifier in WRITE statement at ... has invalid value" } +write (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +write (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" } + +write (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign='') ! { dg-error "SIGN specifier in WRITE statement at ... has invalid value" } +write (1, sign='no') ! { dg-error "SIGN specifier in WRITE statement at ... has invalid value" } +write (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +write (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" } + +end Index: Fortran/gfortran/regression/io_tags_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +close (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg='') ! { dg-error "Non-variable expression" } +close (1, iomsg='no') ! { dg-error "Non-variable expression" } +close (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +close (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } +close (1, iomsg=['no']) ! { dg-error "IOMSG tag at ... must be scalar" } + +close (1, status=1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=1e1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=1d1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=.false.) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status='') ! { dg-error "STATUS specifier in CLOSE statement at ... has invalid value" } +close (1, status='no') ! { dg-error "STATUS specifier in CLOSE statement at ... has invalid value" } +close (1, status=null()) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=(1)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=(1., 0.)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=[1]) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +close (1, status=['']) ! { dg-error "STATUS tag at ... must be scalar" } +end Index: Fortran/gfortran/regression/io_tags_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +endfile (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg='') ! { dg-error "Non-variable expression" } +endfile (1, iomsg='no') ! { dg-error "Non-variable expression" } +endfile (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +endfile (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } +end Index: Fortran/gfortran/regression/io_tags_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +flush (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg='') ! { dg-error "Non-variable expression" } +flush (1, iomsg='no') ! { dg-error "Non-variable expression" } +flush (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +flush (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } +end Index: Fortran/gfortran/regression/io_tags_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_5.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +inquire (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg='') ! { dg-error "Non-variable expression" } +inquire (1, iomsg='no') ! { dg-error "Non-variable expression" } +inquire (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +inquire (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } +end Index: Fortran/gfortran/regression/io_tags_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_6.f90 @@ -0,0 +1,175 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +open (1, access=1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=1e1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=1d1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=.false.) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access='') ! { dg-error "ACCESS specifier in OPEN statement at ... has invalid value" } +open (1, access='no') ! { dg-error "ACCESS specifier in OPEN statement at ... has invalid value" } +open (1, access=null()) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=(1)) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=(1., 0.)) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=[1]) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" } +open (1, access=['']) ! { dg-error "ACCESS tag at ... must be scalar" } + +open (1, action=1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=1e1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=1d1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=.false.) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action='') ! { dg-error "ACTION specifier in OPEN statement at ... has invalid value" } +open (1, action='no') ! { dg-error "ACTION specifier in OPEN statement at ... has invalid value" } +open (1, action=null()) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=(1)) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=(1., 0.)) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=[1]) ! { dg-error "ACTION tag at ... must be of type CHARACTER" } +open (1, action=['']) ! { dg-error "ACTION tag at ... must be scalar" } + +open (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in OPEN statement at ... has invalid value" } +open (1, asynchronous='no') +open (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +open (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" } + +open (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank='') ! { dg-error "BLANK specifier in OPEN statement at ... has invalid value" } +open (1, blank='no') ! { dg-error "BLANK specifier in OPEN statement at ... has invalid value" } +open (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +open (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" } + +open (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim='') ! { dg-error "DELIM specifier in OPEN statement at ... has invalid value" } +open (1, delim='no') ! { dg-error "DELIM specifier in OPEN statement at ... has invalid value" } +open (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +open (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" } + +open (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal='') ! { dg-error "DECIMAL specifier in OPEN statement at ... has invalid value" } +open (1, decimal='no') ! { dg-error "DECIMAL specifier in OPEN statement at ... has invalid value" } +open (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +open (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" } + +open (1, encoding=1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=1e1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=1d1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=.false.) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding='') ! { dg-error "ENCODING specifier in OPEN statement at ... has invalid value" } +open (1, encoding='no') ! { dg-error "ENCODING specifier in OPEN statement at ... has invalid value" } +open (1, encoding=null()) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=(1)) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=(1., 0.)) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=[1]) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" } +open (1, encoding=['']) ! { dg-error "ENCODING tag at ... must be scalar" } + +open (1, form=1) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=1e1) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=1d1) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=.false.) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form='') ! { dg-error "FORM specifier in OPEN statement at ... has invalid value" } +open (1, form='no') ! { dg-error "FORM specifier in OPEN statement at ... has invalid value" } +open (1, form=null()) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=(1)) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=(1., 0.)) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=[1]) ! { dg-error "FORM tag at ... must be of type CHARACTER" } +open (1, form=['']) ! { dg-error "FORM tag at ... must be scalar" } + +open (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg='') ! { dg-error "Non-variable expression" } +open (1, iomsg='no') ! { dg-error "Non-variable expression" } +open (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +open (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } + +open (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad='') ! { dg-error "PAD specifier in OPEN statement at ... has invalid value" } +open (1, pad='no') +open (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +open (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" } + +open (1, position=1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=1e1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=1d1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=.false.) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position='') ! { dg-error "POSITION specifier in OPEN statement at ... has invalid value" } +open (1, position='no') ! { dg-error "POSITION specifier in OPEN statement at ... has invalid value" } +open (1, position=null()) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=(1)) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=(1., 0.)) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=[1]) ! { dg-error "POSITION tag at ... must be of type CHARACTER" } +open (1, position=['']) ! { dg-error "POSITION tag at ... must be scalar" } + +open (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round='') ! { dg-error "ROUND specifier in OPEN statement at ... has invalid value" } +open (1, round='no') ! { dg-error "ROUND specifier in OPEN statement at ... has invalid value" } +open (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +open (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" } + +open (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign='') ! { dg-error "SIGN specifier in OPEN statement at ... has invalid value" } +open (1, sign='no') ! { dg-error "SIGN specifier in OPEN statement at ... has invalid value" } +open (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +open (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" } + +open (1, status=1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=1e1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=1d1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=.false.) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status='') ! { dg-error "STATUS specifier in OPEN statement at ... has invalid value" } +open (1, status='no') ! { dg-error "STATUS specifier in OPEN statement at ... has invalid value" } +open (1, status=null()) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=(1)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=(1., 0.)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=[1]) ! { dg-error "STATUS tag at ... must be of type CHARACTER" } +open (1, status=['']) ! { dg-error "STATUS tag at ... must be scalar" } + + +end Index: Fortran/gfortran/regression/io_tags_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_7.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +read (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in READ statement at ... has invalid value" } +read (1, asynchronous='no') +read (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" } +read (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" } + +read (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank='') ! { dg-error "BLANK specifier in READ statement at ... has invalid value" } +read (1, blank='no') ! { dg-error "BLANK specifier in READ statement at ... has invalid value" } +read (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" } +read (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" } + +read (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim='') ! { dg-error "DELIM specifier in READ statement at ... has invalid value" } +read (1, delim='no') ! { dg-error "DELIM specifier in READ statement at ... has invalid value" } +read (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" } +read (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" } + +read (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal='') ! { dg-error "DECIMAL specifier in READ statement at ... has invalid value" } +read (1, decimal='no') ! { dg-error "DECIMAL specifier in READ statement at ... has invalid value" } +read (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" } +read (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" } + +read (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg='') ! { dg-error "Non-variable expression" } +read (1, iomsg='no') ! { dg-error "Non-variable expression" } +read (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +read (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } + +read (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad='') ! { dg-error "PAD specifier in READ statement at ... has invalid value" } +read (1, pad='no') ! { dg-error "the PAD= specifier at ... must be with an explicit format expression" } +read (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" } +read (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" } + +read (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round='') ! { dg-error "ROUND specifier in READ statement at ... has invalid value" } +read (1, round='no') ! { dg-error "ROUND specifier in READ statement at ... has invalid value" } +read (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" } +read (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" } + +read (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign='') ! { dg-error "SIGN specifier in READ statement at ... has invalid value" } +read (1, sign='no') ! { dg-error "SIGN specifier in READ statement at ... has invalid value" } +read (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" } +read (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" } + + +end Index: Fortran/gfortran/regression/io_tags_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +rewind (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg='') ! { dg-error "Non-variable expression" } +rewind (1, iomsg='no') ! { dg-error "Non-variable expression" } +rewind (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +rewind (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } + +end Index: Fortran/gfortran/regression/io_tags_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/io_tags_9.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923. +! + +wait (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg='') ! { dg-error "Non-variable expression" } +wait (1, iomsg='no') ! { dg-error "Non-variable expression" } +wait (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" } +wait (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" } + +end Index: Fortran/gfortran/regression/iomsg_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iomsg_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Test implementation of the iomsg tag. +program iomsg_test + character(len=70) ch + + ! Test that iomsg is left unchanged with no error + ch = 'asdf' + open(10, status='scratch', iomsg=ch, iostat=i) + if (ch .ne. 'asdf') STOP 1 + + ! Test iomsg with data transfer statement + read(10,'(I2)', iomsg=ch, end=100) k + STOP 2 +100 continue + if (ch .ne. 'End of file') STOP 3 + + ! Test iomsg with open + open (-3, err=200, iomsg=ch) + + STOP 4 +200 continue + if (ch .ne. 'Bad unit number in OPEN statement') STOP 5 + + ! Test iomsg with close + close(23,status="no_idea", err=500, iomsg=ch) ! { dg-warning "STATUS specifier in CLOSE statement.*has invalid value" } +500 continue + if (ch .ne. "Bad STATUS parameter in CLOSE statement") STOP 6 +end program iomsg_test Index: Fortran/gfortran/regression/iomsg_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iomsg_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +subroutine foo1 + implicit none + integer i + open(1, iomsg=666) ! { dg-error "must be of type CHARACTER" } + open(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + open(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + close(1, iomsg=666) ! { dg-error "must be of type CHARACTER" } + close(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + close(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } +end subroutine foo1 + +subroutine foo + implicit none + integer i + real :: x = 1 + write(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" } + write(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" } + read(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" } + read(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" } + flush(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + flush(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + rewind(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + rewind(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + backspace(1,iomsg='sgk') ! { dg-error "Non-variable expression" } + backspace(1,iomsg=i) ! { dg-error "must be of type CHARACTER" } + wait(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + wait(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } +end subroutine foo + +subroutine bar + implicit none + integer i + real :: x = 1 + character(len=20) s(2) + open(1, iomsg=s) ! { dg-error "must be scalar" } + close(1, iomsg=s) ! { dg-error "must be scalar" } + write(1, *, iomsg=s) x ! { dg-error "must be scalar" } + read(1, *, iomsg=s) x ! { dg-error "must be scalar" } + flush(1, iomsg=s) ! { dg-error "must be scalar" } + rewind(1, iomsg=s) ! { dg-error "must be scalar" } + backspace(1,iomsg=s) ! { dg-error "must be scalar" } + wait(1, iomsg=s) ! { dg-error "must be scalar" } +end subroutine bar Index: Fortran/gfortran/regression/iostat_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iostat_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 23598 - The iostat variable wasn't reset if the previous +! I/O library call had an error. +program main + implicit none + integer :: ios, i + open (10, pad='no', status='scratch') + write (10, '(A)') '1','1' + rewind (10) + read (10,'(I2)',iostat=ios) i + ios = -4321 + read (10, '(I1)', iostat=ios) i + if (ios /= 0) STOP 1 +end program main Index: Fortran/gfortran/regression/iostat_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iostat_2.f90 @@ -0,0 +1,8 @@ +! PR libfortran/23784 +! { dg-do run } + integer i + close(10, status="whatever", iostat=i) ! { dg-warning "STATUS specifier in CLOSE statement.*has invalid value" } + if (i == 0) STOP 1 + write(17,*) 'foo' + close(17, status="delete") + end Index: Fortran/gfortran/regression/iostat_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iostat_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Testcase for PR libfortran/25068 + real :: u + integer(kind=8) :: i + open (10,status="scratch") + read (10,*,iostat=i) u ! { dg-error "Fortran 95 requires default INTEGER in IOSTAT tag" } + close (10,iostat=i) ! { dg-error "Fortran 95 requires default INTEGER in IOSTAT tag" } + end Index: Fortran/gfortran/regression/iostat_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iostat_4.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR31201 Too large unit number generates wrong code +! This tests initialization of the IOSTAT variable + integer :: i + character(len=50) :: str + write (2_8*int(huge(0_4),kind=8)+9_8, iostat=i, iomsg=str) 555 + if (i.ne.5005) STOP 1 + if (str.ne."Unit number in I/O statement too large") STOP 2 + end \ No newline at end of file Index: Fortran/gfortran/regression/iostat_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iostat_5.f90 @@ -0,0 +1,16 @@ +! PR libfortran/101255 +! { dg-do run } + +program test + use ISO_FORTRAN_ENV, only: IOSTAT_EOR, IOSTAT_END + implicit none + character(len=50) :: err + integer :: i + + err = "" + flush(99, iostat=i, iomsg=err) + + if (err == "") stop 1 + if (i >= 0) stop 2 + if (i == IOSTAT_EOR .or. i == IOSTAT_END) stop 3 +end Index: Fortran/gfortran/regression/ipa-sra-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ipa-sra-1.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-O2 -fno-inline -fno-ipa-cp -fwhole-program -fdump-ipa-sra-details" } + +module foo + implicit none +contains + subroutine bar(a,x) + real, dimension(:,:), intent(in) :: a + real, intent(out) :: x + integer :: i,j + + x = 0 + do j=1,ubound(a,2) + do i=1,ubound(a,1) + x = x + a(i,j)**2 + end do + end do + end subroutine bar +end module foo + +program main + use foo + implicit none + real, dimension(2,3) :: a + real :: x + integer :: i + + data a /1.0, 2.0, 3.0, -1.0, -2.0, -3.0/ + + do i=1,2000000 + call bar(a,x) + end do + print *,x +end program main + +! { dg-final { scan-ipa-dump "Created new node.*bar\\.isra" "sra" } } +! { dg-final { scan-ipa-dump-times "IPA_PARAM_OP_SPLIT" 7 "sra" } } Index: Fortran/gfortran/regression/ipcp-array-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ipcp-array-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-ipa-cp-details -fno-inline -fdump-tree-optimized" } + +subroutine bar (a, b, n) + integer :: a(n), b(n) + call foo (a, b) +contains +subroutine foo (a, b) + integer :: a(:), b(:) + a = b +end subroutine +end + +! { dg-final { scan-ipa-dump "Creating a specialized node of foo" "cp" } } +! { dg-final { scan-ipa-dump-times "Aggregate replacements\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=" 2 "cp" } } +! { dg-final { scan-tree-dump-not "stride;" "optimized" } } +! { dg-final { scan-tree-dump-not "lbound;" "optimized" } } Index: Fortran/gfortran/regression/ipcp-array-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ipcp-array-2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-O3 -fno-inline -fwhole-program -fdump-ipa-cp-details -fdump-tree-lversion-details" } + +module x + implicit none +contains + subroutine foo(a, b) + real :: a(:,:) + real :: b + integer :: i,j + b = 0. + do j=1,size(a,2) + do i=1,size(a,1) + b = b + a(i,j) * i * j + end do + end do + end subroutine foo + + subroutine bar(a, b) + real :: a(:,:) + real :: b + call foo (a,b) + end subroutine bar + +end module x + +program main + use x + implicit none + integer :: n, m + real, dimension(4,3) :: a + real, dimension(3,4) :: c + real :: b + call random_number(a) + call bar(a,b) + print *,b + + call random_number(c) + call bar(c,b) + print *,b + +end program main + +! { dg-final { scan-ipa-dump "op assert_expr 1" "cp" } } +! { dg-final { scan-tree-dump-not "versioned this loop for when certain strides are 1" "lversion" } } Index: Fortran/gfortran/regression/is_contiguous_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/is_contiguous_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/45424 +! PR fortran/48820 +! +! Run-time checks for IS_CONTIGUOUS + +implicit none +integer, pointer :: a(:), b(:,:) +integer :: i, j, k, s + +allocate(a(5), b(10,10)) + +s = 1 +if (.true. .neqv. is_contiguous (a(::s))) stop 1 +s = 2 +if (.false. .neqv. is_contiguous (a(::s))) stop 2 +i=5; j=7 +if (.true. .neqv. is_contiguous (b(1:i*2,1:j))) stop 3 +if (.false. .neqv. is_contiguous (b(1:i,1:j))) stop 4 +i=5; j=5; s=1 +if (.false. .neqv. is_contiguous (b(i:5:s,i:j*2))) stop 5 + +! The following test zero-sized arrays. For the standard, they +! are regarded as noncontiguous. However, gfortran in line with +! other compilers only checks for the strides and thus prints +! .true. or .false. depending on this setting. + +s = 4 +if (.false. .neqv. is_contiguous (a(2:1:s))) stop 6 +s = 1 +if (.true. .neqv. is_contiguous (a(2:1:s))) stop 7 +end Index: Fortran/gfortran/regression/is_contiguous_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/is_contiguous_2.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! PR fortran/45424 +! PR fortran/48820 +! +! Additional run-time checks for IS_CONTIGUOUS with assumed type/rank +program is_contiguous_2 + implicit none + real, allocatable :: b(:,:) + real, pointer :: c(:,:) + integer, volatile :: k + target :: b + allocate(b(10,10)) + k = 2 + if (fail_ar (b, .true.) ) stop 1 + if (fail_ar (b(::1,::1), .true.) ) stop 2 + if (fail_ar (b(::2,::1), .false.)) stop 3 + if (fail_ar (b(::1,::2), .false.)) stop 4 + if (fail_ar (b(:10,:10), .true. )) stop 5 + if (fail_ar (b(: 9,:10), .false.)) stop 6 + if (fail_ar (b(2: ,: ), .false.)) stop 7 + if (fail_ar (b(: ,2: ), .true. )) stop 8 + if (fail_ar (b(k: ,: ), .false.)) stop 9 + if (fail_ar (b(: ,k: ), .true. )) stop 10 + if (fail_at (b(::1,k: ), .true. )) stop 11 + if (fail_at (b(::k,k: ), .false.)) stop 12 + if (fail_at (b(10,k) , .true. )) stop 13 + c => b(::1,:) + if (fail_ar (c, .true.) ) stop 14 + c => b(::2,:) + if (fail_ar (c, .false.)) stop 15 + associate (d => b(:,2:), e => b(::k,:)) + if (fail_ar (d, .true.) ) stop 16 + if (fail_ar (e, .false.)) stop 17 + end associate +contains + pure logical function fail_ar (x, expect) result (fail) + real, dimension(..), intent(in) :: x ! Assumed rank + logical, intent(in) :: expect + fail = is_contiguous (x) .neqv. expect + end function fail_ar + pure logical function fail_at (x, expect) result (fail) + type(*), dimension(..), intent(in) :: x ! Assumed type/assumed rank + logical, intent(in) :: expect + fail = is_contiguous (x) .neqv. expect + end function fail_at +end program Index: Fortran/gfortran/regression/is_contiguous_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/is_contiguous_3.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 45424 - compile-time simplification of is_contiguous +program main + real, dimension(10,5) :: a + character (len=1) :: line + + write (unit=line,fmt='(L1)') is_contiguous(a(4:2,:)) + if (line /= 'F') stop 1 + + write (unit=line,fmt='(L1)') is_contiguous(a(:,2:4)) + if (line /= 'T') stop 1 + + write (unit=line,fmt='(L1)') is_contiguous(a(2:4,3:4)) + if (line /= 'F') stop 3 + + write (unit=line,fmt='(L1)') is_contiguous(a(::2,:)) + if (line /= 'F') stop 4 + + write (unit=line,fmt='(L1)') is_contiguous(a(:,::2)) + if (line /= 'F') stop 5 + +end program main +! { dg-final { scan-tree-dump-not " _gfortran_is_contiguous" "original" } } Index: Fortran/gfortran/regression/is_iostat_end_eor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/is_iostat_end_eor_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! Test for the Fortran 2003 intrinsics is_iostat_end & is_iostat_eor +! +program test + use iso_fortran_env + implicit none + if ((.not. is_iostat_end(IOSTAT_END)) .or. is_iostat_end(0)) STOP 1 + if ((.not. is_iostat_eor(IOSTAT_EOR)) .or. is_iostat_end(0)) STOP 2 +end program test Index: Fortran/gfortran/regression/is_iostat_end_eor_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/is_iostat_end_eor_2.f90 @@ -0,0 +1,39 @@ +! Check that we correctly simplify IS_IOSTAT_END and IS_IOSTAT_EOR. +! Not very useful, but required by the standards +! +! This test relies on the error numbers for END and EOR being -1 and -2. +! This is good to actual +! +! { dg-do compile } +! + + use iso_fortran_env, only : iostat_end, iostat_eor + implicit none + + integer(kind=merge(4, 0, is_iostat_end(-1))) :: a + integer(kind=merge(4, 0, is_iostat_end(-1_1))) :: b + integer(kind=merge(4, 0, is_iostat_end(-1_2))) :: c + integer(kind=merge(4, 0, is_iostat_end(-1_4))) :: d + integer(kind=merge(4, 0, is_iostat_end(-1_8))) :: e + + integer(kind=merge(4, 0, is_iostat_eor(-2))) :: f + integer(kind=merge(4, 0, is_iostat_eor(-2_1))) :: g + integer(kind=merge(4, 0, is_iostat_eor(-2_2))) :: h + integer(kind=merge(4, 0, is_iostat_eor(-2_4))) :: i + integer(kind=merge(4, 0, is_iostat_eor(-2_8))) :: j + + integer(kind=merge(0, 4, is_iostat_eor(-1))) :: k + integer(kind=merge(0, 4, is_iostat_end(-2))) :: l + + integer(kind=merge(0, 4, is_iostat_eor(0))) :: m + integer(kind=merge(0, 4, is_iostat_end(0))) :: n + + integer(kind=merge(4, 0, is_iostat_end(0))) :: o ! { dg-error "not supported for type" } + integer(kind=merge(4, 0, is_iostat_eor(0))) :: p ! { dg-error "not supported for type" } + + integer(kind=merge(4, 0, is_iostat_eor(iostat_eor))) :: q + integer(kind=merge(4, 0, is_iostat_end(iostat_end))) :: r + integer(kind=merge(0, 4, is_iostat_end(iostat_eor))) :: s + integer(kind=merge(0, 4, is_iostat_eor(iostat_end))) :: t + + end Index: Fortran/gfortran/regression/ishft_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ishft_1.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! verifies basic functioning of the ishft and ishftc intrinsics +if (ishft (1_1, 0) /= 1) STOP 1 +if (ishft (1_1, 1) /= 2) STOP 2 +if (ishft (3_1, 1) /= 6) STOP 3 +if (ishft (-1_1, 1) /= -2) STOP 4 +if (ishft (-1_1, -1) /= 127) STOP 5 +if (ishft (96_1, 2) /= -128) STOP 6 + +if (ishft (1_2, 0) /= 1) STOP 7 +if (ishft (1_2, 1) /= 2) STOP 8 +if (ishft (3_2, 1) /= 6) STOP 9 +if (ishft (-1_2, 1) /= -2) STOP 10 +if (ishft (-1_2, -1) /= 32767) STOP 11 +if (ishft (16384_2 + 8192_2, 2) /= -32768_4) STOP 12 + +if (ishft (1_4, 0) /= 1) STOP 13 +if (ishft (1_4, 1) /= 2) STOP 14 +if (ishft (3_4, 1) /= 6) STOP 15 +if (ishft (-1_4, 1) /= -2) STOP 16 +if (ishft (-1_4, -1) /= 2147483647) STOP 17 +if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) STOP 18 + +if (ishft (1_8, 0) /= 1) STOP 19 +if (ishft (1_8, 1) /= 2) STOP 20 +if (ishft (3_8, 1) /= 6) STOP 21 +if (ishft (-1_8, 1) /= -2) STOP 22 + +if (ishftc (1_1, 0) /= 1) STOP 24 +if (ishftc (1_1, 1) /= 2) STOP 25 +if (ishftc (3_1, 1) /= 6) STOP 26 +if (ishftc (-1_1, 1) /= -1) STOP 27 +if (ishftc (-1_1, -1) /= -1) STOP 28 +if (ishftc (ishftc (96_1, 2), -2) /= 96) STOP 29 + +if (ishftc (1_2, 0) /= 1) STOP 30 +if (ishftc (1_2, 1) /= 2) STOP 31 +if (ishftc (3_2, 1) /= 6) STOP 32 +if (ishftc (-1_2, 1) /= -1) STOP 33 +if (ishftc (-1_2, -1) /= -1) STOP 34 +if (ishftc (ishftc (25000_2, 2), -2) /= 25000) STOP 35 + +if (ishftc (1_4, 0) /= 1) STOP 36 +if (ishftc (1_4, 1) /= 2) STOP 37 +if (ishftc (3_4, 1) /= 6) STOP 38 +if (ishftc (-1_4, 1) /= -1) STOP 39 +if (ishftc (-1_4, -1) /= -1) STOP 40 +if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) STOP 41 + +if (ishftc (1_8, 0) /= 1) STOP 42 +if (ishftc (1_8, 1) /= 2) STOP 43 +if (ishftc (3_8, 1) /= 6) STOP 44 +if (ishftc (-1_8, 1) /= -1) STOP 45 +if (ishftc (-1_8, -1) /= -1) STOP 46 +if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) STOP 47 +end + + Index: Fortran/gfortran/regression/ishft_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ishft_2.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +program ishft_2 + if ( ishftc(3, 2, 3) /= 5 ) STOP 1 + if ( ishftc(256+3, 2, 3) /= 256+5 ) STOP 2 + if ( ishftc(1_4, 31)+1 /= -huge(1_4) ) STOP 3 +end program Index: Fortran/gfortran/regression/ishft_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ishft_3.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! PR fortran/50514 +program ishft_3 + + implicit none + + integer j, m + + m = 42 + ! + ! These should compile. + ! + j = ishft(m, 16) + j = ishft(m, -16) + j = ishftc(m, 16) + j = ishftc(m, -16) + ! + ! These should issue an error. + ! + j = ishft(m, 640) ! { dg-error "absolute value of SHIFT" } + j = ishftc(m, 640) ! { dg-error "absolute value of SHIFT" } + j = ishft(m, -640) ! { dg-error "absolute value of SHIFT" } + j = ishftc(m, -640) ! { dg-error "absolute value of SHIFT" } + + ! abs(SHIFT) must be <= SIZE + + j = ishftc(m, 1, 2) + j = ishftc(m, 1, 2) + j = ishftc(m, -1, 2) + j = ishftc(m, -1, 2) + + j = ishftc(m, 10, 2)! { dg-error "absolute value of SHIFT" } + j = ishftc(m, 10, 2)! { dg-error "absolute value of SHIFT" } + j = ishftc(m, -10, 2)! { dg-error "absolute value of SHIFT" } + j = ishftc(m, -10, 2)! { dg-error "absolute value of SHIFT" } + + j = ishftc(m, 1, -2) ! { dg-error "must be positive" } +end program Index: Fortran/gfortran/regression/ishft_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ishft_4.f90 @@ -0,0 +1,39 @@ +! We want to check that ISHFT evaluates its arguments only once +! +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +program test + + if (ishft (foo(), 2) /= 4) STOP 1 + if (ishft (foo(), -1) /= 1) STOP 2 + if (ishft (1, foo()) /= 8) STOP 3 + if (ishft (16, -foo()) /= 1) STOP 4 + + if (ishftc (bar(), 2) /= 4) STOP 5 + if (ishftc (bar(), -1) /= 1) STOP 6 + if (ishftc (1, bar()) /= 8) STOP 7 + if (ishftc (16, -bar()) /= 1) STOP 8 + +contains + + integer function foo () + integer, save :: i = 0 + i = i + 1 + foo = i + end function + + integer function bar () + integer, save :: i = 0 + i = i + 1 + bar = i + end function + +end program + +! The regexp "foo ()" should be seen once in the dump: +! -- once in the function definition itself +! -- plus as many times as the function is called +! +! { dg-final { scan-tree-dump-times "foo *\\\(\\\)" 5 "original" } } +! { dg-final { scan-tree-dump-times "bar *\\\(\\\)" 5 "original" } } Index: Fortran/gfortran/regression/isnan_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/isnan_1.f90 @@ -0,0 +1,20 @@ +! Test for the ISNAN intrinsic +! +! { dg-do run } +! { dg-add-options ieee } +! + implicit none + real :: x + x = -1.0 + x = sqrt(x) + if (.not. isnan(x)) STOP 1 + x = 0.0 + x = x / x + if (.not. isnan(x)) STOP 2 + + x = 5.0 + if (isnan(x)) STOP 3 + x = huge(x) + x = 2*x + if (isnan(x)) STOP 4 +end Index: Fortran/gfortran/regression/isnan_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/isnan_2.f90 @@ -0,0 +1,17 @@ +! Test for the ISNAN intrinsic on constants +! +! { dg-do run } +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } +! + implicit none + character(len=1) :: s + write(s,'(L1)') isnan(0.) + if (s /= 'F') STOP 1 + + write(s,'(L1)') isnan(exp(huge(0.))) + if (s /= 'F') STOP 2 + + write(s,'(L1)') isnan(0./0.) + if (s /= 'T') STOP 3 +end Index: Fortran/gfortran/regression/iso_c_binding_c_loc_char_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_c_loc_char_1.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR 38536 - don't reject substring of length one +! Original test case by Scot Breitenfeld +SUBROUTINE test(buf, buf2, buf3, n) + USE, INTRINSIC :: ISO_C_BINDING + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(INOUT), TARGET :: buf + INTEGER, INTENT(in) :: n + CHARACTER(LEN=*), INTENT(INOUT), DIMENSION(1:2), TARGET :: buf2 + CHARACTER(LEN=3), TARGET :: buf3 + TYPE(C_PTR) :: f_ptr + + f_ptr = C_LOC(buf(1:1)) ! Used to fail + ! Error: CHARACTER argument 'buf' to 'c_loc' + ! at (1) must have a length of 1 + f_ptr = C_LOC(buf2(1)(1:1)) ! PASSES + + f_ptr = C_LOC(buf(n:n)) + + f_ptr = C_LOC(buf3(3:)) +END SUBROUTINE test Index: Fortran/gfortran/regression/iso_c_binding_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_char_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test the fix for PR90352. +! +! Contributed by Thomas Koenig +! +subroutine bar(c,d) BIND(C) ! { dg-error "Character dummy argument 'd' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'bar' has the BIND\\(C\\) attribute" } + character (len=*) c + character (len=2) d +end Index: Fortran/gfortran/regression/iso_c_binding_class.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_class.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 47023: C_Sizeof: Rejects valid code +! +! Contributed by Tobias Burnus + + use iso_c_binding + type t + integer(c_int) :: i + end type t +contains + subroutine test(a) bind(c) ! { dg-error "is not C interoperable" } + class(t) :: a + end subroutine +end Index: Fortran/gfortran/regression/iso_c_binding_compiler_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_compiler_1.f90 @@ -0,0 +1,21 @@ +! { dg-do link } +! The compiler_options() function is dependent on the +! command line options and thus incompatible with -fcompare-debug. +! { dg-skip-if "-fcompare-debug incompatible test" { *-*-* } { "-fcompare-debug" } { "" } } */ +! +! PR fortran/40569 +! +! Check compiler_version/compiler_options intrinsics +! +subroutine test() + use iso_fortran_env, only: compiler_version + print '(3a)', '>>',compiler_version(),'<<' +end + +use iso_fortran_env, foo => compiler_version, bar => compiler_version + implicit none + print *, foo() + print *, bar() + print '(3a)', '>',compiler_options(),'<' + call test() +end Index: Fortran/gfortran/regression/iso_c_binding_compiler_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_compiler_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/40569 +! +! Check compiler_version/compiler_options intrinsics +! +use iso_fortran_env, only: compiler_options ! { dg-error "is not in the selected standard" } +use iso_fortran_env, only: compiler_version ! { dg-error "is not in the selected standard" } + implicit none +end Index: Fortran/gfortran/regression/iso_c_binding_compiler_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_compiler_3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! The compiler_options() function is dependent on the +! command line options and thus incompatible with -fcompare-debug. +! { dg-skip-if "-fcompare-debug incompatible test" { *-*-* } { "-fcompare-debug" } { "" } } */ +! +! PR fortran/45823 +! +! We used to warn about +! "Type specified for intrinsic function" for this file +! + +use iso_c_binding +use iso_Fortran_env +implicit none +intrinsic sin +real :: x = 3.4 +print *, sin(x), c_sizeof(c_int), compiler_options(), compiler_version() +end + + +module test_mod + use iso_fortran_env +end module test_mod + +subroutine test +use test_mod +end subroutine test Index: Fortran/gfortran/regression/iso_c_binding_compiler_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_compiler_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/51308 +! +! Contributed by Matthias Moeller +! + +module mymod + use iso_c_binding + implicit none + + private + public :: c_ptr + public :: c_null_ptr + +end module mymod Index: Fortran/gfortran/regression/iso_c_binding_init_expr.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_init_expr.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/42354 + +use iso_c_binding +implicit none +integer, target :: a +type t + type(c_ptr) :: ptr = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" } +end type t +type(c_ptr) :: ptr2 = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" } +end Index: Fortran/gfortran/regression/iso_c_binding_only.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_only.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +module iso_c_binding_only + ! c_f_procpointer verifies that the c_funptr derived type for the cptr param + ! is auto-generated, and c_f_pointer tests c_ptr. + use, intrinsic :: iso_c_binding, only: c_null_ptr, c_f_procpointer + ! This should be allowed since the C_PTR that the C_NULL_PTR needs will use + ! a mangled name to prevent collisions. + integer :: c_ptr +end module iso_c_binding_only Index: Fortran/gfortran/regression/iso_c_binding_only_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_only_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 87172: [9 Regression] Spurious "Derived type 'c_funptr' at (1) has not been declared" error after r263782 +! +! Contributed by Dominique d'Humieres + +module m1 + use iso_c_binding, only: c_funptr +end module + +module m2 + use m1 + use iso_c_binding +end module Index: Fortran/gfortran/regression/iso_c_binding_param_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_param_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Check that the GNU additions to ISO_C_Binding are properly diagnosed +! +use, intrinsic :: iso_c_binding, only: c_int128_t ! { dg-error "is not in the selected standard" } +use, intrinsic :: iso_c_binding, only: c_int_least128_t ! { dg-error "is not in the selected standard" } +use, intrinsic :: iso_c_binding, only: c_int_fast128_t ! { dg-error "is not in the selected standard" } +use, intrinsic :: iso_c_binding, only: c_float128 ! { dg-error "is not in the selected standard" } +use, intrinsic :: iso_c_binding, only: c_float128_complex ! { dg-error "is not in the selected standard" } +implicit none +end Index: Fortran/gfortran/regression/iso_c_binding_param_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_param_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-optimized" } +! +! Check that the GNU additions to ISO_C_Binding are accepted +! +use, intrinsic :: iso_c_binding, only: c_int128_t +use, intrinsic :: iso_c_binding, only: c_int_least128_t +use, intrinsic :: iso_c_binding, only: c_int_fast128_t +use, intrinsic :: iso_c_binding, only: c_float128 +use, intrinsic :: iso_c_binding, only: c_float128_complex +implicit none +if (c_int128_t >= 0 .and. c_int128_t /= 16) call unreachable() +if (c_int_least128_t >= 0 .and. c_int_least128_t < 16) call unreachable() +if (c_int_fast128_t >= 0 .and. c_int_fast128_t < 16) call unreachable() +if (c_float128 >= 0 .and. c_float128 /= 16) call unreachable() +if (c_float128_complex >= 0 .and. c_float128_complex /= 16) call unreachable() +end + +! { dg-final { scan-tree-dump-times "unreachable" 0 "optimized" } } Index: Fortran/gfortran/regression/iso_c_binding_rename_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_rename_1.f03 @@ -0,0 +1,82 @@ +! { dg-do run } +! { dg-additional-sources iso_c_binding_rename_1_driver.c } +module iso_c_binding_rename_0 + use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr, & + c_associated +end module iso_c_binding_rename_0 + + +module iso_c_binding_rename_1 + ! rename a couple of the symbols from iso_c_binding. the compiler + ! needs to be able to recognize the derived types with names different + ! from the one in iso_c_binding because it will look up the derived types + ! to define the args and return values of some of the procedures in + ! iso_c_binding. this should verify that this functionality works. + use, intrinsic :: iso_c_binding, my_c_int => c_int, my_c_ptr => c_ptr, & + my_c_associated => c_associated, my_c_f_pointer => c_f_pointer + +contains + subroutine sub0(my_int) bind(c) + integer(my_c_int), value :: my_int + if(my_int .ne. 1) then + STOP 1 + end if + end subroutine sub0 + + subroutine sub1(my_ptr) bind(c) + type(my_c_ptr), value :: my_ptr + + if(.not. my_c_associated(my_ptr)) then + STOP 2 + end if + end subroutine sub1 + + subroutine sub2(my_int, my_long) bind(c) + use, intrinsic :: iso_c_binding, my_c_int_2 => c_int, & + my_c_long_2 => c_long + integer(my_c_int_2), value :: my_int + integer(my_c_long_2), value :: my_long + + if(my_int .ne. 1) then + STOP 3 + end if + if(my_long .ne. 1) then + STOP 4 + end if + end subroutine sub2 + + subroutine sub3(cptr1, cptr2) bind(c) + type(my_c_ptr), value :: cptr1 + type(my_c_ptr), value :: cptr2 + integer(my_c_int), pointer :: my_f90_c_ptr + + if(.not. my_c_associated(cptr1)) then + STOP 5 + end if + + if(.not. my_c_associated(cptr1, cptr2)) then + STOP 6 + end if + + call my_c_f_pointer(cptr1, my_f90_c_ptr) + end subroutine sub3 + + subroutine sub4(cptr1, cptr2) bind(c) + ! rename the my_c_ptr_0 from iso_c_binding_rename_0 just to further test + ! both are actually aliases to c_ptr + use iso_c_binding_rename_0, my_c_ptr_local => my_c_ptr_0, & + my_c_associated_2 => c_associated + + implicit none + type(my_c_ptr_local), value :: cptr1 + type(my_c_ptr_local), value :: cptr2 + + if(.not. my_c_associated_2(cptr1)) then + STOP 7 + end if + + if(.not. my_c_associated_2(cptr2)) then + STOP 8 + end if + end subroutine sub4 +end module iso_c_binding_rename_1 Index: Fortran/gfortran/regression/iso_c_binding_rename_1_driver.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_rename_1_driver.c @@ -0,0 +1,19 @@ +void sub0(int); +void sub1(int *); +void sub2(int, long); +void sub3(int *, int *); +void sub4(int *, int *); + +int main(int argc, char **argv) +{ + int i = 1; + long j = 1; + + sub0(i); + sub1(&i); + sub2(i, j); + sub3(&i, &i); + sub4(&i, &i); + + return 0; +} Index: Fortran/gfortran/regression/iso_c_binding_rename_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_rename_2.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-additional-sources iso_c_binding_rename_2_driver.c } +module mod0 + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated +end module mod0 + +module mod1 + use mod0, my_c_ptr => c_ptr, my_c_associated => c_associated +end module mod1 + +module mod2 +contains + subroutine sub2(my_ptr1) bind(c) + use mod1, my_c_ptr_2 => my_c_ptr, my_c_associated_2 => my_c_associated + implicit none + type(my_c_ptr_2) :: my_ptr1 + if( .not. my_c_associated_2(my_ptr1)) then + STOP 1 + end if + end subroutine sub2 + + subroutine sub3(my_ptr1) bind(c) + use mod1, my_c_ptr_2 => my_c_ptr + implicit none + type(my_c_ptr_2) :: my_ptr1 + if( .not. my_c_associated(my_ptr1)) then + STOP 2 + end if + end subroutine sub3 + + subroutine sub4(my_ptr1) bind(c) + use mod1, my_c_associated_3 => my_c_associated + implicit none + type(my_c_ptr) :: my_ptr1 + if( .not. my_c_associated_3(my_ptr1)) then + STOP 3 + end if + end subroutine sub4 + +end module mod2 Index: Fortran/gfortran/regression/iso_c_binding_rename_2_driver.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_rename_2_driver.c @@ -0,0 +1,16 @@ +void sub2(int **); +void sub3(int **); +void sub4(int **); + +int main(int argc, char **argv) +{ + int i = 1; + int *ptr; + + ptr = &i; + sub2(&ptr); + sub3(&ptr); + sub4(&ptr); + + return 0; +} Index: Fortran/gfortran/regression/iso_c_binding_rename_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_c_binding_rename_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/55343 +! +! Contributed by Janus Weil +! +module my_mod + implicit none + type int_type + integer :: i + end type int_type +end module my_mod +program main + use iso_c_binding, only: C_void_ptr=>C_ptr, C_string_ptr=>C_ptr + use my_mod, only: i1_type=>int_type, i2_type=>int_type + implicit none + type(C_string_ptr) :: p_string + type(C_void_ptr) :: p_void + type (i1_type) :: i1 + type (i2_type) :: i2 + p_void = p_string + i1 = i2 +end program main Index: Fortran/gfortran/regression/iso_fortran_binding_uint8_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_binding_uint8_array.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-additional-sources iso_fortran_binding_uint8_array_driver.c } + +module m + use iso_c_binding +contains + subroutine fsub( x ) bind(C, name="fsub") + integer(c_int8_t), intent(inout) :: x(:) + x = x+1 + end subroutine +end module Index: Fortran/gfortran/regression/iso_fortran_binding_uint8_array_driver.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_binding_uint8_array_driver.c @@ -0,0 +1,25 @@ +#include +#include +#include +#include + +extern void fsub(CFI_cdesc_t *); + +int main(void) +{ + int8_t x[] = {1,2,3,4}; + int N = sizeof(x)/sizeof(x[0]); + + CFI_CDESC_T(1) dat; + CFI_index_t ext[1]; + ext[0] = (CFI_index_t)N; + int rc = CFI_establish((CFI_cdesc_t *)&dat, &x, CFI_attribute_other, + CFI_type_int8_t, 0, (CFI_rank_t)1, ext); + printf("CFI_establish call returned: %d\n", rc); + + fsub((CFI_cdesc_t *)&dat ); + + for (int i=0; i output_unit + implicit none + + if (input_unit /= 5 .or. uu /= 6) STOP 17 + call bar + call bar2 +end Index: Fortran/gfortran/regression/iso_fortran_env_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_2.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +module iso_fortran_env + logical :: x +end module iso_fortran_env + +subroutine bar1 + use , intrinsic :: iso_fortran_env + print *, character_storage_size +end + +subroutine bar2 + use, intrinsic :: iso_fortran_env + print *, character_storage_size +end + +subroutine bar3 + use,intrinsic :: iso_fortran_env + print *, character_storage_size +end + +subroutine bar4 + use,intrinsic::iso_fortran_env + print *, character_storage_size +end + +subroutine bar5 + use ,intrinsic :: iso_fortran_env + print *, character_storage_size +end + +subroutine foo1 + use :: iso_fortran_env + print *, x +end + +subroutine foo2 + use:: iso_fortran_env + print *, x +end + +subroutine foo3 + use::iso_fortran_env + print *, x +end + +subroutine foo4 + use ::iso_fortran_env + print *, x +end + +subroutine gee1 + use , non_intrinsic :: iso_fortran_env + print *, x +end + +subroutine gee2 + use, non_intrinsic :: iso_fortran_env + print *, x +end + +subroutine gee3 + use,non_intrinsic :: iso_fortran_env + print *, x +end + +subroutine gee4 + use,non_intrinsic::iso_fortran_env + print *, x +end + +subroutine gee5 + use ,non_intrinsic :: iso_fortran_env + print *, x +end Index: Fortran/gfortran/regression/iso_fortran_env_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +subroutine foo1 (x,y) + use iso_fortran_env + integer, intent(out) :: x, y + + x = numeric_storage_size + y = character_storage_size +end + +subroutine foo2 (x,y) + use iso_fortran_env, foo => numeric_storage_size + integer, intent(in) :: x, y + + if (foo /= x .or. character_storage_size /= y) STOP 1 +end + +subroutine foo3 (x,y) + use iso_fortran_env, only : numeric_storage_size, character_storage_size + integer, intent(in) :: x, y + + if (numeric_storage_size /= x .or. character_storage_size /= y) STOP 2 +end + +program test + integer :: x, y + call foo1(x,y) + call foo2(x,y) + call foo3(x,y) +end Index: Fortran/gfortran/regression/iso_fortran_env_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +module iso_fortran_env +end module iso_fortran_env + +program foo + use, intrinsic :: iso_fortran_env + use, non_intrinsic :: iso_fortran_env ! { dg-error "conflicts with intrinsic module" } +end program foo + +subroutine truc + use, non_intrinsic :: iso_fortran_env + use, intrinsic :: iso_fortran_env ! { dg-error "conflicts with non-intrinsic module" } +end subroutine truc Index: Fortran/gfortran/regression/iso_fortran_env_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_5.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +! +! Check for new F2008 integer constants, needed for +! coarray support (cf. PR fortran/18918) +! + +USE iso_fortran_env +implicit none +integer :: i +integer(kind=ATOMIC_INT_KIND) :: atomic_int +logical(kind=ATOMIC_LOGICAL_KIND) :: atomic_bool + +i = 0 +if (IOSTAT_INQUIRE_INTERNAL_UNIT <= 0) STOP 1 +if (IOSTAT_INQUIRE_INTERNAL_UNIT == STAT_STOPPED_IMAGE) STOP 2 +if (STAT_STOPPED_IMAGE <= 0) STOP 3 + +if ((STAT_LOCKED_OTHER_IMAGE == STAT_LOCKED) & + .or.(STAT_LOCKED_OTHER_IMAGE == STAT_UNLOCKED)) STOP 4 +if (STAT_LOCKED == STAT_UNLOCKED) STOP 5 + +end + +! { dg-final { scan-tree-dump-times "_gfortran_stop" 0 "original" } } + Index: Fortran/gfortran/regression/iso_fortran_env_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_6.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Check for new F2008 integer constants, needed for +! coarray support (cf. PR fortran/18918) +! + +USE iso_fortran_env +implicit none +integer(kind=ATOMIC_INT_KIND) :: atomic_int ! { dg-error "has no IMPLICIT type" } +logical(kind=ATOMIC_LOGICAL_KIND) :: atomic_bool ! { dg-error "has no IMPLICIT type" } + +print *, OUTPUT_UNIT + +if (IOSTAT_INQUIRE_INTERNAL_UNIT <= 0) STOP 1 ! { dg-error "has no IMPLICIT type" } +print *,STAT_STOPPED_IMAGE ! { dg-error "has no IMPLICIT type" } +print *, STAT_LOCKED_OTHER_IMAGE ! { dg-error "has no IMPLICIT type" } +print *, STAT_LOCKED ! { dg-error "has no IMPLICIT type" } +print *, STAT_UNLOCKED ! { dg-error "has no IMPLICIT type" } +end + +module m +USE iso_fortran_env, only: INPUT_UNIT +USE iso_fortran_env, only: ATOMIC_INT_KIND ! { dg-error "is not in the selected standard" } +implicit none +end module m + +module m2 +USE iso_fortran_env, only: foo => STAT_UNLOCKED ! { dg-error "is not in the selected standard" } +implicit none +end module m2 + +module m3 +USE iso_fortran_env, foo => IOSTAT_INQUIRE_INTERNAL_UNIT ! { dg-error "not in the selected standard" } +implicit none +end module m3 Index: Fortran/gfortran/regression/iso_fortran_env_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/iso_fortran_env_7.f90 @@ -0,0 +1,61 @@ +! { dg-do link } +! +! PR fortran/40571 +! +! This test case adds check for the new Fortran 2008 array parameters +! in ISO_FORTRAN_ENV: integer_kinds, logical_kinds, character_kinds, +! and real_kinds. +! +! The test thus also checks that the values of the parameter are used +! and no copy is made. (Cf. PR 44856.) + +program test + use iso_fortran_env, only: integer_kinds, character_kinds + implicit none + integer :: aaaa(2),i + i=1 + + print *, integer_kinds + print *, integer_kinds(1) + print *, (integer_kinds) + print *, (integer_kinds + 1) + print *, integer_kinds(1:2) + print *, integer_kinds(i) + + aaaa = character_kinds + aaaa(1:2) = character_kinds(1:2) + aaaa(i) = character_kinds(i) + aaaa = character_kinds + 0 + aaaa(1:2) = character_kinds(1:2) + 0 + aaaa(i) = character_kinds(i) + 0 +end program test + +subroutine one() + use iso_fortran_env, only: ik => integer_kinds, ik2 => integer_kinds + implicit none + + if (any (ik /= ik2)) call never_call_me() +end subroutine one + +subroutine two() + use iso_fortran_env + implicit none + + ! Should be 1, 2, 4, 8 and possibly 16 + if (size (integer_kinds) < 4) call never_call_me() + if (any (integer_kinds(1:4) /= [1,2,4,8])) call never_call_me() + if (any (integer_kinds /= logical_kinds)) call never_call_me() + + if (size (character_kinds) /= 2) call never_call_me() + if (any (character_kinds /= [1,4])) call never_call_me() + + if (size (real_kinds) < 2) call never_call_me() + if (any (real_kinds(1:2) /= [4,8])) call never_call_me() +end subroutine two + +subroutine three() + use iso_fortran_env + integer :: i, j(2) + i = real_kinds(1) + j = real_kinds(1:2) +end subroutine three Index: Fortran/gfortran/regression/itime_idate_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/itime_idate_1.f @@ -0,0 +1,12 @@ +! { dg-do run } +! Test for ITIME and IDATE intrinsics + integer x(3) + call itime(x) + if (x(1) < 0 .or. x(1) > 23 .or. + & x(2) < 0 .or. x(2) > 59 .or. + & x(3) < 0 .or. x(3) > 61) STOP 1 + call idate(x) + if (x(1) < 1 .or. x(1) > 31 .or. + & x(2) < 1 .or. x(2) > 12 .or. + & x(3) < 2001 .or. x(3) > 2100) STOP 2 + end Index: Fortran/gfortran/regression/itime_idate_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/itime_idate_2.f @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! Test for ITIME and IDATE intrinsics + integer x(3) + call itime(x) + if (x(1) < 0 .or. x(1) > 23 .or. + & x(2) < 0 .or. x(2) > 59 .or. + & x(3) < 0 .or. x(3) > 61) STOP 1 + call idate(x) + if (x(1) < 1 .or. x(1) > 31 .or. + & x(2) < 1 .or. x(2) > 12 .or. + & x(3) < 2001 .or. x(3) > 2100) STOP 2 + end Index: Fortran/gfortran/regression/keyword_symbol_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/keyword_symbol_1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! This tests the fix for PR28526, in which a public interface named +! 'end' would be treated as a variable because the matcher tried +! 'END INTERFACE' as an assignment and left the symbol modified in +! failing. The various pitfalls that were encountered in developing +! the fix are checked here. +! +! Contributed by Paul Thomas +! +module blahblah + public function, end + +! The original PR from Yusuke IGUCHI + interface end + module procedure foo1 + end interface + +! A contribution to the PR from Tobias Schlueter + interface function + module procedure foo2 ! { dg-error "is neither function nor" } + end interface + + interface function + module procedure foo3 + end interface + + interface + function foo4 () + real foo4 + x = 1.0 ! { dg-error "in INTERFACE" } + end function foo4 + end interface + + interface + x = 2.0 ! { dg-error "in INTERFACE block" } + function foo5 () + real foo5 + end function foo5 + end interface + + x = 3.0 ! { dg-error "in MODULE" } + +contains + + subroutine foo1 + end subroutine foo1 + + function foo2 ! { dg-error "Expected formal argument list" } + foo2 = 0 ! { dg-error "already been host associated" } + end function foo2 ! { dg-error "Expecting END MODULE" } + + function foo3 () + real foo3 + end function foo3 + + x = 4.0 ! { dg-error "in CONTAINS section" } +end module blahblah Index: Fortran/gfortran/regression/kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/kind_1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 63363: No diagnostic for passing function as actual argument to KIND +! +! Contributed by Ian Harvey + + type :: t + end type + type(t) :: d + class(*), allocatable :: c + + print *, KIND(d) ! { dg-error "must be of intrinsic type" } + print *, KIND(c) ! { dg-error "must be of intrinsic type" } + + print *, KIND(f) ! { dg-error "must be a data entity" } + print *, KIND(f()) + print *, KIND(s) ! { dg-error "must be a data entity" } +contains + FUNCTION f() + INTEGER(SELECTED_INT_KIND(4)) :: f + END FUNCTION + subroutine s + end subroutine +END Index: Fortran/gfortran/regression/kind_tests_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/kind_tests_2.f03 @@ -0,0 +1,7 @@ +! { dg-do compile } +module kind_tests_2 + use, intrinsic :: iso_c_binding + + integer, parameter :: myFKind = c_float + real(myFKind), bind(c) :: myF +end module kind_tests_2 Index: Fortran/gfortran/regression/kind_tests_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/kind_tests_3.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module my_kinds + use, intrinsic :: iso_c_binding + integer, parameter :: myFKind = c_float +end module my_kinds + +module my_module + use my_kinds + real(myFKind), bind(c) :: myF +end module my_module Index: Fortran/gfortran/regression/kind_tests_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/kind_tests_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR 50752: [4.7 Regression] ICE in match_kind_param +! +! Contributed by Joost VandeVondele + +rPos=0.0_dp ! { dg-error "Missing kind-parameter" } +end Index: Fortran/gfortran/regression/label_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/label_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Test the fix for PR 25106 and 25055. + +program a +0056780 continue ! { dg-error "Too many digits" } +0 continue ! { dg-error "Zero is not a valid statement label" } +end program a + + Index: Fortran/gfortran/regression/label_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/label_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/24640. We needed to check that whitespace follows +! a statement label in free form. +! +program pr24640 + +10: a=10 ! { dg-error "character in statement" } + +end program + Index: Fortran/gfortran/regression/label_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/label_4.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wunused-label" } +! PR 26277 +! We used to give an incorect warning about label 99 not being referenced + open(unit=12,err=99) +99 print *,"could not open file ..." +98 continue ! { dg-warning "Label 98 .* defined but not used" } + close(unit=12,status="delete") +end Index: Fortran/gfortran/regression/label_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/label_5.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR fortran/27553 +program pr27553 +10: a=10 ! { dg-error "character in statement" } +end program Index: Fortran/gfortran/regression/large_integer_kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_integer_kind_1.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } + +module testmod + integer,parameter :: k = selected_int_kind (range (0_8) + 1) +contains + subroutine testoutput (a,b,length,f) + integer(kind=k),intent(in) :: a + integer(kind=8),intent(in) :: b + integer,intent(in) :: length + character(len=*),intent(in) :: f + + character(len=length) :: ca + character(len=length) :: cb + + write (ca,f) a + write (cb,f) b + if (ca /= cb) STOP 1 + end subroutine testoutput +end module testmod + + +! Testing I/O of large integer kinds (larger than kind=8) +program test + use testmod + implicit none + + integer(kind=k) :: x + character(len=50) :: c1, c2 + + call testoutput (0_k,0_8,50,'(I50)') + call testoutput (1_k,1_8,50,'(I50)') + call testoutput (-1_k,-1_8,50,'(I50)') + x = huge(0_8) + call testoutput (x,huge(0_8),50,'(I50)') + x = -huge(0_8) + call testoutput (x,-huge(0_8),50,'(I50)') +end program test Index: Fortran/gfortran/regression/large_integer_kind_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_integer_kind_2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } + +! Testing library calls on large integer kinds (larger than kind=8) + implicit none + + integer,parameter :: k = selected_int_kind (range (0_8) + 1) + + integer(kind=k) :: i, j + integer(8) :: a, b + + i = 0; j = 1; a = i; b = j + if (i ** j /= a ** b) STOP 1 + +end Index: Fortran/gfortran/regression/large_real_kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_real_kind_1.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } + +module testmod + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) +contains + subroutine testoutput (a,b,length,f) + real(kind=k),intent(in) :: a + real(kind=8),intent(in) :: b + integer,intent(in) :: length + character(len=*),intent(in) :: f + + character(len=length) :: ca + character(len=length) :: cb + + write (ca,f) a + write (cb,f) b + if (ca /= cb) STOP 1 + end subroutine testoutput + + subroutine outputstring (a,f,s) + real(kind=k),intent(in) :: a + character(len=*),intent(in) :: f + character(len=*),intent(in) :: s + + character(len=len(s)) :: c + + write (c,f) a + if (c /= s) STOP 2 + end subroutine outputstring +end module testmod + + +! Testing I/O of large real kinds (larger than kind=8) +program test + use testmod + implicit none + + real(kind=k) :: x + character(len=20) :: c1, c2 + + call testoutput (0.0_k,0.0_8,40,'(F40.35)') + + call testoutput (1.0_k,1.0_8,40,'(F40.35)') + call testoutput (0.1_k,0.1_8,15,'(F15.10)') + call testoutput (1e10_k,1e10_8,15,'(F15.10)') + call testoutput (7.51e100_k,7.51e100_8,15,'(F15.10)') + call testoutput (1e-10_k,1e-10_8,15,'(F15.10)') + call testoutput (7.51e-100_k,7.51e-100_8,15,'(F15.10)') + + call testoutput (-1.0_k,-1.0_8,40,'(F40.35)') + call testoutput (-0.1_k,-0.1_8,15,'(F15.10)') + call testoutput (-1e10_k,-1e10_8,15,'(F15.10)') + call testoutput (-7.51e100_k,-7.51e100_8,15,'(F15.10)') + call testoutput (-1e-10_k,-1e-10_8,15,'(F15.10)') + call testoutput (-7.51e-100_k,-7.51e-100_8,15,'(F15.10)') + + x = huge(x) + call outputstring (2*x,'(F20.15)',' Infinity') + call outputstring (-2*x,'(F20.15)',' -Infinity') + + write (c1,'(G20.10E5)') x + write (c2,'(G20.10E5)') -x + if (c2(1:1) /= '-') STOP 3 + c2(1:1) = ' ' + if (c1 /= c2) STOP 4 + + x = tiny(x) + call outputstring (x,'(F20.15)',' 0.000000000000000') + call outputstring (-x,'(F20.15)',' -0.000000000000000') + + write (c1,'(G20.10E5)') x + write (c2,'(G20.10E5)') -x + if (c2(1:1) /= '-') STOP 5 + c2(1:1) = ' ' + if (c1 /= c2) STOP 6 +end program test Index: Fortran/gfortran/regression/large_real_kind_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_real_kind_2.F90 @@ -0,0 +1,104 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } + +! Testing library calls on large real kinds (larger than kind=8) + implicit none + + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(8),parameter :: eps = 1e-8 + + real(kind=k) :: x, x1 + real(8) :: y, y1 + complex(kind=k) :: z, z1 + complex(8) :: w, w1 + +#define TEST_FUNCTION(func,val) \ + x = val ;\ + y = x ;\ + x = func (x) ;\ + y = func (y) ;\ + if (abs((y - x) / y) > eps) STOP 1 + +#define CTEST_FUNCTION(func,valc) \ + z = valc ;\ + w = z ;\ + z = func (z) ;\ + w = func (w) ;\ + if (abs((z - w) / w) > eps) STOP 2 + + TEST_FUNCTION(cos,17.456) + TEST_FUNCTION(sin,17.456) + TEST_FUNCTION(tan,1.456) + TEST_FUNCTION(cosh,-2.45) + TEST_FUNCTION(sinh,7.1) + TEST_FUNCTION(tanh,12.7) + TEST_FUNCTION(acos,0.78) + TEST_FUNCTION(asin,-0.24) + TEST_FUNCTION(atan,-17.123) + TEST_FUNCTION(acosh,0.2) + TEST_FUNCTION(asinh,0.3) + TEST_FUNCTION(atanh,0.4) + TEST_FUNCTION(exp,1.74) + TEST_FUNCTION(log,0.00178914) + TEST_FUNCTION(log10,123789.123) + TEST_FUNCTION(sqrt,789.1356) + + CTEST_FUNCTION(cos,(17.456,-1.123)) + CTEST_FUNCTION(sin,(17.456,-7.6)) + CTEST_FUNCTION(exp,(1.74,-1.01)) + CTEST_FUNCTION(log,(0.00178914,-1.207)) + CTEST_FUNCTION(sqrt,(789.1356,2.4)) + +#define TEST_POWER(val1,val2) \ + x = val1 ; \ + y = x ; \ + x1 = val2 ; \ + y1 = x1; \ + if (abs((x**x1 - y**y1)/(y**y1)) > eps) STOP 3 + +#define CTEST_POWER(val1,val2) \ + z = val1 ; \ + w = z ; \ + z1 = val2 ; \ + w1 = z1; \ + if (abs((z**z1 - w**w1)/(w**w1)) > eps) STOP 4 + + CTEST_POWER (1.0,1.0) + CTEST_POWER (1.0,5.4) + CTEST_POWER (1.0,-5.4) + CTEST_POWER (1.0,0.0) + CTEST_POWER (-1.0,1.0) + CTEST_POWER (-1.0,5.4) + CTEST_POWER (-1.0,-5.4) + CTEST_POWER (-1.0,0.0) + CTEST_POWER (0.0,1.0) + CTEST_POWER (0.0,5.4) + CTEST_POWER (0.0,-5.4) + CTEST_POWER (0.0,0.0) + CTEST_POWER (7.6,1.0) + CTEST_POWER (7.6,5.4) + CTEST_POWER (7.6,-5.4) + CTEST_POWER (7.6,0.0) + CTEST_POWER (-7.6,1.0) + CTEST_POWER (-7.6,5.4) + CTEST_POWER (-7.6,-5.4) + CTEST_POWER (-7.6,0.0) + + CTEST_POWER ((10.78,123.213),(14.123,13279.5)) + CTEST_POWER ((-10.78,123.213),(14.123,13279.5)) + CTEST_POWER ((10.78,-123.213),(14.123,13279.5)) + CTEST_POWER ((10.78,123.213),(-14.123,13279.5)) + CTEST_POWER ((10.78,123.213),(14.123,-13279.5)) + CTEST_POWER ((-10.78,-123.213),(14.123,13279.5)) + CTEST_POWER ((-10.78,123.213),(-14.123,13279.5)) + CTEST_POWER ((-10.78,123.213),(14.123,-13279.5)) + CTEST_POWER ((10.78,-123.213),(-14.123,13279.5)) + CTEST_POWER ((10.78,-123.213),(14.123,-13279.5)) + CTEST_POWER ((10.78,123.213),(-14.123,-13279.5)) + CTEST_POWER ((-10.78,-123.213),(-14.123,13279.5)) + CTEST_POWER ((-10.78,-123.213),(14.123,-13279.5)) + CTEST_POWER ((-10.78,123.213),(-14.123,-13279.5)) + CTEST_POWER ((10.78,-123.213),(-14.123,-13279.5)) + CTEST_POWER ((-10.78,-123.213),(-14.123,-13279.5)) + +end Index: Fortran/gfortran/regression/large_real_kind_3.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_real_kind_3.F90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } + +! Testing erf and erfc library calls on large real kinds (larger than kind=8) + implicit none + + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(8),parameter :: eps = 1e-8 + + real(kind=k) :: x + real(8) :: y + +#define TEST_FUNCTION(func,val) \ + x = val ;\ + y = x ;\ + x = func (x) ;\ + y = func (y) ;\ + if (abs((y - x) / y) > eps) STOP 1 + + TEST_FUNCTION(erf,1.45123231) + TEST_FUNCTION(erfc,-0.123789) + +end Index: Fortran/gfortran/regression/large_real_kind_form_io_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_real_kind_form_io_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! PR 24174 and PR 24305 +program large_real_kind_form_io_1 + ! This should be 10 on systems that support kind=10 + integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(kind=k) :: a,b(2), c, eps + complex(kind=k) :: d, e, f(2), g + character(len=200) :: tmp + ! Test real(k) scalar and array formatted IO + eps = 10 * spacing (2.0_k) ! 10 ulp precision is enough. + b(:) = 2.0_k + write (tmp, *) b + read (tmp, *) a, c + if (abs (a - b(1)) > eps) STOP 1 + if (abs (c - b(2)) > eps) STOP 2 + ! Complex(k) scalar and array formatted and list formatted IO + d = cmplx ( 1.0_k, 2.0_k, k) + f = d + write (tmp, *) f + read (tmp, *) e, g + if (abs (e - d) > eps) STOP 3 + if (abs (g - d) > eps) STOP 4 + write (tmp, '(2(e12.4e5, 2x))') d + read (tmp, '(2(e12.4e5, 2x))') e + if (abs (e - d) > eps) STOP 5 +end program large_real_kind_form_io_1 Index: Fortran/gfortran/regression/large_real_kind_form_io_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_real_kind_form_io_2.f90 @@ -0,0 +1,35 @@ +! { dg-do run { xfail powerpc*-apple-darwin* powerpc*-*-linux* } } +! Test XFAILed on these platforms because the system's printf() lacks +! proper support for denormalized long doubles. See PR24685 +! { dg-require-effective-target fortran_large_real } +! PR libfortran/24685 +program large_real_kind_form_io_2 + ! This should be 10 or 16 on systems that support kind=10 or kind=16 + integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(kind=k) :: a,b(2), c + character(len=180) :: tmp + + b(:) = huge(0.0_k) + write (tmp, *) b + read (tmp, *) a, c + if (a /= b(1)) STOP 1 + if (c /= b(2)) STOP 2 + + b(:) = -huge(0.0_k) + write (tmp, *) b + read (tmp, *) a, c + if (a /= b(1)) STOP 3 + if (c /= b(2)) STOP 4 + + b(:) = nearest(tiny(0.0_k),1.0_k) + write (tmp, *) b + read (tmp, *) a, c + if (a /= b(1)) STOP 5 + if (c /= b(2)) STOP 6 + + b(:) = nearest(-tiny(0.0_k),-1.0_k) + write (tmp, *) b + read (tmp, *) a, c + if (a /= b(1)) STOP 7 + if (c /= b(2)) STOP 8 +end program large_real_kind_form_io_2 Index: Fortran/gfortran/regression/large_recl.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_recl.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 44292 Large RECL= +program large_recl + implicit none + integer(kind=8) :: r + open(10, status="scratch", recl=12345678901_8, form="unformatted", access="direct") + inquire(10, recl=r) + close(10, status="delete") + if (r /= 12345678901_8) then + STOP 1 + end if +end program large_recl Index: Fortran/gfortran/regression/large_unit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_unit_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-shouldfail "Unit number in I/O statement too large" } +! PR31201 Unit number in I/O statement too large +! Test case from PR + integer(kind=8) :: k= 2_8**36 + 10 + integer(kind=4) :: j= 10 + logical ex,op + INQUIRE(unit=k, exist=ex,opened=op) + print *, ex, op + IF (ex) THEN + OPEN(unit=k) + INQUIRE(unit=j, opened=op) + IF (op) STOP 1 + ENDIF + print *, k + close(k) + end Index: Fortran/gfortran/regression/large_unit_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/large_unit_2.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR31201 Too large unit number generates wrong code +! Test case by Francois-Xavier Coudert + integer :: i + logical :: l + character(len=60) :: s + open(2_8*huge(0)+20_8,file="foo",iostat=i) + if (i == 0) STOP 1 + open(2_8*huge(0)+20_8,file="foo",err=99) + STOP 2 + 99 inquire(unit=18,opened=l) + if (l) STOP 3 + end Index: Fortran/gfortran/regression/largeequiv_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/largeequiv_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 20361 : We didn't check if a large equivalence actually fit on +! the stack, and therefore segfaulted at execution time +subroutine test +integer i(1000000), j +equivalence (i(50), j) + +j = 1 +if (i(50) /= j) STOP 1 +end subroutine test + +call test +end Index: Fortran/gfortran/regression/ldist-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ldist-1.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" } + +Subroutine PADEC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT) + IMPLICIT REAL*8 (A-H, O-Z) + DIMENSION DKS(*),DKDS(*),HVAR(*) + COMPLEX*16 WM(*),WG(*),FN(*),AN(*),BN(*),CN(*) + COMPLEX*16 H2,CONST + COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP + Parameter (F1 = .8333333333333333D0, F2 = .0833333333333333D0) + + SS=DT/(2.0D0) + + do J=2,NS + BS=SS*DKS(J)*HVAR(J)*HVAR(J) + AN(J)=F1+2.*BS + BN(J)=F2-BS + CN(J)=F2-BS + H2=WM(J+1) + + if(J.EQ.NS) then + CONST=CN(J)*H2 + else + CONST=(0.D0,0.D0) + endif + FN(J)=(BS+F2)*(H2)+(F1-2.D0*BS)-CONST + end do + + return +end Subroutine PADEC + +! There are 5 legal partitions in this code. Based on the data +! locality heuristic, this loop should not be split. + +! { dg-final { scan-tree-dump-not "distributed: split to" "ldist" } } Index: Fortran/gfortran/regression/ldist-pr43023.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ldist-pr43023.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-loop-distribution" } + +MODULE NFT_mod + +implicit none +integer :: Nangle +real:: Z0 +real, dimension(:,:), allocatable :: Angle +real, dimension(:), allocatable :: exth, ezth, hxth, hyth, hyphi + +CONTAINS + +SUBROUTINE NFT_Init() + +real :: th, fi +integer :: n + +do n = 1,Nangle + th = Angle(n,1) + fi = Angle(n,2) + + exth(n) = cos(fi)*cos(th) + ezth(n) = -sin(th) + hxth(n) = -sin(fi) + hyth(n) = cos(fi) + hyphi(n) = -sin(fi) +end do +END SUBROUTINE NFT_Init + +END MODULE NFT_mod Index: Fortran/gfortran/regression/ldist-pr45199.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ldist-pr45199.f @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-ldist-details" } + + parameter(numlev=3,numoblev=1000) + integer i_otyp(numoblev,numlev), i_styp(numoblev,numlev) + logical l_numob(numoblev,numlev) + do ixe=1,numoblev + do iye=1,numlev + i_otyp(ixe,iye)=0 + i_styp(ixe,iye)=0 + l_numob(ixe,iye)=.false. + enddo + enddo + do i=1,m + do j=1,n + if (l_numob(i,j)) then + write(20,'(7I4,F12.2,4F16.10)') i_otyp(i,j),i_styp(i,j) + endif + enddo + enddo + end + +! GCC should apply memset zero loop distribution and it should not ICE. + +! { dg-final { scan-tree-dump "distributed: split to 0 loops and 9 library calls" "ldist" } } +! { dg-final { scan-tree-dump-times "generated memset zero" 9 "ldist" } } Index: Fortran/gfortran/regression/leadz_trailz_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/leadz_trailz_1.f90 @@ -0,0 +1,133 @@ +! { dg-do run } + + integer(kind=1) :: i1 + integer(kind=2) :: i2 + integer(kind=4) :: i4 + integer(kind=8) :: i8 + + i1 = -1 + i2 = -1 + i4 = -1 + i8 = -1 + + if (leadz(i1) /= 0) STOP 1 + if (leadz(i2) /= 0) STOP 2 + if (leadz(i4) /= 0) STOP 3 + if (leadz(i8) /= 0) STOP 4 + + if (trailz(i1) /= 0) STOP 5 + if (trailz(i2) /= 0) STOP 6 + if (trailz(i4) /= 0) STOP 7 + if (trailz(i8) /= 0) STOP 8 + + if (leadz(-1_1) /= 0) STOP 9 + if (leadz(-1_2) /= 0) STOP 10 + if (leadz(-1_4) /= 0) STOP 11 + if (leadz(-1_8) /= 0) STOP 12 + + if (trailz(-1_1) /= 0) STOP 13 + if (trailz(-1_2) /= 0) STOP 14 + if (trailz(-1_4) /= 0) STOP 15 + if (trailz(-1_8) /= 0) STOP 16 + + i1 = -64 + i2 = -64 + i4 = -64 + i8 = -64 + + if (leadz(i1) /= 0) STOP 17 + if (leadz(i2) /= 0) STOP 18 + if (leadz(i4) /= 0) STOP 19 + if (leadz(i8) /= 0) STOP 20 + + if (trailz(i1) /= 6) STOP 21 + if (trailz(i2) /= 6) STOP 22 + if (trailz(i4) /= 6) STOP 23 + if (trailz(i8) /= 6) STOP 24 + + if (leadz(-64_1) /= 0) STOP 25 + if (leadz(-64_2) /= 0) STOP 26 + if (leadz(-64_4) /= 0) STOP 27 + if (leadz(-64_8) /= 0) STOP 28 + + if (trailz(-64_1) /= 6) STOP 29 + if (trailz(-64_2) /= 6) STOP 30 + if (trailz(-64_4) /= 6) STOP 31 + if (trailz(-64_8) /= 6) STOP 32 + + i1 = -108 + i2 = -108 + i4 = -108 + i8 = -108 + + if (leadz(i1) /= 0) STOP 33 + if (leadz(i2) /= 0) STOP 34 + if (leadz(i4) /= 0) STOP 35 + if (leadz(i8) /= 0) STOP 36 + + if (trailz(i1) /= 2) STOP 37 + if (trailz(i2) /= 2) STOP 38 + if (trailz(i4) /= 2) STOP 39 + if (trailz(i8) /= 2) STOP 40 + + if (leadz(-108_1) /= 0) STOP 41 + if (leadz(-108_2) /= 0) STOP 42 + if (leadz(-108_4) /= 0) STOP 43 + if (leadz(-108_8) /= 0) STOP 44 + + if (trailz(-108_1) /= 2) STOP 45 + if (trailz(-108_2) /= 2) STOP 46 + if (trailz(-108_4) /= 2) STOP 47 + if (trailz(-108_8) /= 2) STOP 48 + + i1 = 1 + i2 = 1 + i4 = 1 + i8 = 1 + + if (leadz(i1) /= bit_size(i1) - 1) STOP 49 + if (leadz(i2) /= bit_size(i2) - 1) STOP 50 + if (leadz(i4) /= bit_size(i4) - 1) STOP 51 + if (leadz(i8) /= bit_size(i8) - 1) STOP 52 + + if (trailz(i1) /= 0) STOP 53 + if (trailz(i2) /= 0) STOP 54 + if (trailz(i4) /= 0) STOP 55 + if (trailz(i8) /= 0) STOP 56 + + if (leadz(1_1) /= bit_size(1_1) - 1) STOP 57 + if (leadz(1_2) /= bit_size(1_2) - 1) STOP 58 + if (leadz(1_4) /= bit_size(1_4) - 1) STOP 59 + if (leadz(1_8) /= bit_size(1_8) - 1) STOP 60 + + if (trailz(1_1) /= 0) STOP 61 + if (trailz(1_2) /= 0) STOP 62 + if (trailz(1_4) /= 0) STOP 63 + if (trailz(1_8) /= 0) STOP 64 + + i1 = 64 + i2 = 64 + i4 = 64 + i8 = 64 + + if (leadz(i1) /= 1) STOP 65 + if (leadz(i2) /= 9) STOP 66 + if (leadz(i4) /= 25) STOP 67 + if (leadz(i8) /= 57) STOP 68 + + if (trailz(i1) /= 6) STOP 69 + if (trailz(i2) /= 6) STOP 70 + if (trailz(i4) /= 6) STOP 71 + if (trailz(i8) /= 6) STOP 72 + + if (leadz(64_1) /= 1) STOP 73 + if (leadz(64_2) /= 9) STOP 74 + if (leadz(64_4) /= 25) STOP 75 + if (leadz(64_8) /= 57) STOP 76 + + if (trailz(64_1) /= 6) STOP 77 + if (trailz(64_2) /= 6) STOP 78 + if (trailz(64_4) /= 6) STOP 79 + if (trailz(64_8) /= 6) STOP 80 + +end Index: Fortran/gfortran/regression/leadz_trailz_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/leadz_trailz_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } + + integer(kind=16) :: i16 + + i16 = -1 + if (leadz(i16) /= 0) STOP 1 + if (trailz(i16) /= 0) STOP 2 + if (leadz(-1_16) /= 0) STOP 3 + if (trailz(-1_16) /= 0) STOP 4 + + i16 = -64 + if (leadz(i16) /= 0) STOP 5 + if (trailz(i16) /= 6) STOP 6 + if (leadz(-64_16) /= 0) STOP 7 + if (trailz(-64_16) /= 6) STOP 8 + + i16 = -108 + if (leadz(i16) /= 0) STOP 9 + if (trailz(i16) /= 2) STOP 10 + if (leadz(-108_16) /= 0) STOP 11 + if (trailz(-108_16) /= 2) STOP 12 + + i16 = 1 + if (leadz(i16) /= bit_size(i16) - 1) STOP 13 + if (trailz(i16) /= 0) STOP 14 + if (leadz(1_16) /= bit_size(1_16) - 1) STOP 15 + if (trailz(1_16) /= 0) STOP 16 + + i16 = 64 + if (leadz(i16) /= 121) STOP 17 + if (trailz(i16) /= 6) STOP 18 + if (leadz(64_16) /= 121) STOP 19 + if (trailz(64_16) /= 6) STOP 20 + +end Index: Fortran/gfortran/regression/leadz_trailz_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/leadz_trailz_3.f90 @@ -0,0 +1,29 @@ +! We want to check that ISHFT evaluates its arguments only once +! +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +program test + + if (leadz (foo()) /= bit_size(0) - 1) STOP 1 + if (leadz (foo()) /= bit_size(0) - 2) STOP 2 + if (trailz (foo()) /= 0) STOP 3 + if (trailz (foo()) /= 2) STOP 4 + if (trailz (foo()) /= 0) STOP 5 + if (trailz (foo()) /= 1) STOP 6 + +contains + + integer function foo () + integer, save :: i = 0 + i = i + 1 + foo = i + end function + +end program + +! The regexp "foo ()" should be seen once in the dump: +! -- once in the function definition itself +! -- plus as many times as the function is called +! +! { dg-final { scan-tree-dump-times "foo *\\\(\\\)" 7 "original" } } Index: Fortran/gfortran/regression/len_trim.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/len_trim.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-O -Wall -Wconversion-extra -fdump-tree-original" } +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } +! PR fortran/87711 - ICE in gfc_trans_transfer +! PR fortran/87851 - return type for len_trim + +program main + implicit none + character(3), parameter :: a(1) = 'aa' + character(3) :: b = "bb" + character(3) :: c(1) = 'cc' + integer(4), parameter :: l4(1) = len_trim (a, kind=4) + integer(8), parameter :: l8(1) = len_trim (a, kind=8) + integer :: kk(1) = len_trim (a) + integer(4) :: mm(1) = len_trim (a, kind=4) + integer(8) :: nn(1) = len_trim (a, kind=8) + kk = len_trim (a) + mm = len_trim (a, kind=4) + nn = len_trim (a, kind=8) + mm = len_trim (a, 4) + nn = len_trim (a, 8) + kk = len_trim ([b]) + mm = len_trim ([b],kind=4) + nn = len_trim ([b],kind=8) + mm = len_trim ([b], 4) + nn = len_trim ([b], 8) + kk = len_trim (c) + mm = len_trim (c, kind=4) + nn = len_trim (c, kind=8) + mm = len_trim (c, 4) + nn = len_trim (c, 8) + if (any (l4 /= 2_4) .or. any (l8 /= 2_8)) stop 1 +end program main Index: Fortran/gfortran/regression/line_length_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_1.f @@ -0,0 +1,7 @@ +! Testcase for -ffixed-line-length-none +! { dg-do compile } +! { dg-options "-ffixed-line-length-none" } + program one + if (abs(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa).gt.999.d0.or.abs(bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb).gt.999.d0.or.abs(cccccccccccccccccccc).gt.999.d0) THEN + endif + end program one Index: Fortran/gfortran/regression/line_length_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_10.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Wno-line-truncation" } +! +! By default, for free-form source code: Error out +! But due to the explicit -Wno-line-truncation, compile w/o warning +! + print *, 1 + 2 + end Index: Fortran/gfortran/regression/line_length_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_11.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Wno-all" } +! +! By default, for free-form source code: Error out +! But due to the explicit -Wno-all, compile w/o warning +! + print *, 1 + 2 + end Index: Fortran/gfortran/regression/line_length_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_2.f90 @@ -0,0 +1,8 @@ +! Testcase for -ffree-line-length-none +! See PR fortran/21302 +! { dg-do compile } +! { dg-options "-ffree-line-length-none" } +program two + if (abs(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa).gt.999.d0.or.abs(bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb).gt.999.d0.or.abs(cccccccccccccccccccc).gt.999.d0) THEN + endif +end program two Index: Fortran/gfortran/regression/line_length_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_3.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=gnu -ffixed-form -Wline-truncation" } +! PR39229 No warning of truncated lines if a continuation line follows + ! expected: no warning by default (as column 73+ is often used for ) + ! comments in fixed-form source code. + ! however, with -wline-truncation there shall be a warning. + implicit none + call foo([11, 22, 33, 44, 55, 66, 770, 9900, 1100, 1100, 120], 12 warn + & , 'hello') + print *, min(35 + 1 , 25 warn + 2 ) + contains + subroutine foo(a,n,s) + integer :: a(*), n, i + character(len=*) :: s + do i = 1, n + print *, s, a(i) + end do + end subroutine foo + end +! { dg-warning "Line truncated" " " { target *-*-* } 8 } +! { dg-warning "Line truncated" " " { target *-*-* } 11 } Index: Fortran/gfortran/regression/line_length_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Wline-truncation -ffree-line-length-80" } +! PR39229 No warning of truncated lines if a continuation line follows + implicit none + call foo([11, 22, 33, 44, 55, 66, 770, 9900, 1100, 1100, 120],11,'hello') !no warn + + print *, min(35 & + & , 25 ), " Explanation ! " warn + contains + subroutine foo(a,n,s) + integer :: a(*), n, i + character(len=*) :: s + do i = 1, n + print *, s, a(i) + end do + end subroutine foo + end +! { dg-error "Line truncated" " " { target *-*-* } 8 } +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/line_length_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_5.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wline-truncation" } +print *, 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' +end +! { dg-error "Line truncated" " " { target *-*-* } 3 } +! { dg-error "Unterminated character constant" " " { target *-*-* } 3 } +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/line_length_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_6.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "" } +! +! By default, for free-form source code: Error out +! + print *, 1 + 2 ! { dg-error "Line truncated at .1." } + end +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/line_length_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Wno-error" } +! +! By default, for free-form source code: Error out +! But due to -Wno-error, we only expect a warning +! + print *, 1 + 2 ! { dg-warning "Line truncated at .1." } + end Index: Fortran/gfortran/regression/line_length_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_8.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wline-truncation" } +! +! By default, for free-form source code: Error out +! Even with -Wline-truncation, we still get an error +! + print *, 1 + 2 ! { dg-error "Line truncated at .1." } + end +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/line_length_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/line_length_9.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! By default, for free-form source code: Error out +! Even with -Wall, we still get an error +! + print *, 1 + 2 ! { dg-error "Line truncated at .1." } + end +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/linefile.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/linefile.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wall" } + +! This will verify that the # directive later does not +! mess up the diagnostic on this line +SUBROUTINE s(dummy) ! { dg-warning "Unused" } + INTEGER, INTENT(in) :: dummy +END SUBROUTINE + +# 12345 "foo-f" +SUBROUTINE s2(dummy) + INTEGER, INTENT(in) :: dummy +END SUBROUTINE +! We want to check that the # directive changes the filename in the +! diagnostic. Nothing else really matters here. dg-regexp allows us +! to see the entire diagnostic. We just have to make sure to consume +! the entire message. +! { dg-regexp "foo-f\[^\n]*" } Index: Fortran/gfortran/regression/linked_list_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/linked_list_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Regression. ICE on valid code. +! The following worked with 4.1.3 and 4.2.2, but failed +! (segmentation fault) with 4.3.0 because the type comparison +! tried to comparethe types of the components of type(node), even +! though the only component is of type(node). +! +! Found using the Fortran Company Fortran 90 Test Suite (Lite), +! Version 1.4 +! +! Reported by Tobias Burnus +! +program error + implicit none + type node + sequence + type(node), pointer :: next + end type + type(node), pointer :: list + + interface + subroutine insert(ptr) + implicit none + type node + sequence + type(node), pointer :: next + end type + type(node), pointer :: ptr + end subroutine insert + end interface + allocate (list); +end program error Index: Fortran/gfortran/regression/list_directed_large.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_directed_large.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! PR libfortran/89274 Inconsistent list directed output of INTEGER(16) +! +integer(16) :: j(2) +character(82) :: str +j = huge(1_16) +write(str,*) j +if (str /= " 170141183460469231731687303715884105727 170141183460469231731687303715884105727") stop 1 +j = 1 +write(str,*) j +if (str /= " 1 1") stop 2 +j = -huge(1_16) +write(str,*) j +if (str /= " -170141183460469231731687303715884105727 -170141183460469231731687303715884105727") stop 3 +end Index: Fortran/gfortran/regression/list_read_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Program to test terminators in list-directed input +program list_read_1 + character(len=5) :: s + + open (unit=11, status="SCRATCH") + ! The / terminator was causing the next value to be skipped. + write (11, '(a)') " 42 /" + write (11, '(a)') " 43" + write (11, '(a)') " 44" + + rewind(11) + + read (11, *) i + if (i .ne. 42) STOP 1 + read (11, *) i + if (i .ne. 43) STOP 2 + read (11, *) i + if (i .ne. 44) STOP 3 + close (11) +end + Index: Fortran/gfortran/regression/list_read_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_10.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 42422 - read with a repeat specifyer following a separator +program main + integer, dimension(10) :: i1, i2 + + i1 = 0 + i2 = (/ 1, 2, 3, 5, 5, 5, 5, 0, 0, 0 /) + open (10,file="pr42422.dat") + write (10,'(A)') ' 1 2 3 4*5 /' + rewind 10 + read (10,*) i1 + if (any(i1 /= i2)) STOP 1 + close (10,status="delete") +end program main Index: Fortran/gfortran/regression/list_read_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_11.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! +! PR fortran/57633 +! +program teststuff + implicit none + integer::a + character(len=10)::s1,s2 + + open(11,file="testcase.txt",form='unformatted',access='stream',status='new') + write(11) 'line1,1,\r\nline2' + close(11) + + open(11,file="testcase.txt",form='formatted') + s1 = repeat('x', len(s1)) + a = 99 + read(11,*)s1,a + if (s1 /= "line1" .or. a /= 1) STOP 1 + + s1 = repeat('x', len(s1)) + read(11,"(a)")s1 + close(11,status="delete") + if (s1 /= "line2") STOP 2 + + + open(11,file="testcase.txt",form='unformatted',access='stream',status='new') + write(11) 'word1\rword2,\n' + close(11) + + open(11,file="testcase.txt",form='formatted') + s1 = repeat('x', len(s1)) + s2 = repeat('x', len(s1)) + read(11,*)s1,s2 + close(11,status="delete") + if (s1 /= "word1") STOP 3 + if (s2 /= "word2") STOP 4 +end program teststuff Index: Fortran/gfortran/regression/list_read_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_12.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR58324 Bogus end of file condition +integer :: i, ios +open(99, access='stream', form='unformatted') +write(99) "5 a" +close(99) + +open(99, access='sequential', form='formatted') +read(99, *, iostat=ios) i +close(99, status="delete") +if (ios /= 0) STOP 1 +end Index: Fortran/gfortran/regression/list_read_13.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_13.f @@ -0,0 +1,13 @@ +c { dg-do run } +c PR61049, reduced test case by Dominique d'Humieres + character(len=30) :: buff = ", (2.0, 3.0),,6.0D0, 2*," + DOUBLE PRECISION AVD, BVD, CVD, DVCORR + COMPLEX AVC, BVC, CVC, ZVCORR + + read(buff, *, err=10) AVD, AVC, BVC, BVD, CVC, CVD + goto 20 + 10 STOP 1 + 20 continue + end + + Index: Fortran/gfortran/regression/list_read_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_14.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR70684 incorrect reading of values from file on Windows +program test +implicit none +integer,parameter :: isize=12 +integer,parameter :: funit=12 +integer :: i +character(1), parameter :: cr=char(13) +double precision, dimension(isize) :: a, res +res= (/ 1.0000000000000000, 2.0000000000000000, 3.0000000000000000, & + 4.0000000000000000, 5.0000000000000000, 6.0000000000000000, & + 7.0000000000000000, 8.0000000000000000, 9.0000000000000000, & + 10.000000000000000, 11.000000000000000, 12.000000000000000 /) +do i=1,isize + a(i)=dble(i) +enddo +open(funit,status="scratch") +write(funit,'(1x,6(f25.20,'',''),a)') (a(i),i=1,6), cr +write(funit,'(1x,6(f25.20,'',''),a)') (a(i),i=7,12), cr +rewind(funit) +a=0d0 +read(funit,*) (a(i),i=1,isize) +close(funit) +if (any(a /= res)) STOP 1 +end Index: Fortran/gfortran/regression/list_read_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_2.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR16805 +! Test list directed reads from character substrings +! The IO library was reporting an error rather the end-of-record when it +! got to the end of an internal file record. +program list_read_2 + implicit none + character*10 a + data a /'1234567890'/ + integer i + logical debug + data debug /.TRUE./ + read(a,*)i + if (i.ne.1234567890) STOP 1 + read(a(1:1),*)i + if (i.ne.1) STOP 2 + read(a(2:2),*)i + if (i.ne.2) STOP 3 + read(a(1:5),*)i + if (i.ne.12345) STOP 4 + read(a(5:10),*)i + if (i.ne.567890) STOP 5 + read(a(10:10),*)i + if (i.ne.0) STOP 6 +end Index: Fortran/gfortran/regression/list_read_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_3.f90 @@ -0,0 +1,101 @@ +! { dg-do run } +! Program to test reading in a list of integer values into REAL variables. +! The comma separator was not handled correctly. +! +program fg + + character(len=80) buff + logical debug + + debug = .FALSE. + a = 0 + b = 0 + c = 0 + d = 0 + write (buff,'(a)') '10,20,30,40' + read(buff,*) a, b, c, d + + if (debug) then + print*,buff + print*,a, b, c, d + end if + + if (abs(10. - a) > 1e-5) STOP 1 + if (abs(20. - b) > 1e-5) STOP 2 + if (abs(30. - c) > 1e-5) STOP 3 + if (abs(40. - d) > 1e-5) STOP 4 + + a = 0 + b = 0 + c = 0 + d = 0 + write (buff,'(a)') '10.,20.,30.,40.' + read(buff,*) a, b, c, d + + if (abs(10. - a) > 1e-5) STOP 5 + if (abs(20. - b) > 1e-5) STOP 6 + if (abs(30. - c) > 1e-5) STOP 7 + if (abs(40. - d) > 1e-5) STOP 8 + + if (debug) then + print*,buff + print*,a, b, c, d + end if + + a = 0 + b = 0 + c = 0 + d = 0 + write (buff,'(a)') '10.0,20.0,30.0,40.0' + read(buff,*) a, b, c, d + + if (abs(10. - a) > 1e-5) STOP 9 + if (abs(20. - b) > 1e-5) STOP 10 + if (abs(30. - c) > 1e-5) STOP 11 + if (abs(40. - d) > 1e-5) STOP 12 + + if (debug) then + print*,buff + print*,a, b, c, d + end if + + + a = 0 + b = -99 + c = 0 + d = 0 + write (buff,'(a)') '10.0,,30.0,40.0' + read(buff,*) a, b, c, d + + if (abs(10. - a) > 1e-5) STOP 13 + if (abs(-99. - b) > 1e-5) STOP 14 + if (abs(30. - c) > 1e-5) STOP 15 + if (abs(40. - d) > 1e-5) STOP 16 + + if (debug) then + print*,buff + print*,a, b, c, d + end if + + + call abc + +end program + +subroutine abc + + character(len=80) buff + + a = 0 + b = 0 + c = 0 + d = 0 + write (buff,'(a)') '10,-20,30,-40' + read(buff,*) a, b, c, d + + if (abs(10. - a) > 1e-5) STOP 17 + if (abs(-20. - b) > 1e-5) STOP 18 + if (abs(30. - c) > 1e-5) STOP 19 + if (abs(-40. - d) > 1e-5) STOP 20 + +end subroutine abc Index: Fortran/gfortran/regression/list_read_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_4.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Test of gfortran list directed read> check delimiters are correctly +! treated. Written in f77 so that g77 will run for comparison. +! +! f , e and i edit reads are terminated separately by read_real.c +! +! PThomas Jan 2005 +! BDavis + program list_read_4 + integer i(10),l(10),k,j + real x(10),y(10) +! expected results + data y / 1.0,2.0,3.0,-1.0,-1.0,-1.0,4.0,4.0,99.0,99.0 / + data l /1,2,3,-1,-1,-1,4,4,99,99/ +! put them in a file + open (10,status="scratch") + write (10,*) " 1.0, 2.0 , 3.0,, 2* , 2*4.0 , 5*99.0" + write (10,*) " 1.0e0, 2.0e0 , 3.0e0,, 2* , 2*4.0e0 , 5*99.0e0" + write (10,*) " 1, 2 , 3,, 2* , 2*4 , 5*99" + write (10,*) " 1, 2 , 3,, 2* , 2*4 , 5*99" + rewind (10) +! + do k = 1,10 + x(k) = -1.0 + enddo + read (10,*,iostat=ier) x + if (ier.ne.0) STOP 1 + do k = 1,10 + if (x(k).ne.y(k)) STOP 2 + x(k) = -1 + end do + READ(10,*,iostat=ier) x + if (ier.ne.0) STOP 3 + do k = 1,10 + if (x(k).ne.y(k)) STOP 4 + x(k) = -1 + end do + READ(10,*,iostat=ier) x + if (ier.ne.0) STOP 5 + do k = 1,10 + if (x(k).ne.y(k)) STOP 6 + x(k) = -1 + end do +! integer + do k = 1,10 + i(k) = -1 + end do + READ(10,*,iostat=ier) (i(j),j=1,10) + if (ier.ne.0) STOP 7 + do k = 1,10 + if (i(k).ne.y(k)) STOP 8 + i(k) = -1 + end do + end Index: Fortran/gfortran/regression/list_read_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_5.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR25307 Check handling of end-of-file conditions for list directed reads. +! Prepared by Jerry DeLisle +program pr25307 + character(len=10) :: str + character(len=10) :: a(5) + a="" + a(1)="123" + a(3)="234" + str = '123' +! Check internal unit + i = 0 + j = 0 + read( str, *, end=10 ) i,j + STOP 1 +10 continue + if (i.ne.123) STOP 2 + if (j.ne.0) STOP 3 +! Check file unit + i = 0 + open(10, status="scratch") + write(10,'(a)') "123" + rewind(10) + read(10, *, end=20) i,j + STOP 4 +20 continue + if (i.ne.123) STOP 5 + if (j.ne.0) STOP 6 +! Check internal array unit + i = 0 + j = 0 + k = 0 + read(a(1:5:2),*, end=30)i,j,k + STOP 7 +30 continue + if (i.ne.123) STOP 8 + if (j.ne.234) STOP 9 + if (k.ne.0) STOP 10 +end program pr25307 Index: Fortran/gfortran/regression/list_read_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_6.f90 @@ -0,0 +1,42 @@ +! { dg-do run { target fd_truncate } } +! PR30435 Slash at end of input not recognized according to standard. +! Test case from PR by Steve Kargl. + +program t + integer a, b, c, d + ! This worked as expected + open(unit=10, file='tmp.dat') + write(10,*) '1 2 3 / 4' + rewind(10) + a = -1; b = -1; c = -1; d = -1; + read(10,*) a,b,c,d + if (d.ne.-1) STOP 1 + + ! This worked as expected + rewind(10) + write(10,*) '1 2 3 /' + rewind(10) + a = -2; b = -2; c = -2; d = -2; + read(10,*) a,b,c,d + if (d.ne.-2) STOP 2 + + ! This worked as expected. + rewind(10) + write(10,*) '1 2' + write(10,*) '3 /' + rewind(10) + a = -3; b = -3; c = -3; d = -3; + read(10,*) a,b,c,d + if (d.ne.-3) STOP 3 + + ! This failed before the patch. + rewind(10) + write(10,*) '1 2 3' + write(10,*) '/' + rewind(10) + a = -4; b = -4; c = -4; d = -4; + read(10,*) a,b,c,d + if (d.ne.-4) STOP 4 + + close(unit=10, status='delete') +end program t Index: Fortran/gfortran/regression/list_read_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_7.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR33400 Formatted read fails if line ends without line break +! Test case modified from that in PR by +integer, parameter :: fgsl_strmax = 128 +character(len=fgsl_strmax) :: ieee_str1, ieee_str2 +open(unit=20, file='test.dat',form='FORMATTED', status="replace") +write(20,'(a)',advance="no") ' 1.01010101010101010101010101010101& + &01010101010101010101*2^-2 1.01010101010101010101011*2^-2' +rewind(20) +read(20, fmt=*) ieee_str1, ieee_str2 +if (trim(ieee_str1) /= & + '1.0101010101010101010101010101010101010101010101010101*2^-2') & + STOP 1 +if (trim(ieee_str2) /= & + '1.01010101010101010101011*2^-2') & + STOP 2 +close(20, status="delete") +end Index: Fortran/gfortran/regression/list_read_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_8.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR34676 IO error delayed +! Test case from PR modified by +implicit none +integer::i,badness +character::c +open(unit=10,status="scratch") +write(10,'(a)') '1' +write(10,'(a)') '2' +write(10,'(a)') '3' +rewind(10) +do i=1,10 + read(10,*,iostat=badness) + if (badness/=0) exit +enddo +if (i /= 4) STOP 1 +end Index: Fortran/gfortran/regression/list_read_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/list_read_9.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! pr37083 formatted read of line without trailing new-line fails +real :: a, b, c +open(unit=10,file="atest",access='stream',form='unformatted',& + & status="replace") +write(10) '1.2'//achar(10)//'2.2'//achar(10)//'3.' +call fputc(10,'3') +close(10, status="keep") +open(unit=10,file="atest",form='formatted',status="old") +read(10,*) a, b, c +if (a.ne.1.2 .or. b.ne.2.2 .or. c.ne.3.3) STOP 1 +close(10, status="delete") +end Index: Fortran/gfortran/regression/literal_character_constant_1.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_character_constant_1.inc @@ -0,0 +1,20 @@ +C fixed-form literal character constant with continuation line padding test +C PR fortran/25486 + program a + character(len=90) c + character(90) :: fil +c A tab is between 8 and 9. + c = '1234567 + &8 9' + write(fil,'(a)') c +#ifdef LL_NONE + if(fil.ne. "12345678 9") + & STOP 1 +#else + if(fil.ne. + &"1234567 8 9" + &) + & STOP 2 +#endif + end + Index: Fortran/gfortran/regression/literal_character_constant_1_x.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_character_constant_1_x.F @@ -0,0 +1,5 @@ +! { dg-do run } +C fixed-form literal character constant with continuation line padding test +C PR fortran/25486 +! { dg-options "" } +#include "literal_character_constant_1.inc" Index: Fortran/gfortran/regression/literal_character_constant_1_y.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_character_constant_1_y.F @@ -0,0 +1,5 @@ +! { dg-do run } +C fixed-form literal character constant with continuation line padding test +C PR fortran/25486 +! { dg-options "-ffixed-line-length-72" } +#include "literal_character_constant_1.inc" Index: Fortran/gfortran/regression/literal_character_constant_1_z.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_character_constant_1_z.F @@ -0,0 +1,5 @@ +! { dg-do run } +C fixed-form literal character constant with continuation line padding test +C PR fortran/25486 +! { dg-options "-ffixed-line-length-none -DLL_NONE" } +#include "literal_character_constant_1.inc" Index: Fortran/gfortran/regression/literal_constants.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_constants.f @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-ffixed-form" } +! PR fortran/92805 - blanks within literal constants in fixed-form mode + + implicit none + integer, parameter :: ck = kind ("a") ! default character kind + integer, parameter :: rk = kind (1.0) ! default real kind + print *, 1_"abc" + print *, 1 _"abc" + print *, 1_ "abc" + print *, ck_"a" + print *, ck _"ab" + print *, ck_ "ab" + print *, 3.1415_4 + print *, 3.1415 _4 + print *, 3.1415_ 4 + print *, 3.1415_rk + print *, 3.1415 _rk + print *, 3.1415_ rk + end Index: Fortran/gfortran/regression/literal_constants.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/literal_constants.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-ffree-form" } +! PR fortran/92805 - blanks within literal constants in free-form mode + + implicit none + integer, parameter :: ck = kind ("a") ! default character kind + integer, parameter :: rk = kind (1.0) ! default real kind + print *, 1_"abc" + print *, 1 _"abc" ! { dg-error "Syntax error" } + print *, 1_ "abc" ! { dg-error "Missing kind-parameter" } + print *, 1 _ "abc" ! { dg-error "Syntax error" } + print *, ck_"a" + print *, ck _"ab" ! { dg-error "Syntax error" } + print *, ck_ "ab" ! { dg-error "Syntax error" } + print *, ck _ "ab" ! { dg-error "Syntax error" } + print *, 3.1415_4 + print *, 3.1415 _4 ! { dg-error "Syntax error" } + print *, 3.1415_ 4 ! { dg-error "Missing kind-parameter" } + print *, 3.1415 _ 4 ! { dg-error "Syntax error" } + print *, 3.1415_rk + print *, 3.1415 _rk ! { dg-error "Syntax error" } + print *, 3.1415_ rk ! { dg-error "Missing kind-parameter" } + print *, 3.141 _ rk ! { dg-error "Syntax error" } + end Index: Fortran/gfortran/regression/loc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loc_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } + +! This test is here to prevent a regression in gfc_conv_intrinsic_loc. +! Taking the loc of something in a common block was a special case +! that caused in internal compiler error in gcc/expr.c, in +! expand_expr_addr_expr_1(). +program test + common /targ/targ + integer targ(10) + call fn +end program test + +subroutine fn + common /targ/targ + integer targ(10) + call foo (loc (targ)) ! Line that caused ICE +end subroutine fn + +subroutine foo (ii) + use iso_c_binding, only: c_intptr_t + common /targ/targ + integer targ(10) + integer(c_intptr_t) ii + targ(2) = ii +end subroutine foo + Index: Fortran/gfortran/regression/loc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loc_2.f90 @@ -0,0 +1,115 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Series of routines for testing a loc() implementation +program test + common /errors/errors(12) + integer i + logical errors + errors = .false. + call testloc + do i=1,12 + if (errors(i)) then + STOP 1 + endif + end do +end program test + +! Test loc +subroutine testloc + common /errors/errors(12) + logical errors + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer :: offset + integer :: i,j,k,intsize,realsize,dblsize,chsize,ch8size + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + + intsize = kind(itarg1(1)) + realsize = kind(rtarg1(1)) + chsize = kind(chtarg1(1))*len(chtarg1(1)) + ch8size = kind(ch8targ1(1))*len(ch8targ1(1)) + + do, i=1,n + offset = i-1 + if (loc(itarg1).ne.loc(itarg1(i))-offset*intsize) then + ! Error #1 + errors(1) = .true. + end if + if (loc(rtarg1).ne.loc(rtarg1(i))-offset*realsize) then + ! Error #2 + errors(2) = .true. + end if + if (loc(chtarg1).ne.loc(chtarg1(i))-offset*chsize) then + ! Error #3 + errors(3) = .true. + end if + if (loc(ch8targ1).ne.loc(ch8targ1(i))-offset*ch8size) then + ! Error #4 + errors(4) = .true. + end if + + do, j=1,m + offset = (j-1)+m*(i-1) + if (loc(itarg2).ne. & + loc(itarg2(j,i))-offset*intsize) then + ! Error #5 + errors(5) = .true. + end if + if (loc(rtarg2).ne. & + loc(rtarg2(j,i))-offset*realsize) then + ! Error #6 + errors(6) = .true. + end if + if (loc(chtarg2).ne. & + loc(chtarg2(j,i))-offset*chsize) then + ! Error #7 + errors(7) = .true. + end if + if (loc(ch8targ2).ne. & + loc(ch8targ2(j,i))-offset*ch8size) then + ! Error #8 + errors(8) = .true. + end if + + do k=1,o + offset = (k-1)+o*(j-1)+o*m*(i-1) + if (loc(itarg3).ne. & + loc(itarg3(k,j,i))-offset*intsize) then + ! Error #9 + errors(9) = .true. + end if + if (loc(rtarg3).ne. & + loc(rtarg3(k,j,i))-offset*realsize) then + ! Error #10 + errors(10) = .true. + end if + if (loc(chtarg3).ne. & + loc(chtarg3(k,j,i))-offset*chsize) then + ! Error #11 + errors(11) = .true. + end if + if (loc(ch8targ3).ne. & + loc(ch8targ3(k,j,i))-offset*ch8size) then + ! Error #12 + errors(12) = .true. + end if + + end do + end do + end do + +end subroutine testloc + Index: Fortran/gfortran/regression/logical_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR middle-end/19543 +program logical_1 + implicit none + logical(1), parameter :: t1 = .TRUE., f1 = .FALSE. + logical(2), parameter :: t2 = .TRUE., f2 = .FALSE. + logical(4), parameter :: t4 = .TRUE., f4 = .FALSE. + logical(8), parameter :: t8 = .TRUE., f8 = .FALSE. + character*2 :: t(4), f(4) + + write(t(1),*) t1 + write(f(1),*) f1 + write(t(2),*) t2 + write(f(2),*) f2 + write(t(3),*) t4 + write(f(3),*) f4 + write(t(4),*) t8 + write(f(4),*) f8 + + if (any(t .ne. " T")) STOP 1 + if (any(f .ne. " F")) STOP 2 +end Index: Fortran/gfortran/regression/logical_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/30799 +! Inconsistent handling of bad (invalid) LOGICAL kinds +! Reporter: Harald Anlauf +! Testcase altered by Steven G. Kargl +program gfcbug57 + implicit none + ! + ! These are logical kinds known by gfortran and many other compilers: + ! + print *, kind (.true._1) ! This prints "1" + print *, kind (.true._2) ! This prints "2" + print *, kind (.true._4) ! This prints "4" + print *, kind (.true._8) ! This prints "8" + ! + ! These are very strange (read: bad (invalid?)) logical kinds, + ! handled inconsistently by gfortran (there's no logical(kind=0) etc.) + ! + print *, kind (.true._0) ! { dg-error "kind for logical constant" } + print *, kind (.true._3) ! { dg-error "kind for logical constant" } + print *, kind (.true._123) ! { dg-error "kind for logical constant" } + ! + ! Here gfortran bails out with a runtime error: + ! + print *, .true._3 ! { dg-error "kind for logical constant" } +end program gfcbug57 Index: Fortran/gfortran/regression/logical_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! This checks the fix for PR30406. +! +! Contributed by Francois-Xavier Coudert +!=============================================================== + +function f() + logical(8) :: f + f = .false._8 +end function f Index: Fortran/gfortran/regression/logical_assignment_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_assignment_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 79312 - assigning a logical value to a real +! is invalid. +! Test case by John Harper. +program emptyarray5 + implicit none + real a(0) + a = [logical::] ! { dg-error "Cannot convert LOGICAL" } + print *,size(a) +end program emptyarray5 Index: Fortran/gfortran/regression/logical_comp.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_comp.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/22503, PR fortran/32899 +! Suggest use of appropriate comparison operator + +program foo + logical :: b + b = b .eq. b ! { dg-error "must be compared with" } + b = b .ne. b ! { dg-error "must be compared with" } +end program Index: Fortran/gfortran/regression/logical_data_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_data_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR19589 +! Logical objects/values with differing type kinds were being rejected in +! data statements. +program logical_data_1 + logical(kind=4) :: a + logical(kind=8) :: b + data a, b /.true., .false./ +end program Index: Fortran/gfortran/regression/logical_dot_product.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_dot_product.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Checks the LOGICAL version of dot_product +! +! Contributed by Paul Thomas +! + logical :: l1(4) = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./) + logical :: l2(4) = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./) + if (dot_product (l1, l2)) STOP 1 + l2 = .TRUE. + if (.not.dot_product (l1, l2)) STOP 2 +end \ No newline at end of file Index: Fortran/gfortran/regression/logical_temp_io.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_temp_io.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 82869 +! A temp variable of type logical was incorrectly transferred +! to the I/O library as a logical type of a different kind. +program pr82869 + use, intrinsic :: iso_c_binding + type(c_ptr) :: p = c_null_ptr + character(len=4) :: s + write (s, *) c_associated(p), c_associated(c_null_ptr) + if (s /= ' F F') then + STOP 1 + end if +end program pr82869 Index: Fortran/gfortran/regression/logical_temp_io_kind8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logical_temp_io_kind8.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! PR 82869 +! A temp variable of type logical was incorrectly transferred +! to the I/O library as a logical type of a different kind. +program pr82869_8 + use, intrinsic :: iso_c_binding + type(c_ptr) :: p = c_null_ptr + character(len=4) :: s + write (s, *) c_associated(p), c_associated(c_null_ptr) + if (s /= ' F F') then + STOP 1 + end if +end program pr82869_8 Index: Fortran/gfortran/regression/logint_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logint_1.f @@ -0,0 +1,43 @@ +c { dg-do compile } +c { dg-options "-O2 -std=legacy" } + LOGICAL(kind=1) l1 + LOGICAL(kind=2) l2 + LOGICAL l4 + INTEGER(kind=1) i1 + INTEGER(kind=2) i2 + INTEGER i4 + + i1 = .TRUE. + i2 = .TRUE. + i4 = .TRUE. + + i1 = .FALSE. + i2 = .FALSE. + i4 = .FALSE. + + i1 = l1 + i2 = l1 + i4 = l1 + + i1 = l2 + i2 = l2 + i4 = l2 + + i1 = l4 + i2 = l4 + i4 = l4 + + l1 = i1 + l2 = i1 + l4 = i1 + + l1 = i2 + l2 = i2 + l4 = i2 + + l1 = i4 + l2 = i4 + l4 = i4 + + END + Index: Fortran/gfortran/regression/logint_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logint_2.f @@ -0,0 +1,43 @@ +c { dg-do compile } +c { dg-options "-O2 -std=f95" } + LOGICAL(kind=1) l1 + LOGICAL(kind=2) l2 + LOGICAL l4 + INTEGER(kind=1) i1 + INTEGER(kind=2) i2 + INTEGER i4 + + i1 = .TRUE. ! { dg-error "convert" } + i2 = .TRUE. ! { dg-error "convert" } + i4 = .TRUE. ! { dg-error "convert" } + + i1 = .FALSE. ! { dg-error "convert" } + i2 = .FALSE. ! { dg-error "convert" } + i4 = .FALSE. ! { dg-error "convert" } + + i1 = l1 ! { dg-error "convert" } + i2 = l1 ! { dg-error "convert" } + i4 = l1 ! { dg-error "convert" } + + i1 = l2 ! { dg-error "convert" } + i2 = l2 ! { dg-error "convert" } + i4 = l2 ! { dg-error "convert" } + + i1 = l4 ! { dg-error "convert" } + i2 = l4 ! { dg-error "convert" } + i4 = l4 ! { dg-error "convert" } + + l1 = i1 ! { dg-error "convert" } + l2 = i1 ! { dg-error "convert" } + l4 = i1 ! { dg-error "convert" } + + l1 = i2 ! { dg-error "convert" } + l2 = i2 ! { dg-error "convert" } + l4 = i2 ! { dg-error "convert" } + + l1 = i4 ! { dg-error "convert" } + l2 = i4 ! { dg-error "convert" } + l4 = i4 ! { dg-error "convert" } + + END + Index: Fortran/gfortran/regression/logint_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/logint_3.f @@ -0,0 +1,43 @@ +c { dg-do compile } +c { dg-options "-O2" } + LOGICAL(kind=1) l1 + LOGICAL(kind=2) l2 + LOGICAL l4 + INTEGER(kind=1) i1 + INTEGER(kind=2) i2 + INTEGER i4 + + i1 = .TRUE. ! { dg-warning "Extension: Conversion" } + i2 = .TRUE. ! { dg-warning "Extension: Conversion" } + i4 = .TRUE. ! { dg-warning "Extension: Conversion" } + + i1 = .FALSE. ! { dg-warning "Extension: Conversion" } + i2 = .FALSE. ! { dg-warning "Extension: Conversion" } + i4 = .FALSE. ! { dg-warning "Extension: Conversion" } + + i1 = l1 ! { dg-warning "Extension: Conversion" } + i2 = l1 ! { dg-warning "Extension: Conversion" } + i4 = l1 ! { dg-warning "Extension: Conversion" } + + i1 = l2 ! { dg-warning "Extension: Conversion" } + i2 = l2 ! { dg-warning "Extension: Conversion" } + i4 = l2 ! { dg-warning "Extension: Conversion" } + + i1 = l4 ! { dg-warning "Extension: Conversion" } + i2 = l4 ! { dg-warning "Extension: Conversion" } + i4 = l4 ! { dg-warning "Extension: Conversion" } + + l1 = i1 ! { dg-warning "Extension: Conversion" } + l2 = i1 ! { dg-warning "Extension: Conversion" } + l4 = i1 ! { dg-warning "Extension: Conversion" } + + l1 = i2 ! { dg-warning "Extension: Conversion" } + l2 = i2 ! { dg-warning "Extension: Conversion" } + l4 = i2 ! { dg-warning "Extension: Conversion" } + + l1 = i4 ! { dg-warning "Extension: Conversion" } + l2 = i4 ! { dg-warning "Extension: Conversion" } + l4 = i4 ! { dg-warning "Extension: Conversion" } + + END + Index: Fortran/gfortran/regression/longline.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/longline.f @@ -0,0 +1,11 @@ +# 1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.f" +! { dg-do compile } +! { dg-options "-std=legacy" } + + subroutine foo + character*10 cpnam + character*4 csig + write (34,808) csig,ilax,cpnam + 808 format (/9X,4HTHE ,A4, 29HTIVE MINOS ERROR OF PARAMETER,I3, 2H + +, ,A10) + end Index: Fortran/gfortran/regression/longnames.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/longnames.f90 @@ -0,0 +1,92 @@ +! { dg-do compile } +! +! PR fortran/99369 +! +! Contributed by G. Steinmetz +! + +module m1bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + type tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + end type + interface operator (.oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc.) + procedure fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + end interface +contains + function fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc & + (uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc) + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc), intent(in) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + end +end +subroutine p1 + use m1bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc + wabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc = & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc & + .oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc. & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabc +end + + +module m2bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + type tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + end type + interface operator (.oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd.) + procedure fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + end interface +contains + function fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd & + (uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd) + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd), intent(in) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + end +end +subroutine p2 + use m2bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd + wabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd = & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd & + .oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd. & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcd +end + + +module m3bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + type tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + end type + interface operator (.oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab.) + procedure fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + end interface +contains + function fabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab & + (uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab) + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab), intent(in) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + end +end +subroutine p3 + use m3bcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + type (tabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab) :: & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab, & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab + wabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab = & + uabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab & + .oabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab. & + vabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzabcdefgxyzab +end + +program main + call p1 + call p2 + call p3 +end Index: Fortran/gfortran/regression/loop_interchange_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_interchange_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-O -Wfrontend-loop-interchange" } +PROGRAM TEST_DO_SPEED + IMPLICIT NONE + + REAL, ALLOCATABLE :: A(:,:,:), B(:,:,:), C(:,:,:) + REAL :: TIC + INTEGER :: T0, T1, T2 + INTEGER :: I, J, K + INTEGER, PARAMETER :: L = 512, M = 512, N = 512 + + ALLOCATE( A(L,M,N), B(L,M,N), C(L,M,N) ) + CALL RANDOM_NUMBER(A) + CALL RANDOM_NUMBER(B) + + CALL SYSTEM_CLOCK( T0, TIC) + + DO CONCURRENT( K=1:N, J=1:M, I=1:L) ! { dg-warning "Interchanging loops" } + C(I,J,K) = A(I,J,K) +B(I,J,K) + END DO +END + Index: Fortran/gfortran/regression/loop_interchange_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_interchange_2.f @@ -0,0 +1,20 @@ +C { dg-do compile } +C { dg-options "-std=legacy -O3 -floop-interchange" } +C PR 50439 - this used to hang. Test case by Pat Haugen. + + subroutine comnul +C----------------------------------------------------------------------- + implicit real*8 (a-h,o-z) + parameter(zero=0.0d0,half=0.5d0,one=1.0d0) + common/secom/rtc(9,18,10,5),rts(9,18,10,5) + save +C----------------------------------------------------------------------- + do 110 i1=1,9 + do 110 i2=1,18 + do 110 i3=1,10 + do 110 i4=1,5 + rtc(i1,i2,i3,i4)=zero + rts(i1,i2,i3,i4)=zero + 110 continue + return + end Index: Fortran/gfortran/regression/loop_versioning_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_1.f90 @@ -0,0 +1,28 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +! The simplest IV case. + +subroutine f1(x) + real :: x(:) + x(:) = 100 +end subroutine f1 + +subroutine f2(x, n, step) + integer :: n, step + real :: x(n * step) + do i = 1, n + x(i * step) = 100 + end do +end subroutine f2 + +subroutine f3(x, limit, step) + integer :: limit, step + real :: x(limit) + do i = 1, limit, step + x(i) = 100 + end do +end subroutine f3 + +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 3 "lversion" } } +! { dg-final { scan-tree-dump-times {versioned this loop} 3 "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_10.f90 @@ -0,0 +1,31 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +subroutine f1(x) + real :: x(:, :) + x(:, 1) = 100 +end subroutine f1 + +subroutine f2(x, i) + real :: x(:, :) + integer :: i + x(:, i) = 100 +end subroutine f2 + +subroutine f3(x) + real :: x(:, :) + do j = lbound(x, 1), ubound(x, 1) + x(j, 1) = 100 + end do +end subroutine f3 + +subroutine f4(x, i) + real :: x(:, :) + integer :: i + do j = lbound(x, 1), ubound(x, 1) + x(j, i) = 100 + end do +end subroutine f4 + +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" } } +! { dg-final { scan-tree-dump-times {want to version} 4 "lversion" } } +! { dg-final { scan-tree-dump-times {versioned} 4 "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_2.f90 @@ -0,0 +1,39 @@ +! { dg-options "-O3 -fdump-tree-lversion-details -fno-frontend-loop-interchange" } + +! We could version the loop for when the first dimension has a stride +! of 1, but at present there's no real benefit. The gimple loop +! interchange pass couldn't handle the versioned loop, and interchange +! is instead done by the frontend (but disabled by the options above). + +subroutine f1(x) + real :: x(:, :) + do i = lbound(x, 1), ubound(x, 1) + do j = lbound(x, 2), ubound(x, 2) + x(i, j) = 100 + end do + end do +end subroutine f1 + +subroutine f2(x, n, step) + integer :: n, step + real :: x(100, 100) + do i = 1, n + do j = 1, n + x(i * step, j) = 100 + end do + end do +end subroutine f2 + +subroutine f3(x, n, step) + integer :: n, step + real :: x(n * step, n) + do i = 1, n + do j = 1, n + x(i * step, j) = 100 + end do + end do +end subroutine f3 + +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" } } +! { dg-final { scan-tree-dump-not {want to version} "lversion" } } +! { dg-final { scan-tree-dump-not {versioned} "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_3.f90 @@ -0,0 +1,30 @@ +! { dg-options "-O3 -fdump-tree-lversion-details -fno-frontend-loop-interchange" } + +! Test a case in which the outer loop iterates over the inner dimension. +! The options above prevent the frontend from interchanging the loops. + +subroutine f1(x, limit, step, n) + integer :: limit, step, n + real :: x(limit, n) + do i = 1, limit, step + do j = 1, n + x(i, j) = 100 + end do + end do +end subroutine f1 + +subroutine f2(x, n, limit, step) + integer :: n, limit, step + real :: x(limit, n) + do i = 1, n + do j = 1, limit, step + x(j, i) = 100 + end do + end do +end subroutine f2 + +! FIXME: The frontend doesn't give us enough information to tell which loop +! is iterating over the innermost dimension, so we optimistically +! assume the inner one is. +! { dg-final { scan-tree-dump-not {want to version} "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-not {versioned} "lversion" { xfail *-*-* } } } Index: Fortran/gfortran/regression/loop_versioning_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_4.f90 @@ -0,0 +1,95 @@ +! { dg-options "-O3 -fdump-tree-lversion-details -fno-frontend-loop-interchange" } + +! Test cases in which versioning is useful for a two-dimensional array. + +subroutine f1(x) + real :: x(:, :) + x(:, :) = 100 +end subroutine f1 + +subroutine f2(x) + real :: x(:, :) + do i = lbound(x, 1), ubound(x, 1) + do j = lbound(x, 2), ubound(x, 2) + x(j, i) = 100 + end do + end do +end subroutine f2 + +subroutine f3(x, n, step) + integer :: n, step + real :: x(100, 100) + do i = 1, n + do j = 1, n + x(j * step, i) = 100 + end do + end do +end subroutine f3 + +subroutine f4(x, n, step) + integer :: n, step + real :: x(n * step, n) + do i = 1, n + do j = 1, n + x(j * step, i) = 100 + end do + end do +end subroutine f4 + +subroutine f5(x, n, limit, step) + integer :: n, limit, step + real :: x(limit, n) + do i = 1, n + do j = 1, limit, step + x(j, i) = 100 + end do + end do +end subroutine f5 + +subroutine f6(x, y) + real :: x(:, :), y(:) + do i = lbound(x, 1), ubound(x, 1) + do j = lbound(x, 2), ubound(x, 2) + x(j, i) = 100 + end do + y(i) = 200 + end do +end subroutine f6 + +subroutine f7(x, y, n, step) + integer :: n, step + real :: x(100, 100), y(100) + do i = 1, n + do j = 1, n + x(j * step, i) = 100 + end do + y(i * step) = 200 + end do +end subroutine f7 + +subroutine f8(x, y, n, step) + integer :: n, step + real :: x(n * step, n), y(n * step) + do i = 1, n + do j = 1, n + x(j * step, i) = 100 + end do + y(i * step) = 200 + end do +end subroutine f8 + +subroutine f9(x, n, limit, step) + integer :: n, limit, step + real :: x(limit, n), y(limit) + do i = 1, n + do j = 1, limit, step + x(j, i) = 100 + end do + y(i) = 200 + end do +end subroutine f9 + +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 3 "lversion" } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" } } +! { dg-final { scan-tree-dump-times {hoisting check} 9 "lversion" } } +! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_5.f90 @@ -0,0 +1,57 @@ +! { dg-options "-O3 -fdump-tree-lversion-details -fno-frontend-loop-interchange" } + +! Make sure that in a "badly nested" loop, we don't treat the inner loop +! as iterating over the inner dimension with a variable stride. + +subroutine f1(x, n) + integer :: n + real :: x(100, 100) + do i = 1, n + do j = 1, n + x(i, j) = 100 + end do + end do +end subroutine f1 + +subroutine f2(x, n, step) + integer :: n, step + real :: x(100, 100) + do i = 1, n + do j = 1, n + x(i, j * step) = 100 + end do + end do +end subroutine f2 + +subroutine f3(x, n) + integer :: n + real :: x(n, n) + do i = 1, n + do j = 1, n + x(i, j) = 100 + end do + end do +end subroutine f3 + +subroutine f4(x, n, step) + integer :: n, step + real :: x(n, n * step) + do i = 1, n + do j = 1, n + x(i, j * step) = 100 + end do + end do +end subroutine f4 + +subroutine f5(x, n, limit, step) + integer :: n, limit, step + real :: x(n, limit) + do i = 1, n + do j = 1, limit, step + x(i, j) = 100 + end do + end do +end subroutine f5 + +! { dg-final { scan-tree-dump-not {want to version} "lversion" } } +! { dg-final { scan-tree-dump-not {versioned} "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_6.f90 @@ -0,0 +1,93 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +! Check that versioning can handle small groups of accesses. + +subroutine f1(x) + real :: x(:) + do i = lbound(x, 1), ubound(x, 1) / 2 + x(i * 2) = 100 + x(i * 2 + 1) = 101 + end do +end subroutine f1 + +subroutine f2(x, n, step) + integer :: n, step + real :: x(n * step * 2) + do i = 1, n + x(i * step * 2) = 100 + x(i * step * 2 + 1) = 101 + end do +end subroutine f2 + +subroutine f3(x, limit, step) + integer :: limit, step + real :: x(limit * 2) + do i = 1, limit, step + x(i * 2) = 100 + x(i * 2 + 1) = 101 + end do +end subroutine f3 + +subroutine f4(x) + real :: x(:) + do i = lbound(x, 1), ubound(x, 1) / 3 + x(i * 3) = 100 + x(i * 3 + 1) = 101 + x(i * 3 + 2) = 102 + end do +end subroutine f4 + +subroutine f5(x, n, step) + integer :: n, step + real :: x(n * step * 3) + do i = 1, n + x(i * step * 3) = 100 + x(i * step * 3 + 1) = 101 + x(i * step * 3 + 2) = 102 + end do +end subroutine f5 + +subroutine f6(x, limit, step) + integer :: limit, step + real :: x(limit * 3) + do i = 1, limit, step + x(i * 3) = 100 + x(i * 3 + 1) = 101 + x(i * 3 + 2) = 102 + end do +end subroutine f6 + +subroutine f7(x) + real :: x(:) + do i = lbound(x, 1), ubound(x, 1) / 4 + x(i * 4) = 100 + x(i * 4 + 1) = 101 + x(i * 4 + 2) = 102 + x(i * 4 + 3) = 103 + end do +end subroutine f7 + +subroutine f8(x, n, step) + integer :: n, step + real :: x(n * step * 4) + do i = 1, n + x(i * step * 4) = 100 + x(i * step * 4 + 1) = 101 + x(i * step * 4 + 2) = 102 + x(i * step * 4 + 3) = 103 + end do +end subroutine f8 + +subroutine f9(x, limit, step) + integer :: limit, step + real :: x(limit * 4) + do i = 1, limit, step + x(i * 4) = 100 + x(i * 4 + 1) = 101 + x(i * 4 + 2) = 102 + x(i * 4 + 3) = 103 + end do +end subroutine f9 + +! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" { xfail { ! lp64 } } } } +! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" { xfail { ! lp64 } } } } Index: Fortran/gfortran/regression/loop_versioning_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_7.f90 @@ -0,0 +1,67 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +! Check that versioning can handle small groups of accesses, with the +! group being a separate array dimension. + +subroutine f1(x, n, step) + integer :: n, step + real :: x(2, n * step) + do i = 1, n + x(1, i * step) = 100 + x(2, i * step) = 101 + end do +end subroutine f1 + +subroutine f2(x, limit, step) + integer :: limit, step + real :: x(2, limit) + do i = 1, limit, step + x(1, i) = 100 + x(2, i) = 101 + end do +end subroutine f2 + +subroutine f3(x, n, step) + integer :: n, step + real :: x(3, n * step) + do i = 1, n + x(1, i * step) = 100 + x(2, i * step) = 101 + x(3, i * step) = 102 + end do +end subroutine f3 + +subroutine f4(x, limit, step) + integer :: limit, step + real :: x(3, limit) + do i = 1, limit, step + x(1, i) = 100 + x(2, i) = 101 + x(3, i) = 102 + end do +end subroutine f4 + +subroutine f5(x, n, step) + integer :: n, step + real :: x(4, n * step) + do i = 1, n + x(1, i * step) = 100 + x(2, i * step) = 101 + x(3, i * step) = 102 + x(4, i * step) = 103 + end do +end subroutine f5 + +subroutine f6(x, limit, step) + integer :: limit, step + real :: x(4, limit) + do i = 1, limit, step + x(1, i) = 100 + x(2, i) = 101 + x(3, i) = 102 + x(4, i) = 103 + end do +end subroutine f6 + +! { dg-final { scan-tree-dump-times {want to version containing loop} 6 "lversion" } } +! { dg-final { scan-tree-dump-times {versioned this loop} 6 "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_8.f90 @@ -0,0 +1,13 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +! Check that versioning is applied to a gather-like reduction operation. + +function f(x, index, n) + integer :: n + real :: x(:) + integer :: index(n) + f = sum(x(index(:))) +end function f + +! { dg-final { scan-tree-dump-times {want to version containing loop} 1 "lversion" } } +! { dg-final { scan-tree-dump-times {versioned this loop} 1 "lversion" } } Index: Fortran/gfortran/regression/loop_versioning_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/loop_versioning_9.f90 @@ -0,0 +1,31 @@ +! { dg-options "-O3 -fdump-tree-lversion-details" } + +subroutine f1(x) + real :: x(:, :) + x(1, :) = 100 +end subroutine f1 + +subroutine f2(x, i) + real :: x(:, :) + integer :: i + x(i, :) = 100 +end subroutine f2 + +subroutine f3(x) + real :: x(:, :) + do j = lbound(x, 2), ubound(x, 2) + x(1, j) = 100 + end do +end subroutine f3 + +subroutine f4(x, i) + real :: x(:, :) + integer :: i + do j = lbound(x, 2), ubound(x, 2) + x(i, j) = 100 + end do +end subroutine f4 + +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" } } +! { dg-final { scan-tree-dump-not {want to version} "lversion" } } +! { dg-final { scan-tree-dump-not {versioned} "lversion" } } Index: Fortran/gfortran/regression/lrshift_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lrshift_1.c @@ -0,0 +1,3 @@ +/* Left and right shift C routines, to compare to Fortran results. */ +int c_lshift_ (int *x, int *y) { return (*x) << (*y); } +int c_rshift_ (int *x, int *y) { return (*x) >> (*y); } Index: Fortran/gfortran/regression/lrshift_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lrshift_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-std=gnu -w" } +! { dg-additional-sources lrshift_1.c } +program test_rshift_lshift + implicit none + integer :: i(15), j, n + integer, external :: c_lshift, c_rshift + + i = (/ -huge(i), -huge(i)/2, -129, -128, -127, -2, -1, 0, & + 1, 2, 127, 128, 129, huge(i)/2, huge(i) /) + + do n = 1, size(i) + do j = 0, 31 + if (lshift(i(n),j) /= c_lshift(i(n),j)) STOP 1 + if (rshift(i(n),j) /= c_rshift(i(n),j)) STOP 2 + end do + end do +end program test_rshift_lshift Index: Fortran/gfortran/regression/ltime_gmtime_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ltime_gmtime_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-std=gnu" } + integer :: x(9), y(9), t + + t = time() + call ltime(t,x) + call gmtime(t,y) + if (x(1) /= y(1) .or. mod(x(2),30) /= mod(y(2),30)) STOP 1 + end Index: Fortran/gfortran/regression/ltime_gmtime_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ltime_gmtime_2.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8 -std=gnu" } + integer :: x(9), y(9), t + + t = time() + call ltime(t,x) + call gmtime(t,y) + if (x(1) /= y(1) .or. mod(x(2),30) /= mod(y(2),30)) STOP 1 + end Index: Fortran/gfortran/regression/make_unit.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/make_unit.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! PR61933, useing inquire to get available units. +program makeunit +integer :: ic, istat, nc +logical :: exists, is_open + +if (get_unit_number("foo0.dat") .ne. 10) STOP 1 +if (get_unit_number("foo1.dat") .ne. 11) STOP 2 +if (get_unit_number("foo2.dat") .ne. 12) STOP 3 +if (get_unit_number("foo3.dat") .ne. 13) STOP 4 + +close(unit=12, status="delete") +if (get_unit_number("foo2.dat") .ne. 12) STOP 1 +close(unit=10, status="delete") +close(unit=11, status="delete") +close(unit=12, status="delete") +close(unit=13, status="delete") + +contains + function get_unit_number(file_name) result(unit_number) + character(len=*), intent(in), optional :: file_name + integer :: unit_number + ! get a new unit number + do unit_number=10,100 + inquire (unit=unit_number,exist=exists,opened=is_open,iostat=istat) + if (exists.and.(.not.is_open).and.(istat == 0)) then + open(unit=unit_number, file=file_name) + return + endif + end do + unit_number = -1 + end function get_unit_number + +end program makeunit Index: Fortran/gfortran/regression/malloc_free_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/malloc_free_1.f90 @@ -0,0 +1,11 @@ +! Test for the MALLOC and FREE intrinsics +! If something is wrong with them, this test might segfault +! { dg-do run } + integer j + integer(kind=8) i8 + + do j = 1, 10000 + i8 = malloc (10 * j) + call free (i8) + end do + end Index: Fortran/gfortran/regression/mapping_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mapping_1.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! Tests the fix for PR31213, which exposed rather a lot of +! bugs - see the PR and the ChangeLog. +! +! Contributed by Joost VandeVondele +! +module mykinds + implicit none + integer, parameter :: ik1 = selected_int_kind (2) + integer, parameter :: ik2 = selected_int_kind (4) + integer, parameter :: dp = selected_real_kind (15,300) +end module mykinds + +module spec_xpr + use mykinds + implicit none + integer(ik2) c_size +contains + pure function tricky (str,ugly) + character(*), intent(in) :: str + integer(ik1) :: ia_ik1(len(str)) + interface yoagly + pure function ugly(n) + use mykinds + implicit none + integer, intent(in) :: n + complex(dp) :: ugly(3*n+2) + end function ugly + end interface yoagly + logical :: la(size (yoagly (size (ia_ik1)))) + integer :: i + character(tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size) :: tricky + + tricky = transfer (yoagly (1), tricky) + end function tricky + + pure function tricky_helper (lb) + logical, intent(in) :: lb(:) + integer :: tricky_helper + tricky_helper = 2 * size (lb) + 3 + end function tricky_helper +end module spec_xpr + +module xtra_fun + implicit none +contains + pure function butt_ugly(n) + use mykinds + implicit none + integer, intent(in) :: n + complex(dp) :: butt_ugly(3*n+2) + real(dp) pi, sq2 + + pi = 4 * atan (1.0_dp) + sq2 = sqrt (2.0_dp) + butt_ugly = cmplx (pi, sq2, dp) + end function butt_ugly +end module xtra_fun + +program spec_test + use mykinds + use spec_xpr + use xtra_fun + implicit none + character(54) :: chr + + c_size = 5 + if (tricky ('Help me', butt_ugly) .ne. transfer (butt_ugly (1), chr)) STOP 1 +end program spec_test Index: Fortran/gfortran/regression/mapping_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mapping_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR33998, in which the chain of expressions +! determining the character length of my_string were not being +! resolved by the formal to actual mapping. +! +! Contributed by Tobias Burnus +! +module test + implicit none + contains + function my_string(x) + integer i + real, intent(in) :: x(:) + character(0) h4(1:minval([(i,i=30,32), 15])) + character(0) sv1(size(x,1):size(h4)) + character(0) sv2(2*lbound(sv1,1):size(h4)) + character(lbound(sv2,1)-3) my_string + + do i = 1, len(my_string) + my_string(i:i) = achar(modulo(i-1,10)+iachar('0')) + end do + end function my_string +end module test + +program len_test + use test + implicit none + real x(7) + + if (my_string(x) .ne. "01234567890") STOP 1 +end program len_test Index: Fortran/gfortran/regression/mapping_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mapping_3.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Tests the fix for PR33888, in which the character length of +! the elemental function myfunc was not being calculated before +! the temporary for the array result was allocated. +! +! Contributed by Walter Spector +! +program ftn95bug + implicit none + + character(8) :: indata(4) = & + (/ '12344321', '98766789', 'abcdefgh', 'ABCDEFGH' /) + + call process (myfunc (indata)) ! <- This caused a gfortran ICE ! + +contains + + elemental function myfunc (s) + character(*), intent(in) :: s + character(len (s)) :: myfunc + + myfunc = s + + end function + + subroutine process (strings) + character(*), intent(in) :: strings(:) + + if (any (strings .ne. indata)) STOP 1 + + end subroutine + +end program Index: Fortran/gfortran/regression/maskl_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maskl_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/103789 +! Check the absence of ICE when generating calls to MASKL with a KIND argument. + +program p + integer :: z(2), y(2), x(2) + y = [1, 13] + z = maskl(y, kind=4) + 1 + x = maskl(y, 4) + 1 +end program p Index: Fortran/gfortran/regression/masklr_1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/masklr_1.F90 @@ -0,0 +1,82 @@ +! Test the MASKL and MASKR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + +#define CHECK(I,KIND,FUNCL,FUNCR,RESL,RESR) \ + if (maskl(I,KIND) /= RESL) STOP 1; \ + if (FUNCL(I) /= RESL) STOP 2; \ + if (maskr(I,KIND) /= RESR) STOP 3; \ + if (FUNCR(I) /= RESR) STOP 4 + + CHECK(0,1,run_maskl1,run_maskr1,0_1,0_1) + CHECK(1,1,run_maskl1,run_maskr1,-huge(0_1)-1_1,1_1) + CHECK(2,1,run_maskl1,run_maskr1,(-huge(0_1)-1_1)/2_1,3_1) + CHECK(3,1,run_maskl1,run_maskr1,(-huge(0_1)-1_1)/4_1,7_1) + CHECK(int(bit_size(0_1))-2,1,run_maskl1,run_maskr1,-4_1,huge(0_1)/2_1) + CHECK(int(bit_size(0_1))-1,1,run_maskl1,run_maskr1,-2_1,huge(0_1)) + CHECK(int(bit_size(0_1)),1,run_maskl1,run_maskr1,-1_1,-1_1) + + CHECK(0,2,run_maskl2,run_maskr2,0_2,0_2) + CHECK(1,2,run_maskl2,run_maskr2,-huge(0_2)-1_2,1_2) + CHECK(2,2,run_maskl2,run_maskr2,(-huge(0_2)-1_2)/2_2,3_2) + CHECK(3,2,run_maskl2,run_maskr2,(-huge(0_2)-1_2)/4_2,7_2) + CHECK(int(bit_size(0_2))-2,2,run_maskl2,run_maskr2,-4_2,huge(0_2)/2_2) + CHECK(int(bit_size(0_2))-1,2,run_maskl2,run_maskr2,-2_2,huge(0_2)) + CHECK(int(bit_size(0_2)),2,run_maskl2,run_maskr2,-1_2,-1_2) + + CHECK(0,4,run_maskl4,run_maskr4,0_4,0_4) + CHECK(1,4,run_maskl4,run_maskr4,-huge(0_4)-1_4,1_4) + CHECK(2,4,run_maskl4,run_maskr4,(-huge(0_4)-1_4)/2_4,3_4) + CHECK(3,4,run_maskl4,run_maskr4,(-huge(0_4)-1_4)/4_4,7_4) + CHECK(int(bit_size(0_4))-2,4,run_maskl4,run_maskr4,-4_4,huge(0_4)/2_4) + CHECK(int(bit_size(0_4))-1,4,run_maskl4,run_maskr4,-2_4,huge(0_4)) + CHECK(int(bit_size(0_4)),4,run_maskl4,run_maskr4,-1_4,-1_4) + + CHECK(0,8,run_maskl8,run_maskr8,0_8,0_8) + CHECK(1,8,run_maskl8,run_maskr8,-huge(0_8)-1_8,1_8) + CHECK(2,8,run_maskl8,run_maskr8,(-huge(0_8)-1_8)/2_8,3_8) + CHECK(3,8,run_maskl8,run_maskr8,(-huge(0_8)-1_8)/4_8,7_8) + CHECK(int(bit_size(0_8))-2,8,run_maskl8,run_maskr8,-4_8,huge(0_8)/2_8) + CHECK(int(bit_size(0_8))-1,8,run_maskl8,run_maskr8,-2_8,huge(0_8)) + CHECK(int(bit_size(0_8)),8,run_maskl8,run_maskr8,-1_8,-1_8) + +contains + + pure integer(kind=1) function run_maskl1(i) result(res) + integer, intent(in) :: i + res = maskl(i,kind=1) + end function + pure integer(kind=1) function run_maskr1(i) result(res) + integer, intent(in) :: i + res = maskr(i,kind=1) + end function + + pure integer(kind=2) function run_maskl2(i) result(res) + integer, intent(in) :: i + res = maskl(i,kind=2) + end function + pure integer(kind=2) function run_maskr2(i) result(res) + integer, intent(in) :: i + res = maskr(i,kind=2) + end function + + pure integer(kind=4) function run_maskl4(i) result(res) + integer, intent(in) :: i + res = maskl(i,kind=4) + end function + pure integer(kind=4) function run_maskr4(i) result(res) + integer, intent(in) :: i + res = maskr(i,kind=4) + end function + + pure integer(kind=8) function run_maskl8(i) result(res) + integer, intent(in) :: i + res = maskl(i,kind=8) + end function + pure integer(kind=8) function run_maskr8(i) result(res) + integer, intent(in) :: i + res = maskr(i,kind=8) + end function + +end Index: Fortran/gfortran/regression/masklr_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/masklr_2.F90 @@ -0,0 +1,32 @@ +! Test the MASKL and MASKR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + +#define CHECK(I,KIND,FUNCL,FUNCR,RESL,RESR) \ + if (maskl(I,KIND) /= RESL) STOP 1; \ + if (FUNCL(I) /= RESL) STOP 2; \ + if (maskr(I,KIND) /= RESR) STOP 3; \ + if (FUNCR(I) /= RESR) STOP 4 + + CHECK(0,16,run_maskl16,run_maskr16,0_16,0_16) + CHECK(1,16,run_maskl16,run_maskr16,-huge(0_16)-1_16,1_16) + CHECK(2,16,run_maskl16,run_maskr16,(-huge(0_16)-1_16)/2_16,3_16) + CHECK(3,16,run_maskl16,run_maskr16,(-huge(0_16)-1_16)/4_16,7_16) + CHECK(int(bit_size(0_16))-2,16,run_maskl16,run_maskr16,-4_16,huge(0_16)/2_16) + CHECK(int(bit_size(0_16))-1,16,run_maskl16,run_maskr16,-2_16,huge(0_16)) + CHECK(int(bit_size(0_16)),16,run_maskl16,run_maskr16,-1_16,-1_16) + +contains + + pure integer(kind=16) function run_maskl16(i) result(res) + integer, intent(in) :: i + res = maskl(i,kind=16) + end function + pure integer(kind=16) function run_maskr16(i) result(res) + integer, intent(in) :: i + res = maskr(i,kind=16) + end function + +end Index: Fortran/gfortran/regression/masklr_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/masklr_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/103777 - ICE in gfc_simplify_maskl +! Contributed by G.Steinmetz + +program p + print *, maskl([999]) ! { dg-error "must be less than or equal" } + print *, maskr([999]) ! { dg-error "must be less than or equal" } + print *, maskl([-999]) ! { dg-error "must be nonnegative" } + print *, maskr([-999]) ! { dg-error "must be nonnegative" } + print *, maskl([32],kind=4) + print *, maskl([33],kind=4) ! { dg-error "must be less than or equal" } + print *, maskl([64],kind=8) + print *, maskl([65],kind=8) ! { dg-error "must be less than or equal" } +end Index: Fortran/gfortran/regression/maskr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maskr_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/103789 +! Check the absence of ICE when generating calls to MASKR with a KIND argument. + +program p + integer :: z(2), y(2), x(2) + y = [1, 13] + z = maskr(y, kind=4) + 1 + x = maskr(y, 4) + 1 +end program p Index: Fortran/gfortran/regression/matmul_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_1.f90 @@ -0,0 +1,53 @@ +!{ dg-do run } +! Test MATMUL for various arguments and results +! (test values checked with GNU octave). +! PR18857 was due to an incorrect assertion that component base==0 +! for both input arguments and the result. +! provided by Paul Thomas - pault@gcc.gnu.org + +Program matmul_1 + integer, parameter :: N = 5 + integer, parameter :: T = 4 + integer :: i + real(kind=T), dimension(:,:), allocatable :: a, b, c + real(kind=T), dimension(N,N) :: x, y, z + + allocate (a(2*N, N), b(N, N), c(2*N, N)) + + do i = 1, 2*N + a(i, :) = real (i) + end do + b = 4.0_T + + do i = 1, N + x(i, :) = real (i) + end do + y = 2.0_T + +! whole array + + z = 0.0_T + z = matmul (x, y) + if (sum (z) /= 750.0_T) STOP 1 + +! array sections + + c = 0.0_T + c(1:3,1:2) = matmul (a(7:9,3:N), b(3:N,3:4)) + if (sum (c) /= 576.0_T) STOP 2 + +! uses a temp + + c = 0.0_T + c = matmul (a, b + x) + if (sum (c) /= 9625.0_T) STOP 3 + +! returns to a temp + + c = 0.0_T + c = a + matmul (a, b) + if (sum (c) /= 5775.0_T) STOP 4 + + deallocate (a, b, c) + +end program matmul_1 Index: Fortran/gfortran/regression/matmul_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_10.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! PR 71961 - no array temporary was created. +! Original test case by Joost VandeVondele +program main + implicit none + integer :: i + integer, dimension(:,:), pointer :: a + integer, dimension(:,:), allocatable :: b + ALLOCATE(a(4,4),b(4,2)) + a=1 ; b=2 + a(:,1:2)=matmul(a(:,1:4),b(:,:)) ! { dg-warning "Creating array temporary" } + if (any(a /= reshape((/8,8,8,8,8,8,8,8,1,1,1,1,1,1,1,1/),(/4,4/)))) & + STOP 1 + a = reshape([((-1**i)*i,i=1,16)],[4,4]) + b = reshape([((-1**(i-1))*i**2,i=1,8)],[4,2]) + b(1:2,1:2) = matmul(a(1:2,:),b) ! { dg-warning "Creating array temporary" } + if (any(b /= reshape([310, 340, -9, -16, 1478, 1652, -49, -64],[4,2]))) & + STOP 2 + deallocate(a) + deallocate(b) +end program main Index: Fortran/gfortran/regression/matmul_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_11.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 77915 - ICE of matmul with forall. +program x + integer, parameter :: d = 3 + real,dimension(d,d,d) :: cube,xcube + real, dimension(d,d) :: cmatrix + integer :: i,j + forall(i=1:d,j=1:d) + xcube(i,j,:) = matmul(cmatrix,cube(i,j,:)) + end forall +end program x + +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 1 "original" } } Index: Fortran/gfortran/regression/matmul_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_12.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program main + integer, parameter :: sz=5, su=3 + integer, parameter :: l=2 + integer, parameter :: u=l-1+su + integer(kind=4), dimension(sz,sz) :: r,a,b + integer :: i,j + do i=1,4 + do j=1,4 + a(i,j) = i*10+j + b(i,j) = 100+i*10+j + end do + end do + r = -1 + b(l:u,l:u) = reshape([(i,i=1,su*su)],[su,su]); + a(l:u,l:u) = reshape([(i,i=1,su*su)],[su,su]); + + r(1:su,1:su) = matmul(a(l:u,l:u),b(l:u,l:u)) + if (any(reshape(r,[sz*sz]) /= [30, 36, 42, -1, -1, 66, 81, 96, -1, -1,& + & 102, 126, 150, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1])) & + STOP 1 +end program main Index: Fortran/gfortran/regression/matmul_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_13.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } +! Check that the default limit of 30 for inlining matmul applies. +program main + integer, parameter :: n = 31 + real, dimension(n,n) :: a, b, c + call random_number(a) + call random_number(b) + c = matmul(a,b) + print *,sum(c) +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul_r4" 1 "optimized" } } Index: Fortran/gfortran/regression/matmul_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_14.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } +! Check that the default limit of 30 for inlining matmul applies. +program main + integer, parameter :: n = 30 + real, dimension(n,n) :: a, b, c + call random_number(a) + call random_number(b) + c = matmul(a,b) + print *,sum(c) +end program main +! { dg-final { scan-tree-dump-times "_gfortran_matmul_r4" 0 "optimized" } } Index: Fortran/gfortran/regression/matmul_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_15.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-finline-matmul-limit=0" } +! Stress-test the matmul blocking code with sizes close to or +! equal to powers ot two. + +program main + implicit none + integer, dimension(*), parameter :: nn = & + & [2,3,4,5, 7,8,9, 15,16,17, 31,32,33, 63,64,65, & + 127 ,228,129, 255,256,257]; + integer, parameter :: s = size(nn) + real, dimension(:,:),allocatable :: a, b, c + integer :: i1, i2, i3 + integer :: nx, ny, count + real :: sm + + sm = 0.0 + do i1=1, s + nx = nn(i1) + do i2=1,s + ny = nn(i2) + do i3=1,s + count = nn(i3) + allocate (a(nx,ny), b(ny,count), c(nx,count)) + call random_number(a) + call random_number(b) + c = matmul(a,b) + sm = sm + sum(c) + deallocate(a,b,c) + end do + end do + end do + +end program main Index: Fortran/gfortran/regression/matmul_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_16.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-finline-matmul-limit=0" } +! PR 80975 - this did not zero the result array +program bogus_matmul + implicit none + real :: M(3,0), v(0), w(3) + + w = 7 + w = matmul(M,v) + if( any(w .ne. 0) ) then + STOP 1 + end if +end program bogus_matmul Index: Fortran/gfortran/regression/matmul_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_17.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR Fortran/83900 +! Contributed by Gerhard Steinmetz +program p + integer, parameter :: a(3,2) = 1 + real, parameter :: b(2,3) = 2 + real, parameter :: c(3,3) = matmul(a, b) + if (any(c /= 4.)) STOP 1 +end Index: Fortran/gfortran/regression/matmul_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_18.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +program p + integer, parameter :: a(3,2) = 1 + real, parameter :: b(2,3) = 2 + real d(3,3) + d = 4 + if (any(d /= matmul(a,b))) STOP 1 +end Index: Fortran/gfortran/regression/matmul_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_19.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-finline-matmul-limit=0" } +! PR 86704 - this used to segfault. + +program testmaticovenasobeni +implicit none + + character(len=10) :: line + write (unit=line,fmt=*) testmatmul(120,1,3) + + contains + + function testmatmul(m,n,o) + integer, intent(in) :: m,n,o + real :: A(n,m),B(n,o),C(m,o) + logical :: testmatmul + + call random_number(A) + call random_number(B) + + C=matmul(transpose(A),B) + testmatmul=.true. + end function + +end program testmaticovenasobeni Index: Fortran/gfortran/regression/matmul_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_2.f90 @@ -0,0 +1,21 @@ +!{ dg-do run } +! PR libfortran/26985 +program matmul_2 + implicit none + integer :: a(2,9), b(9,7), c(2,7) + integer :: i, j + + a = 1 + b = 2 + c = 1789789 + c(:,1:7:2) = matmul(a,b(:,1:7:2)) + + if (c(1,1) /= 18 .or. c(2,1) /= 18 .or. & + c(1,2) /= 1789789 .or. c(2,2) /= 1789789 .or. & + c(1,3) /= 18 .or. c(2,3) /= 18 .or. & + c(1,4) /= 1789789 .or. c(2,4) /= 1789789 .or. & + c(1,5) /= 18 .or. c(2,5) /= 18 .or. & + c(1,6) /= 1789789 .or. c(2,6) /= 1789789 .or. & + c(1,7) /= 18 .or. c(2,7) /= 18) STOP 1 + +end program matmul_2 Index: Fortran/gfortran/regression/matmul_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_20.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR97063 - Wrong result for vector (step size is negative) * matrix + +program p + implicit none + integer, parameter :: m = 3, k = 2*m, l = k-1, n = 4 + integer :: i, j, m1, m2, ms + integer :: ai(k), bi(k,n), ci(n), ci_ref(n), c1, c2 + real :: ar(k), br(k,n), cr(n), cr_ref(n) + + ai(:) = [(i,i=0,k-1)] + bi(:,:) = reshape ([(((5*i+j),i=0,k-1),j=0,n-1)],[k,n]) + + ! Parameters of subscript triplet + m1 = 1; m2 = l; ms = 2 + + ! Reference values for cross-checks: integer variant + c1 = dot_product (ai(m1:m2: ms), bi(m1:m2: ms,1)) + c2 = dot_product (ai(m1:m2: ms), bi(m1:m2: ms,2)) + ci_ref = matmul (ai(m1:m2: ms), bi(m1:m2: ms,:)) + ci = matmul (ai(m2:m1:-ms), bi(m2:m1:-ms,:)) + + if (ci_ref(1) /= c1 .or. ci_ref(2) /= c2) stop 1 + if (any (ci /= ci_ref)) stop 2 + + ! Real variant + ar = real (ai) + br = real (bi) + cr_ref = matmul (ar(m1:m2: ms), br(m1:m2: ms,:)) + cr = matmul (ar(m2:m1:-ms), br(m2:m1:-ms,:)) + + if (any (cr_ref /= real (ci_ref))) stop 3 + if (any (cr /= cr_ref )) stop 4 + + ! Mixed variants + cr_ref = matmul (ar(m1:m2: ms), bi(m1:m2: ms,:)) + cr = matmul (ar(m2:m1:-ms), bi(m2:m1:-ms,:)) + + if (any (cr_ref /= real (ci_ref))) stop 5 + if (any (cr /= cr_ref )) stop 6 + + cr_ref = matmul (ai(m1:m2: ms), br(m1:m2: ms,:)) + cr = matmul (ai(m2:m1:-ms), br(m2:m1:-ms,:)) + + if (any (cr_ref /= real (ci_ref))) stop 7 + if (any (cr /= cr_ref )) stop 8 +end program Index: Fortran/gfortran/regression/matmul_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_21.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR libfortran/99218 - matmul on temporary array accesses invalid memory + +program p + implicit none + integer, parameter :: nState = 300000 + integer, parameter :: nCon = 1 + real, parameter :: ZERO = 0.0 + real :: G(nCon,nState) = ZERO + real :: H(nState,nCon) = ZERO + real :: lambda(nCon) = ZERO + real :: f(nState) = ZERO + f = matmul (transpose (G), lambda) + if (f(1) /= ZERO) stop 1 +end program Index: Fortran/gfortran/regression/matmul_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Check the fix for PR28005, in which the mechanism for dealing +! with matmul (transpose (a), b) would cause wrong results for +! matmul (a(i, 1:n), b(1:n, 1:n)). +! +! Based on the original testcase contributed by +! Tobias Burnus +! + implicit none + integer, parameter :: nmax = 3 + integer :: i, n = 2 + integer, dimension(nmax,nmax) :: iB=0 , iC=1 + integer, dimension(nmax,nmax) :: iX1=99, iX2=99, iChk + iChk = reshape((/30,66,102,36,81,126,42,96,150/),(/3,3/)) + +! This would give 3, 3, 99 + iB = reshape((/1 ,3 ,0 ,2 ,5 ,0 ,0 ,0 ,0 /),(/3,3/)) + iX1(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) ) + +! This would give 4, 4, 99 + ib(3,1) = 1 + iX2(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) ) + +! Whereas, we should have 8, 8, 99 + if (any (iX1(1:n+1,1) .ne. (/8, 8, 99/))) STOP 1 + if (any (iX1 .ne. iX2)) STOP 2 + +! Make sure that the fix does not break transpose temporaries. + iB = reshape((/(i, i = 1, 9)/),(/3,3/)) + ic = transpose (iB) + iX1 = transpose (iB) + iX1 = matmul (iX1, iC) + iX2 = matmul (transpose (iB), iC) + if (any (iX1 .ne. iX2)) STOP 3 + if (any (iX1 .ne. iChk)) STOP 4 +end Index: Fortran/gfortran/regression/matmul_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Check the fix for PR28947, in which the mechanism for dealing +! with matmul (a, transpose (b)) would cause wrong results for +! a having a rank == 1. +! +! Contributed by Harald Anlauf +! +program gfcbug40 + implicit none + + real :: h(3,3), mat(2,3) + + h(:,:) = - HUGE (1.0)/4 ! Preset unused elements suitably... + + h(3,:) = 0 + h(3,3) = 1 + mat(:,:) = 1 + h(3,:) = h(3,:) + matmul (matmul (h(3,:), transpose (mat)), mat) + + if (any (h(3,:) .ne. (/2.0, 2.0, 3.0/))) STOP 1 + +end program gfcbug40 Index: Fortran/gfortran/regression/matmul_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_5.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-shouldfail "dimension of array B incorrect in MATMUL intrinsic" } +! { dg-options "-finline-matmul-limit=0" } +program main + real, dimension(:,:), allocatable :: a + real, dimension(:), allocatable :: b + allocate (a(2,2), b(3)) + call random_number(a) + call random_number(b) + print *,matmul(a,b) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1" } Index: Fortran/gfortran/regression/matmul_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_6.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! PR 34566 - logical matmul used to give the wrong result. +! We check this by running through every permutation in +! multiplying two 3*3 matrices, and all permutations of multiplying +! a 3-vector and a 3*3 matrices and checking against equivalence +! with integer matrix multiply. +program main + implicit none + integer, parameter :: ki=4 + integer, parameter :: dimen=3 + integer :: i, j, k + real, dimension(dimen,dimen) :: r1, r2 + integer, dimension(dimen,dimen) :: m1, m2 + logical(kind=ki), dimension(dimen,dimen) :: l1, l2 + logical(kind=ki), dimension(dimen*dimen) :: laux + logical(kind=ki), dimension(dimen) :: lv + integer, dimension(dimen) :: iv + + do i=0,2**(dimen*dimen)-1 + forall (k=1:dimen*dimen) + laux(k) = btest(i, k-1) + end forall + l1 = reshape(laux,shape(l1)) + m1 = ltoi(l1) + + ! Check matrix*matrix multiply + do j=0,2**(dimen*dimen)-1 + forall (k=1:dimen*dimen) + laux(k) = btest(i, k-1) + end forall + l2 = reshape(laux,shape(l2)) + m2 = ltoi(l2) + if (any(matmul(l1,l2) .neqv. (matmul(m1,m2) /= 0))) then + STOP 1 + end if + end do + + ! Check vector*matrix and matrix*vector multiply. + do j=0,2**dimen-1 + forall (k=1:dimen) + lv(k) = btest(j, k-1) + end forall + iv = ltoi(lv) + if (any(matmul(lv,l1) .neqv. (matmul(iv,m1) /=0))) then + STOP 2 + end if + if (any(matmul(l1,lv) .neqv. (matmul(m1,iv) /= 0))) then + STOP 3 + end if + end do + end do + +contains + elemental function ltoi(v) + implicit none + integer :: ltoi + real :: rtoi + logical(kind=4), intent(in) :: v + if (v) then + ltoi = 1 + else + ltoi = 0 + end if + end function ltoi + +end program main Index: Fortran/gfortran/regression/matmul_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_7.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! PR 35988 - failure on some zero-sized matmuls. +! Test case contributed by Dick Hendrickson. + + program try_gf1003 + + call gf1003a( 9, 8, 6) + call gf1003b( 9, 8, 6) + call gf1003c( 9, 8, 6) !fails + call gf1003d( 9, 8, 6) !fails + end program + + + SUBROUTINE GF1003a(nf9,nf8,nf6) + REAL RDA(3,2) + REAL RDA1(3,5) + REAL RDA2(5,2) + RDA = MATMUL(RDA1(:, 9:8),RDA2( 8:6,:)) + END SUBROUTINE + + SUBROUTINE GF1003b(nf9,nf8,nf6) + REAL RDA(3,2) + REAL RDA1(3,0) + REAL RDA2(0,2) + RDA = MATMUL(RDA1(:,NF9:NF8),RDA2(NF9:NF8,:)) + END SUBROUTINE + + SUBROUTINE GF1003c(nf9,nf8,nf6) + REAL RDA(3,2) + REAL RDA1(3,0) + REAL RDA2(0,2) + RDA = MATMUL(RDA1(:,NF9:NF8),RDA2(NF8:NF6,:)) + END SUBROUTINE + + SUBROUTINE GF1003d(nf9,nf8,nf6) + REAL RDA(3,2) + REAL RDA1(3,5) + REAL RDA2(5,2) + RDA = MATMUL(RDA1(:,NF9:NF8),RDA2(NF8:NF6,:)) + END SUBROUTINE Index: Fortran/gfortran/regression/matmul_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_8.f03 @@ -0,0 +1,12 @@ +! { dg-do run } +! Transformational intrinsic MATMUL as initialization expression. + + REAL, PARAMETER :: PI = 3.141592654, theta = PI/6.0 + + REAL, PARAMETER :: unity(2,2) = RESHAPE([1.0, 0.0, 0.0, 1.0], [2, 2]) + REAL, PARAMETER :: m1(2,2) = RESHAPE([COS(theta), SIN(theta), -SIN(theta), COS(theta)], [2, 2]) + REAL, PARAMETER :: m2(2,2) = RESHAPE([COS(theta), -SIN(theta), SIN(theta), COS(theta)], [2, 2]) + REAL, PARAMETER :: m(2,2) = MATMUL(m1, m2) + + IF (ANY(ABS(m - unity) > EPSILON(0.0))) STOP 1 +END Index: Fortran/gfortran/regression/matmul_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_9.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/56318 +! +! Contributed by Alberto Luaces +! +SUBROUTINE mass_matrix + DOUBLE PRECISION,PARAMETER::m1=1.d0 + DOUBLE PRECISION,DIMENSION(3,2),PARAMETER::A1=reshape([1.d0,0.d0, 0.d0, & + 0.d0,1.d0, 0.d0],[3,2]) + DOUBLE PRECISION,DIMENSION(2,2),PARAMETER::Mel=reshape([1.d0/3.d0, 0.d0, & + 0.d0, 1.d0/3.d0],[2,2]) + + DOUBLE PRECISION,DIMENSION(3,3)::MM1 + + MM1=m1*matmul(A1,matmul(Mel,transpose(A1))) + !print '(3f8.3)', MM1 + if (any (abs (MM1 & + - reshape ([1.d0/3.d0, 0.d0, 0.d0, & + 0.d0, 1.d0/3.d0, 0.d0, & + 0.d0, 0.d0, 0.d0], & + [3,3])) > epsilon(1.0d0))) & + STOP 1 +END SUBROUTINE mass_matrix + +program name + implicit none + integer, parameter :: A(3,2) = reshape([1,2,3,4,5,6],[3,2]) + integer, parameter :: B(2,3) = reshape([3,17,23,31,43,71],[2,3]) + integer, parameter :: C(3) = [-5,-7,-21] + integer, parameter :: m1 = 1 + +! print *, matmul(B,C) + if (any (matmul(B,C) /= [-1079, -1793])) STOP 2 +! print *, matmul(C,A) + if (any (matmul(C,A) /= [-82, -181])) STOP 3 +! print '(3i5)', m1*matmul(A,B) + if (any (m1*matmul(A,B) /= reshape([71,91,111, 147,201,255, 327,441,555],& + [3,3]))) & + STOP 4 + call mass_matrix +end program name + +! { dg-final { scan-tree-dump-times "matmul" 0 "original" } } + Index: Fortran/gfortran/regression/matmul_argument_types.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_argument_types.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR fortran/36355 +! Check MATMUL argument types: +! +! numeric logical other +! numeric 1 2 3 +! logical 2 1 3 +! other 3 3 3 +! +! where +! 1 ok +! 2 argument type mismatch +! 3 invalid argument types +! + + INTEGER :: a(2,2) + LOGICAL :: b(2,2) + CHARACTER :: c + + a = MATMUL(a, a) ! ok + a = MATMUL(a, b) ! { dg-error "must match" } + a = MATMUL(a, c) ! { dg-error "must be numeric or LOGICAL" } + + b = MATMUL(b, a) ! { dg-error "must match" } + b = MATMUL(b, b) ! ok + b = MATMUL(b, c) ! { dg-error "must be numeric or LOGICAL" } + + c = MATMUL(c, a) ! { dg-error "must be numeric or LOGICAL" } + c = MATMUL(c, b) ! { dg-error "must be numeric or LOGICAL" } + c = MATMUL(c, c) ! { dg-error "must be numeric or LOGICAL" } +END Index: Fortran/gfortran/regression/matmul_blas_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_blas_1.f @@ -0,0 +1,240 @@ +C { dg-do run } +C { dg-options "-fcheck=bounds -fdump-tree-optimized -fblas-matmul-limit=1 -O -fexternal-blas" } +C { dg-additional-sources blas_gemm_routines.f } +C Test calling of BLAS routines + + program main + call sub_s + call sub_d + call sub_c + call sub_z + end + + subroutine sub_d + implicit none + real(8), dimension(3,2) :: a + real(8), dimension(2,3) :: at + real(8), dimension(2,4) :: b + real(8), dimension(4,2) :: bt + real(8), dimension(3,4) :: c + real(8), dimension(3,4) :: cres + real(8), dimension(:,:), allocatable :: c_alloc + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., + & 692., 411., -640., 816./ + + c = matmul(a,b) + if (any (c /= cres)) stop 31 + + at = transpose(a) + c = (1.2,-2.2) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 32 + + bt = transpose(b) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 33 + + c_alloc = matmul(a,b) + if (any (c /= cres)) stop 34 + + at = transpose(a) + deallocate (c_alloc) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 35 + + bt = transpose(b) + allocate (c_alloc(20,20)) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 36 + + end + + subroutine sub_s + implicit none + real, dimension(3,2) :: a + real, dimension(2,3) :: at + real, dimension(2,4) :: b + real, dimension(4,2) :: bt + real, dimension(3,4) :: c + real, dimension(3,4) :: cres + real, dimension(:,:), allocatable :: c_alloc + data a / 2., -3., 5., -7., 11., -13./ + data b /17., -23., 29., -31., 37., -39., 41., -47./ + data cres /195., -304., 384., 275., -428., 548., 347., -540., + & 692., 411., -640., 816./ + + c = matmul(a,b) + if (any (c /= cres)) stop 21 + + at = transpose(a) + c = (1.2,-2.2) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 22 + + bt = transpose(b) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 23 + + c_alloc = matmul(a,b) + if (any (c /= cres)) stop 24 + + at = transpose(a) + deallocate (c_alloc) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 25 + + bt = transpose(b) + allocate (c_alloc(20,20)) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 26 + + end + + subroutine sub_c + implicit none + complex, dimension(3,2) :: a + complex, dimension(2,3) :: at, ah + complex, dimension(2,4) :: b + complex, dimension(4,2) :: bt, bh + complex, dimension(3,4) :: c + complex, dimension(3,4) :: cres + complex, dimension(:,:), allocatable :: c_alloc + + data a / (2.,-3.), (-5.,7.), (11.,-13.), (17.,19), (-23., -29), + & (-31., 37.)/ + + data b / (-41., 43.), (-47., 53.), (-59.,-61.), (-67., 71), + & ( 73.,79. ), (83.,-89.), (97.,-101.), (-107.,-109.)/ + data cres /(-1759.,217.), (2522.,-358.), (-396.,-2376.), + & (-2789.,-11.), + & (4322.,202.), (-1992.,-4584.), (3485.,3.), (-5408.,-244.), + & (2550.,5750.), (143.,-4379.), (-478.,6794.), (7104.,-2952.) / + + c = matmul(a,b) + if (any (c /= cres)) stop 1 + + at = transpose(a) + c = (1.2,-2.2) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 2 + + bt = transpose(b) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 3 + + ah = transpose(conjg(a)) + c = (1.2,-2.2) + c = matmul(conjg(transpose(ah)), b) + if (any (c /= cres)) stop 4 + + bh = transpose(conjg(b)) + c = (1.2,-2.2) + c = matmul(a, transpose(conjg(bh))) + if (any (c /= cres)) stop 5 + + c_alloc = matmul(a,b) + if (any (c /= cres)) stop 6 + + at = transpose(a) + deallocate (c_alloc) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 7 + + bt = transpose(b) + allocate (c_alloc(20,20)) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 8 + + ah = transpose(conjg(a)) + c = (1.2,-2.2) + c = matmul(conjg(transpose(ah)), b) + if (any (c /= cres)) stop 9 + + deallocate (c_alloc) + allocate (c_alloc(0,0)) + bh = transpose(conjg(b)) + c = (1.2,-2.2) + c = matmul(a, transpose(conjg(bh))) + if (any (c /= cres)) stop 10 + + end + + subroutine sub_z + implicit none + complex(8), dimension(3,2) :: a + complex(8), dimension(2,3) :: at, ah + complex(8), dimension(2,4) :: b + complex(8), dimension(4,2) :: bt, bh + complex(8), dimension(3,4) :: c + complex(8), dimension(3,4) :: cres + complex(8), dimension(:,:), allocatable :: c_alloc + + data a / (2.,-3.), (-5._8,7.), (11.,-13.), (17.,19), + & (-23., -29), (-31., 37.)/ + + data b / (-41., 43.), (-47., 53.), (-59.,-61.), (-67., 71), + & ( 73.,79. ), (83.,-89.), (97.,-101.), (-107.,-109.)/ + data cres /(-1759.,217.), (2522.,-358.), (-396.,-2376.), + & (-2789.,-11.), + & (4322.,202.), (-1992.,-4584.), (3485.,3.), (-5408.,-244.), + & (2550.,5750.), (143.,-4379.), (-478.,6794.), (7104.,-2952.) / + + c = matmul(a,b) + if (any (c /= cres)) stop 11 + + at = transpose(a) + c = (1.2,-2.2) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 12 + + bt = transpose(b) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 13 + + ah = transpose(conjg(a)) + c = (1.2,-2.2) + c = matmul(conjg(transpose(ah)), b) + if (any (c /= cres)) stop 14 + + bh = transpose(conjg(b)) + c = (1.2,-2.2) + c = matmul(a, transpose(conjg(bh))) + if (any (c /= cres)) stop 15 + + c_alloc = matmul(a,b) + if (any (c /= cres)) stop 16 + + at = transpose(a) + deallocate (c_alloc) + c = matmul(transpose(at), b) + if (any (c /= cres)) stop 17 + + bt = transpose(b) + allocate (c_alloc(20,20)) + c = (1.2,-2.1) + c = matmul(a, transpose(bt)) + if (any (c /= cres)) stop 18 + + ah = transpose(conjg(a)) + c = (1.2,-2.2) + c = matmul(conjg(transpose(ah)), b) + if (any (c /= cres)) stop 19 + + deallocate (c_alloc) + allocate (c_alloc(0,0)) + bh = transpose(conjg(b)) + c = (1.2,-2.2) + c = matmul(a, transpose(conjg(bh))) + if (any (c /= cres)) stop 20 + + end +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/matmul_blas_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_blas_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-original -fexternal-blas" } +! PR fortran/92321 - this used to cause an ICE. Original test case +! by Nathan Wukie. + +module mod_badmatmul + implicit none +contains + + subroutine test(c) + real, intent(inout) :: c(3,3) + real :: a(3,3), b(3,3) + c = matmul(a, b) + end subroutine test + +end module mod_badmatmul + +program main + use mod_badmatmul, only: test + implicit none + + real :: a(3,3) + call test(a) + +end program main Index: Fortran/gfortran/regression/matmul_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +program matmul_bounds_1 + implicit none + real, dimension(3,2) :: a + real, dimension(2,3) :: b + real, dimension(3,2) :: rab + real, dimension(2,2) :: rok + real, dimension(2) :: rv + real, dimension(3) :: rw + real, dimension(3) :: x + real, dimension(2) :: y + a = 1 + b = 2 + x = 3 + y = 4 + ! These tests should throw an error + rab = matmul(a,b) ! { dg-error "Different shape" } + rv = matmul(a,y) ! { dg-error "Different shape" } + rv = matmul(x,b) ! { dg-error "Different shape" } + ! These are ok. + rw = matmul(a,y) + rv = matmul(x,a) + rok = matmul(b,a) +end program matmul_bounds_1 + Index: Fortran/gfortran/regression/matmul_bounds_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_10.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fno-backtrace -fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 4, should be 3" } +program main + real, dimension(3,2) :: a + real, dimension(3,2) :: b + real, dimension(:,:), allocatable :: ret + allocate (ret(3,3)) + a = 1.0 + b = 2.3 + ret = matmul(a,transpose(b)) ! This is OK + deallocate(ret) + allocate(ret(4,3)) + ret = matmul(a,transpose(b)) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of array.*" } Index: Fortran/gfortran/regression/matmul_bounds_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_11.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-O -finline-matmul-limit=30 -fcheck=all" } +! { dg-shouldfail "Dimension of array B incorrect in MATMUL intrinsic" } +program main + real, dimension(:,:), allocatable :: a + real, dimension(:), allocatable :: b + real, dimension(:), allocatable :: res + allocate (a(2,2), b(3)) + call random_number(a) + call random_number(b) + res = matmul(a,b) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1: is 3, should be 2" } + Index: Fortran/gfortran/regression/matmul_bounds_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_12.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +program main + real, dimension(3,2) :: a + real, dimension(3) :: bp + real, dimension(3) :: res1 + real, dimension(:), allocatable :: c3 + real, dimension(2) :: res2 + + data a /-2., 3., -5., 7., -11., 13./ + data bp /-23., -31., -41./ + data res2 /158., -353./ + + c3 = matmul(bp,a) + if (size(c3,1) /= 2) STOP 1 + if (any(c3 /= res2)) STOP 2 + +end program main Index: Fortran/gfortran/regression/matmul_bounds_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_13.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1" } +program main + real, dimension(:,:), allocatable :: a, b, c + character(len=100) :: line + allocate (a(3,2)) + allocate (b(2,4)) + call random_number(a) + call random_number(b) + write (unit=line, fmt=*) matmul(a,transpose(b)) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1" } Index: Fortran/gfortran/regression/matmul_bounds_14.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_14.f @@ -0,0 +1,16 @@ +C { dg-do run } +C { dg-options "-fno-realloc-lhs -fdump-tree-optimized -fcheck=bounds -fblas-matmul-limit=1 -O -fexternal-blas" } +C { dg-shouldfail "Fortran runtime error: Array bound mismatch for dimension 2 of array." } +C { dg-additional-sources blas_gemm_routines.f } + + program main + real, dimension(3,2) :: a + real, dimension(2,3) :: b + real, dimension(:,:), allocatable :: ret + a = 1.0 + b = 2.3 + allocate(ret(3,2)) + ret = matmul(a,b) ! This should throw an error. + end +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 2 of array.*" } +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/matmul_bounds_15.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_15.f @@ -0,0 +1,19 @@ +C { dg-do run } +C { dg-options "-fdump-tree-optimized -fcheck=bounds -fblas-matmul-limit=1 -O -fexternal-blas" } +C { dg-shouldfail "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1.*" } +C { dg-additional-sources blas_gemm_routines.f } + program main + character(len=20) :: line + integer :: n, m + real, dimension(3,2) :: a + real, dimension(:,:), allocatable :: b + real, dimension(:,:), allocatable :: ret + a = 1.0 + line = '3 3' + read (unit=line,fmt=*) n, m + allocate (b(n,m)) + b = 2.3 + ret = matmul(a,b) ! This should throw an error. + end +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1.*" } +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/matmul_bounds_16.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_16.f @@ -0,0 +1,20 @@ +C { dg-do run } +C { dg-options "-fdump-tree-optimized -fcheck=bounds -fblas-matmul-limit=1 -O -fexternal-blas" } +C { dg-shouldfail "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1" } +C { dg-additional-sources blas_gemm_routines.f } + + program main + character(len=20) :: line + integer :: n, m + real, dimension(3,2) :: a + real, dimension(:,:), allocatable :: b + real, dimension(:,:), allocatable :: ret + a = 1.0 + line = '4 3' + read (unit=line,fmt=*) n, m + allocate (b(n,m)) + b = 2.3 + ret = matmul(transpose(a),b) ! This should throw an error. + end +! { dg-output "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic in dimension 1.*" } +! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } } Index: Fortran/gfortran/regression/matmul_bounds_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" } +program main + real, dimension(3,2) :: a + real, dimension(2,3) :: b + real, dimension(:,:), allocatable :: ret + allocate (ret(2,2)) + a = 1.0 + b = 2.3 + ret = matmul(b,a) ! This is OK + deallocate(ret) + allocate(ret(3,2)) + ret = matmul(a,b) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 2 of array.*" } Index: Fortran/gfortran/regression/matmul_bounds_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" } +program main + real, dimension(3,2) :: a + real, dimension(2,3) :: b + real, dimension(:,:), allocatable :: ret + allocate (ret(3,3)) + a = 1.0 + b = 2.3 + ret = matmul(a,b) ! This is OK + deallocate(ret) + allocate(ret(2,3)) + ret = matmul(a,b) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of array" } Index: Fortran/gfortran/regression/matmul_bounds_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } +program main + real, dimension(3) :: a + real, dimension(3,2) :: b + real, dimension(:), allocatable :: ret + allocate (ret(2)) + a = 1.0 + b = 2.3 + ret = matmul(a,b) ! This is OK + deallocate(ret) + allocate(ret(3)) + ret = matmul(a,b) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of array" } Index: Fortran/gfortran/regression/matmul_bounds_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_5.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" } +program main + real, dimension(2,3) :: a + real, dimension(3) :: b + real, dimension(:), allocatable :: ret + allocate (ret(2)) + a = 1.0 + b = 2.3 + ret = matmul(a,b) ! This is OK + deallocate(ret) + allocate(ret(3)) + ret = matmul(a,b) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of array" } Index: Fortran/gfortran/regression/matmul_bounds_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_6.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +program main + real, dimension(3,2) :: a + real, dimension(6) :: b + real, dimension(3) :: res1 + real, dimension(:), allocatable :: c1, c2,c3 + real, dimension(2) :: res2 + + data a /-2., 3., -5., 7., -11., 13./ + data b /17., -23., 29., -31., 37., -41./ + data res1 /201., -320., 336./ + data res2 /158., -353./ + + c1 = matmul(a,[29.,37.]) + if (size(c1,1) /= 3) STOP 1 + if (any(c1/=res1)) STOP 2 + + c2 = matmul(a,pack(b,[b>20.])) + if (size(c1,1) /= 3) STOP 3 + if (any(c1/=res1)) STOP 4 + + c3 = matmul(pack(b,[b<0.]),a) + if (size(c3,1) /= 2) STOP 5 + if (any(c3 /= res2)) STOP 6 + +end program main Index: Fortran/gfortran/regression/matmul_bounds_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_7.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds" } +! { dg-shouldfail "Fortran runtime error: dimension of array B incorrect in MATMUL intrinsic" } + +program main + real, dimension(3,2) :: a + real, dimension(6) :: b + real, dimension(:), allocatable :: c + + data a /-2., 3., -5., 7., -11., 13./ + data b /17., -23., 29., -31., 37., -41./ + + c = matmul(pack(b,[b<20.]),a) + print *,sum(c) + +end program main Index: Fortran/gfortran/regression/matmul_bounds_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_8.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fno-backtrace -fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" } +program main + real, dimension(3,2) :: a + real, dimension(3,2) :: b + real, dimension(:,:), allocatable :: ret + allocate (ret(3,3)) + a = 1.0 + b = 2.3 + ret = matmul(a,transpose(b)) ! This is OK + deallocate(ret) + allocate(ret(3,2)) + ret = matmul(a,transpose(b)) ! This should throw an error. +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 2 of array" } Index: Fortran/gfortran/regression/matmul_bounds_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_bounds_9.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fbounds-check -ffrontend-optimize" } +! { dg-shouldfail "Fortran runtime error: Incorrect extent in argument B in MATMUL intrinsic for dimension 2: is 1, should be 2" } +module x + implicit none +contains + subroutine mmul(c, a, b) + real, dimension(:,:), intent(in) :: a,b + real, dimension(:,:), intent(out) :: c + c = matmul(a,transpose(b)) + end subroutine mmul +end module x + +program main + use x + integer, parameter :: n = 3, m=4, cnt=2 + real, dimension(n,cnt) :: a + real, dimension(m,cnt-1) :: b + real, dimension(n,m) :: c + a = 1.0 + b = 2.3 + call mmul(c,a,b) +end program main Index: Fortran/gfortran/regression/matmul_const.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_const.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-additional-options "-fno-frontend-optimize -fdump-tree-original" } +program main + integer, parameter :: A(3,2) = reshape([1,2,3,4,5,6],[3,2]) + integer, parameter :: B(2,3) = reshape([1,1,1,1,1,1],[2,3]) + character (len=30) :: line + write (unit=line,fmt='(9i3)') matmul(A,B) + if (line /= ' 5 7 9 5 7 9 5 7 9') STOP 1 +end program main +! { dg-final { scan-tree-dump-times "matmul_i4" 0 "original" } } Index: Fortran/gfortran/regression/matmul_rank_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/matmul_rank_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-additional-options "-ffrontend-optimize" } +! PR 85044 - used to die on allocating a negative amount of memory. +! Test case by Gerhard Steinmetz. +program p + real :: a(3,3) = 1.0 + real :: b(33) + b = matmul(a, a) ! { dg-error "Incompatible ranks" } +end Index: Fortran/gfortran/regression/max_expr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/max_expr.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } + +subroutine foo (a, b, c, d, e, f, g, h) + real (kind=8) :: a, b, c, d, e, f, g, h + a = max (a, b, c, d, e, f, g, h) +end subroutine + +subroutine foof (a, b, c, d, e, f, g, h) + real (kind=4) :: a, b, c, d, e, f, g, h + a = max (a, b, c, d, e, f, g, h) +end subroutine + + +! { dg-final { scan-tree-dump-times "MAX_EXPR " 14 "optimized" } } Index: Fortran/gfortran/regression/maxerrors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxerrors.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1" } +! PR66528 +! { dg-prune-output "compilation terminated" } +program main + read (*,*) n + if (n<0) then + print *,foo + end ! { dg-error "END IF statement expected" } + print *,bar +end program main + Index: Fortran/gfortran/regression/maxloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } + integer :: a(3), n + a(1) = -huge(n) + a(2) = -huge(n) + a(3) = -huge(n) + a(1) = a(1) - 1 + a(2) = a(2) - 1 + a(3) = a(3) - 1 + n = maxloc (a, dim = 1) + if (n .ne. 1) STOP 1 + a(2) = -huge(n) + n = maxloc (a, dim = 1) + if (n .ne. 2) STOP 2 +end Index: Fortran/gfortran/regression/maxloc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_2.f90 @@ -0,0 +1,155 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3), nan, minf, pinf + real, allocatable :: c(:) + integer :: ia(1) + logical :: l + logical :: l2(3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + + allocate (c(3)) + a(:) = nan + ia = maxloc (a) + if (ia(1).ne.1) STOP 1 + a(:) = minf + ia = maxloc (a) + if (ia(1).ne.1) STOP 2 + a(1:2) = nan + ia = maxloc (a) + if (ia(1).ne.3) STOP 3 + a(2) = 1.0 + ia = maxloc (a) + if (ia(1).ne.2) STOP 4 + a(2) = pinf + ia = maxloc (a) + if (ia(1).ne.2) STOP 5 + c(:) = nan + ia = maxloc (c) + if (ia(1).ne.1) STOP 6 + c(:) = minf + ia = maxloc (c) + if (ia(1).ne.1) STOP 7 + c(1:2) = nan + ia = maxloc (c) + if (ia(1).ne.3) STOP 8 + c(2) = 1.0 + ia = maxloc (c) + if (ia(1).ne.2) STOP 9 + c(2) = pinf + ia = maxloc (c) + if (ia(1).ne.2) STOP 10 + l = .false. + l2(:) = .false. + a(:) = nan + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 11 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 12 + a(:) = minf + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 13 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 14 + a(1:2) = nan + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 15 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 16 + a(2) = 1.0 + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 17 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 18 + a(2) = pinf + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 19 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 20 + c(:) = nan + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 21 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 22 + c(:) = minf + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 23 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 24 + c(1:2) = nan + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 25 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 26 + c(2) = 1.0 + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 27 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 28 + c(2) = pinf + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 29 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 30 + l = .true. + l2(:) = .true. + a(:) = nan + ia = maxloc (a, mask = l) + if (ia(1).ne.1) STOP 31 + ia = maxloc (a, mask = l2) + if (ia(1).ne.1) STOP 32 + a(:) = minf + ia = maxloc (a, mask = l) + if (ia(1).ne.1) STOP 33 + ia = maxloc (a, mask = l2) + if (ia(1).ne.1) STOP 34 + a(1:2) = nan + ia = maxloc (a, mask = l) + if (ia(1).ne.3) STOP 35 + ia = maxloc (a, mask = l2) + if (ia(1).ne.3) STOP 36 + a(2) = 1.0 + ia = maxloc (a, mask = l) + if (ia(1).ne.2) STOP 37 + ia = maxloc (a, mask = l2) + if (ia(1).ne.2) STOP 38 + a(2) = pinf + ia = maxloc (a, mask = l) + if (ia(1).ne.2) STOP 39 + ia = maxloc (a, mask = l2) + if (ia(1).ne.2) STOP 40 + c(:) = nan + ia = maxloc (c, mask = l) + if (ia(1).ne.1) STOP 41 + ia = maxloc (c, mask = l2) + if (ia(1).ne.1) STOP 42 + c(:) = minf + ia = maxloc (c, mask = l) + if (ia(1).ne.1) STOP 43 + ia = maxloc (c, mask = l2) + if (ia(1).ne.1) STOP 44 + c(1:2) = nan + ia = maxloc (c, mask = l) + if (ia(1).ne.3) STOP 45 + ia = maxloc (c, mask = l2) + if (ia(1).ne.3) STOP 46 + c(2) = 1.0 + ia = maxloc (c, mask = l) + if (ia(1).ne.2) STOP 47 + ia = maxloc (c, mask = l2) + if (ia(1).ne.2) STOP 48 + c(2) = pinf + ia = maxloc (c, mask = l) + if (ia(1).ne.2) STOP 49 + ia = maxloc (c, mask = l2) + if (ia(1).ne.2) STOP 50 + deallocate (c) + allocate (c(-2:-3)) + ia = maxloc (c) + if (ia(1).ne.0) STOP 51 +end Index: Fortran/gfortran/regression/maxloc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_3.f90 @@ -0,0 +1,122 @@ +! { dg-do run } + integer :: a(3), h, ia(1) + integer, allocatable :: c(:) + logical :: l + logical :: l2(3) + + h = -huge(h) + h = h - 1 + allocate (c(3)) + a(:) = 5 + ia = maxloc (a) + if (ia(1).ne.1) STOP 1 + a(2) = huge(h) + ia = maxloc (a) + if (ia(1).ne.2) STOP 2 + a(:) = h + ia = maxloc (a) + if (ia(1).ne.1) STOP 3 + a(3) = -huge(h) + ia = maxloc (a) + if (ia(1).ne.3) STOP 4 + c(:) = 5 + ia = maxloc (c) + if (ia(1).ne.1) STOP 5 + c(2) = huge(h) + ia = maxloc (c) + if (ia(1).ne.2) STOP 6 + c(:) = h + ia = maxloc (c) + if (ia(1).ne.1) STOP 7 + c(3) = -huge(h) + ia = maxloc (c) + if (ia(1).ne.3) STOP 8 + l = .false. + l2(:) = .false. + a(:) = 5 + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 9 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 10 + a(2) = huge(h) + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 11 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 12 + a(:) = h + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 13 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 14 + a(3) = -huge(h) + ia = maxloc (a, mask = l) + if (ia(1).ne.0) STOP 15 + ia = maxloc (a, mask = l2) + if (ia(1).ne.0) STOP 16 + c(:) = 5 + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 17 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 18 + c(2) = huge(h) + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 19 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 20 + c(:) = h + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 21 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 22 + c(3) = -huge(h) + ia = maxloc (c, mask = l) + if (ia(1).ne.0) STOP 23 + ia = maxloc (c, mask = l2) + if (ia(1).ne.0) STOP 24 + l = .true. + l2(:) = .true. + a(:) = 5 + ia = maxloc (a, mask = l) + if (ia(1).ne.1) STOP 25 + ia = maxloc (a, mask = l2) + if (ia(1).ne.1) STOP 26 + a(2) = huge(h) + ia = maxloc (a, mask = l) + if (ia(1).ne.2) STOP 27 + ia = maxloc (a, mask = l2) + if (ia(1).ne.2) STOP 28 + a(:) = h + ia = maxloc (a, mask = l) + if (ia(1).ne.1) STOP 29 + ia = maxloc (a, mask = l2) + if (ia(1).ne.1) STOP 30 + a(3) = -huge(h) + ia = maxloc (a, mask = l) + if (ia(1).ne.3) STOP 31 + ia = maxloc (a, mask = l2) + if (ia(1).ne.3) STOP 32 + c(:) = 5 + ia = maxloc (c, mask = l) + if (ia(1).ne.1) STOP 33 + ia = maxloc (c, mask = l2) + if (ia(1).ne.1) STOP 34 + c(2) = huge(h) + ia = maxloc (c, mask = l) + if (ia(1).ne.2) STOP 35 + ia = maxloc (c, mask = l2) + if (ia(1).ne.2) STOP 36 + c(:) = h + ia = maxloc (c, mask = l) + if (ia(1).ne.1) STOP 37 + ia = maxloc (c, mask = l2) + if (ia(1).ne.1) STOP 38 + c(3) = -huge(h) + ia = maxloc (c, mask = l) + if (ia(1).ne.3) STOP 39 + ia = maxloc (c, mask = l2) + if (ia(1).ne.3) STOP 40 + deallocate (c) + allocate (c(-2:-3)) + ia = maxloc (c) + if (ia(1).ne.0) STOP 41 +end Index: Fortran/gfortran/regression/maxloc_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_4.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Check that simplification of maxloc works +program main + implicit none + integer :: d + real, dimension(2), parameter :: a = [1.0, 0.0] + character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ] + integer, parameter :: b = maxloc(a,dim=1) + integer, parameter :: b2 = maxloc(a,dim=1,mask=[.false.,.false.]) + integer, parameter :: b3 = maxloc(c,dim=1) + integer, parameter :: b4 = maxloc(c,dim=1,mask=[c<"iii"]) + integer, parameter,dimension(2,2) :: i1 = reshape([4,5,3,2],shape(i1)) + integer, parameter, dimension(2) :: b5 = maxloc(i1) + integer, parameter, dimension(2) :: b6 = maxloc(i1,mask=i1>7) + integer, parameter, dimension(2) :: b7 = maxloc(i1, mask=i1<5) + integer, parameter, dimension(2) :: b8 = maxloc(i1, mask=.true.) + integer, parameter, dimension(2) :: b9 = maxloc(i1, mask=.false.) + integer, parameter, dimension(2,3) :: i2 = & + reshape([2, -1, -3, 4, -5, 6], shape(i2)) + integer, parameter, dimension(3) :: b10 = maxloc(i2, dim=1) + integer, parameter, dimension(2) :: b11 = maxloc(i2, dim=2) + integer, parameter, dimension(3) :: b12 = maxloc(i2,dim=1,mask=i2<0) + integer, parameter, dimension(2) :: b13 = maxloc(i2,dim=2, mask=i2<-10) + if (b /= 1) STOP 1 + if (b2 /= 0) STOP 2 + if (b3 /= 3) STOP 3 + if (b4 /= 1) STOP 4 + if (any(b5 /= [2,1])) STOP 5 + if (any(b6 /= [0, 0])) STOP 6 + if (any(b7 /= [1,1])) STOP 7 + if (any(b8 /= b5)) STOP 8 + if (any(b9 /= [0, 0])) STOP 9 + d = 1 + if (any(b10 /= maxloc(i2,dim=d))) STOP 10 + d = 2 + if (any(b11 /= maxloc(i2,dim=2))) STOP 11 + d = 1 + if (any(b12 /= maxloc(i2, dim=d,mask=i2<0))) STOP 12 + if (any(b13 /= 0)) STOP 13 +end program main Index: Fortran/gfortran/regression/maxloc_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } +program main + integer(kind=4), allocatable :: f(:,:) + integer(kind=4) :: res(3) + character(len=80) line + allocate (f(2,2)) + f = 3 + res = maxloc(f,dim=1) + write(line,fmt='(80I1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } + Index: Fortran/gfortran/regression/maxloc_bounds_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } +program main + integer(kind=4), allocatable :: f(:,:) + logical, allocatable :: m(:,:) + integer(kind=4) :: res(3) + character(len=80) line + allocate (f(2,2),m(2,2)) + f = 3 + m = .true. + res = maxloc(f,dim=1,mask=m) + write(line,fmt='(80I1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } + Index: Fortran/gfortran/regression/maxloc_bounds_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } +program main + integer(kind=4), allocatable :: f(:,:) + logical, allocatable :: m(:,:) + integer(kind=4) :: res(2) + character(len=80) line + allocate (f(2,2),m(2,3)) + f = 3 + m = .true. + res = maxloc(f,dim=1,mask=m) + write(line,fmt='(80I1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } + Index: Fortran/gfortran/regression/maxloc_bounds_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_4.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +module tst +contains + subroutine foo(res) + integer(kind=4), allocatable :: f(:,:) + integer, dimension(:) :: res + allocate (f(2,5)) + f = 3 + res = maxloc(f) + end subroutine foo + +end module tst +program main + use tst + implicit none + integer :: res(3) + call foo(res) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } Index: Fortran/gfortran/regression/maxloc_bounds_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_5.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +module tst +contains + subroutine foo(res) + integer(kind=4), allocatable :: f(:,:) + integer, dimension(:) :: res + allocate (f(2,5)) + f = 3 + res = maxloc(f,mask=f>2) + end subroutine foo + +end module tst +program main + use tst + implicit none + integer :: res(3) + call foo(res) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } Index: Fortran/gfortran/regression/maxloc_bounds_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_6.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } +program main + integer(kind=4), allocatable :: f(:,:) + logical, allocatable :: m(:,:) + integer(kind=4) :: res(2) + character(len=80) line + allocate (f(2,2),m(2,3)) + f = 3 + m = .true. + res = maxloc(f,mask=m) + write(line,fmt='(80I1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" } Index: Fortran/gfortran/regression/maxloc_bounds_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_7.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } +module tst +contains + subroutine foo(res) + integer(kind=4), allocatable :: f(:,:) + integer, dimension(:) :: res + allocate (f(2,5)) + f = 3 + res = maxloc(f,mask=.true.) + end subroutine foo + +end module tst +program main + use tst + implicit none + integer :: res(3) + call foo(res) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic: is 3, should be 2" } Index: Fortran/gfortran/regression/maxloc_bounds_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_bounds_8.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } +program main + integer(kind=4), allocatable :: f(:,:) + logical, allocatable :: m(:,:) + integer(kind=4) :: res(3) + character(len=80) line + allocate (f(2,2),m(2,2)) + f = 3 + m = .true. + res = maxloc(f,dim=1,mask=.true.) + write(line,fmt='(80I1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" } + Index: Fortran/gfortran/regression/maxloc_shape_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_shape_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Tests the implementation of compile-time shape testing, required to fix +! PR19015. The functionality of maxloc and friends is tested by existing +! testcases. +! +! Contributed by Thomas Koeing +! + integer, dimension(0:1,0:1) :: n + integer, dimension(1) :: i + n = reshape((/1, 2, 3, 4/), shape(n)) + i = maxloc(n) ! { dg-error "Different shape for array assignment" } + i = maxloc(n,dim=1) ! { dg-error "Different shape for array assignment" } +! print *,i +end program Index: Fortran/gfortran/regression/maxloc_string_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxloc_string_1.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! Test maxloc for strings for different code paths + +program main + implicit none + integer, parameter :: n=4 + character(len=4), dimension(n,n) :: c + integer, dimension(n,n) :: a + integer, dimension(2) :: res1, res2 + real, dimension(n,n) :: r + logical, dimension(n,n) :: amask + logical(kind=8) :: smask + integer :: i,j + integer, dimension(n) :: q1, q2 + character(len=4,kind=4), dimension(n,n) :: c4 + character(len=4), dimension(n*n) :: e + integer, dimension(n*n) :: f + logical, dimension(n*n) :: cmask + + call random_number (r) + a = int(r*100) + do j=1,n + do i=1,n + write (unit=c(i,j),fmt='(I4.4)') a(i,j) + write (unit=c4(i,j),fmt='(I4.4)') a(i,j) + end do + end do + res1 = maxloc(c) + res2 = maxloc(a) + + if (any(res1 /= res2)) STOP 1 + res1 = maxloc(c4) + if (any(res1 /= res2)) STOP 2 + + amask = a < 50 + res1 = maxloc(c,mask=amask) + res2 = maxloc(a,mask=amask) + + if (any(res1 /= res2)) STOP 3 + + amask = .false. + res1 = maxloc(c,mask=amask) + if (any(res1 /= 0)) STOP 4 + + amask(2,3) = .true. + res1 = maxloc(c,mask=amask) + if (any(res1 /= [2,3])) STOP 5 + + res1 = maxloc(c,mask=.false.) + if (any(res1 /= 0)) STOP 6 + + res2 = maxloc(a) + res1 = maxloc(c,mask=.true.) + if (any(res1 /= res2)) STOP 7 + + q1 = maxloc(c, dim=1) + q2 = maxloc(a, dim=1) + if (any(q1 /= q2)) STOP 8 + + q1 = maxloc(c, dim=2) + q2 = maxloc(a, dim=2) + if (any(q1 /= q2)) STOP 9 + + q1 = maxloc(c, dim=1, mask=amask) + q2 = maxloc(a, dim=1, mask=amask) + if (any(q1 /= q2)) STOP 10 + + q1 = maxloc(c, dim=2, mask=amask) + q2 = maxloc(a, dim=2, mask=amask) + if (any(q1 /= q2)) STOP 11 + + amask = a < 50 + + q1 = maxloc(c, dim=1, mask=amask) + q2 = maxloc(a, dim=1, mask=amask) + if (any(q1 /= q2)) STOP 12 + + q1 = maxloc(c, dim=2, mask=amask) + q2 = maxloc(a, dim=2, mask=amask) + if (any(q1 /= q2)) STOP 13 + + e = reshape(c, shape(e)) + f = reshape(a, shape(f)) + if (maxloc(e,dim=1) /= maxloc(f,dim=1)) STOP 14 + + cmask = .false. + if (maxloc(e,dim=1,mask=cmask) /= 0) STOP 15 + + cmask = f > 50 + if ( maxloc(e, dim=1, mask=cmask) /= maxloc (f, dim=1, mask=cmask)) STOP 16 +end program main Index: Fortran/gfortran/regression/maxlocval_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxlocval_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Check that maxval uses for integers HUGE()-1. +! PR fortran/30512 + +program main +implicit none +integer(1) :: i1(3), a1(3:2) +integer(2) :: i2(3), a2(3:2) +integer(4) :: i4(3), a4(3:2) +integer(8) :: i8(3), a8(3:2) + +integer(kind=4), allocatable :: a(:,:) +integer(kind=8), allocatable :: b(:,:) + +logical :: msk(3) +msk = .false. + +i1 = 1 +i2 = 1 +i4 = 1 +i8 = 1 + +if(-huge(i1)-1_1 /= maxval(i1, msk)) STOP 1 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(-huge(a1)-1_1 /= maxval(a1)) STOP 2 ! { dg-warning "outside symmetric range implied by Standard Fortran" } + +if(-huge(i2)-1_2 /= maxval(i2, msk)) STOP 3 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(-huge(a2)-1_2 /= maxval(a2)) STOP 4 ! { dg-warning "outside symmetric range implied by Standard Fortran" } + +if(-huge(i4)-1_4 /= maxval(i4, msk)) STOP 5 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(-huge(a4)-1_4 /= maxval(a4)) STOP 6 ! { dg-warning "outside symmetric range implied by Standard Fortran" } + +if(-huge(i8)-1_4 /= maxval(i8, msk)) STOP 7 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(-huge(a8)-1_4 /= maxval(a8)) STOP 8 ! { dg-warning "outside symmetric range implied by Standard Fortran" } + +allocate (a(0:-1,1:1)) +allocate (b(0:-1,1:1)) + +if(any(maxval(a,dim=1) /= -huge(a)-1_4)) STOP 9 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(any(minval(a,dim=1) /= huge(a) )) STOP 10 + +if(any(maxval(b,dim=1) /= -huge(b)-1_8)) STOP 11 ! { dg-warning "outside symmetric range implied by Standard Fortran" } +if(any(minval(b,dim=1) /= huge(b) )) STOP 12 + +end program main Index: Fortran/gfortran/regression/maxlocval_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxlocval_2.f90 @@ -0,0 +1,154 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3), nan, minf, pinf + real, allocatable :: c(:) + logical :: l + logical :: l2(3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + + allocate (c(3)) + a(:) = nan + if (maxloc (a, dim = 1).ne.1) STOP 1 + if (.not.isnan(maxval (a, dim = 1))) STOP 2 + a(:) = minf + if (maxloc (a, dim = 1).ne.1) STOP 3 + if (maxval (a, dim = 1).ne.minf) STOP 4 + a(1:2) = nan + if (maxloc (a, dim = 1).ne.3) STOP 5 + if (maxval (a, dim = 1).ne.minf) STOP 6 + a(2) = 1.0 + if (maxloc (a, dim = 1).ne.2) STOP 7 + if (maxval (a, dim = 1).ne.1) STOP 8 + a(2) = pinf + if (maxloc (a, dim = 1).ne.2) STOP 9 + if (maxval (a, dim = 1).ne.pinf) STOP 10 + c(:) = nan + if (maxloc (c, dim = 1).ne.1) STOP 11 + if (.not.isnan(maxval (c, dim = 1))) STOP 12 + c(:) = minf + if (maxloc (c, dim = 1).ne.1) STOP 13 + if (maxval (c, dim = 1).ne.minf) STOP 14 + c(1:2) = nan + if (maxloc (c, dim = 1).ne.3) STOP 15 + if (maxval (c, dim = 1).ne.minf) STOP 16 + c(2) = 1.0 + if (maxloc (c, dim = 1).ne.2) STOP 17 + if (maxval (c, dim = 1).ne.1) STOP 18 + c(2) = pinf + if (maxloc (c, dim = 1).ne.2) STOP 19 + if (maxval (c, dim = 1).ne.pinf) STOP 20 + l = .false. + l2(:) = .false. + a(:) = nan + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 21 + if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) STOP 22 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 23 + if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) STOP 24 + a(:) = minf + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 25 + if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) STOP 26 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 27 + if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) STOP 28 + a(1:2) = nan + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 29 + if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) STOP 30 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 31 + if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) STOP 32 + a(2) = 1.0 + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 33 + if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) STOP 34 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 35 + if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) STOP 36 + a(2) = pinf + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 37 + if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) STOP 38 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 39 + if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) STOP 40 + c(:) = nan + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 41 + if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) STOP 42 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 43 + if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) STOP 44 + c(:) = minf + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 45 + if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) STOP 46 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 47 + if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) STOP 48 + c(1:2) = nan + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 49 + if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) STOP 50 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 51 + if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) STOP 52 + c(2) = 1.0 + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 53 + if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) STOP 54 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 55 + if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) STOP 56 + c(2) = pinf + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 57 + if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) STOP 58 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 59 + if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) STOP 60 + l = .true. + l2(:) = .true. + a(:) = nan + if (maxloc (a, dim = 1, mask = l).ne.1) STOP 61 + if (.not.isnan(maxval (a, dim = 1, mask = l))) STOP 62 + if (maxloc (a, dim = 1, mask = l2).ne.1) STOP 63 + if (.not.isnan(maxval (a, dim = 1, mask = l2))) STOP 64 + a(:) = minf + if (maxloc (a, dim = 1, mask = l).ne.1) STOP 65 + if (maxval (a, dim = 1, mask = l).ne.minf) STOP 66 + if (maxloc (a, dim = 1, mask = l2).ne.1) STOP 67 + if (maxval (a, dim = 1, mask = l2).ne.minf) STOP 68 + a(1:2) = nan + if (maxloc (a, dim = 1, mask = l).ne.3) STOP 69 + if (maxval (a, dim = 1, mask = l).ne.minf) STOP 70 + if (maxloc (a, dim = 1, mask = l2).ne.3) STOP 71 + if (maxval (a, dim = 1, mask = l2).ne.minf) STOP 72 + a(2) = 1.0 + if (maxloc (a, dim = 1, mask = l).ne.2) STOP 73 + if (maxval (a, dim = 1, mask = l).ne.1) STOP 74 + if (maxloc (a, dim = 1, mask = l2).ne.2) STOP 75 + if (maxval (a, dim = 1, mask = l2).ne.1) STOP 76 + a(2) = pinf + if (maxloc (a, dim = 1, mask = l).ne.2) STOP 77 + if (maxval (a, dim = 1, mask = l).ne.pinf) STOP 78 + if (maxloc (a, dim = 1, mask = l2).ne.2) STOP 79 + if (maxval (a, dim = 1, mask = l2).ne.pinf) STOP 80 + c(:) = nan + if (maxloc (c, dim = 1, mask = l).ne.1) STOP 81 + if (.not.isnan(maxval (c, dim = 1, mask = l))) STOP 82 + if (maxloc (c, dim = 1, mask = l2).ne.1) STOP 83 + if (.not.isnan(maxval (c, dim = 1, mask = l2))) STOP 84 + c(:) = minf + if (maxloc (c, dim = 1, mask = l).ne.1) STOP 85 + if (maxval (c, dim = 1, mask = l).ne.minf) STOP 86 + if (maxloc (c, dim = 1, mask = l2).ne.1) STOP 87 + if (maxval (c, dim = 1, mask = l2).ne.minf) STOP 88 + c(1:2) = nan + if (maxloc (c, dim = 1, mask = l).ne.3) STOP 89 + if (maxval (c, dim = 1, mask = l).ne.minf) STOP 90 + if (maxloc (c, dim = 1, mask = l2).ne.3) STOP 91 + if (maxval (c, dim = 1, mask = l2).ne.minf) STOP 92 + c(2) = 1.0 + if (maxloc (c, dim = 1, mask = l).ne.2) STOP 93 + if (maxval (c, dim = 1, mask = l).ne.1) STOP 94 + if (maxloc (c, dim = 1, mask = l2).ne.2) STOP 95 + if (maxval (c, dim = 1, mask = l2).ne.1) STOP 96 + c(2) = pinf + if (maxloc (c, dim = 1, mask = l).ne.2) STOP 97 + if (maxval (c, dim = 1, mask = l).ne.pinf) STOP 98 + if (maxloc (c, dim = 1, mask = l2).ne.2) STOP 99 + if (maxval (c, dim = 1, mask = l2).ne.pinf) STOP 100 + deallocate (c) + allocate (c(-2:-3)) + if (maxloc (c, dim = 1).ne.0) STOP 101 + if (maxval (c, dim = 1).ne.-huge(minf)) STOP 102 +end Index: Fortran/gfortran/regression/maxlocval_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxlocval_3.f90 @@ -0,0 +1,122 @@ +! { dg-do run } + integer :: a(3), h + integer, allocatable :: c(:) + logical :: l + logical :: l2(3) + + h = -huge(h) + h = h - 1 + allocate (c(3)) + a(:) = 5 + if (maxloc (a, dim = 1).ne.1) STOP 1 + if (maxval (a, dim = 1).ne.5) STOP 2 + a(2) = huge(h) + if (maxloc (a, dim = 1).ne.2) STOP 3 + if (maxval (a, dim = 1).ne.huge(h)) STOP 4 + a(:) = h + if (maxloc (a, dim = 1).ne.1) STOP 5 + if (maxval (a, dim = 1).ne.h) STOP 6 + a(3) = -huge(h) + if (maxloc (a, dim = 1).ne.3) STOP 7 + if (maxval (a, dim = 1).ne.-huge(h)) STOP 8 + c(:) = 5 + if (maxloc (c, dim = 1).ne.1) STOP 9 + if (maxval (c, dim = 1).ne.5) STOP 10 + c(2) = huge(h) + if (maxloc (c, dim = 1).ne.2) STOP 11 + if (maxval (c, dim = 1).ne.huge(h)) STOP 12 + c(:) = h + if (maxloc (c, dim = 1).ne.1) STOP 13 + if (maxval (c, dim = 1).ne.h) STOP 14 + c(3) = -huge(h) + if (maxloc (c, dim = 1).ne.3) STOP 15 + if (maxval (c, dim = 1).ne.-huge(h)) STOP 16 + l = .false. + l2(:) = .false. + a(:) = 5 + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 17 + if (maxval (a, dim = 1, mask = l).ne.h) STOP 18 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 19 + if (maxval (a, dim = 1, mask = l2).ne.h) STOP 20 + a(2) = huge(h) + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 21 + if (maxval (a, dim = 1, mask = l).ne.h) STOP 22 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 23 + if (maxval (a, dim = 1, mask = l2).ne.h) STOP 24 + a(:) = h + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 25 + if (maxval (a, dim = 1, mask = l).ne.h) STOP 26 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 27 + if (maxval (a, dim = 1, mask = l2).ne.h) STOP 28 + a(3) = -huge(h) + if (maxloc (a, dim = 1, mask = l).ne.0) STOP 29 + if (maxval (a, dim = 1, mask = l).ne.h) STOP 30 + if (maxloc (a, dim = 1, mask = l2).ne.0) STOP 31 + if (maxval (a, dim = 1, mask = l2).ne.h) STOP 32 + c(:) = 5 + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 33 + if (maxval (c, dim = 1, mask = l).ne.h) STOP 34 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 35 + if (maxval (c, dim = 1, mask = l2).ne.h) STOP 36 + c(2) = huge(h) + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 37 + if (maxval (c, dim = 1, mask = l).ne.h) STOP 38 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 39 + if (maxval (c, dim = 1, mask = l2).ne.h) STOP 40 + c(:) = h + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 41 + if (maxval (c, dim = 1, mask = l).ne.h) STOP 42 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 43 + if (maxval (c, dim = 1, mask = l2).ne.h) STOP 44 + c(3) = -huge(h) + if (maxloc (c, dim = 1, mask = l).ne.0) STOP 45 + if (maxval (c, dim = 1, mask = l).ne.h) STOP 46 + if (maxloc (c, dim = 1, mask = l2).ne.0) STOP 47 + if (maxval (c, dim = 1, mask = l2).ne.h) STOP 48 + l = .true. + l2(:) = .true. + a(:) = 5 + if (maxloc (a, dim = 1, mask = l).ne.1) STOP 49 + if (maxval (a, dim = 1, mask = l).ne.5) STOP 50 + if (maxloc (a, dim = 1, mask = l2).ne.1) STOP 51 + if (maxval (a, dim = 1, mask = l2).ne.5) STOP 52 + a(2) = huge(h) + if (maxloc (a, dim = 1, mask = l).ne.2) STOP 53 + if (maxval (a, dim = 1, mask = l).ne.huge(h)) STOP 54 + if (maxloc (a, dim = 1, mask = l2).ne.2) STOP 55 + if (maxval (a, dim = 1, mask = l2).ne.huge(h)) STOP 56 + a(:) = h + if (maxloc (a, dim = 1, mask = l).ne.1) STOP 57 + if (maxval (a, dim = 1, mask = l).ne.h) STOP 58 + if (maxloc (a, dim = 1, mask = l2).ne.1) STOP 59 + if (maxval (a, dim = 1, mask = l2).ne.h) STOP 60 + a(3) = -huge(h) + if (maxloc (a, dim = 1, mask = l).ne.3) STOP 61 + if (maxval (a, dim = 1, mask = l).ne.-huge(h)) STOP 62 + if (maxloc (a, dim = 1, mask = l2).ne.3) STOP 63 + if (maxval (a, dim = 1, mask = l2).ne.-huge(h)) STOP 64 + c(:) = 5 + if (maxloc (c, dim = 1, mask = l).ne.1) STOP 65 + if (maxval (c, dim = 1, mask = l).ne.5) STOP 66 + if (maxloc (c, dim = 1, mask = l2).ne.1) STOP 67 + if (maxval (c, dim = 1, mask = l2).ne.5) STOP 68 + c(2) = huge(h) + if (maxloc (c, dim = 1, mask = l).ne.2) STOP 69 + if (maxval (c, dim = 1, mask = l).ne.huge(h)) STOP 70 + if (maxloc (c, dim = 1, mask = l2).ne.2) STOP 71 + if (maxval (c, dim = 1, mask = l2).ne.huge(h)) STOP 72 + c(:) = h + if (maxloc (c, dim = 1, mask = l).ne.1) STOP 73 + if (maxval (c, dim = 1, mask = l).ne.h) STOP 74 + if (maxloc (c, dim = 1, mask = l2).ne.1) STOP 75 + if (maxval (c, dim = 1, mask = l2).ne.h) STOP 76 + c(3) = -huge(h) + if (maxloc (c, dim = 1, mask = l).ne.3) STOP 77 + if (maxval (c, dim = 1, mask = l).ne.-huge(h)) STOP 78 + if (maxloc (c, dim = 1, mask = l2).ne.3) STOP 79 + if (maxval (c, dim = 1, mask = l2).ne.-huge(h)) STOP 80 + deallocate (c) + allocate (c(-2:-3)) + if (maxloc (c, dim = 1).ne.0) STOP 81 + if (maxval (c, dim = 1).ne.h) STOP 82 +end Index: Fortran/gfortran/regression/maxlocval_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxlocval_4.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3,3), b(3), nan, minf, pinf, h + logical :: l, l2 + logical :: l3(3,3), l4(3,3), l5(3,3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + h = -huge(h) + l = .false. + l2 = .true. + l3 = .false. + l4 = .true. + l5 = .true. + l5(1,1) = .false. + l5(1,2) = .false. + l5(2,3) = .false. + a = reshape ((/ nan, nan, nan, minf, minf, minf, minf, pinf, minf /), (/ 3, 3 /)) + if (maxval (a).ne.pinf) STOP 1 + if (any (maxloc (a).ne.(/ 2, 3 /))) STOP 2 + b = maxval (a, dim = 1) + if (.not.isnan(b(1))) STOP 3 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, minf, pinf /))) STOP 4 + if (any (maxloc (a, dim = 1).ne.(/ 1, 1, 2 /))) STOP 5 + b = maxval (a, dim = 2) + if (any (b.ne.(/ minf, pinf, minf /))) STOP 6 + if (any (maxloc (a, dim = 2).ne.(/ 2, 3, 2 /))) STOP 7 + if (maxval (a, mask = l).ne.h) STOP 8 + if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) STOP 9 + b = maxval (a, dim = 1, mask = l) + if (any (b.ne.(/ h, h, h /))) STOP 10 + if (any (maxloc (a, dim = 1, mask = l).ne.(/ 0, 0, 0 /))) STOP 11 + b = maxval (a, dim = 2, mask = l) + if (any (b.ne.(/ h, h, h /))) STOP 12 + if (any (maxloc (a, dim = 2, mask = l).ne.(/ 0, 0, 0 /))) STOP 13 + if (maxval (a, mask = l3).ne.h) STOP 14 + if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 15 + b = maxval (a, dim = 1, mask = l3) + if (any (b.ne.(/ h, h, h /))) STOP 16 + if (any (maxloc (a, dim = 1, mask = l3).ne.(/ 0, 0, 0 /))) STOP 17 + b = maxval (a, dim = 2, mask = l3) + if (any (b.ne.(/ h, h, h /))) STOP 18 + if (any (maxloc (a, dim = 2, mask = l3).ne.(/ 0, 0, 0 /))) STOP 19 + if (maxval (a, mask = l2).ne.pinf) STOP 20 + if (maxval (a, mask = l4).ne.pinf) STOP 21 + if (any (maxloc (a, mask = l2).ne.(/ 2, 3 /))) STOP 22 + if (any (maxloc (a, mask = l4).ne.(/ 2, 3 /))) STOP 23 + b = maxval (a, dim = 1, mask = l2) + if (.not.isnan(b(1))) STOP 24 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, minf, pinf /))) STOP 25 + if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) STOP 26 + b = maxval (a, dim = 2, mask = l2) + if (any (b.ne.(/ minf, pinf, minf /))) STOP 27 + if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) STOP 28 + b = maxval (a, dim = 1, mask = l4) + if (.not.isnan(b(1))) STOP 29 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, minf, pinf /))) STOP 30 + if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) STOP 31 + b = maxval (a, dim = 2, mask = l4) + if (any (b.ne.(/ minf, pinf, minf /))) STOP 32 + if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) STOP 33 + if (maxval (a, mask = l5).ne.minf) STOP 34 + if (any (maxloc (a, mask = l5).ne.(/ 2, 2 /))) STOP 35 + b = maxval (a, dim = 1, mask = l5) + if (.not.isnan(b(1))) STOP 36 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, minf, minf /))) STOP 37 + if (any (maxloc (a, dim = 1, mask = l5).ne.(/ 2, 2, 1 /))) STOP 38 + b = maxval (a, dim = 2, mask = l5) + if (any (b.ne.(/ minf, minf, minf /))) STOP 39 + if (any (maxloc (a, dim = 2, mask = l5).ne.(/ 3, 2, 2 /))) STOP 40 + a = nan + if (.not.isnan(maxval (a))) STOP 41 + if (maxval (a, mask = l).ne.h) STOP 42 + if (.not.isnan(maxval (a, mask = l2))) STOP 43 + if (maxval (a, mask = l3).ne.h) STOP 44 + if (.not.isnan(maxval (a, mask = l4))) STOP 45 + if (.not.isnan(maxval (a, mask = l5))) STOP 46 + if (any (maxloc (a).ne.(/ 1, 1 /))) STOP 47 + if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) STOP 48 + if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) STOP 49 + if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 50 + if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) STOP 51 + if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) STOP 52 + a = minf + if (maxval (a).ne.minf) STOP 53 + if (maxval (a, mask = l).ne.h) STOP 54 + if (maxval (a, mask = l2).ne.minf) STOP 55 + if (maxval (a, mask = l3).ne.h) STOP 56 + if (maxval (a, mask = l4).ne.minf) STOP 57 + if (maxval (a, mask = l5).ne.minf) STOP 58 + if (any (maxloc (a).ne.(/ 1, 1 /))) STOP 59 + if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) STOP 60 + if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) STOP 61 + if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 62 + if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) STOP 63 + if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) STOP 64 + a = nan + a(1,3) = minf + if (maxval (a).ne.minf) STOP 65 + if (maxval (a, mask = l).ne.h) STOP 66 + if (maxval (a, mask = l2).ne.minf) STOP 67 + if (maxval (a, mask = l3).ne.h) STOP 68 + if (maxval (a, mask = l4).ne.minf) STOP 69 + if (maxval (a, mask = l5).ne.minf) STOP 70 + if (any (maxloc (a).ne.(/ 1, 3 /))) STOP 71 + if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) STOP 72 + if (any (maxloc (a, mask = l2).ne.(/ 1, 3 /))) STOP 73 + if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 74 + if (any (maxloc (a, mask = l4).ne.(/ 1, 3 /))) STOP 75 + if (any (maxloc (a, mask = l5).ne.(/ 1, 3 /))) STOP 76 +end Index: Fortran/gfortran/regression/maxval_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_char_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5, m=3 + character(len=5), dimension(n) :: a + character(len=5), dimension(n,m) :: b + character(len=5) :: res + integer, dimension(n,m) :: v + real, dimension(n,m) :: r + integer :: i,j + logical, dimension(n,m) :: mask + character(len=5), dimension(:,:), allocatable :: empty + character(len=5) , parameter :: all_zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0) + logical :: smask + + write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n) + res = maxval(a) + if (res /= '00030') STOP 1 + res = maxval(a,dim=1) + if (res /= '00030') STOP 2 + do + call random_number(r) + v = int(r * 100) + if (count (v>20) > 1) exit + end do + write (unit=b,fmt='(I5.5)') v + write (unit=res,fmt='(I5.5)') maxval(v) + if (res /= maxval(b)) STOP 3 + smask = .true. + if (res /= maxval(b, smask)) STOP 4 + smask = .false. + if (all_zero /= maxval(b, smask)) STOP 5 + + mask = v > 20 + write (unit=res,fmt='(I5.5)') maxval(v,mask) + if (res /= maxval(b, mask)) STOP 6 + mask = .false. + if (maxval(b, mask) /= all_zero) STOP 7 + allocate (empty(0:3,0)) + res = maxval(empty) + if (res /= all_zero) STOP 8 +end program main Index: Fortran/gfortran/regression/maxval_char_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_char_2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5, m=3 + character(kind=4,len=5), dimension(n) :: a + character(kind=4,len=5), dimension(n,m) :: b + character(kind=4,len=5) :: res + integer, dimension(n,m) :: v + real, dimension(n,m) :: r + integer :: i,j + logical, dimension(n,m) :: mask + character(kind=4,len=5), dimension(:,:), allocatable :: empty + character(kind=4,len=5) , parameter :: all_zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0) + logical :: smask + + write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n) + res = maxval(a) + if (res /= 4_'00030') STOP 1 + do + call random_number(r) + v = int(r * 100) + if (count(v > 20) > 1) exit + end do + write (unit=b,fmt='(I5.5)') v + write (unit=res,fmt='(I5.5)') maxval(v) + if (res /= maxval(b)) STOP 2 + smask = .true. + if (res /= maxval(b, smask)) STOP 3 + smask = .false. + if (all_zero /= maxval(b, smask)) STOP 4 + + mask = v > 20 + write (unit=res,fmt='(I5.5)') maxval(v,mask) + if (res /= maxval(b, mask)) STOP 5 + mask = .false. + if (maxval(b, mask) /= all_zero) STOP 6 + allocate (empty(0:3,0)) + res = maxval(empty) + if (res /= all_zero) STOP 7 +end program main Index: Fortran/gfortran/regression/maxval_char_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_char_3.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5 + character(len=6), dimension(n,n) :: a + integer, dimension(n,n) :: v + character(len=6), dimension(n) :: r1, r2 + character(len=6), dimension(:,:), allocatable :: a_alloc + integer, dimension(:,:), allocatable :: v_alloc + character(len=6), parameter :: zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0) // achar(0) + integer :: i + character(len=6),dimension(1) :: ret + logical, dimension(n,n) :: mask + logical :: smask + + v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v)) + write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n) + + r1 = maxval(a,dim=1) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 1 + r1 = 'x' + write (unit=r1,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 2 + + r1 = 'y' + r1 = maxval(a,dim=2) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=2) + if (any (r1 /= r2)) STOP 3 + r1 = 'z' + write (unit=r1,fmt='(I6.6)') maxval(v,dim=2) + if (any (r1 /= r2)) STOP 4 + + allocate (a_alloc(0,1), v_alloc(0,1)) + ret = 'what' + ret = maxval(a_alloc,dim=1) + if (ret(1) /= zero) STOP 5 + + r1 = 'qq' + r1 = maxval(a, dim=1, mask=a>"000200"); + if (any(r1 /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 6 + if (any(maxval(a, dim=1, mask=a>"000200") /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 7 + + r1 = 'rr' + r1 = maxval(a, dim=2, mask=a>"000200"); + if (any(r1 /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 8 + if (any(maxval(a, dim=2, mask=a>"000200") /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 9 + + mask = .true. + forall (i=1:n) + mask(i,i) = .false. + end forall + + r1 = 'aa' + r1 = maxval(a, dim=1, mask=mask) + write(unit=r2,fmt='(I6.6)') maxval(v,dim=1, mask=mask) + if (any(r1 /= r2)) STOP 10 + + r1 = 'xyz' + smask = .true. + r1 = maxval(a, dim=1, mask=smask) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 11 + + smask = .false. + r1 = 'foobar' + r1 = maxval(a, dim=1, mask=smask) + if (any(r1 /= zero)) STOP 12 +end program main Index: Fortran/gfortran/regression/maxval_char_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_char_4.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5 + character(kind=4,len=6), dimension(n,n) :: a + integer, dimension(n,n) :: v + character(kind=4,len=6), dimension(n) :: r1, r2 + character(kind=4,len=6), dimension(:,:), allocatable :: a_alloc + integer, dimension(:,:), allocatable :: v_alloc + character(kind=4,len=6), parameter :: zero = achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4) // achar(0,4) + integer :: i + character(kind=4,len=6),dimension(1) :: ret + logical, dimension(n,n) :: mask + logical :: smask + + v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v)) + write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n) + + r1 = maxval(a,dim=1) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 1 + r1 = 4_'x' + write (unit=r1,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 2 + + r1 = 4_'y' + r1 = maxval(a,dim=2) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=2) + if (any (r1 /= r2)) STOP 3 + r1 = 4_'z' + write (unit=r1,fmt='(I6.6)') maxval(v,dim=2) + if (any (r1 /= r2)) STOP 4 + + allocate (a_alloc(0,1), v_alloc(0,1)) + ret = 4_'what' + ret = maxval(a_alloc,dim=1) + if (ret(1) /= zero) STOP 5 + + r1 = 4_'qq' + r1 = maxval(a, dim=1, mask=a>4_"000200"); + if (any(r1 /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 6 + if (any(maxval(a, dim=1, mask=a>4_"000200") /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 7 + + r1 = 4_'rr' + r1 = maxval(a, dim=2, mask=a>4_"000200"); + if (any(r1 /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 8 + if (any(maxval(a, dim=2, mask=a>4_"000200") /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 9 + + mask = .true. + forall (i=1:n) + mask(i,i) = .false. + end forall + + r1 = 4_'aa' + r1 = maxval(a, dim=1, mask=mask) + write(unit=r2,fmt='(I6.6)') maxval(v,dim=1, mask=mask) + if (any(r1 /= r2)) STOP 10 + + r1 = 4_'xyz' + smask = .true. + r1 = maxval(a, dim=1, mask=smask) + write (unit=r2,fmt='(I6.6)') maxval(v,dim=1) + if (any (r1 /= r2)) STOP 11 + + smask = .false. + r1 = 4_'foobar' + r1 = maxval(a, dim=1, mask=smask) + if (any(r1 /= zero)) STOP 12 +end program main Index: Fortran/gfortran/regression/maxval_maxloc_conformance_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_maxloc_conformance_1.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR 26039: Tests for different ranks for (min|max)loc, (min|max)val, product +! and sum were missing. +program main + integer, dimension(2) :: a + logical, dimension(2,1) :: lo + logical, dimension(3) :: lo2 + a = (/ 1, 2 /) + lo = .true. + print *,minloc(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,maxloc(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,minval(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,maxval(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,sum(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,product(a,mask=lo) ! { dg-error "Incompatible ranks" } + print *,minloc(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + print *,maxloc(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + print *,minval(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + print *,maxval(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + print *,sum(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + print *,product(a,1,mask=lo) ! { dg-error "Incompatible ranks" } + + print *,minloc(a,mask=lo2) ! { dg-error "Different shape" } + print *,maxloc(a,mask=lo2) ! { dg-error "Different shape" } + print *,minval(a,mask=lo2) ! { dg-error "Different shape" } + print *,maxval(a,mask=lo2) ! { dg-error "Different shape" } + print *,sum(a,mask=lo2) ! { dg-error "Different shape" } + print *,product(a,mask=lo2) ! { dg-error "Different shape" } + print *,minloc(a,1,mask=lo2) ! { dg-error "Different shape" } + print *,maxloc(a,1,mask=lo2) ! { dg-error "Different shape" } + print *,minval(a,1,mask=lo2) ! { dg-error "Different shape" } + print *,maxval(a,1,mask=lo2) ! { dg-error "Different shape" } + print *,sum(a,1,mask=lo2) ! { dg-error "Different shape" } + print *,product(a,1,mask=lo2) ! { dg-error "Different shape" } +end program main Index: Fortran/gfortran/regression/maxval_parameter_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/maxval_parameter_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Test for run-time simplification of maxval +program main + implicit none + integer, dimension(2,3), parameter :: i = & + & reshape([-1,2,-3,5,-7,11], shape(i)) + integer, dimension(3), parameter :: im1 = maxval(i,dim=1) + integer, parameter :: im2 = maxval(i,mask=i<0) + integer, dimension(2), parameter :: im3 = maxval(i,dim=2) + integer, parameter :: im4 = maxval(i, mask=i<-1) + integer, dimension(3), parameter :: im5 = maxval(i,dim=1,mask=i<-2) + integer, dimension(2), parameter :: im6 = maxval(i,dim=2,mask=i<0) + + real, dimension(2,3), parameter :: r = & + & reshape([-1.,2.,-3.,5.,-7.,11.], shape(r)) + real, dimension(3), parameter :: rm1 = maxval(r,dim=1) + real, parameter :: rm2 = maxval(r,mask=r<0) + real, dimension(2), parameter :: rm3 = maxval(r,dim=2) + real, parameter :: rm4 = maxval(r, mask=r<-1) + real, dimension(3), parameter :: rm5 = maxval(r,dim=1,mask=r<-2) + real, dimension(2), parameter :: rm6 = maxval(r,dim=2,mask=r<0) + + character(len=3), parameter :: minv = achar(0) // achar(0) // achar(0) + character(len=3), dimension(2,3), parameter :: c = & + reshape(["asd", "fgh", "qwe", "jkl", "ert", "zui"], shape(c)) + character(len=3), parameter :: cm1 = maxval(c) + character(len=3), dimension(3), parameter :: cm2 = maxval(c,dim=1) + character(len=3), dimension(2), parameter :: cm3 = maxval(c,dim=2) + character(len=3), parameter :: cm4 = maxval (c, c<"g") + character(len=3), dimension(3), parameter :: cm5 = maxval(c,dim=1,mask=c<"p") + + if (any (im1 /= [ 2, 5, 11])) STOP 1 + if (im2 /= -1) STOP 2 + if (any (im3 /= [ -1,11])) STOP 3 + if (im4 /= -3) STOP 4 + if (any (im5 /= [-huge(im5)-1, -3, -7])) STOP 5! { dg-warning "Integer outside symmetric range" } + if (any (im6 /= [-1, -huge(im6)-1])) STOP 6! { dg-warning "Integer outside symmetric range" } + + if (any (rm1 /= [ 2., 5., 11.])) STOP 7 + if (rm2 /= -1.) STOP 8 + if (any (rm3 /= [ -1.,11.])) STOP 9 + if (rm4 /= -3.) STOP 10 + if (any (rm5 /= [-huge(rm5), -3., -7.])) STOP 11 + if (any (rm6 /= [-1.,-huge(rm6)])) STOP 12 + + if (cm1 /= "zui") STOP 13 + if (any (cm2 /= ["fgh", "qwe", "zui" ])) STOP 14 + if (any (cm3 /= ["qwe", "zui" ])) STOP 15 + if (cm4 /= "fgh") STOP 16 + if (any(cm5 /= [ "fgh", "jkl", "ert" ] )) STOP 17 +end program main Index: Fortran/gfortran/regression/mclock.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mclock.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=gnu" } + integer(kind=4) :: i4, j4 + integer(kind=8) :: i8, j8 + + i4 = mclock() + i8 = mclock8() + j4 = mclock() + j8 = mclock8() + + if (i4 > j4 .or. i8 > j8 .or. i4 > i8 .or. j4 > j8) STOP 1 + + end Index: Fortran/gfortran/regression/merge_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_1.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! PR fortran/107874 - merge not using all its arguments +! Contributed by John Harper + +program testmerge9 + implicit none + integer :: i + logical :: x(2) = (/.true., .false./) + logical :: called(2) + logical :: y + + ! At run-time all arguments shall be evaluated + do i = 1,2 + called = .false. + y = merge (tstuff(), fstuff(), x(i)) + print *, y + if (any (.not. called)) stop 1 + end do + + ! Compile-time simplification shall not drop non-constant args + called = .false. + y = merge (tstuff(),fstuff(),.true.) + print *, y + if (any (.not. called)) stop 2 + called = .false. + y = merge (tstuff(),fstuff(),.false.) + print *, y + if (any (.not. called)) stop 3 + called = .false. + y = merge (tstuff(),.false.,.true.) + print *, y + if (any (called .neqv. [.true.,.false.])) stop 4 + called = .false. + y = merge (tstuff(),.false.,.false.) + print *, y + if (any (called .neqv. [.true.,.false.])) stop 5 + called = .false. + y = merge (.true.,fstuff(),.true.) + print *, y + if (any (called .neqv. [.false.,.true.])) stop 6 + called = .false. + y = merge (.true.,fstuff(),.false.) + print *, y + if (any (called .neqv. [.false.,.true.])) stop 7 +contains + logical function tstuff() + print *,'tstuff' + tstuff = .true. + called(1) = .true. + end function tstuff + + logical function fstuff() + print *,'fstuff' + fstuff = .false. + called(2) = .true. + end function fstuff +end program testmerge9 Index: Fortran/gfortran/regression/merge_bits_1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_bits_1.F90 @@ -0,0 +1,55 @@ +! Test the MERGE_BITS intrinsic +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + + interface run_merge + procedure run_merge_1 + procedure run_merge_2 + procedure run_merge_4 + procedure run_merge_8 + end interface + +#define CHECK(I,J,K) \ + if (merge_bits(I,J,K) /= ior(iand(I,K),iand(J,not(K)))) STOP 1; \ + if (run_merge(I,J,K) /= merge_bits(I,J,K)) STOP 2 + + CHECK(13_1,18_1,22_1) + CHECK(-13_1,18_1,22_1) + CHECK(13_1,-18_1,22_1) + CHECK(13_1,18_1,-22_1) + + CHECK(13_2,18_2,22_2) + CHECK(-13_2,18_2,22_2) + CHECK(13_2,-18_2,22_2) + CHECK(13_2,18_2,-22_2) + + CHECK(13_4,18_4,22_4) + CHECK(-13_4,18_4,22_4) + CHECK(13_4,-18_4,22_4) + CHECK(13_4,18_4,-22_4) + + CHECK(13_8,18_8,22_8) + CHECK(-13_8,18_8,22_8) + CHECK(13_8,-18_8,22_8) + CHECK(13_8,18_8,-22_8) + +contains + + function run_merge_1 (i, j, k) result(res) + integer(kind=1) :: i, j, k, res + res = merge_bits(i,j,k) + end function + function run_merge_2 (i, j, k) result(res) + integer(kind=2) :: i, j, k, res + res = merge_bits(i,j,k) + end function + function run_merge_4 (i, j, k) result(res) + integer(kind=4) :: i, j, k, res + res = merge_bits(i,j,k) + end function + function run_merge_8 (i, j, k) result(res) + integer(kind=8) :: i, j, k, res + res = merge_bits(i,j,k) + end function +end Index: Fortran/gfortran/regression/merge_bits_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_bits_2.F90 @@ -0,0 +1,22 @@ +! Test the MERGE_BITS intrinsic +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + +#define CHECK(I,J,K) \ + if (merge_bits(I,J,K) /= ior(iand(I,K),iand(J,not(K)))) STOP 1; \ + if (run_merge(I,J,K) /= merge_bits(I,J,K)) STOP 2 + + CHECK(13_16,18_16,22_16) + CHECK(-13_16,18_16,22_16) + CHECK(13_16,-18_16,22_16) + CHECK(13_16,18_16,-22_16) + +contains + + function run_merge (i, j, k) result(res) + integer(kind=16) :: i, j, k, res + res = merge_bits(i,j,k) + end function +end Index: Fortran/gfortran/regression/merge_bits_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_bits_3.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program foo + integer m + m = merge_bits(b'010101', b"101010", 42) ! { dg-error "cannot both be" } +end program foo Index: Fortran/gfortran/regression/merge_bits_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_bits_4.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +program foo + integer m, n, k + m = merge_bits(b'010101', 1234, 42); if (m /= 1232) stop 1 + n = merge_bits(1234, z'3456', 42); if (n /= 13398) stop 2 + k = merge_bits(1234, 3456, o'12334'); if (k /= 3536) stop 3 +end program foo Index: Fortran/gfortran/regression/merge_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_char_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 15327 +! The merge intrinsic didn't work for strings +character*2 :: c(2) +logical :: ll(2) + +ll = (/ .TRUE., .FALSE. /) +c = merge( (/ "AA", "BB" /), (/ "CC", "DD" /), ll ) +if (c(1).ne."AA" .or. c(2).ne."DD") STOP 1 + +c = "" +c = merge( (/ "AA", "BB" /), (/ "CC", "DD" /), (/ .TRUE., .FALSE. /) ) +if (c(1).ne."AA" .or. c(2).ne."DD") STOP 2 +end Index: Fortran/gfortran/regression/merge_char_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_char_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! See PR fortran/31610 +! +implicit none +character(len=2) :: a +character(len=3) :: b +print *, merge(a,a,.true.) +print *, merge(a,'aa',.true.) +print *, merge('aa',a,.true.) +print *, merge('aa','bb',.true.) +print *, merge(a, b, .true.) ! { dg-error "Unequal character lengths" } +print *, merge(a, 'bbb',.true.) ! { dg-error "Unequal character lengths" } +print *, merge('aa',b, .true.) ! { dg-error "Unequal character lengths" } +print *, merge('aa','bbb',.true.) ! { dg-error "Unequal character lengths" } +end Index: Fortran/gfortran/regression/merge_char_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_char_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Unequal character lengths" } + +! PR fortran/38137 +! Test that -fbounds-check detects unequal character lengths to MERGE +! at runtime. + +! Contributed by Tobias Burnus + +subroutine foo(a) +implicit none +character(len=*) :: a +character(len=3) :: b +logical :: ll = .true. +print *, merge(a,b,ll) ! Unequal character lengths +end subroutine foo + +call foo("ab") +end Index: Fortran/gfortran/regression/merge_char_const.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_char_const.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-O0" } +! This tests the patch for PR24311 in which the PRINT statement would +! ICE on trying to print a MERGE statement with character constants +! for the first two arguments. +! +! Contributed by Paul Thomas +! + integer, dimension(6) :: i = (/1,0,0,1,1,0/) + print '(6a1)', Merge ("a", "b", i == 1) ! { dg-output "abbaab" } + end + + Index: Fortran/gfortran/regression/merge_init_expr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_init_expr.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Check simplification of MERGE. +! + + INTEGER, PARAMETER :: array(3) = [1, 2, 3] + LOGICAL, PARAMETER :: mask(3) = [ .TRUE., .FALSE., .TRUE. ] + + INTEGER, PARAMETER :: scalar_1 = MERGE (1, 0, .TRUE.) + INTEGER, PARAMETER :: scalar_2 = MERGE (0, 1, .FALSE.) + + INTEGER, PARAMETER :: array_1(3) = MERGE (array, 0, .TRUE.) + INTEGER, PARAMETER :: array_2(3) = MERGE (array, 0, .FALSE.) + INTEGER, PARAMETER :: array_3(3) = MERGE (0, array, .TRUE.) + INTEGER, PARAMETER :: array_4(3) = MERGE (0, array, .FALSE.) + INTEGER, PARAMETER :: array_5(3) = MERGE (1, 0, mask) + INTEGER, PARAMETER :: array_6(3) = MERGE (array, -array, mask) + + INTEGER, PARAMETER :: array_7(3) = MERGE ([1,2,3], -array, mask) + + IF (scalar_1 /= 1 .OR. scalar_2 /= 1) STOP 1 + IF (.NOT. ALL (array_1 == array)) STOP 2 + IF (.NOT. ALL (array_2 == [0, 0, 0])) STOP 3 + IF (.NOT. ALL (array_3 == [0, 0, 0])) STOP 4 + IF (.NOT. ALL (array_4 == array)) STOP 5 + IF (.NOT. ALL (array_5 == [1, 0, 1])) STOP 6 + IF (.NOT. ALL (array_6 == [1, -2, 3])) STOP 7 +END Index: Fortran/gfortran/regression/merge_init_expr_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/merge_init_expr_2.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! { dg-require-visibility "" } +! +! PR fortran/56649 +! MERGE was not properly compile-time simplified +! +! Contributed by Bill Long +! +module m + implicit none + + integer, parameter :: int32 = 4 + type MPI_Datatype + integer :: i + end type MPI_Datatype + + integer,private,parameter :: dik = kind(0) + type(MPI_Datatype),parameter,private :: MPIx_I4 = MPI_Datatype( 1275069467) + type(MPI_Datatype),parameter,private :: MPIx_I8 = MPI_Datatype( 1275070491) + type(MPI_Datatype),parameter :: MPI_INTEGER = merge(MPIx_I4, MPIx_I8, & + dik==int32) +contains + subroutine foo + integer :: check1 + check1 = MPI_INTEGER%i + end subroutine foo +end module m + +module m2 + implicit none + integer, parameter :: int32 = 4 + type MPI_Datatype + integer :: i + end type MPI_Datatype + + integer,private,parameter :: dik = kind(0) + type(MPI_Datatype),parameter,private :: MPIx_I4 = MPI_Datatype( 1275069467) + type(MPI_Datatype),parameter,private :: MPIx_I8 = MPI_Datatype( 1275070491) + type(MPI_Datatype),parameter :: MPI_INTEGER(1) = merge([MPIx_I4], [MPIx_I8], & + [dik==int32]) +contains + subroutine foo + logical :: check2 + check2 = MPI_INTEGER(1)%i == 1275069467 + end subroutine foo +end module m2 + + +subroutine test + character(len=3) :: one, three + character(len=3), parameter :: two = "def" + logical, parameter :: true = .true. + three = merge (one, two, true) +end subroutine test + +! { dg-final { scan-tree-dump-times "check1 = 1275069467;" 1 "original" } } +! { dg-final { scan-tree-dump-times "check2 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memmove ..void .. &three, .void .. &one, 3.;" 1 "original" } } Index: Fortran/gfortran/regression/min0_max0_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min0_max0_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/100283 + +subroutine s () + integer(kind=8) :: i,j,k + i = min0 (j,k) + i = max0 (-127_8, min0 (j,127_8)) +end subroutine s Index: Fortran/gfortran/regression/min0_max0_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min0_max0_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fdefault-integer-8 -std=gnu" } +! PR fortran/101123 + +SUBROUTINE TEST + IMPLICIT INTEGER*4 (I-N) + MAXMN=MAX0(M,N) + MINMN=MIN0(M,0_4) + MAXRS=MAX1(R,S) +END SUBROUTINE TEST Index: Fortran/gfortran/regression/min_expr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_expr.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } + +subroutine foo (a, b, c, d, e, f, g, h) + real (kind=8) :: a, b, c, d, e, f, g, h + a = min (a, b, c, d, e, f, g, h) +end subroutine + + +subroutine foof (a, b, c, d, e, f, g, h) + real (kind=4) :: a, b, c, d, e, f, g, h + a = min (a, b, c, d, e, f, g, h) +end subroutine + +! { dg-final { scan-tree-dump-times "MIN_EXPR " 14 "optimized" } } Index: Fortran/gfortran/regression/min_max_conformance.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_conformance.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=0" } +! PR 31919: Tests for different ranks in min/max were missing. +program pr31919 + integer :: i4, i4a(2, 2), i4b(2), i4c(4) + real(4) :: r4, r4a(2, 2), r4b(2), r4c(4) + real(8) :: r8, r8a(2, 2), r8b(2), r8c(4) + + i4a = max(i4a, i4b) ! { dg-error "Incompatible ranks" } + i4a = max0(i4a, i4b) ! { dg-error "Incompatible ranks" } + r4a = amax0(i4a, i4b) ! { dg-error "Incompatible ranks" } + i4a = max1(r4a, r4b) ! { dg-error "Incompatible ranks" } + r4a = amax1(r4a, r4b) ! { dg-error "Incompatible ranks" } + r8a = dmax1(r8a, r8b) ! { dg-error "Incompatible ranks" } + + i4a = min(i4a, i4b) ! { dg-error "Incompatible ranks" } + i4a = min0(i4a, i4b) ! { dg-error "Incompatible ranks" } + i4a = amin0(i4a, i4b) ! { dg-error "Incompatible ranks" } + r4a = min1(r4a, r4b) ! { dg-error "Incompatible ranks" } + r4a = amin1(r4a, r4b) ! { dg-error "Incompatible ranks" } + r8a = dmin1(r8a, r8b) ! { dg-error "Incompatible ranks" } + + i4a = max(i4b, i4c) ! { dg-error "Different shape for arguments" } + i4a = max0(i4b, i4c) ! { dg-error "Different shape for arguments" } + r4a = amax0(i4b, i4c) ! { dg-error "Different shape for arguments" } + i4a = max1(r4b, r4c) ! { dg-error "Different shape for arguments" } + r4a = amax1(r4b, r4c) ! { dg-error "Different shape for arguments" } + r8a = dmax1(r8B, r8c) ! { dg-error "Different shape for arguments" } + + i4a = min(i4b, i4c) ! { dg-error "Different shape for arguments" } + i4a = min0(i4b, i4c) ! { dg-error "Different shape for arguments" } + i4a = amin0(i4b, i4c) ! { dg-error "Different shape for arguments" } + r4a = min1(r4b, r4c) ! { dg-error "Different shape for arguments" } + r4a = amin1(r4b, r4c) ! { dg-error "Different shape for arguments" } + r8a = dmin1(r8b, r8c) ! { dg-error "Different shape for arguments" } + + ! checking needs to be position independent + i4a = min(i4, i4a, i4, i4b) ! { dg-error "Incompatible ranks" } + r4a = min(r4, r4a, r4, r4b) ! { dg-error "Incompatible ranks" } + r8a = min(r8, r8a, r8, r8b) ! { dg-error "Incompatible ranks" } + i4a = min(i4, i4b, i4, i4c) ! { dg-error "Different shape for arguments" } + r4a = min(r4, r4b, r4, r4c) ! { dg-error "Different shape for arguments" } + r8a = min(r8, r8b, r8, r8c) ! { dg-error "Different shape for arguments" } + + i4a = max(i4, i4a, i4, i4b) ! { dg-error "Incompatible ranks" } + r4a = max(r4, r4a, r4, r4b) ! { dg-error "Incompatible ranks" } + r8a = max(r8, r8a, r8, r8b) ! { dg-error "Incompatible ranks" } + i4a = max(i4, i4b, i4, i4c) ! { dg-error "Different shape for arguments" } + r4a = max(r4, r4b, r4, r4c) ! { dg-error "Different shape for arguments" } + r8a = max(r8, r8b, r8, r8c) ! { dg-error "Different shape for arguments" } +end program Index: Fortran/gfortran/regression/min_max_conformance_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_conformance_2.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/57894 +! +! Contributed by Vittorio Zecca +! +print *, max(a2=2,a65=45,a2=5) ! { dg-error "has already appeared in the current argument list" } +print *, min(a1=2.0,a65=45.0,a2=5.0e0) ! OK +print *, max(a2=2,a65=45,a3=5) ! { dg-error "Missing 'a1' argument to the max intrinsic" } +print *, min(a1=2.0,a65=45.0,a3=5.0e0) ! { dg-error "Missing 'a2' argument to the min intrinsic" } +print *, min1(2.0,a1=45.0,a2=5.0e0) ! { dg-error "Duplicate argument 'a1'" } + +print *, max0(a1=2,a65a=45,a2=5) ! { dg-error "Unknown argument 'a65a'" } +print *, amax0(a1=2,as65=45,a2=5) ! { dg-error "Unknown argument 'as65'" } +print *, max1(a1=2,a2=45,5) ! { dg-error "Missing keyword name in actual argument list" } +print *, amax1(a1=2,a3=45,a4=5) ! { dg-error "Missing 'a2' argument" } +print *, dmax1(a1=2,a2=45,a4z=5) ! { dg-error "Unknown argument 'a4z'" } + +print *, min0(a1=2,a65a=45,a2=5) ! { dg-error "Unknown argument 'a65a'" } +print *, amin0(a1=2,as65=45,a2=5) ! { dg-error "Unknown argument 'as65'" } +print *, min1(a1=2,a2=45,5) ! { dg-error "Missing keyword name in actual argument list" } +print *, amin1(a1=2,a3=45,a4=5) ! { dg-error "Missing 'a2' argument" } +print *, dmin1(a1=2,a2=45,a4z=5) ! { dg-error "Unknown argument 'a4z'" } +end Index: Fortran/gfortran/regression/min_max_kind.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_kind.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-O2 -std=gnu" } +! Verify that the GNU extensions to MIN/MAX handle mixed kinds properly. + +program p + implicit none + integer(1), parameter :: i1 = 1 + integer(2), parameter :: i2 = 2 + real(4), parameter :: r4 = 4 + real(8), parameter :: r8 = 8 + if (kind (min (i1, i2)) /= kind (i2)) stop 1 + if (kind (min (i2, i1)) /= kind (i2)) stop 2 + if (kind (min (r4, r8)) /= kind (r8)) stop 3 + if (kind (min (r8, r4)) /= kind (r8)) stop 4 +end program p Index: Fortran/gfortran/regression/min_max_optional_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_optional_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +IF (T1(1.0,1.0) .NE. (1.0,1.0) ) STOP 1 +IF (T1(1.0) .NE. (1.0,0.0)) STOP 2 +IF (M1(1,2,3) .NE. 3) STOP 3 +IF (M1(1,2,A4=4) .NE. 4) STOP 4 +CONTAINS + +COMPLEX FUNCTION T1(X,Y) + REAL :: X + REAL, OPTIONAL :: Y + T1=CMPLX(X,Y) +END FUNCTION T1 + +INTEGER FUNCTION M1(A1,A2,A3,A4) + INTEGER :: A1,A2 + INTEGER, OPTIONAL :: A3,A4 + M1=MAX(A1,A2,A3,A4) +END FUNCTION M1 + +END Index: Fortran/gfortran/regression/min_max_optional_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_optional_5.f90 @@ -0,0 +1,21 @@ +! More tests for MIN/MAX with optional arguments +! PR33095 +! +! { dg-do run } + if (m1(3,4) /= 4) STOP 1 + if (m1(3) /= 3) STOP 2 + if (m1() /= 2) STOP 3 + + if (m1(3,4) /= 4) STOP 4 + if (m1(3) /= 3) STOP 5 +contains + integer function m1(a1,a2) + integer, optional, intent(in) :: a1, a2 + m1 = max(1, 2, a1, a2) + end function m1 + + integer function m2(a1,a2) + integer, optional, intent(in) :: a1, a2 + m2 = max(1, a1, 2, a2) + end function m2 +end Index: Fortran/gfortran/regression/min_max_type.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_type.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! Make sure this is evaluated correctly even though max +! has been declared integer. +! Original test case by Gerhard Steinmetz. +program main + integer :: max + character(len=1), parameter :: c = max('a','b') + character(len=1), parameter :: d = min('a','b') + if (c /= 'b' .or. d /= 'a') stop 1 +end program main Index: Fortran/gfortran/regression/min_max_type_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/min_max_type_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR 88658 - make sure the types for min1, max1, amax0 and amin0 are +! correct when simplified + +program main + real :: RVCOMP + character (len=12) :: line + integer :: n + + RVCOMP = MAX1(2.3, 3.1, 4.4) / 5 + if (rvcomp /= 0.) stop 1 + rvcomp = min1(2.3, 3.1, 5.1) / 5 + if (rvcomp /= 0.) stop 2 + write (unit=line, fmt='(F12.5)') amax0(42, 21, 7) + if (line /= ' 42.00000') stop 3 + write (unit=line, fmt='(F12.5)') amin0(42,21,7) + if (line /= ' 7.00000') stop 4 +end program main Index: Fortran/gfortran/regression/minloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minloc_1.f90 @@ -0,0 +1,155 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3), nan, minf, pinf + integer :: ia(1) + real, allocatable :: c(:) + logical :: l + logical :: l2(3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + + allocate (c(3)) + a(:) = nan + ia = minloc (a) + if (ia(1).ne.1) STOP 1 + a(:) = pinf + ia = minloc (a) + if (ia(1).ne.1) STOP 2 + a(1:2) = nan + ia = minloc (a) + if (ia(1).ne.3) STOP 3 + a(2) = 1.0 + ia = minloc (a) + if (ia(1).ne.2) STOP 4 + a(2) = minf + ia = minloc (a) + if (ia(1).ne.2) STOP 5 + c(:) = nan + ia = minloc (c) + if (ia(1).ne.1) STOP 6 + c(:) = pinf + ia = minloc (c) + if (ia(1).ne.1) STOP 7 + c(1:2) = nan + ia = minloc (c) + if (ia(1).ne.3) STOP 8 + c(2) = 1.0 + ia = minloc (c) + if (ia(1).ne.2) STOP 9 + c(2) = minf + ia = minloc (c) + if (ia(1).ne.2) STOP 10 + l = .false. + l2(:) = .false. + a(:) = nan + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 11 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 12 + a(:) = pinf + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 13 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 14 + a(1:2) = nan + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 15 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 16 + a(2) = 1.0 + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 17 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 18 + a(2) = minf + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 19 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 20 + c(:) = nan + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 21 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 22 + c(:) = pinf + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 23 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 24 + c(1:2) = nan + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 25 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 26 + c(2) = 1.0 + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 27 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 28 + c(2) = minf + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 29 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 30 + l = .true. + l2(:) = .true. + a(:) = nan + ia = minloc (a, mask = l) + if (ia(1).ne.1) STOP 31 + ia = minloc (a, mask = l2) + if (ia(1).ne.1) STOP 32 + a(:) = pinf + ia = minloc (a, mask = l) + if (ia(1).ne.1) STOP 33 + ia = minloc (a, mask = l2) + if (ia(1).ne.1) STOP 34 + a(1:2) = nan + ia = minloc (a, mask = l) + if (ia(1).ne.3) STOP 35 + ia = minloc (a, mask = l2) + if (ia(1).ne.3) STOP 36 + a(2) = 1.0 + ia = minloc (a, mask = l) + if (ia(1).ne.2) STOP 37 + ia = minloc (a, mask = l2) + if (ia(1).ne.2) STOP 38 + a(2) = minf + ia = minloc (a, mask = l) + if (ia(1).ne.2) STOP 39 + ia = minloc (a, mask = l2) + if (ia(1).ne.2) STOP 40 + c(:) = nan + ia = minloc (c, mask = l) + if (ia(1).ne.1) STOP 41 + ia = minloc (c, mask = l2) + if (ia(1).ne.1) STOP 42 + c(:) = pinf + ia = minloc (c, mask = l) + if (ia(1).ne.1) STOP 43 + ia = minloc (c, mask = l2) + if (ia(1).ne.1) STOP 44 + c(1:2) = nan + ia = minloc (c, mask = l) + if (ia(1).ne.3) STOP 45 + ia = minloc (c, mask = l2) + if (ia(1).ne.3) STOP 46 + c(2) = 1.0 + ia = minloc (c, mask = l) + if (ia(1).ne.2) STOP 47 + ia = minloc (c, mask = l2) + if (ia(1).ne.2) STOP 48 + c(2) = minf + ia = minloc (c, mask = l) + if (ia(1).ne.2) STOP 49 + ia = minloc (c, mask = l2) + if (ia(1).ne.2) STOP 50 + deallocate (c) + allocate (c(-2:-3)) + ia = minloc (c) + if (ia(1).ne.0) STOP 51 +end Index: Fortran/gfortran/regression/minloc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minloc_2.f90 @@ -0,0 +1,122 @@ +! { dg-do run } + integer :: a(3), h, ia(1) + integer, allocatable :: c(:) + logical :: l + logical :: l2(3) + + h = -huge(h) + h = h - 1 + allocate (c(3)) + a(:) = 5 + ia = minloc (a) + if (ia(1).ne.1) STOP 1 + a(2) = h + ia = minloc (a) + if (ia(1).ne.2) STOP 2 + a(:) = huge(h) + ia = minloc (a) + if (ia(1).ne.1) STOP 3 + a(3) = huge(h) - 1 + ia = minloc (a) + if (ia(1).ne.3) STOP 4 + c(:) = 5 + ia = minloc (c) + if (ia(1).ne.1) STOP 5 + c(2) = h + ia = minloc (c) + if (ia(1).ne.2) STOP 6 + c(:) = huge(h) + ia = minloc (c) + if (ia(1).ne.1) STOP 7 + c(3) = huge(h) - 1 + ia = minloc (c) + if (ia(1).ne.3) STOP 8 + l = .false. + l2(:) = .false. + a(:) = 5 + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 9 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 10 + a(2) = h + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 11 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 12 + a(:) = huge(h) + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 13 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 14 + a(3) = huge(h) - 1 + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 15 + ia = minloc (a, mask = l2) + if (ia(1).ne.0) STOP 16 + c(:) = 5 + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 17 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 18 + c(2) = h + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 19 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 20 + c(:) = huge(h) + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 21 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 22 + c(3) = huge(h) - 1 + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 23 + ia = minloc (c, mask = l2) + if (ia(1).ne.0) STOP 24 + l = .true. + l2(:) = .true. + a(:) = 5 + ia = minloc (a, mask = l) + if (ia(1).ne.1) STOP 25 + ia = minloc (a, mask = l2) + if (ia(1).ne.1) STOP 26 + a(2) = h + ia = minloc (a, mask = l) + if (ia(1).ne.2) STOP 27 + ia = minloc (a, mask = l2) + if (ia(1).ne.2) STOP 28 + a(:) = huge(h) + ia = minloc (a, mask = l) + if (ia(1).ne.1) STOP 29 + ia = minloc (a, mask = l2) + if (ia(1).ne.1) STOP 30 + a(3) = huge(h) - 1 + ia = minloc (a, mask = l) + if (ia(1).ne.3) STOP 31 + ia = minloc (a, mask = l2) + if (ia(1).ne.3) STOP 32 + c(:) = 5 + ia = minloc (c, mask = l) + if (ia(1).ne.1) STOP 33 + ia = minloc (c, mask = l2) + if (ia(1).ne.1) STOP 34 + c(2) = h + ia = minloc (c, mask = l) + if (ia(1).ne.2) STOP 35 + ia = minloc (c, mask = l2) + if (ia(1).ne.2) STOP 36 + c(:) = huge(h) + ia = minloc (c, mask = l) + if (ia(1).ne.1) STOP 37 + ia = minloc (c, mask = l2) + if (ia(1).ne.1) STOP 38 + c(3) = huge(h) - 1 + ia = minloc (c, mask = l) + if (ia(1).ne.3) STOP 39 + ia = minloc (c, mask = l2) + if (ia(1).ne.3) STOP 40 + deallocate (c) + allocate (c(-2:-3)) + ia = minloc (c) + if (ia(1).ne.0) STOP 41 +end Index: Fortran/gfortran/regression/minloc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minloc_3.f90 @@ -0,0 +1,95 @@ +! { dg-do run } + real :: a(30), m + real, allocatable :: c(:) + integer :: e(30), n, ia(1) + integer, allocatable :: g(:) + logical :: l(30) + allocate (c (30)) + allocate (g (30)) + a = 7.0 + c = 7.0 + e = 7 + g = 7 + m = huge(m) + n = huge(n) + a(7) = 6.0 + c(7) = 6.0 + e(7) = 6 + g(7) = 6 + ia = minloc (a) + if (ia(1).ne.7) STOP 1 + ia = minloc (a(::2)) + if (ia(1).ne.4) STOP 2 + if (any (minloc (a).ne.(/ 7 /))) STOP 3 + if (any (minloc (a(::2)).ne.(/ 4 /))) STOP 4 + ia = minloc (c) + if (ia(1).ne.7) STOP 5 + ia = minloc (c(::2)) + if (ia(1).ne.4) STOP 6 + if (any (minloc (c).ne.(/ 7 /))) STOP 7 + if (any (minloc (c(::2)).ne.(/ 4 /))) STOP 8 + ia = minloc (e) + if (ia(1).ne.7) STOP 9 + ia = minloc (e(::2)) + if (ia(1).ne.4) STOP 10 + if (any (minloc (e).ne.(/ 7 /))) STOP 11 + if (any (minloc (e(::2)).ne.(/ 4 /))) STOP 12 + ia = minloc (g) + if (ia(1).ne.7) STOP 13 + ia = minloc (g(::2)) + if (ia(1).ne.4) STOP 14 + if (any (minloc (g).ne.(/ 7 /))) STOP 15 + if (any (minloc (g(::2)).ne.(/ 4 /))) STOP 16 + l = .true. + ia = minloc (a, mask = l) + if (ia(1).ne.7) STOP 17 + ia = minloc (a(::2), mask = l(::2)) + if (ia(1).ne.4) STOP 18 + if (any (minloc (a, mask = l).ne.(/ 7 /))) STOP 19 + if (any (minloc (a(::2), mask = l(::2)).ne.(/ 4 /))) STOP 20 + ia = minloc (c, mask = l) + if (ia(1).ne.7) STOP 21 + ia = minloc (c(::2), mask = l(::2)) + if (ia(1).ne.4) STOP 22 + if (any (minloc (c, mask = l).ne.(/ 7 /))) STOP 23 + if (any (minloc (c(::2), mask = l(::2)).ne.(/ 4 /))) STOP 24 + ia = minloc (e, mask = l) + if (ia(1).ne.7) STOP 25 + ia = minloc (e(::2), mask = l(::2)) + if (ia(1).ne.4) STOP 26 + if (any (minloc (e, mask = l).ne.(/ 7 /))) STOP 27 + if (any (minloc (e(::2), mask = l(::2)).ne.(/ 4 /))) STOP 28 + ia = minloc (g, mask = l) + if (ia(1).ne.7) STOP 29 + ia = minloc (g(::2), mask = l(::2)) + if (ia(1).ne.4) STOP 30 + if (any (minloc (g, mask = l).ne.(/ 7 /))) STOP 31 + if (any (minloc (g(::2), mask = l(::2)).ne.(/ 4 /))) STOP 32 + l = .false. + ia = minloc (a, mask = l) + if (ia(1).ne.0) STOP 33 + ia = minloc (a(::2), mask = l(::2)) + if (ia(1).ne.0) STOP 34 + if (any (minloc (a, mask = l).ne.(/ 0 /))) STOP 35 + if (any (minloc (a(::2), mask = l(::2)).ne.(/ 0 /))) STOP 36 + ia = minloc (c, mask = l) + if (ia(1).ne.0) STOP 37 + ia = minloc (c(::2), mask = l(::2)) + if (ia(1).ne.0) STOP 38 + if (any (minloc (c, mask = l).ne.(/ 0 /))) STOP 39 + if (any (minloc (c(::2), mask = l(::2)).ne.(/ 0 /))) STOP 40 + ia = minloc (e, mask = l) + if (ia(1).ne.0) STOP 41 + ia = minloc (e(::2), mask = l(::2)) + if (ia(1).ne.0) STOP 42 + if (any (minloc (e, mask = l).ne.(/ 0 /))) STOP 43 + if (any (minloc (e(::2), mask = l(::2)).ne.(/ 0 /))) STOP 44 + ia = minloc (g, mask = l) + if (ia(1).ne.0) STOP 45 + ia = minloc (g(::2), mask = l(::2)) + if (ia(1).ne.0) STOP 46 + if (any (minloc (g, mask = l).ne.(/ 0 /))) STOP 47 + if (any (minloc (g(::2), mask = l(::2)).ne.(/ 0 /))) STOP 48 + a = 7.0 + c = 7.0 +end Index: Fortran/gfortran/regression/minloc_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minloc_4.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Check that simplification of minloc works +program main + implicit none + integer :: d + real, dimension(2), parameter :: a = [1.0, 0.0] + character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ] + integer, parameter :: b = minloc(a,dim=1) + integer, parameter :: b2 = minloc(a,dim=1,mask=[.false.,.false.]) + integer, parameter :: b3 = minloc(c,dim=1) + integer, parameter :: b4 = minloc(c,dim=1,mask=[c>"bbb"]) + integer, parameter,dimension(2,2) :: i1 = reshape([4,3,2,5],shape(i1)) + integer, parameter, dimension(2) :: b5 = minloc(i1) + integer, parameter, dimension(2) :: b6 = minloc(i1,mask=i1>7) + integer, parameter, dimension(2) :: b7 = minloc(i1, mask=i1>2) + integer, parameter, dimension(2) :: b8 = minloc(i1, mask=.true.) + integer, parameter, dimension(2) :: b9 = minloc(i1, mask=.false.) + integer, parameter, dimension(2,3) :: i2 = & + reshape([2, -1, -3, 4, -5, 6], shape(i2)) + integer, parameter, dimension(3) :: b10 = minloc(i2, dim=1) + integer, parameter, dimension(2) :: b11 = minloc(i2, dim=2) + integer, parameter, dimension(3) :: b12 = minloc(i2,dim=1,mask=i2>3) + integer, parameter, dimension(2) :: b13 = minloc(i2,dim=2, mask=i2<-10) + if (b /= 2) STOP 1 + if (b2 /= 0) STOP 2 + if (b3 /= 2) STOP 3 + if (b4 /= 1) STOP 4 + if (any(b5 /= [1, 2])) STOP 5 + if (any(b6 /= [0, 0])) STOP 6 + if (any(b7 /= [2, 1])) STOP 7 + if (any(b8 /= [1, 2])) STOP 8 + if (any(b9 /= [0, 0])) STOP 9 + d = 1 + if (any(b10 /= minloc(i2,dim=d))) STOP 10 + d = 2 + if (any(b11 /= minloc(i2,dim=2))) STOP 11 + d = 1 + if (any(b12 /= minloc(i2, dim=d,mask=i2>3))) STOP 12 + if (any(b13 /= 0)) STOP 13 +end program main Index: Fortran/gfortran/regression/minloc_string_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minloc_string_1.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! Test minloc for strings for different code paths + +program main + implicit none + integer, parameter :: n=4 + character(len=4), dimension(n,n) :: c + integer, dimension(n,n) :: a + integer, dimension(2) :: res1, res2 + real, dimension(n,n) :: r + logical, dimension(n,n) :: amask + logical(kind=8) :: smask + integer :: i,j + integer, dimension(n) :: q1, q2 + character(len=4,kind=4), dimension(n,n) :: c4 + character(len=4), dimension(n*n) :: e + integer, dimension(n*n) :: f + logical, dimension(n*n) :: cmask + + call random_number (r) + a = int(r*100) + do j=1,n + do i=1,n + write (unit=c(i,j),fmt='(I4.4)') a(i,j) + write (unit=c4(i,j),fmt='(I4.4)') a(i,j) + end do + end do + res1 = minloc(c) + res2 = minloc(a) + + if (any(res1 /= res2)) STOP 1 + res1 = minloc(c4) + if (any(res1 /= res2)) STOP 2 + + amask = a < 50 + res1 = minloc(c,mask=amask) + res2 = minloc(a,mask=amask) + + if (any(res1 /= res2)) STOP 3 + + amask = .false. + res1 = minloc(c,mask=amask) + if (any(res1 /= 0)) STOP 4 + + amask(2,3) = .true. + res1 = minloc(c,mask=amask) + if (any(res1 /= [2,3])) STOP 5 + + res1 = minloc(c,mask=.false.) + if (any(res1 /= 0)) STOP 6 + + res2 = minloc(a) + res1 = minloc(c,mask=.true.) + if (any(res1 /= res2)) STOP 7 + + q1 = minloc(c, dim=1) + q2 = minloc(a, dim=1) + if (any(q1 /= q2)) STOP 8 + + q1 = minloc(c, dim=2) + q2 = minloc(a, dim=2) + if (any(q1 /= q2)) STOP 9 + + q1 = minloc(c, dim=1, mask=amask) + q2 = minloc(a, dim=1, mask=amask) + if (any(q1 /= q2)) STOP 10 + + q1 = minloc(c, dim=2, mask=amask) + q2 = minloc(a, dim=2, mask=amask) + if (any(q1 /= q2)) STOP 11 + + amask = a < 50 + + q1 = minloc(c, dim=1, mask=amask) + q2 = minloc(a, dim=1, mask=amask) + if (any(q1 /= q2)) STOP 12 + + q1 = minloc(c, dim=2, mask=amask) + q2 = minloc(a, dim=2, mask=amask) + if (any(q1 /= q2)) STOP 13 + + e = reshape(c, shape(e)) + f = reshape(a, shape(f)) + if (minloc(e,dim=1) /= minloc(f,dim=1)) STOP 14 + + cmask = .false. + if (minloc(e,dim=1,mask=cmask) /= 0) STOP 15 + + cmask = f > 50 + if ( minloc(e, dim=1, mask=cmask) /= minloc (f, dim=1, mask=cmask)) STOP 16 +end program main Index: Fortran/gfortran/regression/minlocval_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minlocval_1.f90 @@ -0,0 +1,154 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3), nan, minf, pinf + real, allocatable :: c(:) + logical :: l + logical :: l2(3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + + allocate (c(3)) + a(:) = nan + if (minloc (a, dim = 1).ne.1) STOP 1 + if (.not.isnan(minval (a, dim = 1))) STOP 2 + a(:) = pinf + if (minloc (a, dim = 1).ne.1) STOP 3 + if (minval (a, dim = 1).ne.pinf) STOP 4 + a(1:2) = nan + if (minloc (a, dim = 1).ne.3) STOP 5 + if (minval (a, dim = 1).ne.pinf) STOP 6 + a(2) = 1.0 + if (minloc (a, dim = 1).ne.2) STOP 7 + if (minval (a, dim = 1).ne.1) STOP 8 + a(2) = minf + if (minloc (a, dim = 1).ne.2) STOP 9 + if (minval (a, dim = 1).ne.minf) STOP 10 + c(:) = nan + if (minloc (c, dim = 1).ne.1) STOP 11 + if (.not.isnan(minval (c, dim = 1))) STOP 12 + c(:) = pinf + if (minloc (c, dim = 1).ne.1) STOP 13 + if (minval (c, dim = 1).ne.pinf) STOP 14 + c(1:2) = nan + if (minloc (c, dim = 1).ne.3) STOP 15 + if (minval (c, dim = 1).ne.pinf) STOP 16 + c(2) = 1.0 + if (minloc (c, dim = 1).ne.2) STOP 17 + if (minval (c, dim = 1).ne.1) STOP 18 + c(2) = minf + if (minloc (c, dim = 1).ne.2) STOP 19 + if (minval (c, dim = 1).ne.minf) STOP 20 + l = .false. + l2(:) = .false. + a(:) = nan + if (minloc (a, dim = 1, mask = l).ne.0) STOP 21 + if (minval (a, dim = 1, mask = l).ne.huge(pinf)) STOP 22 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 23 + if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) STOP 24 + a(:) = pinf + if (minloc (a, dim = 1, mask = l).ne.0) STOP 25 + if (minval (a, dim = 1, mask = l).ne.huge(pinf)) STOP 26 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 27 + if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) STOP 28 + a(1:2) = nan + if (minloc (a, dim = 1, mask = l).ne.0) STOP 29 + if (minval (a, dim = 1, mask = l).ne.huge(pinf)) STOP 30 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 31 + if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) STOP 32 + a(2) = 1.0 + if (minloc (a, dim = 1, mask = l).ne.0) STOP 33 + if (minval (a, dim = 1, mask = l).ne.huge(pinf)) STOP 34 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 35 + if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) STOP 36 + a(2) = minf + if (minloc (a, dim = 1, mask = l).ne.0) STOP 37 + if (minval (a, dim = 1, mask = l).ne.huge(pinf)) STOP 38 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 39 + if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) STOP 40 + c(:) = nan + if (minloc (c, dim = 1, mask = l).ne.0) STOP 41 + if (minval (c, dim = 1, mask = l).ne.huge(pinf)) STOP 42 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 43 + if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) STOP 44 + c(:) = pinf + if (minloc (c, dim = 1, mask = l).ne.0) STOP 45 + if (minval (c, dim = 1, mask = l).ne.huge(pinf)) STOP 46 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 47 + if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) STOP 48 + c(1:2) = nan + if (minloc (c, dim = 1, mask = l).ne.0) STOP 49 + if (minval (c, dim = 1, mask = l).ne.huge(pinf)) STOP 50 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 51 + if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) STOP 52 + c(2) = 1.0 + if (minloc (c, dim = 1, mask = l).ne.0) STOP 53 + if (minval (c, dim = 1, mask = l).ne.huge(pinf)) STOP 54 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 55 + if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) STOP 56 + c(2) = minf + if (minloc (c, dim = 1, mask = l).ne.0) STOP 57 + if (minval (c, dim = 1, mask = l).ne.huge(pinf)) STOP 58 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 59 + if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) STOP 60 + l = .true. + l2(:) = .true. + a(:) = nan + if (minloc (a, dim = 1, mask = l).ne.1) STOP 61 + if (.not.isnan(minval (a, dim = 1, mask = l))) STOP 62 + if (minloc (a, dim = 1, mask = l2).ne.1) STOP 63 + if (.not.isnan(minval (a, dim = 1, mask = l2))) STOP 64 + a(:) = pinf + if (minloc (a, dim = 1, mask = l).ne.1) STOP 65 + if (minval (a, dim = 1, mask = l).ne.pinf) STOP 66 + if (minloc (a, dim = 1, mask = l2).ne.1) STOP 67 + if (minval (a, dim = 1, mask = l2).ne.pinf) STOP 68 + a(1:2) = nan + if (minloc (a, dim = 1, mask = l).ne.3) STOP 69 + if (minval (a, dim = 1, mask = l).ne.pinf) STOP 70 + if (minloc (a, dim = 1, mask = l2).ne.3) STOP 71 + if (minval (a, dim = 1, mask = l2).ne.pinf) STOP 72 + a(2) = 1.0 + if (minloc (a, dim = 1, mask = l).ne.2) STOP 73 + if (minval (a, dim = 1, mask = l).ne.1) STOP 74 + if (minloc (a, dim = 1, mask = l2).ne.2) STOP 75 + if (minval (a, dim = 1, mask = l2).ne.1) STOP 76 + a(2) = minf + if (minloc (a, dim = 1, mask = l).ne.2) STOP 77 + if (minval (a, dim = 1, mask = l).ne.minf) STOP 78 + if (minloc (a, dim = 1, mask = l2).ne.2) STOP 79 + if (minval (a, dim = 1, mask = l2).ne.minf) STOP 80 + c(:) = nan + if (minloc (c, dim = 1, mask = l).ne.1) STOP 81 + if (.not.isnan(minval (c, dim = 1, mask = l))) STOP 82 + if (minloc (c, dim = 1, mask = l2).ne.1) STOP 83 + if (.not.isnan(minval (c, dim = 1, mask = l2))) STOP 84 + c(:) = pinf + if (minloc (c, dim = 1, mask = l).ne.1) STOP 85 + if (minval (c, dim = 1, mask = l).ne.pinf) STOP 86 + if (minloc (c, dim = 1, mask = l2).ne.1) STOP 87 + if (minval (c, dim = 1, mask = l2).ne.pinf) STOP 88 + c(1:2) = nan + if (minloc (c, dim = 1, mask = l).ne.3) STOP 89 + if (minval (c, dim = 1, mask = l).ne.pinf) STOP 90 + if (minloc (c, dim = 1, mask = l2).ne.3) STOP 91 + if (minval (c, dim = 1, mask = l2).ne.pinf) STOP 92 + c(2) = 1.0 + if (minloc (c, dim = 1, mask = l).ne.2) STOP 93 + if (minval (c, dim = 1, mask = l).ne.1) STOP 94 + if (minloc (c, dim = 1, mask = l2).ne.2) STOP 95 + if (minval (c, dim = 1, mask = l2).ne.1) STOP 96 + c(2) = minf + if (minloc (c, dim = 1, mask = l).ne.2) STOP 97 + if (minval (c, dim = 1, mask = l).ne.minf) STOP 98 + if (minloc (c, dim = 1, mask = l2).ne.2) STOP 99 + if (minval (c, dim = 1, mask = l2).ne.minf) STOP 100 + deallocate (c) + allocate (c(-2:-3)) + if (minloc (c, dim = 1).ne.0) STOP 101 + if (minval (c, dim = 1).ne.huge(pinf)) STOP 102 +end Index: Fortran/gfortran/regression/minlocval_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minlocval_2.f90 @@ -0,0 +1,122 @@ +! { dg-do run } + integer :: a(3), h + integer, allocatable :: c(:) + logical :: l + logical :: l2(3) + + h = -huge(h) + h = h - 1 + allocate (c(3)) + a(:) = 5 + if (minloc (a, dim = 1).ne.1) STOP 1 + if (minval (a, dim = 1).ne.5) STOP 2 + a(2) = h + if (minloc (a, dim = 1).ne.2) STOP 3 + if (minval (a, dim = 1).ne.h) STOP 4 + a(:) = huge(h) + if (minloc (a, dim = 1).ne.1) STOP 5 + if (minval (a, dim = 1).ne.huge(h)) STOP 6 + a(3) = huge(h) - 1 + if (minloc (a, dim = 1).ne.3) STOP 7 + if (minval (a, dim = 1).ne.huge(h)-1) STOP 8 + c(:) = 5 + if (minloc (c, dim = 1).ne.1) STOP 9 + if (minval (c, dim = 1).ne.5) STOP 10 + c(2) = h + if (minloc (c, dim = 1).ne.2) STOP 11 + if (minval (c, dim = 1).ne.h) STOP 12 + c(:) = huge(h) + if (minloc (c, dim = 1).ne.1) STOP 13 + if (minval (c, dim = 1).ne.huge(h)) STOP 14 + c(3) = huge(h) - 1 + if (minloc (c, dim = 1).ne.3) STOP 15 + if (minval (c, dim = 1).ne.huge(h)-1) STOP 16 + l = .false. + l2(:) = .false. + a(:) = 5 + if (minloc (a, dim = 1, mask = l).ne.0) STOP 17 + if (minval (a, dim = 1, mask = l).ne.huge(h)) STOP 18 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 19 + if (minval (a, dim = 1, mask = l2).ne.huge(h)) STOP 20 + a(2) = h + if (minloc (a, dim = 1, mask = l).ne.0) STOP 21 + if (minval (a, dim = 1, mask = l).ne.huge(h)) STOP 22 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 23 + if (minval (a, dim = 1, mask = l2).ne.huge(h)) STOP 24 + a(:) = huge(h) + if (minloc (a, dim = 1, mask = l).ne.0) STOP 25 + if (minval (a, dim = 1, mask = l).ne.huge(h)) STOP 26 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 27 + if (minval (a, dim = 1, mask = l2).ne.huge(h)) STOP 28 + a(3) = huge(h) - 1 + if (minloc (a, dim = 1, mask = l).ne.0) STOP 29 + if (minval (a, dim = 1, mask = l).ne.huge(h)) STOP 30 + if (minloc (a, dim = 1, mask = l2).ne.0) STOP 31 + if (minval (a, dim = 1, mask = l2).ne.huge(h)) STOP 32 + c(:) = 5 + if (minloc (c, dim = 1, mask = l).ne.0) STOP 33 + if (minval (c, dim = 1, mask = l).ne.huge(h)) STOP 34 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 35 + if (minval (c, dim = 1, mask = l2).ne.huge(h)) STOP 36 + c(2) = h + if (minloc (c, dim = 1, mask = l).ne.0) STOP 37 + if (minval (c, dim = 1, mask = l).ne.huge(h)) STOP 38 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 39 + if (minval (c, dim = 1, mask = l2).ne.huge(h)) STOP 40 + c(:) = huge(h) + if (minloc (c, dim = 1, mask = l).ne.0) STOP 41 + if (minval (c, dim = 1, mask = l).ne.huge(h)) STOP 42 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 43 + if (minval (c, dim = 1, mask = l2).ne.huge(h)) STOP 44 + c(3) = huge(h) - 1 + if (minloc (c, dim = 1, mask = l).ne.0) STOP 45 + if (minval (c, dim = 1, mask = l).ne.huge(h)) STOP 46 + if (minloc (c, dim = 1, mask = l2).ne.0) STOP 47 + if (minval (c, dim = 1, mask = l2).ne.huge(h)) STOP 48 + l = .true. + l2(:) = .true. + a(:) = 5 + if (minloc (a, dim = 1, mask = l).ne.1) STOP 49 + if (minval (a, dim = 1, mask = l).ne.5) STOP 50 + if (minloc (a, dim = 1, mask = l2).ne.1) STOP 51 + if (minval (a, dim = 1, mask = l2).ne.5) STOP 52 + a(2) = h + if (minloc (a, dim = 1, mask = l).ne.2) STOP 53 + if (minval (a, dim = 1, mask = l).ne.h) STOP 54 + if (minloc (a, dim = 1, mask = l2).ne.2) STOP 55 + if (minval (a, dim = 1, mask = l2).ne.h) STOP 56 + a(:) = huge(h) + if (minloc (a, dim = 1, mask = l).ne.1) STOP 57 + if (minval (a, dim = 1, mask = l).ne.huge(h)) STOP 58 + if (minloc (a, dim = 1, mask = l2).ne.1) STOP 59 + if (minval (a, dim = 1, mask = l2).ne.huge(h)) STOP 60 + a(3) = huge(h) - 1 + if (minloc (a, dim = 1, mask = l).ne.3) STOP 61 + if (minval (a, dim = 1, mask = l).ne.huge(h)-1) STOP 62 + if (minloc (a, dim = 1, mask = l2).ne.3) STOP 63 + if (minval (a, dim = 1, mask = l2).ne.huge(h)-1) STOP 64 + c(:) = 5 + if (minloc (c, dim = 1, mask = l).ne.1) STOP 65 + if (minval (c, dim = 1, mask = l).ne.5) STOP 66 + if (minloc (c, dim = 1, mask = l2).ne.1) STOP 67 + if (minval (c, dim = 1, mask = l2).ne.5) STOP 68 + c(2) = h + if (minloc (c, dim = 1, mask = l).ne.2) STOP 69 + if (minval (c, dim = 1, mask = l).ne.h) STOP 70 + if (minloc (c, dim = 1, mask = l2).ne.2) STOP 71 + if (minval (c, dim = 1, mask = l2).ne.h) STOP 72 + c(:) = huge(h) + if (minloc (c, dim = 1, mask = l).ne.1) STOP 73 + if (minval (c, dim = 1, mask = l).ne.huge(h)) STOP 74 + if (minloc (c, dim = 1, mask = l2).ne.1) STOP 75 + if (minval (c, dim = 1, mask = l2).ne.huge(h)) STOP 76 + c(3) = huge(h) - 1 + if (minloc (c, dim = 1, mask = l).ne.3) STOP 77 + if (minval (c, dim = 1, mask = l).ne.huge(h)-1) STOP 78 + if (minloc (c, dim = 1, mask = l2).ne.3) STOP 79 + if (minval (c, dim = 1, mask = l2).ne.huge(h)-1) STOP 80 + deallocate (c) + allocate (c(-2:-3)) + if (minloc (c, dim = 1).ne.0) STOP 81 + if (minval (c, dim = 1).ne.huge(h)) STOP 82 +end Index: Fortran/gfortran/regression/minlocval_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minlocval_3.f90 @@ -0,0 +1,285 @@ +! { dg-do run } + real :: a(30), b(10, 10), m + real, allocatable :: c(:), d(:, :) + integer :: e(30), f(10, 10), n + integer, allocatable :: g(:), h(:,:) + logical :: l(30), l2(10, 10) + allocate (c (30)) + allocate (d (10, 10)) + allocate (g (30)) + allocate (h (10, 10)) + a = 7.0 + b = 7.0 + c = 7.0 + d = 7.0 + e = 7 + f = 7 + g = 7 + h = 7 + m = huge(m) + n = huge(n) + a(7) = 6.0 + b(5, 5) = 6.0 + b(5, 6) = 5.0 + b(6, 7) = 4.0 + c(7) = 6.0 + d(5, 5) = 6.0 + d(5, 6) = 5.0 + d(6, 7) = 4.0 + e(7) = 6 + f(5, 5) = 6 + f(5, 6) = 5 + f(6, 7) = 4 + g(7) = 6 + h(5, 5) = 6 + h(5, 6) = 5 + h(6, 7) = 4 + if (minloc (a, dim = 1).ne.7) STOP 1 + if (minval (a, dim = 1).ne.6.0) STOP 2 + if (minloc (a(::2), dim = 1).ne.4) STOP 3 + if (minval (a(::2), dim = 1).ne.6.0) STOP 4 + if (any (minloc (a).ne.(/ 7 /))) STOP 5 + if (minval (a).ne.6.0) STOP 6 + if (any (minloc (a(::2)).ne.(/ 4 /))) STOP 7 + if (minval (a(::2)).ne.6.0) STOP 8 + if (any (minloc (b, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 9 + if (any (minval (b, dim = 1).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) STOP 10 + if (any (minloc (b(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) STOP 11 + if (any (minval (b(::2,::2), dim = 1).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 12 + if (any (minloc (b, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 13 + if (any (minval (b, dim = 2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) STOP 14 + if (any (minloc (b(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) STOP 15 + if (any (minval (b(::2,::2), dim = 2).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 16 + if (any (minloc (b).ne.(/ 6, 7 /))) STOP 17 + if (minval (b).ne.4.0) STOP 18 + if (any (minloc (b(::2,::2)).ne.(/ 3, 3 /))) STOP 19 + if (minval (b(::2,::2)).ne.6.0) STOP 20 + if (minloc (c, dim = 1).ne.7) STOP 21 + if (minval (c, dim = 1).ne.6.0) STOP 22 + if (minloc (c(::2), dim = 1).ne.4) STOP 23 + if (minval (c(::2), dim = 1).ne.6.0) STOP 24 + if (any (minloc (c).ne.(/ 7 /))) STOP 25 + if (minval (c).ne.6.0) STOP 26 + if (any (minloc (c(::2)).ne.(/ 4 /))) STOP 27 + if (minval (c(::2)).ne.6.0) STOP 28 + if (any (minloc (d, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 29 + if (any (minval (d, dim = 1).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) STOP 30 + if (any (minloc (d(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) STOP 31 + if (any (minval (d(::2,::2), dim = 1).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 32 + if (any (minloc (d, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 33 + if (any (minval (d, dim = 2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) STOP 34 + if (any (minloc (d(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) STOP 35 + if (any (minval (d(::2,::2), dim = 2).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 36 + if (any (minloc (d).ne.(/ 6, 7 /))) STOP 37 + if (minval (d).ne.4.0) STOP 38 + if (any (minloc (d(::2,::2)).ne.(/ 3, 3 /))) STOP 39 + if (minval (d(::2,::2)).ne.6.0) STOP 40 + if (minloc (e, dim = 1).ne.7) STOP 41 + if (minval (e, dim = 1).ne.6) STOP 42 + if (minloc (e(::2), dim = 1).ne.4) STOP 43 + if (minval (e(::2), dim = 1).ne.6) STOP 44 + if (any (minloc (e).ne.(/ 7 /))) STOP 45 + if (minval (e).ne.6) STOP 46 + if (any (minloc (e(::2)).ne.(/ 4 /))) STOP 47 + if (minval (e(::2)).ne.6) STOP 48 + if (any (minloc (f, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 49 + if (any (minval (f, dim = 1).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) STOP 50 + if (any (minloc (f(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) STOP 51 + if (any (minval (f(::2,::2), dim = 1).ne.(/ 7, 7, 6, 7, 7 /))) STOP 52 + if (any (minloc (f, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 53 + if (any (minval (f, dim = 2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) STOP 54 + if (any (minloc (f(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) STOP 55 + if (any (minval (f(::2,::2), dim = 2).ne.(/ 7, 7, 6, 7, 7 /))) STOP 56 + if (any (minloc (f).ne.(/ 6, 7 /))) STOP 57 + if (minval (f).ne.4) STOP 58 + if (any (minloc (f(::2,::2)).ne.(/ 3, 3 /))) STOP 59 + if (minval (f(::2,::2)).ne.6) STOP 60 + if (minloc (g, dim = 1).ne.7) STOP 61 + if (minval (g, dim = 1).ne.6) STOP 62 + if (minloc (g(::2), dim = 1).ne.4) STOP 63 + if (minval (g(::2), dim = 1).ne.6) STOP 64 + if (any (minloc (g).ne.(/ 7 /))) STOP 65 + if (minval (g).ne.6) STOP 66 + if (any (minloc (g(::2)).ne.(/ 4 /))) STOP 67 + if (minval (g(::2)).ne.6) STOP 68 + if (any (minloc (h, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 69 + if (any (minval (h, dim = 1).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) STOP 70 + if (any (minloc (h(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) STOP 71 + if (any (minval (h(::2,::2), dim = 1).ne.(/ 7, 7, 6, 7, 7 /))) STOP 72 + if (any (minloc (h, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 73 + if (any (minval (h, dim = 2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) STOP 74 + if (any (minloc (h(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) STOP 75 + if (any (minval (h(::2,::2), dim = 2).ne.(/ 7, 7, 6, 7, 7 /))) STOP 76 + if (any (minloc (h).ne.(/ 6, 7 /))) STOP 77 + if (minval (h).ne.4) STOP 78 + if (any (minloc (h(::2,::2)).ne.(/ 3, 3 /))) STOP 79 + if (minval (h(::2,::2)).ne.6) STOP 80 + l = .true. + l2 = .true. + if (minloc (a, dim = 1, mask = l).ne.7) STOP 81 + if (minval (a, dim = 1, mask = l).ne.6.0) STOP 82 + if (minloc (a(::2), dim = 1, mask = l(::2)).ne.4) STOP 83 + if (minval (a(::2), dim = 1, mask = l(::2)).ne.6.0) STOP 84 + if (any (minloc (a, mask = l).ne.(/ 7 /))) STOP 85 + if (minval (a, mask = l).ne.6.0) STOP 86 + if (any (minloc (a(::2), mask = l(::2)).ne.(/ 4 /))) STOP 87 + if (minval (a(::2), mask = l(::2)).ne.6.0) STOP 88 + if (any (minloc (b, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 89 + if (any (minval (b, dim = 1, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) STOP 90 + if (any (minloc (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 91 + if (any (minval (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 92 + if (any (minloc (b, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 93 + if (any (minval (b, dim = 2, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) STOP 94 + if (any (minloc (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 95 + if (any (minval (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 96 + if (any (minloc (b, mask = l2).ne.(/ 6, 7 /))) STOP 97 + if (minval (b, mask = l2).ne.4.0) STOP 98 + if (any (minloc (b(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) STOP 99 + if (minval (b(::2,::2), mask = l2(::2,::2)).ne.6.0) STOP 100 + if (minloc (c, dim = 1, mask = l).ne.7) STOP 101 + if (minval (c, dim = 1, mask = l).ne.6.0) STOP 102 + if (minloc (c(::2), dim = 1, mask = l(::2)).ne.4) STOP 103 + if (minval (c(::2), dim = 1, mask = l(::2)).ne.6.0) STOP 104 + if (any (minloc (c, mask = l).ne.(/ 7 /))) STOP 105 + if (minval (c, mask = l).ne.6.0) STOP 106 + if (any (minloc (c(::2), mask = l(::2)).ne.(/ 4 /))) STOP 107 + if (minval (c(::2), mask = l(::2)).ne.6.0) STOP 108 + if (any (minloc (d, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 109 + if (any (minval (d, dim = 1, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) STOP 110 + if (any (minloc (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 111 + if (any (minval (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 112 + if (any (minloc (d, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 113 + if (any (minval (d, dim = 2, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) STOP 114 + if (any (minloc (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 115 + if (any (minval (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) STOP 116 + if (any (minloc (d, mask = l2).ne.(/ 6, 7 /))) STOP 117 + if (minval (d, mask = l2).ne.4.0) STOP 118 + if (any (minloc (d(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) STOP 119 + if (minval (d(::2,::2), mask = l2(::2,::2)).ne.6.0) STOP 120 + if (minloc (e, dim = 1, mask = l).ne.7) STOP 121 + if (minval (e, dim = 1, mask = l).ne.6) STOP 122 + if (minloc (e(::2), dim = 1, mask = l(::2)).ne.4) STOP 123 + if (minval (e(::2), dim = 1, mask = l(::2)).ne.6) STOP 124 + if (any (minloc (e, mask = l).ne.(/ 7 /))) STOP 125 + if (minval (e, mask = l).ne.6) STOP 126 + if (any (minloc (e(::2), mask = l(::2)).ne.(/ 4 /))) STOP 127 + if (minval (e(::2), mask = l(::2)).ne.6) STOP 128 + if (any (minloc (f, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 129 + if (any (minval (f, dim = 1, mask = l2).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) STOP 130 + if (any (minloc (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 131 + if (any (minval (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) STOP 132 + if (any (minloc (f, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 133 + if (any (minval (f, dim = 2, mask = l2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) STOP 134 + if (any (minloc (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 135 + if (any (minval (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) STOP 136 + if (any (minloc (f, mask = l2).ne.(/ 6, 7 /))) STOP 137 + if (minval (f, mask = l2).ne.4) STOP 138 + if (any (minloc (f(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) STOP 139 + if (minval (f(::2,::2), mask = l2(::2,::2)).ne.6) STOP 140 + if (minloc (g, dim = 1, mask = l).ne.7) STOP 141 + if (minval (g, dim = 1, mask = l).ne.6) STOP 142 + if (minloc (g(::2), dim = 1, mask = l(::2)).ne.4) STOP 143 + if (minval (g(::2), dim = 1, mask = l(::2)).ne.6) STOP 144 + if (any (minloc (g, mask = l).ne.(/ 7 /))) STOP 145 + if (minval (g, mask = l).ne.6) STOP 146 + if (any (minloc (g(::2), mask = l(::2)).ne.(/ 4 /))) STOP 147 + if (minval (g(::2), mask = l(::2)).ne.6) STOP 148 + if (any (minloc (h, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) STOP 149 + if (any (minval (h, dim = 1, mask = l2).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) STOP 150 + if (any (minloc (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 151 + if (any (minval (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) STOP 152 + if (any (minloc (h, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) STOP 153 + if (any (minval (h, dim = 2, mask = l2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) STOP 154 + if (any (minloc (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) STOP 155 + if (any (minval (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) STOP 156 + if (any (minloc (h, mask = l2).ne.(/ 6, 7 /))) STOP 157 + if (minval (h, mask = l2).ne.4) STOP 158 + if (any (minloc (h(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) STOP 159 + if (minval (h(::2,::2), mask = l2(::2,::2)).ne.6) STOP 160 + l = .false. + l2 = .false. + if (minloc (a, dim = 1, mask = l).ne.0) STOP 161 + if (minval (a, dim = 1, mask = l).ne.m) STOP 162 + if (minloc (a(::2), dim = 1, mask = l(::2)).ne.0) STOP 163 + if (minval (a(::2), dim = 1, mask = l(::2)).ne.m) STOP 164 + if (any (minloc (a, mask = l).ne.(/ 0 /))) STOP 165 + if (minval (a, mask = l).ne.m) STOP 166 + if (any (minloc (a(::2), mask = l(::2)).ne.(/ 0 /))) STOP 167 + if (minval (a(::2), mask = l(::2)).ne.m) STOP 168 + if (any (minloc (b, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 169 + if (any (minval (b, dim = 1, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) STOP 170 + if (any (minloc (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 171 + if (any (minval (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) STOP 172 + if (any (minloc (b, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 173 + if (any (minval (b, dim = 2, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) STOP 174 + if (any (minloc (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 175 + if (any (minval (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) STOP 176 + if (any (minloc (b, mask = l2).ne.(/ 0, 0 /))) STOP 177 + if (minval (b, mask = l2).ne.m) STOP 178 + if (any (minloc (b(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) STOP 179 + if (minval (b(::2,::2), mask = l2(::2,::2)).ne.m) STOP 180 + if (minloc (c, dim = 1, mask = l).ne.0) STOP 181 + if (minval (c, dim = 1, mask = l).ne.m) STOP 182 + if (minloc (c(::2), dim = 1, mask = l(::2)).ne.0) STOP 183 + if (minval (c(::2), dim = 1, mask = l(::2)).ne.m) STOP 184 + if (any (minloc (c, mask = l).ne.(/ 0 /))) STOP 185 + if (minval (c, mask = l).ne.m) STOP 186 + if (any (minloc (c(::2), mask = l(::2)).ne.(/ 0 /))) STOP 187 + if (minval (c(::2), mask = l(::2)).ne.m) STOP 188 + if (any (minloc (d, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 189 + if (any (minval (d, dim = 1, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) STOP 190 + if (any (minloc (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 191 + if (any (minval (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) STOP 192 + if (any (minloc (d, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 193 + if (any (minval (d, dim = 2, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) STOP 194 + if (any (minloc (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 195 + if (any (minval (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) STOP 196 + if (any (minloc (d, mask = l2).ne.(/ 0, 0 /))) STOP 197 + if (minval (d, mask = l2).ne.m) STOP 198 + if (any (minloc (d(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) STOP 199 + if (minval (d(::2,::2), mask = l2(::2,::2)).ne.m) STOP 200 + if (minloc (e, dim = 1, mask = l).ne.0) STOP 201 + if (minval (e, dim = 1, mask = l).ne.n) STOP 202 + if (minloc (e(::2), dim = 1, mask = l(::2)).ne.0) STOP 203 + if (minval (e(::2), dim = 1, mask = l(::2)).ne.n) STOP 204 + if (any (minloc (e, mask = l).ne.(/ 0 /))) STOP 205 + if (minval (e, mask = l).ne.n) STOP 206 + if (any (minloc (e(::2), mask = l(::2)).ne.(/ 0 /))) STOP 207 + if (minval (e(::2), mask = l(::2)).ne.n) STOP 208 + if (any (minloc (f, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 209 + if (any (minval (f, dim = 1, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) STOP 210 + if (any (minloc (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 211 + if (any (minval (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) STOP 212 + if (any (minloc (f, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 213 + if (any (minval (f, dim = 2, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) STOP 214 + if (any (minloc (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 215 + if (any (minval (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) STOP 216 + if (any (minloc (f, mask = l2).ne.(/ 0, 0 /))) STOP 217 + if (minval (f, mask = l2).ne.n) STOP 218 + if (any (minloc (f(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) STOP 219 + if (minval (f(::2,::2), mask = l2(::2,::2)).ne.n) STOP 220 + if (minloc (g, dim = 1, mask = l).ne.0) STOP 221 + if (minval (g, dim = 1, mask = l).ne.n) STOP 222 + if (minloc (g(::2), dim = 1, mask = l(::2)).ne.0) STOP 223 + if (minval (g(::2), dim = 1, mask = l(::2)).ne.n) STOP 224 + if (any (minloc (g, mask = l).ne.(/ 0 /))) STOP 225 + if (minval (g, mask = l).ne.n) STOP 226 + if (any (minloc (g(::2), mask = l(::2)).ne.(/ 0 /))) STOP 227 + if (minval (g(::2), mask = l(::2)).ne.n) STOP 228 + if (any (minloc (h, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 229 + if (any (minval (h, dim = 1, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) STOP 230 + if (any (minloc (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 231 + if (any (minval (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) STOP 232 + if (any (minloc (h, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) STOP 233 + if (any (minval (h, dim = 2, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) STOP 234 + if (any (minloc (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) STOP 235 + if (any (minval (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) STOP 236 + if (any (minloc (h, mask = l2).ne.(/ 0, 0 /))) STOP 237 + if (minval (h, mask = l2).ne.n) STOP 238 + if (any (minloc (h(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) STOP 239 + if (minval (h(::2,::2), mask = l2(::2,::2)).ne.n) STOP 240 + a = 7.0 + b = 7.0 + c = 7.0 + d = 7.0 +end Index: Fortran/gfortran/regression/minlocval_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minlocval_4.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-add-options ieee } + real :: a(3,3), b(3), nan, minf, pinf, h + logical :: l, l2 + logical :: l3(3,3), l4(3,3), l5(3,3) + + nan = 0.0 + minf = 0.0 + pinf = 0.0 + nan = 0.0/nan + minf = -1.0/minf + pinf = 1.0/pinf + h = huge(h) + l = .false. + l2 = .true. + l3 = .false. + l4 = .true. + l5 = .true. + l5(1,1) = .false. + l5(1,2) = .false. + l5(2,3) = .false. + a = reshape ((/ nan, nan, nan, pinf, pinf, pinf, pinf, minf, pinf /), (/ 3, 3 /)) + if (minval (a).ne.minf) STOP 1 + if (any (minloc (a).ne.(/ 2, 3 /))) STOP 2 + b = minval (a, dim = 1) + if (.not.isnan(b(1))) STOP 3 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, pinf, minf /))) STOP 4 + if (any (minloc (a, dim = 1).ne.(/ 1, 1, 2 /))) STOP 5 + b = minval (a, dim = 2) + if (any (b.ne.(/ pinf, minf, pinf /))) STOP 6 + if (any (minloc (a, dim = 2).ne.(/ 2, 3, 2 /))) STOP 7 + if (minval (a, mask = l).ne.h) STOP 8 + if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) STOP 9 + b = minval (a, dim = 1, mask = l) + if (any (b.ne.(/ h, h, h /))) STOP 10 + if (any (minloc (a, dim = 1, mask = l).ne.(/ 0, 0, 0 /))) STOP 11 + b = minval (a, dim = 2, mask = l) + if (any (b.ne.(/ h, h, h /))) STOP 12 + if (any (minloc (a, dim = 2, mask = l).ne.(/ 0, 0, 0 /))) STOP 13 + if (minval (a, mask = l3).ne.h) STOP 14 + if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 15 + b = minval (a, dim = 1, mask = l3) + if (any (b.ne.(/ h, h, h /))) STOP 16 + if (any (minloc (a, dim = 1, mask = l3).ne.(/ 0, 0, 0 /))) STOP 17 + b = minval (a, dim = 2, mask = l3) + if (any (b.ne.(/ h, h, h /))) STOP 18 + if (any (minloc (a, dim = 2, mask = l3).ne.(/ 0, 0, 0 /))) STOP 19 + if (minval (a, mask = l2).ne.minf) STOP 20 + if (minval (a, mask = l4).ne.minf) STOP 21 + if (any (minloc (a, mask = l2).ne.(/ 2, 3 /))) STOP 22 + if (any (minloc (a, mask = l4).ne.(/ 2, 3 /))) STOP 23 + b = minval (a, dim = 1, mask = l2) + if (.not.isnan(b(1))) STOP 24 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, pinf, minf /))) STOP 25 + if (any (minloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) STOP 26 + b = minval (a, dim = 2, mask = l2) + if (any (b.ne.(/ pinf, minf, pinf /))) STOP 27 + if (any (minloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) STOP 28 + b = minval (a, dim = 1, mask = l4) + if (.not.isnan(b(1))) STOP 29 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, pinf, minf /))) STOP 30 + if (any (minloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) STOP 31 + b = minval (a, dim = 2, mask = l4) + if (any (b.ne.(/ pinf, minf, pinf /))) STOP 32 + if (any (minloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) STOP 33 + if (minval (a, mask = l5).ne.pinf) STOP 34 + if (any (minloc (a, mask = l5).ne.(/ 2, 2 /))) STOP 35 + b = minval (a, dim = 1, mask = l5) + if (.not.isnan(b(1))) STOP 36 + b(1) = 0.0 + if (any (b.ne.(/ 0.0, pinf, pinf /))) STOP 37 + if (any (minloc (a, dim = 1, mask = l5).ne.(/ 2, 2, 1 /))) STOP 38 + b = minval (a, dim = 2, mask = l5) + if (any (b.ne.(/ pinf, pinf, pinf /))) STOP 39 + if (any (minloc (a, dim = 2, mask = l5).ne.(/ 3, 2, 2 /))) STOP 40 + a = nan + if (.not.isnan(minval (a))) STOP 41 + if (minval (a, mask = l).ne.h) STOP 42 + if (.not.isnan(minval (a, mask = l2))) STOP 43 + if (minval (a, mask = l3).ne.h) STOP 44 + if (.not.isnan(minval (a, mask = l4))) STOP 45 + if (.not.isnan(minval (a, mask = l5))) STOP 46 + if (any (minloc (a).ne.(/ 1, 1 /))) STOP 47 + if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) STOP 48 + if (any (minloc (a, mask = l2).ne.(/ 1, 1 /))) STOP 49 + if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 50 + if (any (minloc (a, mask = l4).ne.(/ 1, 1 /))) STOP 51 + if (any (minloc (a, mask = l5).ne.(/ 2, 1 /))) STOP 52 + a = pinf + if (minval (a).ne.pinf) STOP 53 + if (minval (a, mask = l).ne.h) STOP 54 + if (minval (a, mask = l2).ne.pinf) STOP 55 + if (minval (a, mask = l3).ne.h) STOP 56 + if (minval (a, mask = l4).ne.pinf) STOP 57 + if (minval (a, mask = l5).ne.pinf) STOP 58 + if (any (minloc (a).ne.(/ 1, 1 /))) STOP 59 + if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) STOP 60 + if (any (minloc (a, mask = l2).ne.(/ 1, 1 /))) STOP 61 + if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 62 + if (any (minloc (a, mask = l4).ne.(/ 1, 1 /))) STOP 63 + if (any (minloc (a, mask = l5).ne.(/ 2, 1 /))) STOP 64 + a = nan + a(1,3) = pinf + if (minval (a).ne.pinf) STOP 65 + if (minval (a, mask = l).ne.h) STOP 66 + if (minval (a, mask = l2).ne.pinf) STOP 67 + if (minval (a, mask = l3).ne.h) STOP 68 + if (minval (a, mask = l4).ne.pinf) STOP 69 + if (minval (a, mask = l5).ne.pinf) STOP 70 + if (any (minloc (a).ne.(/ 1, 3 /))) STOP 71 + if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) STOP 72 + if (any (minloc (a, mask = l2).ne.(/ 1, 3 /))) STOP 73 + if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) STOP 74 + if (any (minloc (a, mask = l4).ne.(/ 1, 3 /))) STOP 75 + if (any (minloc (a, mask = l5).ne.(/ 1, 3 /))) STOP 76 +end Index: Fortran/gfortran/regression/minmax_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmax_char_1.f90 @@ -0,0 +1,73 @@ +! Tests for MIN and MAX intrinsics with character arguments +! +! { dg-do run } +program test + character(len=3), parameter :: sp = "gee" + character(len=6), parameter :: tp = "crunch", wp = "flunch" + character(len=2), parameter :: up = "az", vp = "da" + + character(len=3) :: s + character(len=6) :: t, w + character(len=2) :: u, v + s = "gee" + t = "crunch" + u = "az" + v = "da" + w = "flunch" + + if (.not. equal(min("foo", "bar"), "bar")) STOP 1 + if (.not. equal(max("foo", "bar"), "foo")) STOP 2 + if (.not. equal(min("bar", "foo"), "bar")) STOP 3 + if (.not. equal(max("bar", "foo"), "foo")) STOP 4 + + if (.not. equal(min("bar", "foo", sp), "bar")) STOP 5 + if (.not. equal(max("bar", "foo", sp), "gee")) STOP 6 + if (.not. equal(min("bar", sp, "foo"), "bar")) STOP 7 + if (.not. equal(max("bar", sp, "foo"), "gee")) STOP 8 + if (.not. equal(min(sp, "bar", "foo"), "bar")) STOP 9 + if (.not. equal(max(sp, "bar", "foo"), "gee")) STOP 10 + + if (.not. equal(min("foo", "bar", s), "bar")) STOP 11 + if (.not. equal(max("foo", "bar", s), "gee")) STOP 12 + if (.not. equal(min("foo", s, "bar"), "bar")) STOP 13 + if (.not. equal(max("foo", s, "bar"), "gee")) STOP 14 + if (.not. equal(min(s, "foo", "bar"), "bar")) STOP 15 + if (.not. equal(max(s, "foo", "bar"), "gee")) STOP 16 + + if (.not. equal(min("", ""), "")) STOP 17 + if (.not. equal(max("", ""), "")) STOP 18 + if (.not. equal(min("", " "), " ")) STOP 19 + if (.not. equal(max("", " "), " ")) STOP 20 + + if (.not. equal(min(u,v,w), "az ")) STOP 21 + if (.not. equal(max(u,v,w), "flunch")) STOP 22 + if (.not. equal(min(u,vp,w), "az ")) STOP 23 + if (.not. equal(max(u,vp,w), "flunch")) STOP 24 + if (.not. equal(min(u,v,wp), "az ")) STOP 25 + if (.not. equal(max(u,v,wp), "flunch")) STOP 26 + if (.not. equal(min(up,v,w), "az ")) STOP 27 + if (.not. equal(max(up,v,w), "flunch")) STOP 28 + + call foo("gee ","az ",s,t,u,v) + call foo("gee ","az ",s,t,u,v) + call foo("gee ","az ",s,t,u) + call foo("gee ","crunch",s,t) + +contains + + subroutine foo(res_max, res_min, a, b, c, d) + character(len=*) :: res_min, res_max + character(len=*), optional :: a, b, c, d + + if (.not. equal(min(a,b,c,d), res_min)) STOP 29 + if (.not. equal(max(a,b,c,d), res_max)) STOP 30 + end subroutine foo + + pure function equal(a,b) + character(len=*), intent(in) :: a, b + logical :: equal + + equal = (len(a) == len(b)) .and. (a == b) + end function equal + +end program test Index: Fortran/gfortran/regression/minmax_char_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmax_char_2.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + print *, min("foo", "bar") ! { dg-error "Fortran 2003.* CHARACTER argument" } + end Index: Fortran/gfortran/regression/minmax_char_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmax_char_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR96686: MIN/MAX should reject character arguments of different kind + +program p + implicit none + character(kind=1) :: c1 = "1" + character(kind=4) :: c4 = 4_"4" + print *, min (c1, c4) ! { dg-error "Different character kinds" } + print *, min (c4, c1) ! { dg-error "Different character kinds" } +end program p Index: Fortran/gfortran/regression/minmax_integer.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmax_integer.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } + +subroutine foo (a, b, c, d, e, f, g, h) + integer (kind=4) :: a, b, c, d, e, f, g, h + a = min (a, b, c, d, e, f, g, h) +end subroutine + +subroutine foof (a, b, c, d, e, f, g, h) + integer (kind=4) :: a, b, c, d, e, f, g, h + a = max (a, b, c, d, e, f, g, h) +end subroutine + +! { dg-final { scan-tree-dump-times "MIN_EXPR" 7 "optimized" } } +! { dg-final { scan-tree-dump-times "MAX_EXPR" 7 "optimized" } } Index: Fortran/gfortran/regression/minmaxloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_1.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! Check max/minloc. +! PR fortran/31726 +! +program test + implicit none + integer :: i(1), j(-1:1), res(1) + logical, volatile :: m(3), m2(3) + m = (/ .false., .false., .false. /) + m2 = (/ .false., .true., .false. /) + call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2)) + call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(7, 0, MAXLOC(i(1:0), DIM=1)) + call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(13,0, MINLOC(i(1:0), DIM=1)) + + j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1)) + + j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.)) + + j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.)) + + j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m)) + + j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2)) + +! Check the library minloc and maxloc + res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2, res(1)) + res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0, res(1)) + res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0, res(1)) + res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0, res(1)) + res = MAXLOC(i(1:0)); call check(50, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1)) + res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1)) + res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1)) + res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1)) + res = MINLOC(i(1:0)); call check(56,0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1)) + +contains +subroutine check(n, i,j) + integer, value, intent(in) :: i,j,n + if(i /= j) then + STOP 1 +! print *, 'ERROR: Test',n,' expected ',i,' received ', j + end if +end subroutine check +end program Index: Fortran/gfortran/regression/minmaxloc_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_10.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! { dg-additional-options "-fdefault-integer-8" } +! Check max/minloc with eight-bytes logicals. +! +program test + implicit none + integer :: i(1), j(-1:1), res(1) + logical, volatile :: m(3), m2(3) + m = (/ .false., .false., .false. /) + m2 = (/ .false., .true., .false. /) + call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2)) + call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(7, 0, MAXLOC(i(1:0), DIM=1)) + call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(13,0, MINLOC(i(1:0), DIM=1)) + + j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1)) + + j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.)) + + j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.)) + + j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m)) + + j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2)) + +! Check the library minloc and maxloc + res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2, res(1)) + res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0, res(1)) + res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0, res(1)) + res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0, res(1)) + res = MAXLOC(i(1:0)); call check(50, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1)) + res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1)) + res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1)) + res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1)) + res = MINLOC(i(1:0)); call check(56,0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1)) + +contains +subroutine check(n, i,j) + integer, value, intent(in) :: i,j,n + if(i /= j) then + STOP 1 +! print *, 'ERROR: Test',n,' expected ',i,' received ', j + end if +end subroutine check +end program Index: Fortran/gfortran/regression/minmaxloc_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_11.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +program main + character(len=3), dimension(2) :: a + a(1) = 'aaa' + a(2) = 'bbb' + if (maxloc(a,dim=1) /= 2) STOP 1 + if (minloc(a,dim=1) /= 1) STOP 2 + +end program main Index: Fortran/gfortran/regression/minmaxloc_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_12.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! Test compile-time simplification of minloc and maxloc with BACK argument +program main + integer, parameter :: i1(*) = [ 1,2,3,1,2,3]; + integer, parameter :: d1 = minloc(i1,dim=1,back=.true.) + integer, parameter :: d2 = minloc(i1,dim=1,back=.false.) + integer, parameter :: d3 = maxloc(i1,dim=1,back=.true.) + integer, parameter :: d4 = maxloc(i1,dim=1,back=.false.) + integer, parameter :: i2(4,4) = reshape([1,2,1,2,2,3,3,2,3,4,4,3,4,5,5,4], & + [4,4]); + integer, parameter :: d5(2) = minloc(i2,back=.true.) + integer, parameter :: d6(2) = maxloc(i2,back=.true.) + integer, parameter :: d7(4) = minloc(i2,dim=1,back=.true.) + integer, parameter :: d25(4) = minloc(i2,dim=2,mask=i2<2,back=.true.) + integer, parameter :: d26(4) = maxloc(i2,dim=1,mask=i2<3,back=.true.) + + integer, parameter :: i3(4,4) = transpose(i2) + integer, parameter :: d8(4) = minloc(i3,dim=2,back=.true.) + integer, parameter :: i4(4,4) = reshape([1,2,1,2,2,1,2,1,1,2,1,2,2,1,2,1],& + ([4,4])) + integer, parameter :: d9(4) = minloc(i4,dim=1,mask=i4>1,back=.true.) + + integer, parameter :: d10(4) = maxloc(i4,dim=1,mask=i4>1,back=.true.) + character(len=2), parameter :: c0(9) = ["aa", "bb", "aa", & + "cc", "bb", "cc", "aa", "bb", "aa"] + character(len=2), parameter :: c1 (3,3) = reshape(c0, [3,3]); + integer, parameter :: d11(2) = minloc(c1,back=.true.) + integer, parameter :: d12(2) = maxloc(c1,back=.true.) + integer, parameter :: d13(2) = minloc(c1,mask=c1>"aa",back=.true.) + integer, parameter :: d14(2) = maxloc(c1,mask=c1<"cc",back=.true.) + integer, parameter :: d15(3) = minloc(c1,dim=1,back=.true.) + integer, parameter :: d16(3) = maxloc(c1,dim=1,back=.true.) + integer, parameter :: d17(3) = minloc(c1,dim=2,back=.true.) + integer, parameter :: d18(3) = maxloc(c1,dim=2,back=.true.) + integer, parameter :: d19 = minloc(c0,dim=1,back=.true.) + integer, parameter :: d20 = maxloc(c0,dim=1,back=.true.) + integer, parameter :: d21 = minloc(c0,dim=1,mask=c0>"aa",back=.true.) + integer, parameter :: d22 = maxloc(c0,dim=1,mask=c0<"cc",back=.true.) + integer, parameter :: d23(3) = minloc(c1,dim=2,mask=c1>"aa",back=.true.) + integer, parameter :: d24(3) = maxloc(c1,dim=2,mask=c1<"cc",back=.true.) + + if (d1 /= 4) STOP 2078 + if (d2 /= 1) STOP 2079 + if (d3 /= 6) STOP 2080 + if (d4 /= 3) STOP 2081 + if (any (d5 /= [3,1])) STOP 2082 + if (any (d6 /= [3,4])) STOP 2083 + if (any (d7 /= [3,4,4,4])) STOP 2084 + if (any (d8 /= d7)) STOP 2085 + if (any (d9 /= [4,3,4,3])) STOP 2086 + if (any (d10 /= d9)) STOP 2087 + if (any(d11 /= [3,3])) STOP 2088 + if (any(d12 /= [3,2])) STOP 2089 + if (any(d13 /= [2,3])) STOP 2090 + if (any(d14 /= [2,3])) STOP 2091 + if (any(d15 /= [3,2,3])) STOP 2092 + if (any(d16 /= [2,3,2])) STOP 2093 + if (any(d17 /= [3,3,3])) STOP 2094 + if (any(d18 /= [2,3,2])) STOP 2095 + if (d19 /= 9) STOP 2096 + if (d20 /= 6) STOP 2097 + if (d21 /= 8 .or. d22 /= 8) STOP 2098 + if (any(d23 /= [2,3,2])) STOP 2099 + if (any(d24 /= 3)) STOP 2100 + if (any(d25 /= [1,0,1,0])) STOP 2101 + if (any(d26 /= [4,4,0,0])) STOP 2102 +end program main Index: Fortran/gfortran/regression/minmaxloc_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_13.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! Test run-time of MINLOC and MAXLOC with BACK +program main + implicit none + integer:: i1(6) + integer:: d1 + integer:: d2 + integer:: d3 + integer:: d4 + integer:: i2(4,4) + integer:: d5(2) + integer:: d6(2) + integer:: d7(4) + integer:: d25(4) + integer:: d26(4) + + integer:: i3(4,4) + integer:: d8(4) + integer:: i4(4,4) + integer:: d9(4) + + integer:: d10(4) + character(len=2) :: c0(9) + character(len=2) :: c1(3,3) + integer:: d11(2) + integer:: d12(2) + integer:: d13(2) + integer:: d14(2) + integer:: d15(3) + integer:: d16(3) + integer:: d17(3) + integer:: d18(3) + integer:: d19 + integer:: d20 + integer:: d21 + integer:: d22 + integer:: d23(3) + integer:: d24(3) + + i1 = [ 1,2,3,1,2,3]; + d1 = minloc(i1,dim=1,back=.true.) + d2 = minloc(i1,dim=1,back=.false.) + d3 = maxloc(i1,dim=1,back=.true.) + d4 = maxloc(i1,dim=1,back=.false.) + i2 = reshape([1,2,1,2,2,3,3,2,3,4,4,3,4,5,5,4], & + [4,4]); + d5 = minloc(i2,back=.true.) + d6 = maxloc(i2,back=.true.) + d7= minloc(i2,dim=1,back=.true.) + d25 = minloc(i2,dim=2,mask=i2<2,back=.true.) + d26 = maxloc(i2,dim=1,mask=i2<3,back=.true.) + + i3 = transpose(i2) + d8 = minloc(i3,dim=2,back=.true.) + i4 = reshape([1,2,1,2,2,1,2,1,1,2,1,2,2,1,2,1],& + ([4,4])) + d9 = minloc(i4,dim=1,mask=i4>1,back=.true.) + + d10 = maxloc(i4,dim=1,mask=i4>1,back=.true.) + c0 = ["aa", "bb", "aa", & + "cc", "bb", "cc", "aa", "bb", "aa"] + c1 = reshape(c0, [3,3]); + d11 = minloc(c1,back=.true.) + d12 = maxloc(c1,back=.true.) + d13 = minloc(c1,mask=c1>"aa",back=.true.) + d14 = maxloc(c1,mask=c1<"cc",back=.true.) + d15 = minloc(c1,dim=1,back=.true.) + d16 = maxloc(c1,dim=1,back=.true.) + d17 = minloc(c1,dim=2,back=.true.) + d18 = maxloc(c1,dim=2,back=.true.) + d19 = minloc(c0,dim=1,back=.true.) + d20 = maxloc(c0,dim=1,back=.true.) + d21 = minloc(c0,dim=1,mask=c0>"aa",back=.true.) + d22 = maxloc(c0,dim=1,mask=c0<"cc",back=.true.) + d23 = minloc(c1,dim=2,mask=c1>"aa",back=.true.) + d24 = maxloc(c1,dim=2,mask=c1<"cc",back=.true.) + + if (d1 /= 4) STOP 2626 + if (d2 /= 1) STOP 2627 + if (d3 /= 6) STOP 2628 + if (d4 /= 3) STOP 2629 + if (any (d5 /= [3,1])) STOP 2630 + if (any (d6 /= [3,4])) STOP 2631 + if (any (d7 /= [3,4,4,4])) STOP 2632 + if (any (d8 /= d7)) STOP 2633 + if (any (d9 /= [4,3,4,3])) STOP 2634 + if (any (d10 /= d9)) STOP 2635 + if (any(d11 /= [3,3])) STOP 2636 + if (any(d12 /= [3,2])) STOP 2637 + if (any(d13 /= [2,3])) STOP 2638 + if (any(d14 /= [2,3])) STOP 2639 + if (any(d15 /= [3,2,3])) STOP 2640 + if (any(d16 /= [2,3,2])) STOP 2641 + if (any(d17 /= [3,3,3])) STOP 2642 + if (any(d18 /= [2,3,2])) STOP 2643 + if (d19 /= 9) STOP 2644 + if (d20 /= 6) STOP 2645 + if (d21 /= 8 .or. d22 /= 8) STOP 2646 + if (any(d23 /= [2,3,2])) STOP 2647 + if (any(d24 /= 3)) STOP 2648 + if (any(d25 /= [1,0,1,0])) STOP 2649 + if (any(d26 /= [4,4,0,0])) STOP 2650 +end program Index: Fortran/gfortran/regression/minmaxloc_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_14.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR 92017 - this used to cause an ICE due do a missing charlen. +! Original test case by Gerhard Steinmetz. + +program p + character(3), parameter :: a(4) = 'abc' + integer, parameter :: b(1) = minloc(a) + integer, parameter :: c = minloc(a, dim=1) + integer, parameter :: bb(1) = maxloc(a) + integer, parameter :: c2 = maxloc(a,dim=1) +end program p + Index: Fortran/gfortran/regression/minmaxloc_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_15.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/103473 - ICE in simplify_minmaxloc_nodim +! Test case by Gerhard Steinmetz. + +subroutine s + implicit none + integer, parameter :: a(+'1') = [1] ! { dg-error "unary numeric operator" } + print *, minloc (a) +end + +! { dg-prune-output "Parameter array" } Index: Fortran/gfortran/regression/minmaxloc_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_16.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! PR fortran/104811 +! Frontend-optimization mis-optimized minloc/maxloc of character arrays + +program p + character(1) :: str(3) + str = ["a", "c", "a"] + if (any (maxloc (str) /= 2)) stop 1 + if (minloc (str,dim=1) /= 1) stop 2 +end + +! { dg-final { scan-tree-dump-times "_gfortran_maxloc0_4_s1" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_minloc2_4_s1" 1 "original" } } Index: Fortran/gfortran/regression/minmaxloc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_2.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! Tests the fix for PR32298, in which the scalarizer would generate +! a temporary in the course of evaluating MINLOC or MAXLOC, thereby +! setting the start of the scalarizer loop to zero. +! +! Contributed by Jens Bischoff +! +PROGRAM ERR_MINLOC + + INTEGER, PARAMETER :: N = 7 + + DOUBLE PRECISION, DIMENSION (N), PARAMETER :: A & + = (/ 0.3D0, 0.455D0, 0.6D0, 0.7D0, 0.72D0, 0.76D0, 0.79D0 /) + + DOUBLE PRECISION :: B + INTEGER :: I, J(N), K(N) + + DO I = 1, N + B = A(I) + J(I) = MINLOC (ABS (A - B), 1) + K(I) = MAXLOC (ABS (A - B), 1) + END DO + + if (any (J .NE. (/1,2,3,4,5,6,7/))) STOP 1 + if (any (K .NE. (/7,7,1,1,1,1,1/))) STOP 2 + + STOP + +END PROGRAM ERR_MINLOC Index: Fortran/gfortran/regression/minmaxloc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_3.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! Check max/minloc. +! PR fortran/32956, wrong mask kind with -fdefault-integer-8 +! +program test + implicit none + integer :: i(1), j(-1:1), res(1) + logical, volatile :: m(3), m2(3) + m = (/ .false., .false., .false. /) + m2 = (/ .false., .true., .false. /) + call check(1, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(2, 0, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(3, 2, MAXLOC((/ 42, 23, 11 /), DIM=1, MASK=m2)) + call check(4, 0, MAXLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(5, 0, MAXLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(6, 0, MAXLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(7, 0, MAXLOC(i(1:0), DIM=1)) + call check(8, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=.FALSE.)) + call check(9, 0, MINLOC((/ 42, 23, 11 /), DIM=1, MASK=m)) + call check(10, 0, MINLOC(i(1:0), DIM=1, MASK=.FALSE.)) + call check(11,0, MINLOC(i(1:0), DIM=1, MASK=m(1:0))) + call check(12,0, MINLOC(i(1:0), DIM=1, MASK=.TRUE.)) + call check(13,0, MINLOC(i(1:0), DIM=1)) + + j = (/ 1, 2, 1 /); call check(14, 2, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(15, 3, MAXLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(16, 1, MAXLOC(j, DIM=1)) + j = (/ 1, 2, 1 /); call check(17, 1, MINLOC(j, DIM=1)) + j = (/ 1, 2, 3 /); call check(18, 1, MINLOC(j, DIM=1)) + j = (/ 3, 2, 1 /); call check(19, 3, MINLOC(j, DIM=1)) + + j = (/ 1, 2, 1 /); call check(20, 2, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(21, 3, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(22, 1, MAXLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 1 /); call check(23, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 1, 2, 3 /); call check(24, 1, MINLOC(j, DIM=1,mask=.true.)) + j = (/ 3, 2, 1 /); call check(25, 3, MINLOC(j, DIM=1,mask=.true.)) + + j = (/ 1, 2, 1 /); call check(26, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(27, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(28, 0, MAXLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 1 /); call check(29, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 1, 2, 3 /); call check(30, 0, MINLOC(j, DIM=1,mask=.false.)) + j = (/ 3, 2, 1 /); call check(31, 0, MINLOC(j, DIM=1,mask=.false.)) + + j = (/ 1, 2, 1 /); call check(32, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(33, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(34, 0, MAXLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 1 /); call check(35, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 1, 2, 3 /); call check(36, 0, MINLOC(j, DIM=1,mask=m)) + j = (/ 3, 2, 1 /); call check(37, 0, MINLOC(j, DIM=1,mask=m)) + + j = (/ 1, 2, 1 /); call check(38, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(39, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(40, 2, MAXLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 1 /); call check(41, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 1, 2, 3 /); call check(42, 2, MINLOC(j, DIM=1,mask=m2)) + j = (/ 3, 2, 1 /); call check(43, 2, MINLOC(j, DIM=1,mask=m2)) + +! Check the library minloc and maxloc + res = MAXLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(44, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m); call check(45, 0, res(1)) + res = MAXLOC((/ 42, 23, 11 /), MASK=m2); call check(46, 2, res(1)) + res = MAXLOC(i(1:0), MASK=.TRUE.); call check(47, 0, res(1)) + res = MAXLOC(i(1:0), MASK=.FALSE.); call check(48, 0, res(1)) + res = MAXLOC(i(1:0), MASK=m(1:0)); call check(49, 0, res(1)) + res = MAXLOC(i(1:0)); call check(50, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=.FALSE.); call check(51, 0, res(1)) + res = MINLOC((/ 42, 23, 11 /), MASK=m); call check(52, 0, res(1)) + res = MINLOC(i(1:0), MASK=.FALSE.); call check(53, 0, res(1)) + res = MINLOC(i(1:0), MASK=m(1:0)); call check(54,0, res(1)) + res = MINLOC(i(1:0), MASK=.TRUE.); call check(55,0, res(1)) + res = MINLOC(i(1:0)); call check(56,0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j); call check(57, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j); call check(58, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j); call check(59, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j); call check(60, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j); call check(61, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j); call check(62, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(63, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.true.); call check(65, 3, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.true.); call check(66, 1, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.true.); call check(67, 1, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.true.); call check(68, 1, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.true.); call check(69, 3, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(70, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=.false.); call check(71, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=.false.); call check(72, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=.false.); call check(73, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=.false.); call check(74, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=.false.); call check(75, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m); call check(76, 0, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m); call check(77, 0, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m); call check(78, 0, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m); call check(79, 0, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m); call check(80, 0, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m);call check(81, 0, res(1)) + + j = (/ 1, 2, 1 /); res = MAXLOC(j,mask=m2); call check(82, 2, res(1)) + j = (/ 1, 2, 3 /); res = MAXLOC(j,mask=m2); call check(83, 2, res(1)) + j = (/ 3, 2, 1 /); res = MAXLOC(j,mask=m2); call check(84, 2, res(1)) + j = (/ 1, 2, 1 /); res = MINLOC(j,mask=m2); call check(85, 2, res(1)) + j = (/ 1, 2, 3 /); res = MINLOC(j,mask=m2); call check(86, 2, res(1)) + j = (/ 3, 2, 1 /); res = MINLOC(j,mask=m2); call check(87, 2, res(1)) + +contains +subroutine check(n, i,j) + integer, value, intent(in) :: i,j,n + if(i /= j) then + STOP 1 +! print *, 'ERROR: Test',n,' expected ',i,' received ', j + end if +end subroutine check +end program Index: Fortran/gfortran/regression/minmaxloc_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_4.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! Test to make sure that PR 33354 remains fixed and doesn't regress +PROGRAM TST + IMPLICIT NONE + REAL :: A(1,3) + A(:,1) = 10 + A(:,2) = 20 + A(:,3) = 30 + + !WRITE(*,*) SUM(A(:,1:3),1) + !WRITE(*,*) MINLOC(SUM(A(:,1:3),1),1) + if (minloc(sum(a(:,1:3),1),1) .ne. 1) STOP 1 + if (maxloc(sum(a(:,1:3),1),1) .ne. 3) STOP 2 + +END PROGRAM TST Index: Fortran/gfortran/regression/minmaxloc_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_5.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR35994 [4.3/4.4 regression] MAXLOC and MINLOC off by one with mask +program GA4076 + REAL DDA(100) + dda = (/(J1,J1=1,100)/) + IDS = MAXLOC(DDA,1) + if (ids.ne.100) STOP 1!expect 100 + + IDS = MAXLOC(DDA,1, (/(J1,J1=1,100)/) > 50) + if (ids.ne.100) STOP 2!expect 100 + + IDS = minLOC(DDA,1) + if (ids.ne.1) STOP 3!expect 1 + + IDS = MinLOC(DDA,1, (/(J1,J1=1,100)/) > 50) + if (ids.ne.51) STOP 4!expect 51 + +END Index: Fortran/gfortran/regression/minmaxloc_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_6.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR35994 [4.3/4.4 regression] MAXLOC and MINLOC off by one with mask + REAL DDA(5:104) + dda = (/(J1,J1=1,100)/) + + IDS = MAXLOC(DDA,1) + if (ids.ne.100) STOP 1!expect 100 + IDS = MAXLOC(DDA,1, (/(J1,J1=1,100)/) > 50) + if (ids.ne.100) STOP 2!expect 100 + + END Index: Fortran/gfortran/regression/minmaxloc_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_7.f90 @@ -0,0 +1,21 @@ +! Contributed by Tobias Burnus +! { dg-do run } +program test + implicit none + real, volatile, allocatable :: A(:) + logical, volatile :: mask(11) + + A = [1,2,3,5,6,1,35,3,7,-3,-47] + mask = .true. + mask(7) = .false. + mask(11) = .false. + call sub2 (minloc(A),11) + call sub2 (maxloc(A, mask=mask),9) + A = minloc(A) + if (size (A) /= 1 .or. A(1) /= 11) STOP 1 +contains + subroutine sub2(A,n) + integer :: A(:),n + if (A(1) /= n .or. size (A) /= 1) STOP 2 + end subroutine sub2 +end program test Index: Fortran/gfortran/regression/minmaxloc_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_8.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! Test that minloc and maxloc using KINDs return the right +! kind, by using unformatted I/O for a specific kind. +program main + implicit none + real, dimension(3) :: a + integer :: r1, r2, r4, r8 + integer :: k + character(len=30) :: l1, l2 + + ! Check via I/O if the KIND is used correctly + a = [ 1.0, 3.0, 2.0] + write (unit=l1,fmt=*) 2_1 + write (unit=l2,fmt=*) maxloc(a,kind=1) + if (l1 /= l2) STOP 1 + + write (unit=l1,fmt=*) 2_2 + write (unit=l2,fmt=*) maxloc(a,kind=2) + if (l1 /= l2) STOP 2 + + write (unit=l1,fmt=*) 2_4 + write (unit=l2,fmt=*) maxloc(a,kind=4) + if (l1 /= l2) STOP 3 + + write (unit=l1,fmt=*) 2_8 + write (unit=l2,fmt=*) maxloc(a,kind=8) + if (l1 /= l2) STOP 4 + + a = [ 3.0, -1.0, 2.0] + + write (unit=l1,fmt=*) 2_1 + write (unit=l2,fmt=*) minloc(a,kind=1) + if (l1 /= l2) STOP 5 + + write (unit=l1,fmt=*) 2_2 + write (unit=l2,fmt=*) minloc(a,kind=2) + if (l1 /= l2) STOP 6 + + write (unit=l1,fmt=*) 2_4 + write (unit=l2,fmt=*) minloc(a,kind=4) + if (l1 /= l2) STOP 7 + + write (unit=l1,fmt=*) 2_8 + write (unit=l2,fmt=*) minloc(a,kind=8) + if (l1 /= l2) STOP 8 + +end program main Index: Fortran/gfortran/regression/minmaxloc_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_9.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Check for a few restrictions on the back argument to +! minloc and maxloc. +program main + integer, dimension(3) :: a + a = [1,2,3] + print *,minloc(a,back=42) ! { dg-error "must be LOGICAL" } + print *,minloc(a,back=[.true.,.false.]) ! { dg-error "must be a scalar" } + print *,maxloc(a,back=42) ! { dg-error "must be LOGICAL" } + print *,maxloc(a,back=[.true.,.false.]) ! { dg-error "must be a scalar" } +end program main Index: Fortran/gfortran/regression/minmaxloc_integer_kinds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_integer_kinds_1.f90 @@ -0,0 +1,10 @@ +! { dg-do link } +! PR 30415 - minloc and maxloc for integer kinds=1 and 2 were missing +! Test case by Harald Anlauf +program gfcbug55 + integer(kind=1) :: i1(4) = 1 + integer(kind=2) :: i2(4) = 1 + print *, minloc(i1), maxloc(i1) + print *, minloc(i2), maxloc(i2) +end program gfcbug55 + Index: Fortran/gfortran/regression/minmaxloc_zerosize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxloc_zerosize_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +program main + implicit none + integer, parameter :: z(0) = 0 + integer, parameter, dimension(1) :: a = minloc(z) + integer, parameter, dimension(1) :: b = minloc(z,mask=z>0) + integer, parameter :: c = minloc(z,dim=1) + + integer, parameter, dimension(1) :: d = maxloc(z) + integer, parameter, dimension(1) :: e = maxloc(z,mask=z>0) + integer, parameter :: f = maxloc(z,dim=1) + + character(len=12) line + + if (a(1) /= 0) stop 1 + if (b(1) /= 0) stop 2 + if (c /= 0) stop 3 + + if (d(1) /= 0) stop 4 + if (e(1) /= 0) stop 5 + if (f /= 0) stop 6 + + write (unit=line,fmt='(6I2)') minloc(z), minloc(z,mask=z>0), minloc(z,dim=1), & + maxloc(z), maxloc(z,mask=z<0), maxloc(z,dim=1) + if (line /= ' 0 0 0 0 0 0') stop 7 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_stop" 1 "original" } } Index: Fortran/gfortran/regression/minmaxval_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minmaxval_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Tests the fix for PR37836 in which the specification expressions for +! y were not simplified because there was no simplifier for minval and +! maxval. +! +! Contributed by Tobias Burnus +! +! nint(exp(3.0)) is equal to 20 :-) +! + function fun4a() + integer fun4a + real y(minval([25, nint(exp(3.0)), 15])) + + fun4a = size (y, 1) + end function fun4a + + function fun4b() + integer fun4b + real y(maxval([25, nint(exp(3.0)), 15])) + save + + fun4b = size (y, 1) + end function fun4b + + EXTERNAL fun4a, fun4b + integer fun4a, fun4b + if (fun4a () .ne. 15) STOP 1 + if (fun4b () .ne. 25) STOP 2 + end Index: Fortran/gfortran/regression/minval_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_char_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5, m=3 + character(len=5), dimension(n) :: a + character(len=5), dimension(n,m) :: b + character(len=5) :: res + integer, dimension(n,m) :: v + real, dimension(n,m) :: r + integer :: i,j + logical, dimension(n,m) :: mask + character(len=5), dimension(:,:), allocatable :: empty + character(len=5) , parameter :: all_full = achar(255) // achar(255) // achar(255) // achar(255) // achar(255) + logical :: smask + + write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n) + res = minval(a) + if (res /= '00026') STOP 1 + do + call random_number(r) + v = int(r * 100) + if (count(v < 30) > 1) exit + end do + write (unit=b,fmt='(I5.5)') v + write (unit=res,fmt='(I5.5)') minval(v) + if (res /= minval(b)) STOP 2 + smask = .true. + if (res /= minval(b, smask)) STOP 3 + smask = .false. + if (all_full /= minval(b, smask)) STOP 4 + + mask = v < 30 + write (unit=res,fmt='(I5.5)') minval(v,mask) + if (res /= minval(b, mask)) STOP 5 + mask = .false. + if (minval(b, mask) /= all_full) STOP 6 + allocate (empty(0:3,0)) + res = minval(empty) + if (res /= all_full) STOP 7 +end program main Index: Fortran/gfortran/regression/minval_char_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_char_2.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5, m=3 + character(kind=4,len=5), dimension(n) :: a + character(kind=4,len=5), dimension(n,m) :: b + character(kind=4,len=5) :: res + integer, dimension(n,m) :: v + real, dimension(n,m) :: r + integer :: i,j + logical, dimension(n,m) :: mask + character(kind=4,len=5), dimension(:,:), allocatable :: empty + integer(kind=4), dimension(5) :: kmin = [-1, -1, -1, -1, -1] + character(kind=4,len=5) :: all_full + logical :: smask + + all_full = transfer(kmin,all_full) + write (unit=a,fmt='(I5.5)') (21-i*i+6*i,i=1,n) + res = minval(a) + if (res /= 4_'00026') STOP 1 + do + call random_number(r) + v = int(r * 100) + if (count(v<30) > 1) exit + end do + write (unit=b,fmt='(I5.5)') v + write (unit=res,fmt='(I5.5)') minval(v) + if (res /= minval(b)) STOP 2 + smask = .true. + if (res /= minval(b, smask)) STOP 3 + smask = .false. + if (all_full /= minval(b, smask)) STOP 4 + + mask = v < 30 + write (unit=res,fmt='(I5.5)') minval(v,mask) + if (res /= minval(b, mask)) STOP 5 + mask = .false. + if (minval(b, mask) /= all_full) STOP 6 + allocate (empty(0:3,0)) + res = minval(empty) + if (res /= all_full) STOP 7 +end program main Index: Fortran/gfortran/regression/minval_char_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_char_3.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5 + character(len=6), dimension(n,n) :: a + integer, dimension(n,n) :: v + character(len=6), dimension(n) :: r1, r2 + character(len=6), dimension(:,:), allocatable :: a_alloc + integer, dimension(:,:), allocatable :: v_alloc + character(len=6), parameter :: all_full = achar(255) // achar(255) // achar(255) // achar(255) // achar(255) // achar(255) + integer :: i + character(len=6),dimension(1) :: ret + logical, dimension(n,n) :: mask + logical :: smask + + v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v)) + write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n) + + r1 = minval(a,dim=1) + write (unit=r2,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 1 + r1 = 'x' + write (unit=r1,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 2 + + r1 = 'y' + r1 = minval(a,dim=2) + write (unit=r2,fmt='(I6.6)') minval(v,dim=2) + if (any (r1 /= r2)) STOP 3 + r1 = 'z' + write (unit=r1,fmt='(I6.6)') minval(v,dim=2) + if (any (r1 /= r2)) STOP 4 + + allocate (a_alloc(0,1), v_alloc(0,1)) + ret = 'what' + ret = minval(a_alloc,dim=1) + if (ret(1) /= all_full) STOP 5 + + r1 = 'qq' + r1 = minval(a, dim=1, mask=a>"000200"); + if (any(r1 /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 6 + if (any(minval(a, dim=1, mask=a>"000200") /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 7 + + r1 = 'rr' + r1 = minval(a, dim=2, mask=a>"000200"); + if (any(r1 /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 8 + if (any(minval(a, dim=2, mask=a>"000200") /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 9 + + mask = .true. + forall (i=1:n) + mask(i,i) = .false. + end forall + + r1 = 'aa' + r1 = minval(a, dim=1, mask=mask) + write(unit=r2,fmt='(I6.6)') minval(v,dim=1, mask=mask) + if (any(r1 /= r2)) STOP 10 + + r1 = 'xyz' + smask = .true. + r1 = minval(a, dim=1, mask=smask) + write (unit=r2,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 11 + + smask = .false. + r1 = 'foobar' + r1 = minval(a, dim=1, mask=smask) + if (any(r1 /= all_full)) STOP 12 +end program main Index: Fortran/gfortran/regression/minval_char_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_char_4.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: n=5 + character(len=6,kind=4), dimension(n,n) :: a + integer, dimension(n,n) :: v + character(len=6,kind=4), dimension(n) :: r1, r2 + character(len=6,kind=4), dimension(:,:), allocatable :: a_alloc + integer, dimension(:,:), allocatable :: v_alloc + character(len=6,kind=4):: all_full + integer :: i + character(len=6,kind=4),dimension(1) :: ret + logical, dimension(n,n) :: mask + logical :: smask + integer(kind=4), dimension(6) :: kmin + + kmin = -1 + all_full = transfer(kmin,all_full) + v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v)) + write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n) + + r1 = minval(a,dim=1) + write (unit=r2,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 1 + r1 = 4_'x' + write (unit=r1,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 2 + + r1 = 4_'y' + r1 = minval(a,dim=2) + write (unit=r2,fmt='(I6.6)') minval(v,dim=2) + if (any (r1 /= r2)) STOP 3 + r1 = 4_'z' + write (unit=r1,fmt='(I6.6)') minval(v,dim=2) + if (any (r1 /= r2)) STOP 4 + + allocate (a_alloc(0,1), v_alloc(0,1)) + ret = 4_'what' + ret = minval(a_alloc,dim=1) + if (ret(1) /= all_full) STOP 5 + + r1 = 4_'qq' + r1 = minval(a, dim=1, mask=a>4_"000200"); + if (any(r1 /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 6 + if (any(minval(a, dim=1, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=1, mask=v>200) < 1000)) STOP 7 + + r1 = 4_'rr' + r1 = minval(a, dim=2, mask=a>4_"000200"); + if (any(r1 /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 8 + if (any(minval(a, dim=2, mask=a>4_"000200") /= all_full .neqv. minval(v,dim=2, mask=v>200) < 1000)) STOP 9 + + mask = .true. + forall (i=1:n) + mask(i,i) = .false. + end forall + + r1 = 4_'aa' + r1 = minval(a, dim=1, mask=mask) + write(unit=r2,fmt='(I6.6)') minval(v,dim=1, mask=mask) + if (any(r1 /= r2)) STOP 10 + + r1 = 4_'xyz' + smask = .true. + r1 = minval(a, dim=1, mask=smask) + write (unit=r2,fmt='(I6.6)') minval(v,dim=1) + if (any (r1 /= r2)) STOP 11 + + smask = .false. + r1 = 4_'foobar' + r1 = minval(a, dim=1, mask=smask) + if (any(r1 /= all_full)) STOP 12 +end program main Index: Fortran/gfortran/regression/minval_char_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_char_5.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR fortran/83316 - this used to ICE +program tminmaxval + implicit none + + character(len=*), parameter :: b = "a" + character(len=*), parameter :: e = "c" + character(len=*), parameter :: s(3) = (/"a", "b", "c"/) + + if (minval(s) /= b) then + STOP 1 + end if + + if (maxval(s) /= e) then + STOP 2 + end if + +end program tminmaxval Index: Fortran/gfortran/regression/minval_parameter_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/minval_parameter_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Test for run-time simplification of minval +program main + implicit none + integer, dimension(2,3), parameter :: i = & + & reshape([-1,2,-3,5,-7,11], shape(i)) + integer, dimension(3), parameter :: im1 = minval(i,dim=1) + integer, parameter :: im2 = minval(i,mask=i>4) + integer, dimension(2), parameter :: im3 = minval(i,dim=2) + integer, parameter :: im4 = minval(i, mask=i>-1) + integer, dimension(3), parameter :: im5 = minval(i,dim=1,mask=i>4) + integer, dimension(2), parameter :: im6 = minval(i,dim=2,mask=i>4) + + real, dimension(2,3), parameter :: r = & + & reshape([-1.,2.,-3.,5.,-7.,11.], shape(r)) + real, dimension(3), parameter :: rm1 = minval(r,dim=1) + real, parameter :: rm2 = minval(r,mask=r>4) + real, dimension(2), parameter :: rm3 = minval(r,dim=2) + real, parameter :: rm4 = minval(r, mask=r>-1) + real, dimension(3), parameter :: rm5 = minval(r,dim=1,mask=r>4) + real, dimension(2), parameter :: rm6 = minval(r,dim=2,mask=r>4) + + character(len=3), parameter :: maxv = achar(255) // achar(255) // achar(255) + character(len=3), dimension(2,3), parameter :: c = & + reshape(["asd", "fgh", "qwe", "jkl", "ert", "zui"], shape(c)) + character(len=3), parameter :: cm1 = minval(c) + character(len=3), dimension(3), parameter :: cm2 = minval(c,dim=1) + character(len=3), dimension(2), parameter :: cm3 = minval(c,dim=2) + character(len=3), parameter :: cm4 = minval (c, c>"g") + character(len=3), dimension(3), parameter :: cm5 = minval(c,dim=1,mask=c>"g") + + if (any (im1 /= [ -1, -3, -7])) STOP 1 + if (im2 /= 5) STOP 2 + if (any (im3 /= [ -7,2])) STOP 3 + if (im4 /= 2) STOP 4 + if (any (im5 /= [huge(im5), 5, 11])) STOP 5 + if (any (im6 /= [huge(im6), 5])) STOP 6 + + if (any (rm1 /= [ -1., -3., -7.])) STOP 7 + if (rm2 /= 5) STOP 8 + if (any (rm3 /= [ -7.,2.])) STOP 9 + if (rm4 /= 2) STOP 10 + if (any (rm5 /= [huge(rm5), 5., 11.])) STOP 11 + if (any (rm6 /= [huge(rm6), 5.])) STOP 12 + + if (cm1 /= "asd") STOP 13 + if (any (cm2 /= ["asd", "jkl", "ert" ])) STOP 14 + if (any (cm3 /= ["asd", "fgh" ])) STOP 15 + if (cm4 /= "jkl") STOP 16 + if (any(cm5 /= [ maxv, "jkl", "zui" ] )) STOP 17 +end program main Index: Fortran/gfortran/regression/misplaced_implicit_character.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/misplaced_implicit_character.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/69963 +subroutine s + real x ! { dg-error "" } + implicit character (a) ! { dg-error "IMPLICIT statement at .1. cannot follow data declaration statement at .2." } + x = 1 + a = 'a' +end subroutine s Index: Fortran/gfortran/regression/misplaced_statement.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/misplaced_statement.f90 @@ -0,0 +1,20 @@ +!{ dg-do compile } +! PR fortran/66040 +! +! Original code from Gerhard Steinmetz +! +real function f1(x) + sequence ! { dg-error "Unexpected SEQUENCE statement" } +end function f1 + +real function f2() + else ! { dg-error "Unexpected ELSE statement" } +end function f2 + +real function f3() + block data ! { dg-error "Unexpected BLOCK DATA statement" } +end function f3 + +real function f4() + program p ! { dg-error "Unexpected PROGRAM statement" } +end function f4 Index: Fortran/gfortran/regression/missing_derived_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_derived_type_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR29364, in which the absence of the derived type +! 'nonexist' was not diagnosed. +! +! Contributed by Tobias Burnus +! +module test + implicit none + type epot_t + integer :: c + type(nonexist),pointer :: l ! { dg-error "has not been declared" } + end type epot_t +end module test Index: Fortran/gfortran/regression/missing_optional_dummy_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Test the fix for PR26891, in which an optional argument, whose actual +! is a missing dummy argument would cause a segfault. +! +! Contributed by Paul Thomas +! + logical :: back =.false. + +! This was the case that would fail - PR case was an intrinsic call. + if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) & + .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) & + STOP 1 + +! Check that the patch works with non-intrinsic functions. + if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) & + STOP 2 + +! Check that missing, optional character actual arguments are OK. + if (scan ("A quick brown fox jumps over the lazy dog", "over", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog")) & + STOP 3 + +contains + integer function myscan (str, substr, back) + character(*), intent(in) :: str, substr + logical, optional, intent(in) :: back + myscan = scan (str, substr, back) + end function myscan + + integer function thyscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional, intent(in) :: substr + logical, optional, intent(in) :: back + thyscan = isscan (str, substr, back) + end function thyscan + + integer function isscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional :: substr + logical, optional, intent(in) :: back + if (.not.present(substr)) then + isscan = myscan (str, "over", back) + else + isscan = myscan (str, substr, back) + end if + end function isscan + +end Index: Fortran/gfortran/regression/missing_optional_dummy_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_2.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! Tests the fix for PR29321 and PR29322, in which ICEs occurred for the +! lack of proper attention to checking pointers in gfc_conv_function_call. +! +! Contributed by Olav Vahtras +! and Francois-Xavier Coudert +! +MODULE myint + TYPE NUM + INTEGER :: R = 0 + END TYPE NUM + CONTAINS + FUNCTION FUNC(A,B) RESULT(E) + IMPLICIT NONE + TYPE(NUM) A,B,E + INTENT(IN) :: A,B + OPTIONAL B + E%R=A%R + CALL SUB(A,E) + END FUNCTION FUNC + + SUBROUTINE SUB(A,E,B,C) + IMPLICIT NONE + TYPE(NUM) A,E,B,C + INTENT(IN) A,B + INTENT(OUT) E,C + OPTIONAL B,C + E%R=A%R + END SUBROUTINE SUB +END MODULE myint + + if (isscan () /= 0) STOP 1 +contains + integer function isscan (substr) + character(*), optional :: substr + if (.not.present(substr)) isscan = myscan ("foo", "over") + end function isscan +end Index: Fortran/gfortran/regression/missing_optional_dummy_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_3.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Tests the fix for PR29976, in which the call to CMPLX caused an +! ICE with an optional dummy for the imaginary part. +! +! Contributed by Francois-Xavier Coudert +! +SUBROUTINE pw_sumup (alpha_im) + REAL, INTENT(in), OPTIONAL :: alpha_im + COMPLEX :: my_alpha_c + IF (PRESENT(alpha_im)) THEN + my_alpha_c = CMPLX(0.,alpha_im) + END IF +END SUBROUTINE pw_sumup + +! Check non-intrinsic functions. +SUBROUTINE pw_sumup_2 (alpha_im) + REAL, INTENT(in), OPTIONAL :: alpha_im + COMPLEX :: my_alpha_c + IF (PRESENT(alpha_im)) THEN + my_alpha_c = MY_CMPLX(0.,alpha_im) + END IF +contains + complex function MY_CMPLX (re, im) + real, intent(in) :: re + real, intent(in), optional :: im + if (present (im)) then + MY_CMPLX = cmplx (re, im) + else + MY_CMPLX = cmplx (re, 0.0) + end if + end function MY_CMPLX +END SUBROUTINE pw_sumup_2 Index: Fortran/gfortran/regression/missing_optional_dummy_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_4.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/34848 +! +! The "0" for the string size of the absent optional +! argument was missing. +! +module krmod +contains + subroutine doit() + implicit none + real :: doit1 + doit1 = tm_doit() + return + end subroutine doit + function tm_doit(genloc) + implicit none + character, optional :: genloc + real :: tm_doit + tm_doit = 42.0 + end function tm_doit +end module krmod + +! { dg-final { scan-tree-dump " tm_doit \\(0B, 0\\);" "original" } } Index: Fortran/gfortran/regression/missing_optional_dummy_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_5.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/34848 +! +! This was before giving an ICE; additionally +! the "0" for the string size of the absent optional +! argument was missing. +! +module krmod +contains + subroutine doit() + implicit none + real :: doit1(2) + doit1 = tm_doit() + return + end subroutine doit + function tm_doit(genloc) + implicit none + character, optional :: genloc + real :: tm_doit(2) + tm_doit = 42.0 + end function tm_doit +end module krmod + +! { dg-final { scan-tree-dump " tm_doit \\(&parm\.., 0B, 0\\);" "original" } } Index: Fortran/gfortran/regression/missing_optional_dummy_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_6.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/41907 +! +program test + implicit none + call scalar1 () + call assumed_shape1 () + call explicit_shape1 () +contains + + ! Calling functions + subroutine scalar1 (slr1) + integer, optional :: slr1 + call scalar2 (slr1) + end subroutine scalar1 + + subroutine assumed_shape1 (as1) + integer, dimension(:), optional :: as1 + call assumed_shape2 (as1) + call explicit_shape2 (as1) + end subroutine assumed_shape1 + + subroutine explicit_shape1 (es1) + integer, dimension(5), optional :: es1 + call assumed_shape2 (es1) + call explicit_shape2 (es1) + end subroutine explicit_shape1 + + + ! Called functions + subroutine assumed_shape2 (as2) + integer, dimension(:),optional :: as2 + if (present (as2)) STOP 1 + end subroutine assumed_shape2 + + subroutine explicit_shape2 (es2) + integer, dimension(5),optional :: es2 + if (present (es2)) STOP 2 + end subroutine explicit_shape2 + + subroutine scalar2 (slr2) + integer, optional :: slr2 + if (present (slr2)) STOP 3 + end subroutine scalar2 + +end program test Index: Fortran/gfortran/regression/missing_optional_dummy_6a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_optional_dummy_6a.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/41907 +! +program test + implicit none + call scalar1 () + call assumed_shape1 () + call explicit_shape1 () +contains + + ! Calling functions + subroutine scalar1 (slr1) + integer, optional :: slr1 + call scalar2 (slr1) + end subroutine scalar1 + + subroutine assumed_shape1 (as1) + integer, dimension(:), optional :: as1 + call assumed_shape2 (as1) + call explicit_shape2 (as1) + end subroutine assumed_shape1 + + subroutine explicit_shape1 (es1) + integer, dimension(5), optional :: es1 + call assumed_shape2 (es1) + call explicit_shape2 (es1) + end subroutine explicit_shape1 + + + ! Called functions + subroutine assumed_shape2 (as2) + integer, dimension(:),optional :: as2 + if (present (as2)) STOP 1 + end subroutine assumed_shape2 + + subroutine explicit_shape2 (es2) + integer, dimension(5),optional :: es2 + if (present (es2)) STOP 2 + end subroutine explicit_shape2 + + subroutine scalar2 (slr2) + integer, optional :: slr2 + if (present (slr2)) STOP 3 + end subroutine scalar2 + +end program test + +! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } } + +! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } } +! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } +! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } + +! { dg-final { scan-tree-dump-times "= as1.0 != 0B" 2 "original" } } +! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } } +! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } } Index: Fortran/gfortran/regression/missing_parens_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_parens_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR34325 Wrong error message for syntax error +program aa +implicit none +real(kind=8)::r1=0 +real(kind=8),dimension((1)::r2 ! { dg-error "Missing '\\)' in statement" } +real(kind=8),dimension(3,3)::r3 +character(25) :: a +a = 'I am not a )))))'')''.' +if ((((((a /= "I am not a )))))')'.")))))) STOP 1 +if ((((((a /= 'I am not a )))))'')''.')))))) STOP 2 +a = "I am not a )))))"")""." +if ((((((a /= "I am not a )))))"")"".")))))) STOP 3 +if (((3*r1)**2)>= 0) a = "good" +if ((3*r1)**2)>= 0) a = "bad" ! { dg-error "Missing '\\(' in statement" } +r3((2,2)) = 4.3 ! { dg-error "found COMPLEX" } +do while ((.true.) ! { dg-error "Missing '\\)' in statement" } +do while (.true. ! { dg-error "Missing '\\)' in statement" } +end Index: Fortran/gfortran/regression/missing_parens_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/missing_parens_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR34325 Wrong error message for syntax error +program aa +implicit none +real(kind=8)::r1=0 +character(25) :: a +a = 'I am not a )))))'')''.' +if ((((((a /= "I am not a )))))')'.")))))) STOP 1 +if ((((((a /= 'I am not a )))))'')''.')))))) STOP 2 +a = "I am not a )))))"")""." +if ((((((a /= "I am not a )))))"")"".")))))) STOP 3 +if (((3*r1)**2)>= 0) a = "good" +if (a /= "good") STOP 4 +end Index: Fortran/gfortran/regression/mixed_io_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mixed_io_1.c @@ -0,0 +1,4 @@ +#include +void cio_(void){ + printf("12345"); +} Index: Fortran/gfortran/regression/mixed_io_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mixed_io_1.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! { dg-additional-sources mixed_io_1.c } +! { dg-options "-w" } + call cio + write(*,"(A)") '6789' ! { dg-output "123456789" } + end Index: Fortran/gfortran/regression/mod_large_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mod_large_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/24518 +! MOD/MODULO of large arguments. +! The naive algorithm goes pear-shaped for large arguments, instead +! use fmod. +! Here we test only with constant arguments (evaluated with +! mpfr_fmod), as we don't want to cause failures on targets with a +! crappy libm. +program mod_large_1 + implicit none + real :: r1 + r1 = mod (1e22, 1.7) + if (abs(r1 - 0.995928764) > 1e-5) STOP 1 + r1 = modulo (1e22, -1.7) + if (abs(r1 + 0.704071283) > 1e-5) STOP 2 +end program mod_large_1 Index: Fortran/gfortran/regression/mod_sign0_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mod_sign0_1.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! PR fortran/49010 +! MOD/MODULO sign of zero. + +! We wish to provide the following guarantees: + +! MOD(A, P): The result has the sign of A and a magnitude less than +! that of P. + +! MODULO(A, P): The result has the sign of P and a magnitude less than +! that of P. + +! Here we test only with constant arguments (evaluated with +! mpfr_fmod), as we don't want to cause failures on targets with a +! crappy libm. But, a target where fmod follows C99 Annex F is +! fine. Also, targets where GCC inline expands fmod (such as x86(-64)) +! are also fine. +program mod_sign0_1 + implicit none + real :: r, t + + r = mod (4., 2.) + t = sign (1., r) + if (t < 0.) STOP 1 + + r = modulo (4., 2.) + t = sign (1., r) + if (t < 0.) STOP 2 + + r = mod (-4., 2.) + t = sign (1., r) + if (t > 0.) STOP 3 + + r = modulo (-4., 2.) + t = sign (1., r) + if (t < 0.) STOP 4 + + r = mod (4., -2.) + t = sign (1., r) + if (t < 0.) STOP 5 + + r = modulo (4., -2.) + t = sign (1., r) + if (t > 0.) STOP 6 + + r = mod (-4., -2.) + t = sign (1., r) + if (t > 0.) STOP 7 + + r = modulo (-4., -2.) + t = sign (1., r) + if (t > 0.) STOP 8 + +end program mod_sign0_1 Index: Fortran/gfortran/regression/module_blank_common.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_blank_common.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! +! This tests that blank common works in modules. PR23270 +! Contributed by Paul Thomas +! +module global + common a, b + real a, b +end module global +program blank_common + use global + common z + complex z + a = 999.0_4 + b = -999.0_4 + if (z.ne.cmplx (a,b)) STOP 1 +end program blank_common Index: Fortran/gfortran/regression/module_commons_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_commons_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! This program tests that use associated common blocks work. +! +! provided by Paul Thomas - pault@gcc.gnu.org +! +module m1 + common /x/ a +end module m1 +module m2 + common /x/ a +end module m2 + +subroutine foo () + use m2 + if (a.ne.99.0) STOP 1 +end subroutine foo + +program collision + use m1 + use m2, only: b=>a + b = 99.0 + call foo () +end program collision Index: Fortran/gfortran/regression/module_commons_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_commons_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Tests the fix for PR35474, in which the PRIVATE statement would +! cause the error Internal Error at (1): free_pi_tree(): Unresolved fixup +! This arose because the symbol for 'i' emanating from the COMMON was +! not being fixed-up as the EQUIVALENCE was built. +! +! Contributed by FX Coudert +! +module h5global + integer i + integer j + common /c/ i + equivalence (i, j) + private +end module h5global + +program bug + use h5global +end Index: Fortran/gfortran/regression/module_commons_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_commons_3.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! PR fortran/38657, in which the mixture of PRIVATE and +! COMMON in TEST4, would mess up the association with +! TESTCHAR in TEST2. +! +! Contributed by Paul Thomas +! From a report in clf by Chris Bradley. +! +MODULE TEST4 + PRIVATE + CHARACTER(LEN=80) :: T1 = & + "Mary had a little lamb, Its fleece was white as snow;" + CHARACTER(LEN=80) :: T2 = & + "And everywhere that Mary went, The lamb was sure to go." + CHARACTER(LEN=80) :: TESTCHAR + COMMON /TESTCOMMON1/ TESTCHAR + PUBLIC T1, T2, FOOBAR +CONTAINS + subroutine FOOBAR (CHECK) + CHARACTER(LEN=80) :: CHECK + IF (TESTCHAR .NE. CHECK) STOP 1 + end subroutine +END MODULE TEST4 + +MODULE TEST3 + CHARACTER(LEN=80) :: TESTCHAR + COMMON /TESTCOMMON1/ TESTCHAR +END MODULE TEST3 + +MODULE TEST2 + use TEST4 + USE TEST3, chr => testchar + PRIVATE + CHARACTER(LEN=80) :: TESTCHAR + COMMON /TESTCOMMON1/ TESTCHAR + PUBLIC TESTCHAR, FOO, BAR, CHR, T1, T2, FOOBAR +contains + subroutine FOO + TESTCHAR = T1 + end subroutine + subroutine BAR (CHECK) + CHARACTER(LEN=80) :: CHECK + IF (TESTCHAR .NE. CHECK) STOP 2 + IF (CHR .NE. CHECK) STOP 3 + end subroutine +END MODULE TEST2 + +PROGRAM TEST1 + USE TEST2 + call FOO + call BAR (T1) + TESTCHAR = T2 + call BAR (T2) + CALL FOOBAR (T2) +END PROGRAM TEST1 Index: Fortran/gfortran/regression/module_double_reuse.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_double_reuse.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Test of fix for PR18878 +! +! Based on example in PR by Steve Kargl +! +module a + integer, parameter :: b = kind(1.d0) + real(b) :: z +end module a +program d + use a, only : e => b, f => b, u => z, v => z + real(e) x + real(f) y + x = 1.e0_e + y = 1.e0_f + u = 99.0 + if (kind(x).ne.kind(y)) STOP 1 + if (v.ne.u) STOP 2 +end program d Index: Fortran/gfortran/regression/module_equivalence_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! This tests the fix for PR17917, where equivalences were not being +! written to and read back from modules. +! +! Contributed by Paul Thomas pault@gcc.gnu.org +! +module test_equiv !Bug 17917 + common /my_common/ d + real a(2),b(4),c(4), d(8) + equivalence (a(1),b(2)), (c(1),d(5)) +end module test_equiv + +subroutine foo () + use test_equiv, z=>b + if (any (d(5:8)/=z)) STOP 1 +end subroutine foo + +program module_equiv + use test_equiv + b = 99.0_4 + a = 999.0_4 + c = (/99.0_4, 999.0_4, 999.0_4, 99.0_4/) + call foo () +end program module_equiv Index: Fortran/gfortran/regression/module_equivalence_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Tests the fix for PR27269 and PR27xxx. +! The former caused a segfault in trying to process +! module b, with an unused equivalence in a. The latter +! produced an assembler error due to multiple declarations +! for a module equivalence, when one of the variables was +! initialized, as M in module a. +! +module a + integer, parameter :: dp = selected_real_kind (10) + real(dp) :: reM, M = 1.77d0 + equivalence (M, reM) +end module a + +module b + use a, only : dp +end module b + + use a + use b + if (reM .ne. 1.77d0) STOP 1 + reM = 0.57d1 + if (M .ne. 0.57d1) STOP 2 +end Index: Fortran/gfortran/regression/module_equivalence_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! This checks the fix for PR32103 in which not using one member +! of an equivalence group would cause all memory of the equivalence +! to be lost and subsequent incorrect referencing of the remaining +! members. +! +! Contributed by Toon Moene +! +module aap + real :: a(5) = (/1.0,2.0,3.0,4.0,5.0/) + real :: b(3) + real :: d(5) = (/1.0,2.0,3.0,4.0,5.0/) + equivalence (a(3),b(1)) +end module aap + + use aap, only : b + call foo + call bar +! call foobar +contains + subroutine foo + use aap, only : c=>b + if (any(c .ne. b)) STOP 1 + end subroutine + subroutine bar + use aap, only : a + if (any(a(3:5) .ne. b)) STOP 2 + end subroutine + +! Make sure that bad things do not happen if we do not USE a or b. + + subroutine foobar + use aap, only : d + if (any(d(3:5) .ne. b)) STOP 3 + end subroutine +end Index: Fortran/gfortran/regression/module_equivalence_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_4.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! This checks the fix for PR37706 in which the equivalence would be +! inserted into the 'nudata' namespace with the inevitable consequences. +! +! Contributed by Lester Petrie +! +module data_C + integer, dimension(200) :: l = (/(201-i, i = 1,200)/) + integer :: l0 + integer :: l24, l27, l28, l29 + equivalence ( l(1), l0 ) + end module data_C + +subroutine nudata(nlibe, a, l) + USE data_C, only: l24, l27, l28, l29 + implicit none + integer :: nlibe + integer :: l(*) + real :: a(*) + print *, l(1), l(2) + return +end subroutine nudata + + integer :: l_(2) = (/1,2/), nlibe_ = 42 + real :: a_(2) = (/1.,2./) + call nudata (nlibe_, a_, l_) +end Index: Fortran/gfortran/regression/module_equivalence_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_5.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Fixes PR37787 where the EQUIVALENCE between QLA1 and QLA2 wasn't recognized +! in the dependency checking because the compiler was looking in the wrong name +! space. +! +! Contributed by Dick Hendrickson +! +module stuff + integer, parameter :: r4_kv = 4 +contains + + SUBROUTINE CF0004 +! COPYRIGHT 1999 SPACKMAN & HENDRICKSON, INC. + REAL(R4_KV), dimension (10) :: QLA1, QLA2, QLA3, & + QCA = (/(i, i= 1, 10)/) + EQUIVALENCE (QLA1, QLA2) + QLA1 = QCA + QLA3 = QCA + QLA3( 2:10:3) = QCA ( 1:5:2) + 1 + QLA1( 2:10:3) = QLA2( 1:5:2) + 1 !failed because of dependency + if (any (qla1 .ne. qla3)) STOP 1 + END SUBROUTINE +end module + +program try_cf004 + use stuff + nf1 = 1 + nf2 = 2 + call cf0004 +end Index: Fortran/gfortran/regression/module_equivalence_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_equivalence_6.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Fixes PR38171 a regression caused by the fix for PR37706. +! +! Contributed by Scot Breitenfeld +! +MODULE H5GLOBAL + IMPLICIT NONE + INTEGER :: H5P_flags + INTEGER :: H5P_DEFAULT_F + EQUIVALENCE(H5P_flags, H5P_DEFAULT_F) +END MODULE H5GLOBAL +MODULE HDF5 + USE H5GLOBAL +END MODULE HDF5 +PROGRAM fortranlibtest + USE HDF5 + IMPLICIT NONE + INTEGER :: ii + ii = H5P_DEFAULT_F +END PROGRAM fortranlibtest Index: Fortran/gfortran/regression/module_error_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_error_1.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/50627 +module kernels + select type (args) ! { dg-error "cannot appear in this scope" } +end module kernels Index: Fortran/gfortran/regression/module_function_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_function_type_1.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! This checks the fix for PR33295 in which the A_type in initA was +! not promoted to module level and so not recognised as being the +! same as that emanating directly from module a. +! +! Contributed by Janus Weil +! +module A + type A_type + real comp + end type +end module A + +module B +contains + function initA() + use A + implicit none + type(A_type):: initA + initA%comp=1.0 + end function +end module B + +program C + use B + use A + implicit none + type(A_type):: A_var + A_var = initA() +end program C Index: Fortran/gfortran/regression/module_implicit_conversion.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_implicit_conversion.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + +module module_implicit_conversion + ! double complex :: s = (1.0D0, 0D0) + double complex :: s = (1.0, 0D0) +end module module_implicit_conversion Index: Fortran/gfortran/regression/module_interface_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_interface_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! This tests the fix for PR16940, module interfaces to +! contained functions caused ICEs. +! This is a simplified version of the example in the PR +! discussion, which was due to L.Meissner. +! +! Submitted by Paul Thomas pault@gcc.gnu.org +! + module Max_Loc_Mod + implicit none + interface Max_Location + module procedure I_Max_Loc + end interface + contains + function I_Max_Loc (Vector) result(Ans) + integer, intent (in), dimension(:) :: Vector + integer, dimension(1) :: Ans + Ans = maxloc(Vector) + return + end function I_Max_Loc + end module Max_Loc_Mod + program module_interface + use Max_Loc_Mod + implicit none + integer :: Vector (7) + Vector = (/1,6,3,5,19,1,2/) + call Selection_Sort (Vector) + contains + subroutine Selection_Sort (Unsorted) + integer, intent (in), dimension(:) :: Unsorted + integer, dimension (1) :: N + N = Max_Location (Unsorted) + if (N(1).ne.5) STOP 1 + return + end subroutine Selection_Sort + end program module_interface Index: Fortran/gfortran/regression/module_interface_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_interface_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Tests the fix for PR29464, in which the second USE of the generic +! interface caused an error. +! +! Contributed by Vivek Rao +! +module foo_mod + implicit none + interface twice + module procedure twice_real + end interface twice +contains + real function twice_real(x) + real :: x + twice_real = 2*x + end function twice_real +end module foo_mod + + subroutine foobar () + use foo_mod, only: twice, twice + print *, twice (99.0) + end subroutine foobar + + program xfoo + use foo_mod, only: two => twice, dbl => twice + implicit none + call foobar () + print *, two (2.3) + print *, dbl (2.3) +end program xfoo Index: Fortran/gfortran/regression/module_naming_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_naming_1.f90 @@ -0,0 +1,31 @@ +! { dg-do assemble } +! PR 31144 +! Makes sure that our name mangling scheme can't be outwitted + +! old scheme +module m1 +contains + subroutine m2__m3() + end subroutine m2__m3 +end module m1 + +module m1__m2 +contains + subroutine m3() + end subroutine m3 +end module m1__m2 + +! New scheme, relies on capitalization +module m2 +contains + subroutine m2_MOD_m3() + ! mangled to __m2_MOD_m2_mod_m3 + end subroutine m2_MOD_m3 +end module m2 + +module m2_MOD_m2 +contains + subroutine m3() + ! mangled to __m2_mod_m2_MOD_m3 + end subroutine m3 +end module m2_MOD_m2 Index: Fortran/gfortran/regression/module_nan.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_nan.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } +! +! PR fortran/34318 +! +! Infinity and NaN were not properly written to the .mod file. +! +module nonordinal + implicit none + real, parameter :: inf = 1./0., nan = 0./0., minf = -1./0.0 +end module nonordinal + +program a + use nonordinal + implicit none + character(len=20) :: str + if (log(abs(inf)) < huge(inf)) STOP 1 + if (log(abs(minf)) < huge(inf)) STOP 2 + if (.not. isnan(nan)) STOP 3 + write(str,"(sp,f10.2)") inf + if (adjustl(str) /= "+Infinity") STOP 4 + write(str,*) minf + if (adjustl(str) /= "-Infinity") STOP 5 + write(str,*) nan + if (adjustl(str) /= "NaN") STOP 6 +end program a Index: Fortran/gfortran/regression/module_parameter_array_refs_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_parameter_array_refs_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Tests the fix for 26074, in which the array reference below would +! be determined not to be constant within modules. +! +! Contributed by Jonathan Dursi +! +module foo + + integer, parameter :: len = 5 + integer :: arr(max(len,1)) + +end Index: Fortran/gfortran/regression/module_parameter_array_refs_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_parameter_array_refs_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O" } +! { dg-final { scan-assembler-not "i_am_optimized_away" } } +! +! PR fortran/50960 +! +! PARAMETER arrays and derived types exists as static variables. +! Check that the their read-only nature is taken into account +! when optimizations are done. +! + +module m + integer, parameter :: PARA(*) = [1,2,3,4,5,6,7,8,9,10] +end module m + +subroutine test() +use m +integer :: i +i = 1 +if (para(i) /= 1) call i_am_optimized_away() +end Index: Fortran/gfortran/regression/module_private_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_private_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fmodule-private" } +module bar + implicit none + public :: i + integer :: i +end module bar + +module foo + implicit none + integer :: j +end module foo + +program main + use bar, only : i + use foo, only : j ! { dg-error "not found in module" } + i = 1 + j = 1 + print *, i, j +end program main Index: Fortran/gfortran/regression/module_private_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_private_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! +! PR fortran/47266 +! +! Check whether the private procedure "priv" is optimized away +! +module m + implicit none + private :: priv + private :: export1, export2 + public :: pub +contains + integer function priv() + priv = 44 + end function priv + integer function export1() + export1 = 45 + end function export1 + function export2() bind(C) ! { dg-warning "is marked PRIVATE" } + use iso_c_binding, only: c_int + integer(c_int) :: export2 + export2 = 46 + end function export2 + subroutine pub(a,b) + integer :: a + procedure(export1), pointer :: b + a = priv() + b => export1 + end subroutine pub +end module m +! { dg-final { scan-tree-dump-times "priv" 0 "optimized" } } +! { dg-final { scan-tree-dump-times "export1 \\(\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "export2 \\(\\)" 1 "optimized" } } Index: Fortran/gfortran/regression/module_private_array_refs_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_private_array_refs_1.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! This tests the fix for PR28735 in which an ICE would be triggered in resolve_ref +! because the references to 'a' and 'b' in the dummy arguments of mysub have +! no symtrees in module bar, being private there. +! +! Contributed by Andrew Sampson +! +!-- foo.F ----------------------------------------------- +module foo + implicit none + public + integer, allocatable :: a(:), b(:) +end module foo + +!-- bar.F --------------------------------------------- +module bar + use foo + implicit none + private ! This triggered the ICE + public :: mysub ! since a and b are not public + +contains + + subroutine mysub(n, parray1) + integer, intent(in) :: n + real, dimension(a(n):b(n)) :: parray1 + if ((n == 1) .and. size(parray1, 1) /= 10) STOP 1 + if ((n == 2) .and. size(parray1, 1) /= 42) STOP 2 + end subroutine mysub +end module bar + +!-- sub.F ------------------------------------------------------- +subroutine sub() + + use foo + use bar + real :: z(100) + allocate (a(2), b(2)) + a = (/1, 6/) + b = (/10, 47/) + call mysub (1, z) + call mysub (2, z) + + return +end + +!-- MAIN ------------------------------------------------------ + use bar + call sub () +end Index: Fortran/gfortran/regression/module_proc_external_dummy.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_proc_external_dummy.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! This tests the fix for PR24866 in which the reference to the external str, in +! sub_module, would get mixed up with the module procedure, str, thus +! causing an ICE. This is a completed version of the reporter's testcase; ie +! it adds a main program and working subroutines to allow a check for +! correct functioning. +! +! Contributed by Uttam Pawar +! + subroutine sub() + print *, "external sub" + end subroutine sub + +module test_module + contains + subroutine sub_module(str) + external :: str + call str () + end subroutine sub_module + subroutine str() + print *, "module str" + end subroutine str +end module test_module + + use test_module + external sub + call sub_module (sub) + call sub_module (str) +end Index: Fortran/gfortran/regression/module_procedure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_1.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! Modified program from http://groups.google.com/group/\ +! comp.lang.fortran/browse_frm/thread/423e4392dc965ab7# +! +module myoperator + contains + function dadd(arg1,arg2) + integer ::dadd(2) + integer, intent(in) :: arg1(2), arg2(2) + dadd(1)=arg1(1)+arg2(1) + dadd(2)=arg1(2)+arg2(2) + end function dadd +end module myoperator + +program test_interface + + use myoperator + + implicit none + + interface operator (.myadd.) + module procedure dadd + end interface + + integer input1(2), input2(2), mysum(2) + + input1 = (/0,1/) + input2 = (/3,3/) + mysum = input1 .myadd. input2 + if (mysum(1) /= 3 .and. mysum(2) /= 4) STOP 1 + + call test_sub(input1, input2) + +end program test_interface + +subroutine test_sub(input1, input2) + + use myoperator + + implicit none + + interface operator (.myadd.) + module procedure dadd + end interface + + integer, intent(in) :: input1(2), input2(2) + integer mysum(2) + + mysum = input1 .myadd. input2 + if (mysum(1) /= 3 .and. mysum(2) /= 4) STOP 2 + +end subroutine test_sub Index: Fortran/gfortran/regression/module_procedure_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +program test + implicit none + intrinsic sin + interface gen2 + module procedure sin ! { dg-error "cannot be a MODULE PROCEDURE" } + end interface gen2 +end program test Index: Fortran/gfortran/regression/module_procedure_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_3.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/94348 +! +! Contributed by Damian Rouson + +module foo_module + implicit none + + interface + module function foo() result(bar) + implicit none + integer bar + end function + end interface + +contains + module procedure foo + bar = 5 + end procedure +end module + +program main + use foo_module + implicit none + if (foo() /= 5) stop 1 +end program main Index: Fortran/gfortran/regression/module_procedure_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_4.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! Test the fix for PR96320 in which the assumed shape of 'arg' in the +! interface for 'bar' was mirrored by the 'arg' in the module procedure +! incorrectly have deferred shape. +! +! Contributed by Damian Rouson +! +module foobar + type foo + contains + procedure, nopass :: bar1 + procedure, nopass :: bar2 + procedure, nopass :: bar3 + end type + + interface + + module subroutine bar1(arg) + character(len=*) arg(:) + end subroutine + + module subroutine bar2(arg) + character(len=*) arg(3:) + end subroutine + + module subroutine bar3(arg) + character(len=*) arg(2) + end subroutine + + end interface +contains + + module procedure bar1 + if (lbound(arg, 1) .ne. 1) stop 1 + if (arg(3) .ne. 'hijk') stop 2 + end procedure + +! Make sure that the lower bound of an assumed shape array dummy, +! if defined, is passed to the module procedure. + + module procedure bar2 + if (lbound(arg, 1) .ne. 3) stop 3 + if (arg(3) .ne. 'abcd') stop 4 + end procedure + +! This makes sure that an dummy with explicit shape has the upper +! bound correctly set in the module procedure. + + module procedure bar3 + if (lbound(arg, 1) .ne. 1) stop 5 + if (arg(3) .ne. 'hijk') stop 6 ! { dg-warning "is out of bounds" } + end procedure + +end module + + use foobar + character(4) :: list(3) = ['abcd', 'efgh' , 'hijk'] + type(foo) :: f + call f%bar1(list) + call f%bar2(list) + call f%bar3(list) +end Index: Fortran/gfortran/regression/module_procedure_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_5.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! Test the fix for the testcase in comment 23 of PR96320, which used to +! fail with the message: Variable ‘new_foo’ cannot appear in a variable +! definition context. +! +! Contributed by Damian Rouson +! +module foobar + implicit none + + type foo + integer bar + end type + + interface + pure module function create() result(new_foo) + implicit none + type(foo) new_foo + end function + end interface + +contains + module procedure create + new_foo%bar = 1 ! Error here + end procedure +end module + + use foobar + print *, create () +end Index: Fortran/gfortran/regression/module_procedure_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_6.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test the fix for the testcase in comment 24 of PR96320, which used to +! fail with the message: ‘set_user_defined’ must be a module procedure or +! an external procedure with an explicit interface at (1) +! +! Contributed by Damian Rouson +! +module hole_interface + type hole_t + integer :: user_defined + real :: hole_diameter + contains + procedure set_user_defined + procedure set_diameter + end type + + interface + module subroutine set_diameter (this, diameter) + class(hole_t) :: this + real :: diameter + end subroutine + + module subroutine set_user_defined(this, user_defined) + class(hole_t) :: this + integer :: user_defined + end subroutine + end interface + +contains + module procedure set_user_defined + this%user_defined = user_defined + end procedure + + module procedure set_diameter + this%hole_diameter = diameter + if (this%user_defined .lt. 0) then + call this%set_user_defined (0) + end if + end procedure +end module + + use hole_interface ! Error was here + type (hole_t) :: ht = hole_t (-1, 0.0) + call ht%set_diameter(1.0) + if ((ht%user_defined .ne. 0) .and. (ht%hole_diameter .ne. 1.0)) stop 1 + call ht%set_user_defined (5) + if ((ht%user_defined .ne. 5) .and. (ht%hole_diameter .ne. 1.0)) stop 2 + call ht%set_diameter(2.0) + if ((ht%user_defined .ne. 5) .and. (ht%hole_diameter .ne. 2.0)) stop 3 +end Index: Fortran/gfortran/regression/module_procedure_double_colon_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_double_colon_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/49265 +! Contributed by Erik Toussaint +! +module m1 + implicit none + interface foo + module procedure::bar + module procedure ::bar_none + module procedure:: none_bar + end interface +contains + subroutine bar + end subroutine + subroutine bar_none(i) + integer i + end subroutine + subroutine none_bar(x) + real x + end subroutine +end module Index: Fortran/gfortran/regression/module_procedure_double_colon_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_double_colon_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/49265 +! Contributed by Erik Toussaint +! +module m1 + implicit none + interface foo + module procedure::bar ! { dg-error "double colon" } + module procedure ::bar_none ! { dg-error "double colon" } + module procedure:: none_bar ! { dg-error "double colon" } + end interface +contains + subroutine bar + end subroutine + subroutine bar_none(i) + integer i + end subroutine + subroutine none_bar(x) + real x + end subroutine +end module Index: Fortran/gfortran/regression/module_procedure_double_colon_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_double_colon_3.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/49265 +! +! Contributed by Erik Toussaint +! +module m1 + implicit none + interface foo + procedure :: bar ! { dg-error "Fortran 2008: double colon in MODULE PROCEDURE statement" } + end interface +contains + subroutine bar + end subroutine +end module Index: Fortran/gfortran/regression/module_procedure_double_colon_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_procedure_double_colon_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/49265 +! +! Contributed by Erik Toussaint +! +module m1 + implicit none + interface foo + procedure :: bar ! "::" is valid since Fortran 2008 + end interface +contains + subroutine bar + end subroutine +end module Index: Fortran/gfortran/regression/module_read_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_read_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-Wreturn-type" } +! PR fortran/33941 +! The problem was that the intrinsic operators +! were written to the module file as '/=' etc. +! but this format was not understood on reading. +! +! Test case by Toby White, stripped down by +! Dominique d'Humieres and Francois-Xavier Coudert + +module foo +contains + function pop(n) result(item) ! { dg-warning "not set" } + integer :: n + character(len=merge(1, 0, n > 0)) :: item + end function pop + function push(n) result(item) ! { dg-warning "not set" } + integer :: n + character(len=merge(1, 0, n /= 0)) :: item + end function push +end module foo + +program test + use foo + if(len(pop(0)) /= 0) STOP 1 + if(len(pop(1)) /= 1) STOP 2 + if(len(push(0)) /= 0) STOP 3 + if(len(push(1)) /= 1) STOP 4 +end program Index: Fortran/gfortran/regression/module_read_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_read_2.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR fortran/43199 +! +! This program gave an ICE due to reading the REF_COMPONENT with CLASS. +! +module m_string + type t_string + character, dimension(:), allocatable :: string + end type t_string +contains +pure function string_to_char ( s ) result(res) + class(t_string), intent(in) :: s + character(len=size(s%string)) :: res + integer :: i + do i = 1,len(res) + res(i:i) = s%string(i) + end do +end function string_to_char +end module m_string + +use m_string +type(t_string) :: str +allocate(str%string(5)) +str%string = ['H','e','l','l','o'] +if (len (string_to_char (str)) /= 5) STOP 1 +if (string_to_char (str) /= "Hello") STOP 2 +end Index: Fortran/gfortran/regression/module_variable_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_variable_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! { dg-require-visibility "" } +module foo + integer, private :: i ! { dg-warning "Unused PRIVATE" } + integer, private :: j = 0 +contains + subroutine bar + j = j + 1 + end subroutine bar +end module foo + +module bar + private + integer :: i ! { dg-warning "Unused PRIVATE" } +end module bar Index: Fortran/gfortran/regression/module_variable_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_variable_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wall -fmodule-private" } +! { dg-require-visibility "" } + +module bar + integer :: i ! { dg-warning "Unused PRIVATE" } +end module bar Index: Fortran/gfortran/regression/module_variable_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_variable_3.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/97927 +! +! Did ICE due to the in tree-nested.c due to {clobber} +! + +module mpi2 + interface + subroutine MPI_Allreduce(i) + implicit none + INTEGER, OPTIONAL, INTENT(OUT) :: i + end subroutine MPI_Allreduce + end interface +end module + +module modmpi + implicit none + integer ierror ! module variable = context NAMESPACE_DECL +end module + +subroutine exxengy + use modmpi + use mpi2, only: mpi_allreduce + implicit none + + ! intent(out) implies: ierror = {clobber} + call mpi_allreduce(ierror) + +contains + subroutine zrho2 + return + end subroutine +end subroutine + +! { dg-final { scan-tree-dump "ierror = {CLOBBER};" "original" } } Index: Fortran/gfortran/regression/module_widestring_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_widestring_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! +! Testcase from PR36162 +module m + character(*), parameter :: a ='H\0z' +end module m + + use m + character(len=20) :: s + if (a /= 'H\0z') STOP 1 + if (ichar(a(2:2)) /= 0) STOP 2 + write (s,"(A)") a +end Index: Fortran/gfortran/regression/module_write_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/module_write_1.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! +! PR fortran/41869 +! +! Was ICEing while module write of symbol 'vs_str' in m_dom_dom +! because of "len" being private in fox_m_fsys_format. +! +module fox_m_fsys_array_str +contains + pure function str_vs(vs) result(s) + character, dimension(:), intent(in) :: vs + character(len=size(vs)) :: s + s = transfer(vs, s) + end function str_vs + pure function vs_str(s) result(vs) + character(len=*), intent(in) :: s + character, dimension(len(s)) :: vs + vs = transfer(s, vs) + end function vs_str +end module fox_m_fsys_array_str + +module fox_m_fsys_format + private + interface str + module procedure str_logical_array + end interface str + interface len + module procedure str_logical_array_len + end interface + public :: str +contains + pure function str_logical_array_len(la) result(n) + logical, dimension(:), intent(in) :: la + end function str_logical_array_len + pure function str_logical_array(la) result(s) + logical, dimension(:), intent(in) :: la + character(len=len(la)) :: s + end function str_logical_array + pure function checkFmt(fmt) result(good) + character(len=*), intent(in) :: fmt + logical :: good + good = len(fmt) > 0 + end function checkFmt +end module fox_m_fsys_format + +module m_dom_dom + use fox_m_fsys_array_str, only: str_vs, vs_str +end module m_dom_dom + +module FoX_dom + use fox_m_fsys_format + use m_dom_dom +end module FoX_dom + +use FoX_dom +implicit none +print *, vs_str("ABC") +end Index: Fortran/gfortran/regression/modulo_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/modulo_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/23912 + integer(kind=4) i4 + integer(kind=8) i8 + + i4 = modulo(i4,i8) ! { dg-warning "Extension" } + i4 = modulo(i8,i4) ! { dg-warning "Extension" } + + end Index: Fortran/gfortran/regression/modulo_check.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/modulo_check.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Test checks on modulo with p == 0 +program p + logical :: a(2) = (modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: b = count(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: c = all(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: d = any(modulo([2,3],0) == 0) ! { dg-error "shall not be zero" } +end program Index: Fortran/gfortran/regression/move_alloc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Test the move_alloc intrinsic. +! +! Contributed by Erik Edelmann +! and Paul Thomas +! +program test_move_alloc + + implicit none + integer, allocatable :: x(:), y(:), temp(:) + character(4), allocatable :: a(:), b(:) + integer :: i + + allocate (x(2)) + allocate (a(2)) + + x = [ 42, 77 ] + + call move_alloc (x, y) + if (allocated(x)) STOP 1 + if (.not.allocated(y)) STOP 2 + if (any(y /= [ 42, 77 ])) STOP 3 + + a = [ "abcd", "efgh" ] + call move_alloc (a, b) + if (allocated(a)) STOP 4 + if (.not.allocated(b)) STOP 5 + if (any(b /= [ "abcd", "efgh" ])) STOP 6 + + ! Now one of the intended applications of move_alloc; resizing + + call move_alloc (y, temp) + allocate (y(6), stat=i) + if (i /= 0) STOP 7 + y(1:2) = temp + y(3:) = 99 + deallocate(temp) + if (any(y /= [ 42, 77, 99, 99, 99, 99 ])) STOP 8 +end program test_move_alloc Index: Fortran/gfortran/regression/move_alloc_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_10.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! Test move_alloc for polymorphic scalars +! +! The following checks that a move_alloc from +! a TYPE to a CLASS works +! +module myalloc + implicit none + + type :: base_type + integer :: i =2 + end type base_type + + type, extends(base_type) :: extended_type + integer :: j = 77 + end type extended_type +contains + subroutine myallocate (a) + class(base_type), allocatable, intent(inout) :: a + type(extended_type), allocatable :: tmp + + allocate (tmp) + + if (tmp%i /= 2 .or. tmp%j /= 77) STOP 1 + tmp%i = 5 + tmp%j = 88 + + select type(a) + type is(base_type) + if (a%i /= -44) STOP 2 + a%i = -99 + class default + STOP 3 + end select + + call move_alloc (from=tmp, to=a) + + select type(a) + type is(extended_type) + if (a%i /= 5) STOP 4 + if (a%j /= 88) STOP 5 + a%i = 123 + a%j = 9498 + class default + STOP 6 + end select + + if (allocated (tmp)) STOP 7 + end subroutine myallocate +end module myalloc + +program main + use myalloc + implicit none + class(base_type), allocatable :: a + + allocate (a) + + select type(a) + type is(base_type) + if (a%i /= 2) STOP 8 + a%i = -44 + class default + STOP 9 + end select + + call myallocate (a) + + select type(a) + type is(extended_type) + if (a%i /= 123) STOP 10 + if (a%j /= 9498) STOP 11 + class default + STOP 12 + end select +end program main Index: Fortran/gfortran/regression/move_alloc_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_12.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/51948 +! + type :: t + end type t +contains + function func(x, y) + class(t) :: y + type(t), allocatable :: func + type(t), allocatable :: x + + select type (y) + type is(t) + call move_alloc (x, func) + end select + end function + + function func2(x, y) + class(t) :: y + class(t), allocatable :: func2 + class(t), allocatable :: x + + block + block + select type (y) + type is(t) + call move_alloc (x, func2) + end select + end block + end block + end function +end Index: Fortran/gfortran/regression/move_alloc_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_13.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/51970 +! PR fortran/51977 +! +type t +end type t +type, extends(t) :: t2 + integer :: a +end type t2 + +class(t), allocatable :: y(:), z(:) + +allocate(y(2), source=[t2(2), t2(3)]) +call func2(y,z) + +select type(z) + type is(t2) + if (any (z(:)%a /= [2, 3])) STOP 1 + class default + STOP 2 +end select + +contains + function func(x) + class (t), allocatable :: x(:), func(:) + call move_alloc (x, func) + end function + + function func1(x) + class (t), allocatable :: x(:), func1(:) + call move_alloc (func1, x) + end function + + subroutine func2(x, y) + class (t), allocatable :: x(:), y(:) + call move_alloc (x, y) + end subroutine +end Index: Fortran/gfortran/regression/move_alloc_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_14.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Ensure that move_alloc for CLASS resets the FROM variable's dynamic type +! to the declared one +! +implicit none +type t +end type t +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: a, b, c +class(t), allocatable :: a2(:), b2(:), c2(:) +allocate (t2 :: a) +allocate (t2 :: a2(5)) +call move_alloc (from=a, to=b) +call move_alloc (from=a2, to=b2) +!print *, same_type_as (a,c), same_type_as (a,b) +!print *, same_type_as (a2,c2), same_type_as (a2,b2) +if (.not. same_type_as (a,c) .or. same_type_as (a,b)) STOP 1 +if (.not. same_type_as (a2,c2) .or. same_type_as (a2,b2)) STOP 2 +end Index: Fortran/gfortran/regression/move_alloc_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_15.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Fix for PR...... +! +! The 'to' components of 'mytemp' would remain allocated after the call to +! MOVE_ALLOC, resulting in memory leaks. +! +! Contributed by Alberto Luaces. +! +! See https://groups.google.com/forum/#!topic/comp.lang.fortran/k3bkKUbOpFU +! +module alloctest + type myallocatable + integer, allocatable:: i(:) + end type myallocatable + +contains + subroutine f(num, array) + implicit none + integer, intent(in) :: num + integer :: i + type(myallocatable):: array(:) + + do i = 1, num + allocate(array(i)%i(5), source = [1,2,3,4,5]) + end do + + end subroutine f +end module alloctest + +program name + use alloctest + implicit none + type(myallocatable), allocatable:: myarray(:), mytemp(:) + integer, parameter:: OLDSIZE = 7, NEWSIZE = 20 + logical :: flag + + allocate(myarray(OLDSIZE)) + call f(size(myarray), myarray) + + allocate(mytemp(NEWSIZE)) + mytemp(1:OLDSIZE) = myarray + + flag = .false. + call foo + call bar + + deallocate(myarray) + if (allocated (mytemp)) deallocate (mytemp) + + allocate(myarray(OLDSIZE)) + call f(size(myarray), myarray) + + allocate(mytemp(NEWSIZE)) + mytemp(1:OLDSIZE) = myarray + +! Verfify that there is no segfault if the allocatable components +! are deallocated before the call to move_alloc + flag = .true. + call foo + call bar + + deallocate(myarray) +contains + subroutine foo + integer :: i + if (flag) then + do i = 1, OLDSIZE + deallocate (mytemp(i)%i) + end do + end if + call move_alloc(mytemp, myarray) + end subroutine + + subroutine bar + integer :: i + do i = 1, OLDSIZE + if (.not.flag .and. allocated (myarray(i)%i)) then + if (any (myarray(i)%i .ne. [1,2,3,4,5])) STOP 1 + else + if (.not.flag) STOP 2 + end if + end do + end subroutine +end program name +! { dg-final { scan-tree-dump-times "__builtin_malloc" 14 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } } Index: Fortran/gfortran/regression/move_alloc_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_16.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Tests the fix for PR67177 in which MOVE_ALLOC was not assigning the string +! length for deferred length characters. +! +! Contributed by +! +program str + implicit none + + type string + character(:), Allocatable :: text + end type string + + type strings + type(string), allocatable, dimension(:) :: strlist + end type strings + + type(strings) :: teststrs + type(string) :: tmpstr + integer :: strlen = 20 + + allocate (teststrs%strlist(1)) + allocate (character(len=strlen) :: tmpstr%text) + + allocate (character(len=strlen) :: teststrs%strlist(1)%text) + +! Full string reference was required because reallocation on assignment is +! functioning when it should not if the lhs is a substring - PR67977 + tmpstr%text(1:3) = 'foo' + + if (.not.allocated (teststrs%strlist(1)%text)) STOP 1 + if (len (tmpstr%text) .ne. strlen) STOP 2 + + call move_alloc(tmpstr%text,teststrs%strlist(1)%text) + + if (.not.allocated (teststrs%strlist(1)%text)) STOP 3 + if (len (teststrs%strlist(1)%text) .ne. strlen) STOP 4 + if (trim (teststrs%strlist(1)%text(1:3)) .ne. 'foo') STOP 5 + +! Clean up so that valgrind reports all allocated memory freed. + if (allocated (teststrs%strlist(1)%text)) deallocate (teststrs%strlist(1)%text) + if (allocated (teststrs%strlist)) deallocate (teststrs%strlist) +end program str Index: Fortran/gfortran/regression/move_alloc_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_17.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! The call to MOVE_ALLOC below caused a seg fault in runtime. +! This was discussed in: +! https://groups.google.com/forum/#!topic/comp.lang.fortran/ZVLqXFYDZ0M +! Richard Maine proposed that the code violated the restrictions on +! actual arguments in F2003 12.4.1.7 and so the fix asserts that the +! TO and FROM arguments cannot be the same object or subobjects thereof. +! +! +program test_move_alloc + type :: linked_list + type(linked_list), allocatable :: link + integer :: value + end type linked_list + type(linked_list) :: test + + allocate(test % link) + allocate(test % link % link) + call move_alloc(test % link, test % link % link) ! { dg-error "aliasing restrictions" } +end program test_move_alloc Index: Fortran/gfortran/regression/move_alloc_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_18.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Test that the anti-aliasing restriction does not knock out valid code. +! +! Contributed by Andrew Balwin on +! https://groups.google.com/forum/#!topic/comp.lang.fortran/oiXdl1LPb_s +! + PROGRAM TEST + IMPLICIT NONE + + TYPE FOOBAR + INTEGER, ALLOCATABLE :: COMP(:) + END TYPE + + TYPE (FOOBAR) :: MY_ARRAY(6) + + ALLOCATE (MY_ARRAY(1)%COMP(10)) + + CALL MOVE_ALLOC (MY_ARRAY(1)%COMP, MY_ARRAY(2)%COMP) + + END PROGRAM TEST Index: Fortran/gfortran/regression/move_alloc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_2.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR 45004: [OOP] Segfault with allocatable scalars and move_alloc +! +! Contributed by Salvatore Filippone + +program bug18 + + type foo + integer :: i + end type foo + + type bar + class(foo), allocatable :: bf + end type bar + + class(foo), allocatable :: afab + type(bar) :: bb + + allocate(foo :: afab) + afab%i = 8 + call move_alloc(afab, bb%bf) + if (.not. allocated(bb%bf)) STOP 1 + if (allocated(afab)) STOP 2 + if (bb%bf%i/=8) STOP 3 + +end program bug18 Index: Fortran/gfortran/regression/move_alloc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 44595: INTENT of arguments to intrinsic procedures not checked +! +! Contributed by Janus Weil + +subroutine test(f) + implicit none + integer, allocatable, intent(in) :: f + integer, allocatable :: t + call move_alloc(f,t) ! { dg-error "cannot be INTENT.IN." } +end subroutine Index: Fortran/gfortran/regression/move_alloc_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_4.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR 48700: memory leak with MOVE_ALLOC +! +! Contributed by Salvatore Filippone + +program testmv3 + type bar + integer, allocatable :: ia(:), ja(:) + end type + + block ! For auto-dealloc, as PROGRAM implies SAVE + type(bar), allocatable :: sm,sm2 + + allocate(sm) + allocate(sm%ia(10),sm%ja(10)) + + call move_alloc(sm2,sm) + end block +end program testmv3 + +! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } } Index: Fortran/gfortran/regression/move_alloc_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE +! +! Contributed by Salvatore Filippone + +program testmv1 + + type bar + end type + + type, extends(bar) :: bar2 + end type + + class(bar), allocatable :: sm + type(bar2), allocatable :: sm2 + + allocate (sm2) + call move_alloc (sm2,sm) + + if (allocated(sm2)) STOP 1 + if (.not. allocated(sm)) STOP 2 + +end program Index: Fortran/gfortran/regression/move_alloc_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_6.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Test move_alloc for polymorphic scalars +! +! +module myalloc + implicit none + + type :: base_type + integer :: i =2 + end type base_type + + type, extends(base_type) :: extended_type + integer :: j = 77 + end type extended_type +contains + subroutine myallocate (a) + class(base_type), allocatable, intent(inout) :: a + class(base_type), allocatable :: tmp + + allocate (extended_type :: tmp) + + select type(tmp) + type is(base_type) + STOP 1 + type is(extended_type) + if (tmp%i /= 2 .or. tmp%j /= 77) STOP 2 + tmp%i = 5 + tmp%j = 88 + end select + + select type(a) + type is(base_type) + if (a%i /= -44) STOP 3 + a%i = -99 + class default + STOP 4 + end select + + call move_alloc (from=tmp, to=a) + + select type(a) + type is(extended_type) + if (a%i /= 5) STOP 5 + if (a%j /= 88) STOP 6 + a%i = 123 + a%j = 9498 + class default + STOP 7 + end select + + if (allocated (tmp)) STOP 8 + end subroutine myallocate +end module myalloc + +program main + use myalloc + implicit none + class(base_type), allocatable :: a + + allocate (a) + + select type(a) + type is(base_type) + if (a%i /= 2) STOP 9 + a%i = -44 + class default + STOP 10 + end select + + call myallocate (a) + + select type(a) + type is(extended_type) + if (a%i /= 123) STOP 11 + if (a%j /= 9498) STOP 12 + class default + STOP 13 + end select +end program main Index: Fortran/gfortran/regression/move_alloc_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Check that move alloc handles different, type compatible +! declared types +! +type t +end type t +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: x +class(t2), allocatable :: y +allocate(y) +call move_alloc (y, x) +end Index: Fortran/gfortran/regression/move_alloc_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_8.f90 @@ -0,0 +1,104 @@ +! { dg-do compile } +! +! PR fortran/50684 +! +! Module "bug" contributed by Martin Steghöfer. +! + +MODULE BUG + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE POINTER_INTENT_IN_BUG_WORKING(POINTER_INTENT_IN_VARIABLE) + TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE + TYPE(MY_TYPE), POINTER :: POINTER_VARIABLE_LOCAL + INTEGER, ALLOCATABLE :: LOCAL_VALUE + + POINTER_VARIABLE_LOCAL=>POINTER_INTENT_IN_VARIABLE + CALL MOVE_ALLOC(POINTER_VARIABLE_LOCAL%VALUE, LOCAL_VALUE) + + RETURN + END SUBROUTINE POINTER_INTENT_IN_BUG_WORKING + + SUBROUTINE POINTER_INTENT_IN_BUG_FAILING(POINTER_INTENT_IN_VARIABLE) + TYPE(MY_TYPE), POINTER, INTENT(IN) :: POINTER_INTENT_IN_VARIABLE + INTEGER, ALLOCATABLE :: LOCAL_VALUE + + CALL MOVE_ALLOC(POINTER_INTENT_IN_VARIABLE%VALUE, LOCAL_VALUE) + + RETURN + END SUBROUTINE POINTER_INTENT_IN_BUG_FAILING +end module bug + +subroutine test1() + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE sub (dt) + type(MY_TYPE), intent(in) :: dt + INTEGER, ALLOCATABLE :: lv + call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." } + END SUBROUTINE +end subroutine test1 + +subroutine test2 (x, px) + implicit none + type t + integer, allocatable :: a + end type t + + type t2 + type(t), pointer :: ptr + integer, allocatable :: a + end type t2 + + type(t2), intent(in) :: x + type(t2), pointer, intent(in) :: px + + integer, allocatable :: a + type(t2), pointer :: ta + + call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" } + call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%ptr%a, a) ! OK (3) + call move_alloc (px%a, a) ! OK (4) + call move_alloc (px%ptr%a, a) ! OK (5) +end subroutine test2 + +subroutine test3 (x, px) + implicit none + type t + integer, allocatable :: a + end type t + + type t2 + class(t), pointer :: ptr + integer, allocatable :: a + end type t2 + + type(t2), intent(in) :: x + class(t2), pointer, intent(in) :: px + + integer, allocatable :: a + class(t2), pointer :: ta + + call move_alloc (px, ta) ! { dg-error "must be ALLOCATABLE" } + call move_alloc (x%a, a) ! { dg-error "cannot be INTENT.IN." } + call move_alloc (x%ptr%a, a) ! OK (6) + call move_alloc (px%a, a) ! OK (7) + call move_alloc (px%ptr%a, a) ! OK (8) +end subroutine test3 + +subroutine test4() + TYPE MY_TYPE + INTEGER, ALLOCATABLE :: VALUE + END TYPE +CONTAINS + SUBROUTINE sub (dt) + CLASS(MY_TYPE), intent(in) :: dt + INTEGER, ALLOCATABLE :: lv + call move_alloc(dt%VALUE, lv) ! { dg-error "cannot be INTENT.IN." } + END SUBROUTINE +end subroutine test4 Index: Fortran/gfortran/regression/move_alloc_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/move_alloc_9.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! +! Test diagnostic for MOVE_ALLOC: +! FROM=type, TO=class is OK +! FROM=class, TO=type is INVALID +! +module m2 + type, abstract :: t2 + contains + procedure(intf), deferred, nopass :: f + end type t2 + + interface + function intf() + import + class(t2), allocatable :: intf + end function intf + end interface +end module m2 + +module m3 + use m2 + type, extends(t2) :: t3 + contains + procedure,nopass :: f => my_f + end type t3 +contains + function my_f() + class(t2), allocatable :: my_f + end function my_f +end module m3 + +subroutine my_test +use m3 +type(t3), allocatable :: x +class(t2), allocatable :: y +call move_alloc (x, y) +end subroutine my_test + +program testmv1 + type bar + end type + + type, extends(bar) :: bar2 + end type + + class(bar), allocatable :: sm + type(bar2), allocatable :: sm2 + + allocate (sm2) + call move_alloc (sm,sm2) ! { dg-error "must be polymorphic if FROM is polymorphic" } + + if (allocated(sm2)) STOP 1 + if (.not. allocated(sm)) STOP 2 +end program Index: Fortran/gfortran/regression/multiple_allocation_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/multiple_allocation_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR 25031 - We didn't cause an error when allocating an already +! allocated array. +! +! This testcase has been modified to fix PR 49755. +program alloc_test + implicit none + integer :: i + integer, allocatable :: a(:) + integer, pointer :: b(:) + + allocate(a(4)) + ! This should set the stat code but not change the size. + allocate(a(3),stat=i) + if (i == 0) STOP 1 + if (.not. allocated(a)) STOP 2 + if (size(a) /= 4) STOP 3 + + ! It's OK to allocate pointers twice (even though this causes + ! a memory leak) + allocate(b(4)) + allocate(b(4)) +end program Index: Fortran/gfortran/regression/multiple_allocation_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/multiple_allocation_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 27470: This used fail because of confusion between +! mol (allocatable) and mol(1)%array(:) (pointer). +! Derived from a test case by FX Coudert. +PROGRAM MAIN + TYPE foo + INTEGER, DIMENSION(:), POINTER :: array + END TYPE foo + + type(foo),allocatable,dimension(:) :: mol + + ALLOCATE (mol(1)) + ALLOCATE (mol(1)%array(5)) + ALLOCATE (mol(1)%array(5)) + + END Index: Fortran/gfortran/regression/multiple_allocation_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/multiple_allocation_3.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 49755 - If allocating an already allocated array, and stat= +! is given, set stat to non zero and do not touch the array. +program test + integer, allocatable :: A(:, :) + integer :: stat + + allocate(A(20,20)) + A = 42 + + ! Allocate of already allocated variable + allocate (A(5,5), stat=stat) + + ! Expected: Error stat and previous allocation status + if (stat == 0) STOP 1 + if (any (shape (A) /= [20, 20])) STOP 2 + if (any (A /= 42)) STOP 3 +end program + Index: Fortran/gfortran/regression/mvbits_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! PR 25577 +! MVBITS didn't work correctly for integer types wider than a C int +! The testcase is based on the one Dale Ranta posted in the bug report +implicit none +integer(1) i1,j1 +integer(2) i2,j2 +integer(4) i4,j4 +integer(8) i8,j8 +integer ibits,n + +ibits=bit_size(1_1) +do n=1,ibits + i1=-1 + call mvbits(1_1, 0,n,i1,0) + j1=-1-2_1**n+2 + if(i1.ne.j1)STOP 1 +enddo +ibits=bit_size(1_2) +do n=1,ibits + i2=-1 + call mvbits(1_2, 0,n,i2,0) + j2=-1-2_2**n+2 + if(i2.ne.j2)STOP 2 +enddo +ibits=bit_size(1_4) +do n=1,ibits + i4=-1 + call mvbits(1_4, 0,n,i4,0) + j4=-1-2_4**n+2 + if(i4.ne.j4)STOP 3 +enddo +ibits=bit_size(1_8) +do n=1,ibits + i8=-1 + call mvbits(1_8, 0,n,i8,0) + j8=-1-2_8**n+2 + if(i8.ne.j8)STOP 4 +enddo +end Index: Fortran/gfortran/regression/mvbits_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_2.f90 @@ -0,0 +1,16 @@ +! Test for the MVBITS subroutine +! This used to fail on big-endian architectures (PR 32357) +! { dg-do run } + integer(kind=8) :: i8 = 0 + integer(kind=4) :: i4 = 0 + integer(kind=2) :: i2 = 0 + integer(kind=1) :: i1 = 0 + call mvbits (1_1, 0, 8, i1, 0) + if (i1 /= 1) STOP 1 + call mvbits (1_2, 0, 16, i2, 0) + if (i2 /= 1) STOP 2 + call mvbits (1_4, 0, 16, i4, 0) + if (i4 /= 1) STOP 3 + call mvbits (1_8, 0, 16, i8, 0) + if (i8 /= 1) STOP 4 + end Index: Fortran/gfortran/regression/mvbits_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/ +! +! The trans-*.c part of the compiler did no know +! that mvbits is an elemental function. +! +! Test case contributed by P.H. Lundow. +! +program main + implicit none + integer :: a( 2 ), b( 2 ) + integer :: x, y + + a = 1 + b = 0 + x = 1 + y = 0 + + call mvbits (a, 0, 1, b, 1) + call mvbits (x, 0, 1, y, 1) + +! write (*, *) 'a: ', a +! write (*, *) 'x: ', x +! write (*, *) +! write (*, *) 'b: ', b +! write (*, *) 'y: ', y +! write (*, *) + + if ( any (b /= y) ) STOP 1 +end program main Index: Fortran/gfortran/regression/mvbits_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_4.f90 @@ -0,0 +1,33 @@ +! { dg-do run } + +! PR fortran/35681 +! Check that dependencies of MVBITS arguments are resolved correctly by using +! temporaries if both arguments refer to the same variable. + + integer, dimension(10) :: ila1 = (/1,2,3,4,5,6,7,8,9,10/) + integer, dimension(20) :: ila2 + integer, dimension(10), target :: ila3 + integer, pointer :: ila3_ptr(:) + integer, parameter :: SHOULD_BE(10) = (/17,18,11,4,13,22,7,16,9,18/) + integer, parameter :: INDEX_VECTOR(10) = (/9,9,6,2,4,9,2,9,6,10/) + + ila2(2:20:2) = ila1 + ila3 = ila1 + + ! Argument is already packed. + call mvbits (ila1(INDEX_VECTOR), 2, 4, ila1, 3) + write (*,'(10(I3))') ila1 + if (any (ila1 /= SHOULD_BE)) STOP 1 + + ! Argument is not packed. + call mvbits (ila2(2*INDEX_VECTOR), 2, 4, ila2(2:20:2), 3) + write (*,'(10(I3))') ila2(2:20:2) + if (any (ila2(2:20:2) /= SHOULD_BE)) STOP 2 + + ! Pointer and target + ila3_ptr => ila3 + call mvbits (ila3(INDEX_VECTOR), 2, 4, ila3_ptr, 3) + write (*,'(10(I3))') ila3 + if (any (ila3 /= SHOULD_BE)) STOP 3 + + end Index: Fortran/gfortran/regression/mvbits_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run } + +! PR fortran/38887 +! This aborted at runtime for the runtime zero-sized array arguments. + +! Contributed by Dick Hendrickson + +program try_ya0013 + integer ida(9) + call ya0013(ida,1,5,6) +end program + +SUBROUTINE YA0013(IDA,nf1,nf5,nf6) + INTEGER IDA(9) + IDA = 1 + CALL MVBITS(IDA(NF5:NF1), 0, 1, IDA(NF6:NF1),2) +END SUBROUTINE Index: Fortran/gfortran/regression/mvbits_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_6.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! PR fortran/38883 +! This ICE'd because the temporary-creation in the MVBITS call was wrong. +! This is the original test from the PR, the complicated version. + +! Contributed by Dick Hendrickson + + module yg0009_stuff + + type unseq + integer I + end type + + contains + + SUBROUTINE YG0009(TDA2L,NF4,NF3,NF1,MF1,MF4,MF3) + TYPE(UNSEQ) TDA2L(NF4,NF3) + + CALL MVBITS (TDA2L(NF4:NF1:MF1,NF1:NF3)%I,2, & + 4, TDA2L(-MF4:-MF1:-NF1,-MF1:-MF3)%I, 3) + + END SUBROUTINE + + end module yg0009_stuff + + program try_yg0009 + use yg0009_stuff + type(unseq) tda2l(4,3) + + call yg0009(tda2l,4,3,1,-1,-4,-3) + + end Index: Fortran/gfortran/regression/mvbits_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_7.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + +! PR fortran/38883 +! This ICE'd because the temporary-creation in the MVBITS call was wrong. + +! Contributed by Paul Richard Thomas + + type t + integer :: I + character(9) :: chr + end type + type(t) :: x(4,3) + type(t) :: y(4,3) + x = reshape ([((t (i*j, "a"),i = 1,4), j=1,3)], [4,3]) + call foo (x) + y = reshape ([((t (i*j*2, "a"),i = 1,4), j=1,3)], [4,3]) + call bar(y, 4, 3, 1, -1, -4, -3) + if (any (x%i .ne. y%i)) STOP 1 +contains + SUBROUTINE foo (x) + TYPE(t) x(4, 3) ! No dependency at all + CALL MVBITS (x%i, 0, 6, x%i, 8) + x%i = x%i * 2 + END SUBROUTINE + SUBROUTINE bar (x, NF4, NF3, NF1, MF1, MF4, MF3) + TYPE(t) x(NF4, NF3) ! Dependency through variable indices + CALL MVBITS (x(NF4:NF1:MF1, NF1:NF3)%i, 1, & + 6, x(-MF4:-MF1:-NF1, -MF1:-MF3)%i, 9) + END SUBROUTINE +end + +! { dg-prune-output "reading \[0-9\]+ bytes from a region" } Index: Fortran/gfortran/regression/mvbits_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_8.f90 @@ -0,0 +1,36 @@ +! { dg-do run } + +! PR fortran/38883 +! This ICE'd because the temporary-creation in the MVBITS call was wrong. + +PROGRAM main + IMPLICIT NONE + + TYPE inner + INTEGER :: i + INTEGER :: j + END TYPE inner + + TYPE outer + TYPE(inner) :: comp(2) + END TYPE outer + + TYPE(outer) :: var + + var%comp%i = (/ 1, 2 /) + var%comp%j = (/ 3, 4 /) + + CALL foobar (var, 1, 2) + + IF (ANY (var%comp%i /= (/ 1, 2 /))) STOP 1 + IF (ANY (var%comp%j /= (/ 3, 4 /))) STOP 2 + +CONTAINS + + SUBROUTINE foobar (x, lower, upper) + TYPE(outer), INTENT(INOUT) :: x + INTEGER, INTENT(IN) :: lower, upper + CALL MVBITS (x%comp%i, 1, 2, x%comp(lower:upper)%i, 1) + END SUBROUTINE foobar + +END PROGRAM main Index: Fortran/gfortran/regression/mvbits_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/mvbits_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/44346 +! Original test sumbitted by Vittorio Zecca, zeccav at gmail dot com. +! Modified by Steven G. Kargl for dejagnu testsuite. +! +program a + integer :: n = 42 + ! 64 + 3 > bitsize(n) + call mvbits(n, 64, 3, n, 1) ! { dg-error "must be less than" } + ! 64 + 2 > bitsize(n) + call mvbits(n, 30, 2, n, 64) ! { dg-error "must be less than" } + ! LEN negative + call mvbits(n, 30, -2, n, 30) ! { dg-error "must be nonnegative" } + ! TOPOS negative + call mvbits(n, 30, 2, n, -3) ! { dg-error "must be nonnegative" } + ! FROMPOS negative + call mvbits(n, -1, 2, n, 3) ! { dg-error "must be nonnegative" } +end program a Index: Fortran/gfortran/regression/named_interface.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/named_interface.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 20363 +module snafu + interface foo + subroutine really_snafu (foo) + integer, intent (inout) :: foo + end subroutine really_snafu + end interface foo +end module snafu Index: Fortran/gfortran/regression/namelist_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! Check that private entities in public namelists are rejected +module namelist_1 + public + integer,private :: x + namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" } +end module Index: Fortran/gfortran/regression/namelist_11.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_11.f @@ -0,0 +1,55 @@ +c { dg-do run { target fd_truncate } } +c This program tests: namelist comment, a blank line before the nameilist name, the namelist name, +c a scalar qualifier, various combinations of space, comma and lf delimiters, f-formats, e-formats +c a blank line within the data read, nulls, a range qualifier, a new object name before end of data +c and an integer read. It also tests that namelist output can be re-read by namelist input. +c provided by Paul Thomas - pault@gcc.gnu.org + + program namelist_1 + + REAL x(10) + REAL(kind=8) xx + integer ier + namelist /mynml/ x, xx + + do i = 1 , 10 + x(i) = -1 + end do + x(6) = 6.0 + x(10) = 10.0 + xx = 0d0 + + open (10,status="scratch") + write (10, *) "!mynml" + write (10, *) "" + write (10, *) "&gf /" + write (10, *) "&mynml x(7) =+99.0e0 x=1.0, 2.0 ," + write (10, *) " 2*3.0, ,, 7.0e0,+0.08e+02 !comment" + write (10, *) "" + write (10, *) " 9000e-3 x(4:5)=4 ,5 " + write (10, *) " x=,,3.0, xx=10d0 /" + rewind (10) + + read (10, nml=mynml, IOSTAT=ier) + if (ier.ne.0) STOP 1 + rewind (10) + + do i = 1 , 10 + if ( abs( x(i) - real(i) ) .gt. 1e-8 ) STOP 2 + end do + if ( abs( xx - 10d0 ) .gt. 1e-8 ) STOP 3 + + write (10, nml=mynml, iostat=ier) + if (ier.ne.0) STOP 4 + rewind (10) + + read (10, NML=mynml, IOSTAT=ier) + if (ier.ne.0) STOP 5 + close (10) + + do i = 1 , 10 + if ( abs( x(i) - real(i) ) .gt. 1e-8 ) STOP 6 + end do + if ( abs( xx - 10d0 ) .gt. 1e-8 ) STOP 7 + + end program Index: Fortran/gfortran/regression/namelist_12.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_12.f @@ -0,0 +1,57 @@ +c{ dg-do run { target fd_truncate } } +c{ dg-options "-std=legacy" } +c +c This program repeats many of the same tests as test_nml_1 but for integer +c instead of real. It also tests repeat nulls, comma delimited character read, +c a triplet qualifier, a range with an assumed start, a quote delimited string, +c a qualifier with an assumed end and a fully explicit range. It also tests +c that integers and characters are successfully read back by namelist. +c Provided by Paul Thomas - pault@gcc.gnu.org + + program namelist_12 + + integer x(10) + integer(kind=8) xx + integer ier + character*10 ch , check + namelist /mynml/ x, xx, ch + +c set debug = 0 or 1 in the namelist! (line 33) + + do i = 1 , 10 + x(i) = -1 + end do + x(6) = 6 + x(10) = 10 + xx = 0 + ch ="zzzzzzzzzz" + check="abcdefghij" + + open (10,status="scratch", delim="apostrophe") + write (10, '(a)') "!mynml" + write (10, '(a)') " " + write (10, '(a)') "&mynml x(7) =+99 x=1, 2 ," + write (10, '(a)') " 2*3, ,, 2* !comment" + write (10, '(a)') " 9 ch='qqqdefghqq' , x(8:7:-1) = 8 , 7" + write (10, '(a)') " ch(:3) =""abc""," + write (10, '(a)') " ch(9:)='ij' x(4:5)=4 ,5 xx = 42/" + rewind (10) + + read (10, nml=mynml, IOSTAT=ier) + if (ier.ne.0) STOP 1 + rewind (10) + + write (10, nml=mynml, iostat=ier) + if (ier.ne.0) STOP 2 + rewind (10) + + read (10, NML=mynml, IOSTAT=ier) + if (ier.ne.0) STOP 3 + close (10) + + do i = 1 , 10 + if ( abs( x(i) - i ) .ne. 0 ) STOP 1 + if ( ch(i:i).ne.check(I:I) ) STOP 4 + end do + if (xx.ne.42) STOP 2 + end program Index: Fortran/gfortran/regression/namelist_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_13.f90 @@ -0,0 +1,38 @@ +!{ dg-do run } +! Tests simple derived types. +! Provided by Paul Thomas - pault@gcc.gnu.org + +program namelist_13 + + type :: yourtype + integer, dimension(2) :: yi = (/8,9/) + real, dimension(2) :: yx = (/80.,90./) + character(len=2) :: ych = "xx" + end type yourtype + + type :: mytype + integer, dimension(2) :: myi = (/800,900/) + real, dimension(2) :: myx = (/8000.,9000./) + character(len=2) :: mych = "zz" + type(yourtype) :: my_yourtype + end type mytype + + type(mytype) :: z + integer :: ier + integer :: zeros(10) + namelist /mynml/ zeros, z + + zeros = 0 + zeros(5) = 1 + + open(10,status="scratch", delim="apostrophe") + write (10, nml=mynml, iostat=ier) + if (ier.ne.0) STOP 1 + + rewind (10) + read (10, NML=mynml, IOSTAT=ier) + if (ier.ne.0) STOP 2 + close (10) + +end program namelist_13 + Index: Fortran/gfortran/regression/namelist_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_14.f90 @@ -0,0 +1,97 @@ +!{ dg-do run } +!{ dg-options "-std=legacy" } +! +! Tests various combinations of intrinsic types, derived types, arrays, +! dummy arguments and common to check nml_get_addr_expr in trans-io.c. +! See comments below for selection. +! provided by Paul Thomas - pault@gcc.gnu.org + +module global + type :: mt + sequence + integer :: ii(4) + end type mt +end module global + +program namelist_14 + use global + common /myc/ cdt + integer :: i(2) = (/101,201/) + type(mt) :: dt(2) + type(mt) :: cdt + real(kind=8) :: pi = 3.14159_8 + character*10 :: chs="singleton" + character*10 :: cha(2)=(/"first ","second "/) + + dt = mt ((/99,999,9999,99999/)) + cdt = mt ((/-99,-999,-9999,-99999/)) + call foo (i,dt,pi,chs,cha) + +contains + + logical function dttest (dt1, dt2) + use global + type(mt) :: dt1 + type(mt) :: dt2 + dttest = any(dt1%ii == dt2%ii) + end function dttest + + + subroutine foo (i, dt, pi, chs, cha) + use global + common /myc/ cdt + real(kind=8) :: pi !local real scalar + integer :: i(2) !dummy arg. array + integer :: j(2) = (/21, 21/) !equivalenced array + integer :: jj ! -||- scalar + integer :: ier + type(mt) :: dt(2) !dummy arg., derived array + type(mt) :: dtl(2) !in-scope derived type array + type(mt) :: dts !in-scope derived type + type(mt) :: cdt !derived type in common block + character*10 :: chs !dummy arg. character var. + character*10 :: cha(:) !dummy arg. character array + character*10 :: chl="abcdefg" !in-scope character var. + equivalence (j,jj) + namelist /z/ dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha + + dts = mt ((/1, 2, 3, 4/)) + dtl = mt ((/41, 42, 43, 44/)) + + open (10, status = "scratch", delim='apostrophe') + write (10, nml = z, iostat = ier) + if (ier /= 0 ) STOP 1 + rewind (10) + + i = 0 + j = 0 + jj = 0 + pi = 0 + dt = mt ((/0, 0, 0, 0/)) + dtl = mt ((/0, 0, 0, 0/)) + dts = mt ((/0, 0, 0, 0/)) + cdt = mt ((/0, 0, 0, 0/)) + chs = "" + cha = "" + chl = "" + + read (10, nml = z, iostat = ier) + if (ier /= 0 ) STOP 2 + close (10) + + if (.not.(dttest (dt(1), mt ((/99,999,9999,99999/))) .and. & + dttest (dt(2), mt ((/99,999,9999,99999/))) .and. & + dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and. & + dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and. & + dttest (dts, mt ((/1, 2, 3, 4/))) .and. & + dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. & + all (j ==(/21, 21/)) .and. & + all (i ==(/101, 201/)) .and. & + (pi == 3.14159_8) .and. & + (chs == "singleton") .and. & + (chl == "abcdefg") .and. & + (cha(1)(1:10) == "first ") .and. & + (cha(2)(1:10) == "second "))) STOP 3 + + end subroutine foo +end program namelist_14 Index: Fortran/gfortran/regression/namelist_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_15.f90 @@ -0,0 +1,63 @@ +!{ dg-do run } +! Tests arrays of derived types containing derived type arrays whose +! components are character arrays - exercises object name parser in +! list_read.c. Checks that namelist output can be reread. +! provided by Paul Thomas - pault@gcc.gnu.org + +module global + type :: mt + character(len=2) :: ch(2) = (/"aa","bb"/) + end type mt + type :: bt + integer :: i(2) = (/1,2/) + type(mt) :: m(2) + end type bt +end module global + +program namelist_15 + use global + type(bt) :: x(2) + + namelist /mynml/ x + + open (10, status = "scratch", delim='apostrophe') + write (10, '(A)') "&MYNML" + write (10, '(A)') " x = 3, 4, 'dd', 'ee', 'ff', 'gg'," + write (10, '(A)') " 4, 5, 'hh', 'ii', 'jj', 'kk'," + write (10, '(A)') " x(1)%i = , ," + write (10, '(A)') " x(2)%i = -3, -4" + write (10, '(A)') " x(2)%m(1)%ch(2)(1:1) ='q'," + write (10, '(A)') " x(2)%m(2)%ch(1)(1:1) ='w'," + write (10, '(A)') " x(1)%m(1)%ch(1:2)(2:2) = 'z','z'," + write (10, '(A)') " x(2)%m(1)%ch(1:2)(2:2) = 'z','z'," + write (10, '(A)') " x(1)%m(2)%ch(1:2)(2:2) = 'z','z'," + write (10, '(A)') " x(2)%m(2)%ch(1:2)(2:2) = 'z','z'," + write (10, '(A)') "/" + + rewind (10) + read (10, nml = mynml, iostat = ier) + if (ier .ne. 0) STOP 1 + close (10) + + open (10, status = "scratch", delim='apostrophe') + write (10, nml = mynml) + rewind (10) + + read (10, nml = mynml, iostat = ier) + if (ier .ne. 0) STOP 2 + close(10) + + if (.not. ((x(1)%i(1) == 3) .and. & + (x(1)%i(2) == 4) .and. & + (x(1)%m(1)%ch(1) == "dz") .and. & + (x(1)%m(1)%ch(2) == "ez") .and. & + (x(1)%m(2)%ch(1) == "fz") .and. & + (x(1)%m(2)%ch(2) == "gz") .and. & + (x(2)%i(1) == -3) .and. & + (x(2)%i(2) == -4) .and. & + (x(2)%m(1)%ch(1) == "hz") .and. & + (x(2)%m(1)%ch(2) == "qz") .and. & + (x(2)%m(2)%ch(1) == "wz") .and. & + (x(2)%m(2)%ch(2) == "kz"))) STOP 3 + +end program namelist_15 Index: Fortran/gfortran/regression/namelist_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_16.f90 @@ -0,0 +1,29 @@ +!{ dg-do run } +! Tests namelist on complex variables +! provided by Paul Thomas - pault@gcc.gnu.org +program namelist_16 + complex(kind=8), dimension(2) :: z + namelist /mynml/ z + z = (/(1.0,2.0), (3.0,4.0)/) + + open (10, status = "scratch") + write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /" + rewind (10) + + read (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 1 + close (10) + + open (10, status = "scratch") + write (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 2 + rewind (10) + + z = (/(1.0,2.0), (3.0,4.0)/) + read (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 3 + close (10) + + if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) STOP 4 + +end program namelist_16 Index: Fortran/gfortran/regression/namelist_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_17.f90 @@ -0,0 +1,30 @@ +!{ dg-do run } +! Tests namelist on logical variables +! provided by Paul Thomas - pault@gcc.gnu.org + +program namelist_17 + logical, dimension(2) :: l + namelist /mynml/ l + l = (/.true., .false./) + + open (10, status = "scratch") + write (10, '(A)') "&mynml l = F T /" + rewind (10) + + read (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 1 + close (10) + + open (10, status = "scratch") + write (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 2 + rewind (10) + + l = (/.true., .false./) + read (10, mynml, iostat = ier) + if (ier .ne. 0) STOP 3 + close (10) + + if (l(1) .or. (.not.l(2))) STOP 4 + +end program namelist_17 Index: Fortran/gfortran/regression/namelist_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_18.f90 @@ -0,0 +1,39 @@ +!{ dg-do run } +!{ dg-options "-std=legacy" } +! +! Tests character delimiters for namelist write +! provided by Paul Thomas - pault@gcc.gnu.org + +program namelist_18 + character*3 :: ch = "foo" + character*80 :: buffer + namelist /mynml/ ch + + open (10, status = "scratch") + write (10, mynml) + rewind (10) + read (10, '(a)', iostat = ier) buffer + read (10, '(a)', iostat = ier) buffer + if (ier .ne. 0) STOP 1 + close (10) + If ((buffer(6:6) /= "f") .or. (buffer(9:9) /= """")) STOP 2 + + open (10, status = "scratch", delim ="quote") + write (10, mynml) + rewind (10) + read (10, '(a)', iostat = ier) buffer + read (10, '(a)', iostat = ier) buffer + if (ier .ne. 0) STOP 3 + close (10) + If ((buffer(5:5) /= """") .or. (buffer(9:9) /= """")) STOP 4 + + open (10, status = "scratch", delim ="apostrophe") + write (10, mynml) + rewind (10) + read (10, '(a)', iostat = ier) buffer + read (10, '(a)', iostat = ier) buffer + if (ier .ne. 0) STOP 5 + close (10) + If ((buffer(5:5) /= "'") .or. (buffer(9:9) /= "'")) STOP 6 + +end program namelist_18 Index: Fortran/gfortran/regression/namelist_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_19.f90 @@ -0,0 +1,137 @@ +!{ dg-do run } +!{ dg-options "-std=legacy" } +! +! Test namelist error trapping. +! provided by Paul Thomas - pault@gcc.gnu.org + +program namelist_19 + character*80 wrong, right + +! "=" before any object name + wrong = "&z = i = 1,2 /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! &* instead of &end for termination + wrong = "&z i = 1,2 &xxx" + right = "&z i = 1,2 &end" + call test_err(wrong, right) + +! bad data + wrong = "&z i = 1,q /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! object name not matched + wrong = "&z j = 1,2 /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! derived type component for intrinsic type + wrong = "&z i%j = 1,2 /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! step other than 1 for substring qualifier + wrong = "&z ch(1:2:2) = 'a'/" + right = "&z ch(1:2) = 'ab' /" + call test_err(wrong, right) + +! qualifier for scalar + wrong = "&z k(2) = 1 /" + right = "&z k = 1 /" + call test_err(wrong, right) + +! no '=' after object name + wrong = "&z i 1,2 /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! repeat count too large + wrong = "&z i = 3*2 /" + right = "&z i = 2*2 /" + call test_err(wrong, right) + +! too much data + wrong = "&z i = 1 2 3 /" + right = "&z i = 1 2 /" + call test_err(wrong, right) + +! no '=' after object name + wrong = "&z i 1,2 /" + right = "&z i = 1,2 /" + call test_err(wrong, right) + +! bad number of index fields + wrong = "&z i(1,2) = 1 /" + right = "&z i(1) = 1 /" + call test_err(wrong, right) + +! bad character in index field + wrong = "&z i(x) = 1 /" + right = "&z i(1) = 1 /" + call test_err(wrong, right) + +! null index field + wrong = "&z i( ) = 1 /" + right = "&z i(1) = 1 /" + call test_err(wrong, right) + +! null index field + wrong = "&z i(1::) = 1 2/" + right = "&z i(1:2:1) = 1 2 /" + call test_err(wrong, right) + +! null index field + wrong = "&z i(1:2:) = 1 2/" + right = "&z i(1:2:1) = 1 2 /" + call test_err(wrong, right) + +! index out of range + wrong = "&z i(10) = 1 /" + right = "&z i(1) = 1 /" + call test_err(wrong, right) + +! index out of range + wrong = "&z i(0:1) = 1 /" + right = "&z i(1:1) = 1 /" + call test_err(wrong, right) + +! bad range + wrong = "&z i(1:2:-1) = 1 2 /" + right = "&z i(1:2: 1) = 1 2 /" + call test_err(wrong, right) + +! bad range + wrong = "&z i(2:1: 1) = 1 2 /" + right = "&z i(2:1:-1) = 1 2 /" + call test_err(wrong, right) + +contains + subroutine test_err(wrong, right) + character*80 wrong, right + integer :: i(2) = (/0, 0/) + integer :: k =0 + character*2 :: ch = " " + namelist /z/ i, k, ch + +! Check that wrong namelist input gives an error + + open (10, status = "scratch") + write (10, '(A)') wrong + rewind (10) + read (10, z, iostat = ier) + close(10) + if (ier == 0) STOP 1 + +! Check that right namelist input gives no error + + open (10, status = "scratch") + write (10, '(A)') right + rewind (10) + read (10, z, iostat = ier) + close(10) + if (ier /= 0) STOP 2 + end subroutine test_err + +end program namelist_19 Index: Fortran/gfortran/regression/namelist_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! Check that variable with intent(in) cannot be a member of a namelist +subroutine namelist_2(x) + integer,intent(in) :: x + namelist /n/ x + read(*,n) ! { dg-error "is INTENT" } +end subroutine namelist_2 Index: Fortran/gfortran/regression/namelist_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_20.f90 @@ -0,0 +1,35 @@ +!{ dg-do run } +! Tests namelist io for an explicit shape array with negative bounds +! provided by Paul Thomas - pault@gcc.gnu.org + +program namelist_20 + integer, dimension (-4:-2) :: x + integer :: i, ier + namelist /a/ x + + open (10, status = "scratch") + write (10, '(A)') "&a x(-5)=0 /" !-ve index below lbound + write (10, '(A)') "&a x(-1)=0 /" !-ve index above ubound + write (10, '(A)') "&a x(1:2)=0 /" !+ve indices + write (10, '(A)') "&a x(-4:-2)= -4,-3,-2 /" !correct + write (10, '(A)') " " + rewind (10) + + ier=0 + read(10, a, iostat=ier) + if (ier == 0) STOP 1 + ier=0 + read(10, a, iostat=ier) + if (ier == 0) STOP 2 + ier=0 + read(10, a, iostat=ier) + if (ier == 0) STOP 3 + + ier=0 + read(10, a, iostat=ier) + if (ier /= 0) STOP 4 + do i = -4,-2 + if (x(i) /= i) STOP 5 + end do + +end program namelist_20 Index: Fortran/gfortran/regression/namelist_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_21.f90 @@ -0,0 +1,43 @@ +!{ dg-do run { target fd_truncate } } +!{ dg-options "-std=legacy" } +! +! Tests filling arrays from a namelist read when object list is not complete. +! Developed from a test case provided by Christoph Jacob. +! Contributed by Jerry DeLisle . +program pr24794 + + implicit none + integer, parameter :: maxop=15, iunit=7 + character*8 namea(maxop), nameb(maxop) + integer i, ier + + namelist/ccsopr/ namea,nameb + namea="" + nameb="" + open (12, status="scratch", delim="apostrophe") + write (12, '(a)') "&ccsopr" + write (12, '(a)') " namea='spi01h','spi02o','spi03h','spi04o','spi05h'," + write (12, '(a)') " 'spi07o','spi08h','spi09h'," + write (12, '(a)') " nameb='spi01h','spi03h','spi05h','spi06h','spi08h'," + write (12, '(a)') "&end" + + rewind (12) + read (12, nml=ccsopr, iostat=ier) + if (ier.ne.0) STOP 1 + + rewind (12) + write(12,nml=ccsopr) + + rewind (12) + read (12, nml=ccsopr, iostat=ier) + if (ier.ne.0) STOP 2 + + if (namea(2).ne."spi02o ") STOP 3 + if (namea(9).ne." ") STOP 4 + if (namea(15).ne." ") STOP 5 + if (nameb(1).ne."spi01h ") STOP 6 + if (nameb(6).ne." ") STOP 7 + if (nameb(15).ne." ") STOP 8 + + close (12) +end program pr24794 Index: Fortran/gfortran/regression/namelist_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_22.f90 @@ -0,0 +1,43 @@ +!{ dg-do run { target fd_truncate } } +!{ dg-options "-std=legacy" } +! +! Tests filling arrays from a namelist read when object list is not complete. +! This is the same as namelist_21.f90 except using spaces as seperators instead +! of commas. Developed from a test case provided by Christoph Jacob. +! Contributed by Jerry DeLisle . +program pr24794 + + implicit none + integer, parameter :: maxop=15, iunit=7 + character*8 namea(maxop), nameb(maxop) + integer i, ier + + namelist/ccsopr/ namea,nameb + namea="" + nameb="" + open (12, status="scratch", delim="apostrophe") + write (12, '(a)') "&ccsopr" + write (12, '(a)') " namea='spi01h' 'spi02o' 'spi03h' 'spi04o' 'spi05h'" + write (12, '(a)') " 'spi07o' 'spi08h' 'spi09h'" + write (12, '(a)') " nameb='spi01h' 'spi03h' 'spi05h' 'spi06h' 'spi08h'" + write (12, '(a)') "&end" + + rewind (12) + read (12, nml=ccsopr, iostat=ier) + if (ier.ne.0) STOP 1 + + rewind (12) + write(12,nml=ccsopr) + + rewind (12) + read (12, nml=ccsopr, iostat=ier) + if (ier.ne.0) STOP 2 + if (namea(2).ne."spi02o ") STOP 3 + if (namea(9).ne." ") STOP 4 + if (namea(15).ne." ") STOP 5 + if (nameb(1).ne."spi01h ") STOP 6 + if (nameb(6).ne." ") STOP 7 + if (nameb(15).ne." ") STOP 8 + + close (12) +end program pr24794 Index: Fortran/gfortran/regression/namelist_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_23.f90 @@ -0,0 +1,53 @@ +!{ dg-do run { target fd_truncate } } +! PR26136 Filling logical variables from namelist read when object list is not +! complete. Test case derived from PR. +! Contributed by Jerry DeLisle +program read_logical + implicit none + logical, dimension(4) :: truely + integer, dimension(4) :: truely_a_very_long_variable_name + namelist /mynml/ truely + namelist /mynml/ truely_a_very_long_variable_name + + truely = .false. + truely_a_very_long_variable_name = 0 + + open(10, status="scratch") + write(10,*) "&mynml" + write(10,*) "truely = trouble, traffic .true" + write(10,*) "truely_a_very_long_variable_name = 4, 4, 4" + write(10,*) "/" + rewind(10) + read (10, nml=mynml, err = 1000) + if (.not.all(truely(1:3))) STOP 1 + if (.not.all(truely_a_very_long_variable_name(1:3).eq.4)) STOP 2 + + truely = .false. + truely_a_very_long_variable_name = 0 + + rewind(10) + write(10,*) "&mynml" + write(10,*) "truely = .true., .true.," + write(10,*) "truely_a_very_long_variable_name = 4, 4, 4" + write(10,*) "/" + rewind(10) + read (10, nml=mynml, err = 1000) + if (.not.all(truely(1:2))) STOP 3 + if (.not.all(truely_a_very_long_variable_name(1:3).eq.4)) STOP 4 + + truely = .true. + truely_a_very_long_variable_name = 0 + + rewind(10) + write(10,*) "&mynml" + write(10,*) "truely = .false., .false.," + write(10,*) "truely_a_very_long_variable_name = 4, 4, 4" + write(10,*) "/" + rewind(10) + read (10, nml=mynml, err = 1000) + if (all(truely(1:2))) STOP 5 + if (.not.all(truely_a_very_long_variable_name(1:3).eq.4)) STOP 6 + close(10) + stop +1000 STOP 7 +end program read_logical Index: Fortran/gfortran/regression/namelist_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_24.f90 @@ -0,0 +1,42 @@ +!{ dg-do run } +!{ dg-options -std=gnu } +! Tests namelist read when more data is provided then specified by +! array qualifier in list. +! Contributed by Jerry DeLisle . + program pr24459 + implicit none + integer nd, ier, i, j + parameter ( nd = 5 ) + character*(8) names(nd,nd) + character*(8) names2(nd,nd) + character*(8) names3(nd,nd) + namelist / mynml / names, names2, names3 + open(unit=20,status='scratch', delim='apostrophe') + write (20, '(a)') "&MYNML" + write (20, '(a)') "NAMES = 25*'0'" + write (20, '(a)') "NAMES2 = 25*'0'" + write (20, '(a)') "NAMES3 = 25*'0'" + write (20, '(a)') "NAMES(2,2) = 'frogger'" + write (20, '(a)') "NAMES(1,1) = 'E123' 'E456' 'D789' 'P135' 'P246'" + write (20, '(a)') "NAMES2(1:5:2,2) = 'abcde' 'fghij' 'klmno'" + write (20, '(a)') "NAMES3 = 'E123' 'E456' 'D789' 'P135' 'P246' '0' 'frogger'" + write (20, '(a)') "/" + rewind(20) + read(20,nml=mynml, iostat=ier) + if (ier.ne.0) STOP 1 + if (any(names(:,3:5).ne."0")) STOP 2 + if (names(2,2).ne."frogger") STOP 3 + if (names(1,1).ne."E123") STOP 4 + if (names(2,1).ne."E456") STOP 5 + if (names(3,1).ne."D789") STOP 6 + if (names(4,1).ne."P135") STOP 7 + if (names(5,1).ne."P246") STOP 8 + if (any(names2(:,1).ne."0")) STOP 9 + if (any(names2(:,3:5).ne."0")) STOP 10 + if (names2(1,2).ne."abcde") STOP 11 + if (names2(2,2).ne."0") STOP 12 + if (names2(3,2).ne."fghij") STOP 13 + if (names2(4,2).ne."0") STOP 14 + if (names2(5,2).ne."klmno") STOP 15 + if (any(names3.ne.names)) STOP 16 + end Index: Fortran/gfortran/regression/namelist_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_25.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Tests patch for PR29407, in which the declaration of 'my' as +! a local variable was ignored, so that the procedure and namelist +! attributes for 'my' clashed.. +! +! Contributed by Tobias Burnus +! +program main + implicit none +contains + subroutine my + end subroutine my + subroutine bar + integer :: my + namelist /ops/ my + end subroutine bar +end program main + Index: Fortran/gfortran/regression/namelist_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_26.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! PR30918 Failure to skip commented out NAMELIST +! Before the patch, this read the commented out namelist and iuse would +! equal 2 when done. Test case from PR. +program gfcbug58 + implicit none + integer :: iuse = 0, ios + integer, parameter :: nmlunit = 10 ! Namelist unit + !------------------ + ! Namelist 'REPORT' + !------------------ + character(len=12) :: type, use + integer :: max_proc + namelist /REPORT/ type, use, max_proc + !------------------ + ! Set up the test file + !------------------ + open(unit=nmlunit, status="scratch") + write(nmlunit, '(a)') "!================" + write(nmlunit, '(a)') "! Namelist REPORT" + write(nmlunit, '(a)') "!================" + write(nmlunit, '(a)') "! &REPORT use = 'ignore' / ! Comment" + write(nmlunit, '(a)') "!" + write(nmlunit, '(a)') " &REPORT type = 'SYNOP'" + write(nmlunit, '(a)') " use = 'active'" + write(nmlunit, '(a)') " max_proc = 20" + write(nmlunit, '(a)') " /" + rewind(nmlunit) + !------------------------------------- + ! Loop to read namelist multiple times + !------------------------------------- + do + !---------------------------------------- + ! Preset namelist variables with defaults + !---------------------------------------- + type = '' + use = '' + max_proc = -1 + !-------------- + ! Read namelist + !-------------- + read (nmlunit, nml=REPORT, iostat=ios) + if (ios /= 0) exit + iuse = iuse + 1 + end do + if (iuse /= 1) STOP 1 + +end program gfcbug58 Index: Fortran/gfortran/regression/namelist_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_27.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF. +! Patch derived from PR, submitted by Jerry DeLisle +program gfcbug61 + implicit none + integer :: stat + + open (12, status="scratch") + write (12, '(a)')"!================" + write (12, '(a)')"! Namelist REPORT" + write (12, '(a)')"!================" + write (12, '(a)')" &REPORT type = 'SYNOP' " + write (12, '(a)')" use = 'active'" + write (12, '(a)')" max_proc = 20" + write (12, '(a)')" /" + write (12, '(a)')"! Other namelists..." + write (12, '(a)')" &OTHER i = 1 /" + rewind (12) + + ! Read /REPORT/ the first time + rewind (12) + call position_nml (12, "REPORT", stat) + if (stat.ne.0) STOP 1 + if (stat == 0) call read_report (12, stat) + + ! Comment out the following lines to hide the bug + rewind (12) + call position_nml (12, "MISSING", stat) + if (stat.ne.-1) STOP 2 + + ! Read /REPORT/ again + rewind (12) + call position_nml (12, "REPORT", stat) + if (stat.ne.0) STOP 3 + +contains + + subroutine position_nml (unit, name, status) + ! Check for presence of namelist 'name' + integer :: unit, status + character(len=*), intent(in) :: name + + character(len=255) :: line + integer :: ios, idx, k + logical :: first + + first = .true. + status = 0 + ios = 0 + line = "" + do k=1,10 + read (unit,'(a)',iostat=ios) line + if (first) then + first = .false. + end if + if (ios < 0) then + ! EOF encountered! + backspace (unit) + status = -1 + return + else if (ios > 0) then + ! Error encountered! + status = +1 + return + end if + idx = index (line, "&"//trim (name)) + if (idx > 0) then + backspace (unit) + return + end if + end do + end subroutine position_nml + + subroutine read_report (unit, status) + integer :: unit, status + + integer :: iuse, ios, k + !------------------ + ! Namelist 'REPORT' + !------------------ + character(len=12) :: type, use + integer :: max_proc + namelist /REPORT/ type, use, max_proc + !------------------------------------- + ! Loop to read namelist multiple times + !------------------------------------- + iuse = 0 + do k=1,5 + !---------------------------------------- + ! Preset namelist variables with defaults + !---------------------------------------- + type = '' + use = '' + max_proc = -1 + !-------------- + ! Read namelist + !-------------- + read (unit, nml=REPORT, iostat=ios) + if (ios /= 0) exit + iuse = iuse + 1 + end do + if (iuse.ne.1) STOP 4 + status = ios + end subroutine read_report + +end program gfcbug61 Index: Fortran/gfortran/regression/namelist_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_28.f90 @@ -0,0 +1,92 @@ +! { dg-do run } +! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF. +! Patch derived from PR, submitted by Jerry DeLisle +program gfcbug61 + implicit none + integer, parameter :: nmlunit = 12 ! Namelist unit + integer :: stat + + open (nmlunit, status="scratch") + write(nmlunit, '(a)') "&REPORT type='report1' /" + write(nmlunit, '(a)') "&REPORT type='report2' /" + write(nmlunit, '(a)') "!" + rewind (nmlunit) + +! The call to position_nml is contained in the subroutine + call read_report (nmlunit, stat) + rewind (nmlunit) + call position_nml (nmlunit, 'MISSING', stat) + rewind (nmlunit) + call read_report (nmlunit, stat) ! gfortran fails here + +contains + + subroutine position_nml (unit, name, status) + ! Check for presence of namelist 'name' + integer :: unit, status + character(len=*), intent(in) :: name + + character(len=255) :: line + integer :: ios, idx, k + logical :: first + + first = .true. + status = 0 + do k=1,25 + line = "" + read (unit,'(a)',iostat=ios) line + if (ios < 0) then + ! EOF encountered! + backspace (unit) + status = -1 + return + else if (ios > 0) then + ! Error encountered! + status = +1 + return + end if + idx = index (line, "&"//trim (name)) + if (idx > 0) then + backspace (unit) + return + end if + end do + if (k.gt.10) STOP 1 + end subroutine position_nml + + subroutine read_report (unit, status) + integer :: unit, status + + integer :: iuse, ios, k + !------------------ + ! Namelist 'REPORT' + !------------------ + character(len=12) :: type + namelist /REPORT/ type + !------------------------------------- + ! Loop to read namelist multiple times + !------------------------------------- + iuse = 0 + do k=1,25 + !---------------------------------------- + ! Preset namelist variables with defaults + !---------------------------------------- + type = '' + !-------------- + ! Read namelist + !-------------- + call position_nml (unit, "REPORT", status) + if (stat /= 0) then + ios = status + if (iuse /= 2) STOP 1 + return + end if + read (unit, nml=REPORT, iostat=ios) + if (ios /= 0) exit + iuse = iuse + 1 + end do + if (k.gt.10) STOP 2 + status = ios + end subroutine read_report + +end program gfcbug61 Index: Fortran/gfortran/regression/namelist_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_29.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Checks the fix for PR30878, in which the inclusion +! of an implicit function result variable in a namelist +! would cause an error. +! +! Contributed by Joost VandeVondele +! + character(80) :: buffer + if (f1 (buffer) .ne. 42) STOP 1 +CONTAINS + INTEGER FUNCTION F1 (buffer) + NAMELIST /mynml/ F1 + integer :: check + character(80) :: buffer + F1 = 42 + write (buffer, nml = mynml) + F1 = 0 + READ (buffer, nml = mynml) + end function +END Index: Fortran/gfortran/regression/namelist_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_3.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Check that a pointer cannot be a member of a namelist +program namelist_3 + integer,pointer :: x + allocate (x) + namelist /n/ x ! { dg-error "NAMELIST attribute conflicts with POINTER attribute" } +end program namelist_3 Index: Fortran/gfortran/regression/namelist_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_30.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/32710 - ICE: namelist and subroutine with the same name +! +! Contributed by Janus Weil +! + +program x +contains + subroutine readInput + integer:: a + NAMELIST /foo/ a + read(5,nml=foo) + end subroutine readInput + + subroutine foo() + end subroutine + +end program Index: Fortran/gfortran/regression/namelist_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_31.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! One of two tests for the fix of PR23152 - There used to be +! no warning for assumed shape arrays in namelists. +! +! Conributed by Paul Thomas +! +program assumed_shape_nml + real, dimension (10) :: z + z = 42.0 + call foo (z) +contains + subroutine foo (y) + real, DIMENSION (:) :: y + namelist /mynml/ y + write (*, mynml) + end subroutine foo +end program assumed_shape_nml Index: Fortran/gfortran/regression/namelist_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_32.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! One of two tests for the fix of PR23152 - An ICE would +! ensue from assumed shape arrays in namelists. +! +! Conributed by Paul Thomas +! +program assumed_size_nml + real, dimension (10) :: z + z = 42.0 + call foo (z) +contains + subroutine foo (y) + real, DIMENSION (*) :: y + namelist /mynml/ y ! { dg-error "is not allowed" } + write (6, mynml) + end subroutine foo +end program assumed_size_nml \ No newline at end of file Index: Fortran/gfortran/regression/namelist_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_33.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! +! PR fortran/32876 - accepts private items in public NAMELISTs +! +! USE-associated types with private components may +! not be used in namelists -- anywhere. +! +MODULE types + type :: tp4 + PRIVATE + real :: x + integer :: i + end type + + ! nested type + type :: tp3 + real :: x + integer, private :: i + end type + + type :: tp2 + type(tp3) :: t + end type + + type :: tp1 + integer :: i + type(tp2) :: t + end type +END MODULE + +MODULE nml + USE types + + type(tp1) :: t1 + type(tp4) :: t4 + + namelist /a/ t1 ! { dg-error "use-associated PRIVATE components" } + namelist /b/ t4 ! { dg-error "use-associated PRIVATE components" } + + integer, private :: i + namelist /c/ i ! { dg-error "was declared PRIVATE and cannot be member of PUBLIC namelist" } + +contains + subroutine y() + type(tp2) :: y2 + type(tp3) :: y3 + + namelist /nml2/ y2 ! { dg-error "has use-associated PRIVATE components " } + namelist /nml3/ y3 ! { dg-error "has use-associated PRIVATE components " } + end subroutine +END MODULE + + +program xxx + use types + + type :: tp5 + TYPE(tp4) :: t ! nested private components + end type + type(tp5) :: t5 + + namelist /nml/ t5 ! { dg-error "has use-associated PRIVATE components" } + +contains + subroutine z() + namelist /nml2/ t5 ! { dg-error "has use-associated PRIVATE components" } + end subroutine +end program Index: Fortran/gfortran/regression/namelist_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_34.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! PR fortran/32905 - accepts types with ultimate POINTER components +! updated for PR78659 +MODULE types + type :: tp3 + real :: x + integer, pointer :: i + end type + + type :: tp2 + type(tp3) :: t + end type + + type :: tp1 + integer :: i + type(tp2) :: t + end type +END MODULE + +MODULE nml +USE types + type(tp1) :: t1 + type(tp3) :: t3 +! The following are allowed under f2003. + namelist /a/ t1 ! { dg-error "with ALLOCATABLE or POINTER components" } + namelist /b/ t3 ! { dg-error "with ALLOCATABLE or POINTER components" } +END MODULE Index: Fortran/gfortran/regression/namelist_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_35.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/31818 - accepts namelists with assumed-shape arrays +! + +subroutine test(cha) + implicit none + character(len=10) :: cha(:) + namelist /z/ cha ! { dg-error "with assumed shape in namelist" } +end subroutine test Index: Fortran/gfortran/regression/namelist_36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_36.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Private types and types with private components +! are acceptable in local namelists. +! + +MODULE nml + type :: tp1 + integer :: i + end type + + type :: tp2 + private + integer :: i + end type + + private :: tp1 +contains + subroutine x() + type(tp1) :: t1 + type(tp2) :: t2 + + namelist /nml1/ i ! ok, private variable + namelist /nml2/ t1 ! ok, private type + namelist /nml3/ t2 ! ok, private components + end subroutine +END MODULE Index: Fortran/gfortran/regression/namelist_37.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_37.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR33039 Read NAMELIST: reads wrong namelist name +! Test case from PR modified by Jerry DeLisle +PROGRAM namelist +CHARACTER*25 CHAR +NAMELIST /CODE/ CHAR, X +NAMELIST /CODEtwo/ X + +OPEN(10, status="scratch") +write(10,'(a)') "File with test NAMELIST inputs" +write(10,'(a)') " &CODVJS char='VJS-Not a proper nml name', X=-0.5/" +write(10,'(a)') " &CODEone char='CODEone input', X=-1.0 /" +write(10,'(a)') " &CODEtwo char='CODEtwo inputs', X=-2.0/" +write(10,'(a)') " &code char='Lower case name',X=-3.0/" +write(10,'(a)') " &CODE char='Desired namelist sel', X=44./" +write(10,'(a)') " &CODEx char='Should not read CODEx nml', X=-5./" +write(10,'(a)') " $CODE char='Second desired nml', X=66.0 /" +write(10,'(a)') " $CODE X=77.0, char='Reordered desired nml'/" +rewind(10) +CHAR = 'Initialize string ***' +X = -777. +READ(10, nml=CODE, END=999) +if (x.ne.-3.0) STOP 1 +READ(10, nml=CODE, END=999) +if (x.ne.44.0) STOP 2 +READ(10, nml=CODE, END=999) +if (x.ne.66.0) STOP 3 +READ(10, nml=CODE, END=999) + 999 if (x.ne.77.0) STOP 1 +END PROGRAM namelist Index: Fortran/gfortran/regression/namelist_38.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_38.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! PR33253 namelist: reading back a string, also fixed writing with delimiters. +! Test case modified from that of the PR by +! Jerry DeLisle +program main + implicit none + character(len=3) :: a + character(25) :: b + namelist /foo/ a + + open(10, status="scratch", delim="quote") + a = 'a"a' + write(10,foo) + rewind 10 + a = "" + read (10,foo) ! This gave a runtime error before the patch. + if (a.ne.'a"a') STOP 1 + close (10) + + open(10, status="scratch", delim="apostrophe") + a = "a'a" + write(10,foo) + rewind 10 + a = "" + read (10,foo) + if (a.ne."a'a") STOP 2 + close (10) + + open(10, status="scratch", delim="none") + a = "a'a" + write(10,foo) + rewind (10) + read(10,"(a)") b + if (b .ne. "&FOO") STOP 3 + read(10,"(a)") b + if (b .ne. " A=a'a") STOP 4 + read(10,"(a)") b + if (b .ne. " /") STOP 5 + close(10) +end program main Index: Fortran/gfortran/regression/namelist_39.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_39.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR33421 and PR33253 Weird quotation of namelist output of character arrays +! Test case from Toon Moone, adapted by Jerry DeLisle + +! Long names used to test line_buffer feature is working. + +program test +implicit none +character(len=45) :: b01234567890123456789012345678901234567890123456789012345678901(3) +namelist /nam/ b01234567890123456789012345678901234567890123456789012345678901 +b01234567890123456789012345678901234567890123456789012345678901 = 'x' +open(99, status="scratch") +write(99,'(4(a,/),a)') "&NAM", & + " b01234567890123456789012345678901234567890123456789012345678901(1)=' AAP NOOT MIES WIM ZUS JET',", & + " b01234567890123456789012345678901234567890123456789012345678901(2)='SURF.PRESSURE',", & + " b01234567890123456789012345678901234567890123456789012345678901(3)='APEKOOL',", & + " /" +rewind(99) +read(99,nml=nam) +close(99) + +if (b01234567890123456789012345678901234567890123456789012345678901(1).ne.& + " AAP NOOT MIES WIM ZUS JET ") STOP 1 +if (b01234567890123456789012345678901234567890123456789012345678901(2).ne.& + "SURF.PRESSURE ") STOP 2 +if (b01234567890123456789012345678901234567890123456789012345678901(3).ne.& + "APEKOOL ") STOP 3 +end program test + Index: Fortran/gfortran/regression/namelist_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_4.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! This tests the fix for PR25089 in which it was noted that a +! NAMELIST member that is an internal(or module) procedure gave +! no error if the NAMELIST declaration appeared before the +! procedure declaration. Not mentioned in the PR is that any +! reference to the NAMELIST object would cause a segfault. +! +! Based on the contribution from Joost VanderVondele +! +module M1 +CONTAINS +! This is the original PR + INTEGER FUNCTION G1() + NAMELIST /NML1/ G2 ! { dg-error "PROCEDURE attribute conflicts" } + G1=1 + END FUNCTION + INTEGER FUNCTION G2() + G2=1 + END FUNCTION +! This has always been picked up - namelist after function + INTEGER FUNCTION G3() + NAMELIST /NML2/ G1 ! { dg-error "PROCEDURE attribute conflicts" } + G3=1 + END FUNCTION +END module M1 + +program P1 +implicit none +CONTAINS +! This has the additional wrinkle of a reference to the object. + INTEGER FUNCTION F1() + NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" } +! Used to ICE here + f2 = 1 ! { dg-error "is not a VALUE" } + F1=1 + END FUNCTION + INTEGER FUNCTION F2() + F2=1 + END FUNCTION +END + Index: Fortran/gfortran/regression/namelist_40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_40.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR33672 Additional runtime checks needed for namelist reads +! Submitted by Jerry DeLisle + +module global + type :: mt + character(len=2) :: ch(2) = (/"aa","bb"/) + end type mt + type :: bt + integer :: i(2) = (/1,2/) + type(mt) :: m(2) + end type bt +end module global + +program namelist_40 + use global + type(bt) :: x(2) + character(40) :: teststring + namelist /mynml/ x + + teststring = " x(2)%m%ch(:)(2:2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%ch(:)(2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%ch(:)(:3) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%ch(1:2)(k:) = 'z','z'," + call writenml (teststring) + +contains + +subroutine writenml (astring) + character(40), intent(in) :: astring + character(300) :: errmessage + integer :: ierror + + open (10, status="scratch", delim='apostrophe') + write (10, '(A)') "&MYNML" + write (10, '(A)') astring + write (10, '(A)') "/" + rewind (10) + read (10, nml = mynml, iostat=ierror, iomsg=errmessage) + if (ierror == 0) STOP 1 + print '(a)', trim(errmessage) + close (10) + +end subroutine writenml + +end program namelist_40 +! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%ch(\r*\n+)" } +! { dg-output "Missing colon in substring qualifier for namelist variable x%m%ch(\r*\n+)" } +! { dg-output "Substring out of range for namelist variable x%m%ch(\r*\n+)" } +! { dg-output "Bad character in substring qualifier for namelist variable x%m%ch(\r*\n+)" } Index: Fortran/gfortran/regression/namelist_41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_41.f90 @@ -0,0 +1,22 @@ +! { dg-do run { target fd_truncate } } +! PR34291 Segfault on &end in namelist expanded read of character + implicit none + character(len=10), dimension(2) :: var + namelist /inx/ var + var = "goodbye" + open(unit=11, status='scratch') + write (11, *) "&inx" + write (11, *) "var(1)='hello'" + write (11, *) "&end" + rewind (11) + read(11,nml=inx) + if (var(1) /= 'hello' .and. var(2) /= 'goodbye') STOP 1 + var = "goodbye" + rewind (11) + write (11, *) "$inx" + write (11, *) "var(1)='hello'" + write (11, *) "$end" + rewind (11) + read(11,nml=inx) + if (var(1) /= 'hello' .and. var(2) /= 'goodbye') STOP 2 +end Index: Fortran/gfortran/regression/namelist_42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_42.f90 @@ -0,0 +1,47 @@ +! { dg-do run { target fd_truncate } } +! { dg-add-options ieee } +! +! PR fortran/34427 +! +! Check that namelists and the real values Inf, NaN, Infinity +! properly coexist. +! + PROGRAM TEST + IMPLICIT NONE + real , DIMENSION(11) ::foo + integer :: infinity + NAMELIST /nl/ foo + NAMELIST /nl/ infinity + foo = -1.0 + infinity = -1 + + open (10, status="scratch") +! Works: + write (10,*) " &nl foo = 5, 5, 5, nan, infinity, infinity " + write (10,*) + write (10,*) " = 1, /" + rewind (10) + READ (10, NML = nl) + close (10) + + if(infinity /= 1) STOP 1 + if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) & + .or. foo(5) <= huge(foo) .or. any(foo(6:11) /= -1.0)) & + STOP 2 +! Works too: + foo = -1.0 + infinity = -1 + + open (10, status="scratch") + rewind (10) + write (10,'(a)') "&nl foo = 5, 5, 5, nan, infinity, infinity" + write (10,'(a)') "=1,/" + rewind (10) + READ (10, NML = nl) + CLOSE (10) + + if(infinity /= 1) STOP 3 + if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) & + .or. foo(5) <= huge(foo) .or. any(foo(6:11) /= -1.0)) & + STOP 4 + END PROGRAM TEST Index: Fortran/gfortran/regression/namelist_43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_43.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-add-options ieee } +! +! PR fortran/34427 +! +! Check that namelists and the real values Inf, NaN, Infinity +! properly coexist with interceding line ends and spaces. +! +PROGRAM TEST + IMPLICIT NONE + real , DIMENSION(10) ::foo + integer :: infinity + integer :: numb + NAMELIST /nl/ foo + NAMELIST /nl/ infinity + foo = -1.0 + infinity = -1 + + open (10, status="scratch") + + write (10,'(a)') " &nl foo(1:6) = 5, 5, 5, nan, infinity" + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') "infinity" + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') " " + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') + write (10,'(a)') "=1/" + rewind (10) + READ (10, NML = nl) + CLOSE (10) + if(infinity /= 1) STOP 1 + if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) & + .or. (foo(5) <= huge(foo)) .or. any(foo(6:10) /= -1.0)) & + STOP 2 +END PROGRAM TEST Index: Fortran/gfortran/regression/namelist_44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_44.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/34530 +! +! Skipping over comment line was not working +! +! Test case contributed by Harald Anlauf. +! +program gfcbug77 + implicit none + + character(len=128) :: file = "" + logical :: default + namelist /BLACKLIST/ file, default + integer, parameter :: nnml = 10 + default = .true. + + open (nnml, file='gfcbug77.nml') + write(nnml,*) "&blacklist " ! The trailing space breaks gfortran + write(nnml,*) " ! This is a comment within the namelist" + write(nnml,*) " file = 'myfile'" + write(nnml,*) " default = F" + write(nnml,*) "/" + rewind(nnml) + read (nnml, nml=BLACKLIST) + close(nnml,status="delete") + if(file /= "myfile" .or. default) STOP 1 +! write (*,nml=BLACKLIST) +end program gfcbug77 Index: Fortran/gfortran/regression/namelist_45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_45.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR35617 read namelist error with '!' +program test + character(len=128) :: mhdpath + namelist /nbdrive_naml/ mhdpath + open(10, file='test.nml') + + write(10,'(a)') "&nbdrive_naml" + write(10,'(a)') + write(10,'(a)') "!nstep_stop = 2 ! uncomment to bar" + write(10,'(a)') "!nstep_start = 2 ! uncomment to foo" + write(10,'(a)') " mhdpath = 'mypath.dat'" + write(10,'(a)') "/" + + rewind(10) + read(10, nbdrive_naml) + close(10,status="delete") +end program test Index: Fortran/gfortran/regression/namelist_46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_46.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR35627 Namelist read problem with short logical followed by read real +program test + implicit none + LOGICAL :: nlco(200) ! (1:nbeam) + REAL(kind=8):: xlbtna(200) ! (1:nbeam) + NAMELIST/nbdrive_naml/ nlco, xlbtna + INTEGER :: nbshapa(200) ! (1:nbeam) + NAMELIST/nbdrive_naml/ nbshapa + nlco = .false. + xlbtna = 0.0_8 + nbshapa = 0 + open(10, file='t.nml') + write(10,'(a)') "&nbdrive_naml" + write(10,'(a)') "nlco = 4*T," + write(10,'(a)') "xlbtna = 802.8, 802.8, 802.8, 802.8" + write(10,'(a)') "nbshapa = 4*1" + write(10,'(a)') "/" + rewind(10) + read(10, nbdrive_naml) + !write(*,nbdrive_naml) + close(10, status="delete") +end program test Index: Fortran/gfortran/regression/namelist_47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_47.f90 @@ -0,0 +1,51 @@ +! { dg-do run } + +module nml_47 + type :: mt + character(len=2) :: c012345678901234567890123456789012345678901234567890123456789h(2) = (/"aa","bb"/) + end type mt + type :: bt + integer :: i(2) = (/1,2/) + type(mt) :: m(2) + end type bt +end module nml_47 + +program namelist_47 + use nml_47 + type(bt) :: x(2) + character(140) :: teststring + namelist /mynml/ x + + teststring = " x(2)%m%c012345678901234567890123456789012345678901234567890123456789h(:)(2:2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(:3) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(1:2)(k:) = 'z','z'," + call writenml (teststring) + +contains + +subroutine writenml (astring) + character(140), intent(in) :: astring + character(300) :: errmessage + integer :: ierror + + open (10, status="scratch", delim='apostrophe') + write (10, '(A)') "&MYNML" + write (10, '(A)') astring + write (10, '(A)') "/" + rewind (10) + read (10, nml = mynml, iostat=ierror, iomsg=errmessage) + if (ierror == 0) STOP 1 + print '(a)', trim(errmessage) + close (10) + +end subroutine writenml + +end program namelist_47 +! { dg-output "Multiple sub-objects with non-zero rank in namelist object x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" } +! { dg-output "Missing colon in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" } +! { dg-output "Substring out of range for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" } +! { dg-output "Bad character in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\r*\n+)" } Index: Fortran/gfortran/regression/namelist_48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_48.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! PR36538 namelist failure with tabs preceding object name + program check1 + integer x + namelist/casein/x + open(1, status="scratch") + write(1,'(a)') "&CASEIN" + write(1,'(a)') "\t\tx = 1" + write(1,'(a)') "/" + rewind(1) + x = 0 + read(1,casein) + if (x.ne.1) STOP 1 + end Index: Fortran/gfortran/regression/namelist_49.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_49.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! PR36546 Namelist error with tab following a comma and newline + program check1 + real a,b,c + namelist/CASEDAT/A,B,C + open(1, status="scratch") + write(1,'(a)') "&CASEDAT" + write(1,'(a)') "\t\tA = 1.0,\t\tB = 2.0," + write(1,'(a)') "\t\tC = 3.0," + write(1,'(a)') " /" + rewind(1) + a = 0.0 + b = 0.0 + c = 0.0 + read(1,casedat) + if ((a.ne.1.0) .or. (b.ne.2.0) .or. (c.ne.3.0)) STOP 1 + end + Index: Fortran/gfortran/regression/namelist_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! Tests the fix for PR25054 in which namelist objects with non-constant +! shape were allowed. +! +! Contributed by Joost VandeVondele +! +SUBROUTINE S1(I) + integer :: a,b(I) + NAMELIST /NLIST/ a,b ! { dg-error "with nonconstant shape" } + a=1 ; b=2 + write(6,NML=NLIST) +END SUBROUTINE S1 +END Index: Fortran/gfortran/regression/namelist_50.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_50.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR36657 Namelist string constant immediately followed by comment +program gfcbug79 + implicit none + integer, parameter :: nnml = 10 + character(len=8) :: model = "" + namelist /NML/ model + open (nnml, status="scratch") + write(nnml,*) "&nml! This is a just comment" + write(nnml,*) " model='foo'! This is a just comment" + write(nnml,*) "/" + rewind(nnml) + read (nnml, nml=NML) + if (model /= 'foo') STOP 1 + close(nnml) +end program gfcbug79 Index: Fortran/gfortran/regression/namelist_51.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_51.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR36676 Namelist comment problems +! test case from PR, reduced by Jerry DeLisle +program mem_nml + implicit none + integer, save :: nxc + nxc = 0 + call readNamelist() +contains +subroutine readNamelist() +implicit none +namelist /INPUT/ nxc +open(unit = 101, status="scratch") +write(101,'(a)')"&INPUT" +write(101,'(a)')"" +write(101,'(a)')"!" +write(101,'(a)')"!" +write(101,'(a)')"!" +write(101,'(a)')"nxc = 100" +write(101,'(a)')"&END" +rewind(101) +read(unit = 101, nml = INPUT) +if (nxc /= 100) STOP 1 +close(unit = 101) +endsubroutine +end program mem_nml + Index: Fortran/gfortran/regression/namelist_52.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_52.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR36582 Namelist I/O error: Bogus "Cannot match namelist object" +! Test case derived from PR. +module mod1 + +type screen_io_type +integer :: begin +end type screen_io_type + +type adjoint_type +type(screen_io_type) :: screen_io_fs_ntime +character(12) :: solver_type +end type adjoint_type + +type(adjoint_type) :: adjoint +namelist/info_adjoint/adjoint + +end module mod1 + +program gfortran_error_2 +use mod1 +adjoint%solver_type = "abcdefghijkl" +open(31,status='scratch') +write(31, '(a)') "&info_adjoint" +write(31, '(a)') "adjoint%solver_type = 'direct'" +write(31, '(a)') "adjoint%screen_io_fs_ntime%begin = 42" +write(31, '(a)') "/" +rewind(31) +read(31,nml=info_adjoint) +if (adjoint%solver_type /= 'direct') STOP 1 +if (adjoint%screen_io_fs_ntime%begin /= 42) STOP 2 +end program gfortran_error_2 Index: Fortran/gfortran/regression/namelist_53.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_53.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR36895 Namelist writing to internal files + character(30) :: line + namelist /stuff/ n + n = 123 + line = "" + write(line,nml=stuff) + if (line.ne."&STUFF N=123 , /") print *, line + end Index: Fortran/gfortran/regression/namelist_54.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_54.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR37707 Namelist read of array of derived type incorrect. +type s + integer m + integer n +end type s +type(s) :: a(3) +character*80 :: l = ' &namlis a%m=1,2, a%n=5,6, /' +namelist /namlis/ a +a%m=[87,88,89] +a%n=[97,98,99] +read(l,namlis) +if (a(1)%m /= 1 .or. a(2)%m /= 2 .or. a(1)%n /= 5 .or. a(2)%n /= 6 .or. & + & a(3)%m /= 89 .or. a(3)%n /= 99) STOP 1 +end Index: Fortran/gfortran/regression/namelist_55.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_55.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR37707 Namelist read of array of derived type incorrect +! Test case from PR, prepared by Jerry DeLisle +TYPE geometry + INTEGER :: nlon,nlat,nlev,projection + INTEGER :: center,subcenter,process + REAL :: west,south,east,north + REAL :: dlon,dlat + REAL :: polat,polon + REAL :: lonc,latc + REAL :: projlat,projlat2,projlon + CHARACTER(LEN=1) :: arakawa ='#' + INTEGER :: truncx,truncy ! Spectral truncation + INTEGER :: cie ! Flag fort CI (0), CIE gridpoint (1) + ! or CIE spectral (-1) + INTEGER :: nlat_i,nlon_i ! I length in Y and X direction + INTEGER :: nlat_e ,nlon_e ! E length in Y and X direction + LOGICAL :: do_geo = .true. +END TYPE geometry + +TYPE shortkey + INTEGER :: PPP ! 2. Parameter + INTEGER :: NNN ! 12. Gridpoint or spectral field 0 = gridpoint, 1 = spectral + INTEGER :: INTPM + CHARACTER(LEN=16) :: name +END TYPE shortkey +INTEGER, PARAMETER :: maxl = 200 ! Maximum number of levels to be read from namelist +INTEGER, PARAMETER :: max_atmkey = 10 ! Maximum number of extra fields in the + +REAL :: ahalf(maxl),bhalf(maxl) +TYPE (geometry) :: outgeo ; SAVE outgeo ! Output geometry + +TYPE (shortkey) :: atmkey(max_atmkey) ; SAVE atmkey +TYPE (shortkey) :: mlevkey(max_atmkey) ; SAVE mlevkey + +character*600 :: l = " &NAMINTERP atmkey%ppp = 076,058,062,079, atmkey%nnn = 000,000,000,000, & + & atmkey%name ='LIQUID_WATER','SOLID_WATER','SNOW','RAIN', OUTGEO%NLEV=10, & + & AHALF=0.,1.,2.,3.,4.,5.,6.,7.,8.,9., BHALF=0.,1.,2.,3.,4.,5.,6.,7.,8.,9., /" + +namelist /naminterp/outgeo,ahalf,bhalf,atmkey +print *, outgeo%nlev +read(l,nml=naminterp) +if (outgeo%nlev /= 10) STOP 1 +if (any(ahalf(1:10) .ne. [0.,1.,2.,3.,4.,5.,6.,7.,8.,9.])) STOP 2 +if (any(bhalf(1:10) .ne. [0.,1.,2.,3.,4.,5.,6.,7.,8.,9.])) STOP 3 +if (any(atmkey(1:4)%ppp .ne. [076,058,062,079])) STOP 4 +if (any(atmkey(1:4)%nnn .ne. [0,0,0,0])) STOP 5 +if (any(atmkey(1:4)%name .ne. ['LIQUID_WATER','SOLID_WATER ','SNOW ',& + &'RAIN '])) STOP 6 +end Index: Fortran/gfortran/regression/namelist_56.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_56.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR37707 Namelist read of array of derived type incorrect +! Test case from Tobias Burnus + IMPLICIT NONE + integer :: j + character(len=5) :: str(4) + character(len=900) :: nlstr + namelist /nml/ str, j + str = '' + j = -42 + nlstr = '&nml str = "a", "b", "cde", j = 5 /' + read(nlstr,nml) + open(99, status="scratch") + write(99,nml) + rewind(99) + j = -54 + str = 'XXXX' + read(99,nml) + if (j.ne.5) STOP 1 + if (any(str.ne.["a ","b ","cde "," "])) STOP 2 + close(99) +end Index: Fortran/gfortran/regression/namelist_57.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_57.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR37294 Namelist I/O to array character internal units. +! Test case from adapted from PR by Jerry DeLisle + character(30) :: line(3) + namelist /stuff/ n + n = 123 + line = "" + write(line,nml=stuff) + if (line(1) .ne. "&STUFF") STOP 1 + if (line(2) .ne. " N=123 ,") STOP 2 + if (line(3) .ne. " /") STOP 3 + end Index: Fortran/gfortran/regression/namelist_58.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_58.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR40853 Error in namelist IO. +! Test case derived from example given in PR. < jvdelisle@gcc.gnu.org > +program test + implicit none + type tao_title_struct + character(2) justify + end type + type tao_plot_page_struct + real shape_height_max + type (tao_title_struct) title ! Comment this line out and the bug goes away. + real size(2) + end type + type (tao_plot_page_struct) plot_page + namelist / params / plot_page + open (10, status="scratch") + write(10,'(a)')" ¶ms" + write(10,'(a)')" plot_page%size=5 , 2," + write(10,'(a)')"/" + rewind(10) + read (10, nml = params) + if (any(plot_page%size .ne. (/ 5, 2 /))) STOP 1 + close (10) +end program + Index: Fortran/gfortran/regression/namelist_59.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_59.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR41192 NAMELIST input with just a comment ("&NAME ! comment \") error +program cmdline +! comment by itself causes error in gfortran + call process(' ') + call process('i=10 , j=20 k=30 ! change all three values') + call process(' ') + call process('! change no values')! before patch this failed. +end program cmdline + +subroutine process(string) + implicit none + character(len=*) :: string + character(len=132) :: lines(3) + character(len=255) :: message + integer :: i=1,j=2,k=3 + integer ios + namelist /cmd/ i,j,k + lines(1)='&cmd' + lines(2)=string + lines(3)='/' + + read(lines,nml=cmd,iostat=ios,iomsg=message) + if (ios.ne.0) STOP 1 +end subroutine process Index: Fortran/gfortran/regression/namelist_60.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_60.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR42901 Reading array of structures from namelist +! Test case derived from the reporters test case. +program test_nml +type field_descr + integer number +end type +type fsetup + type (field_descr), dimension(3) :: vel ! 3 velocity components +end type +type (fsetup) field_setup +namelist /nl_setup/ field_setup +field_setup%vel%number = 0 +! write(*,nml=nl_setup) +open(10, status="scratch") +write(10,'(a)') "&nl_setup" +write(10,'(a)') " field_setup%vel(1)%number= 3," +write(10,'(a)') " field_setup%vel(2)%number= 9," +write(10,'(a)') " field_setup%vel(3)%number= 27," +write(10,'(a)') "/" +rewind(10) +read(10,nml=nl_setup) +if (field_setup%vel(1)%number .ne. 3) STOP 1 +if (field_setup%vel(2)%number .ne. 9) STOP 2 +if (field_setup%vel(3)%number .ne. 27) STOP 3 +! write(*,nml=nl_setup) +end program test_nml Index: Fortran/gfortran/regression/namelist_61.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_61.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/43228 +! +integer :: a(3,3) +character(len=100) :: str +namelist /nml/a + +a = -1 +str = '&nml a(1,:) = 1 2 3 /' +read(str, nml=nml) +if (any (a(1,:) /= [1, 2, 3])) STOP 1 +if (any (a([2,3],:) /= -1)) STOP 2 + +a = -1 +str = '&nml a(1,1) = 1 2 3 4 /' +read(str, nml=nml) +if (any (a(:,1) /= [1, 2, 3])) STOP 3 +if (any (a(:,2) /= [4, -1, -1])) STOP 4 +if (any (a(:,3) /= -1)) STOP 5 + +str = '&nml a(1,:) = 1 2 3 , & + & a(2,:) = 4,5,6 & + & a(3,:) = 7 8 9/' +read(str, nml=nml) +if (any (a(1,:) /= [1, 2, 3])) STOP 6 +if (any (a(2,:) /= [4, 5, 6])) STOP 7 +if (any (a(3,:) /= [7, 8, 9])) STOP 8 + +!print *, a(:,1) +!print *, a(:,2) +!print *, a(:,3) +end + + Index: Fortran/gfortran/regression/namelist_62.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_62.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/45066 +! +! Contributed by Michael Richmond. +! +! Was failing due to a -fwhole-file bug. +! + +MODULE GA_commons + INTEGER :: nichflg(2) +END MODULE GA_commons + +PROGRAM gafortran + USE GA_commons + NAMELIST /ga/ nichflg + READ (23, nml=ga) +END PROGRAM gafortran Index: Fortran/gfortran/regression/namelist_63.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_63.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! PR fortran/45530, updated for PR78659 +! +! Contributed by david.sagan@gmail.com +! +program test +implicit none + +type c_struct + type (g_struct), pointer :: g +end type + +type g_struct + type (p_struct), pointer :: p +end type + +type p_struct + type (region_struct), pointer :: r +end type + +type region_struct + type (p_struct) plot +end type + +type (c_struct) curve(10) +! The following is allowed with f2003. +namelist / params / curve ! { dg-error "ALLOCATABLE or POINTER components" } +end program Index: Fortran/gfortran/regression/namelist_64.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_64.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR45532 gfortran namelist read error. +! Derived from the original test case by David Sagan. +program test +implicit none +type line_struct + integer :: width = 10 +end type +type symbol_struct + integer :: typee = 313233 +end type +type curve_struct + type (line_struct) line + type (symbol_struct) symbol +end type +type (curve_struct) curve(10) +namelist / params / curve +! +open (10, status="scratch") +write(10,*) "¶ms" +write(10,*) " curve(1)%symbol%typee = 1234" +write(10,*) "/" +rewind(10) +read (10, nml = params) +if (curve(1)%symbol%typee /= 1234) STOP 1 +close(10) +end program Index: Fortran/gfortran/regression/namelist_65.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_65.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR45710 Adjust format/padding for WRITE of NAMELIST group to internal file +program oneline +real :: a=1,b=2,c=3,d=4 +namelist /nl1/ a,b,c +parameter(ilines=5) +character(len=80) :: out(ilines) + +! fill array out with @ +do i=1,len(out) + out(:)(i:i)='@' +enddo + +write(out,nl1) +if (out(1).ne."&NL1") STOP 1 +if (out(2).ne." A= 1.00000000 ,") STOP 2 +if (out(3).ne." B= 2.00000000 ,") STOP 3 +if (out(4).ne." C= 3.00000000 ,") STOP 4 +if (out(5).ne." /") STOP 5 + +end program oneline Index: Fortran/gfortran/regression/namelist_66.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_66.f90 @@ -0,0 +1,40 @@ +! { dg-do run { target fd_truncate } } +! PR46010 Failure to read these two examples of namelists +type ptracer + character(len = 2) :: sname + logical :: lini +end type ptracer +type(ptracer) , dimension(3) :: tracer +namelist/naml1/ tracer + +type qptracer + character(len = 20) :: sname = ""!: short name + character(len = 45 ) :: lname = ""!: long name + character(len = 20 ) :: sunit = "" !: unit + logical :: lini !: read in a file or not + logical :: lsav !: ouput the tracer or not +end type qptracer +type(qptracer) , dimension(3) :: qtracer +namelist/naml2/ qtracer + +open (99, file='nml_66.dat', status="replace") +write(99,*) "&naml1" +write(99,*) " tracer(1) = 'aa', .true." +write(99,*) " tracer(2) = 'bb', .true." +write(99,*) " tracer(3) = 'cc', .true." +write(99,*) "/" +rewind(99) +read (99, nml=naml1) +write (*, nml=naml1) +rewind(99) +write(99,*) "&naml2 ! just some stuff" +write(99,*) " qtracer(1) = 'dic ' , 'dissolved inorganic concentration ', 'mol-c/l' , .true. , .true.," +write(99,*) " qtracer(2) = 'alkalini' , 'total alkalinity concentration ', 'eq/l ' , .true. , .true.," +write(99,*) "/" +rewind(99) +read (99, nml=naml2) +write (*, nml=naml2) +rewind(99) + +close (99, status="delete") +end Index: Fortran/gfortran/regression/namelist_67.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_67.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + + character(35) :: nml_contents = "&NMLIST NML_STRING='123456789' /" + character(4) :: nml_string + namelist /nmlist/ nml_string + nml_string = "abcd" + read(nml_contents,nml=nmlist) +end program +! { dg-output "Fortran runtime warning: Namelist object 'nml_string' truncated on read." } Index: Fortran/gfortran/regression/namelist_68.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_68.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR47154 END= does not work in namelist read + program foo + real :: a + namelist /b/a + open(10,status="scratch") + read (10,nml=b,end=100) + 100 continue + end Index: Fortran/gfortran/regression/namelist_69.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_69.f90 @@ -0,0 +1,233 @@ +! { dg-do run } +! +! PR fortran/47339 +! PR fortran/43062 +! +! Run-time test for Fortran 2003 NAMELISTS +! Version for non-strings +! +program nml_test + implicit none + + character(len=1000) :: str + + integer, allocatable :: a(:) + integer, allocatable :: b + integer, pointer :: ap(:) + integer, pointer :: bp + integer :: c + integer :: d(3) + + type t + integer :: c1 + integer :: c2(3) + end type t + type(t) :: e,f(2) + type(t),allocatable :: g,h(:) + type(t),pointer :: i,j(:) + + namelist /nml/ a, b, c, d, ap, bp,e,f,g,h,i,j + + a = [1,2] + allocate(b,ap(2),bp) + ap = [98, 99] + b = 7 + bp = 101 + c = 8 + d = [-1, -2, -3] + + e%c1 = -701 + e%c2 = [-702,-703,-704] + f(1)%c1 = 33001 + f(2)%c1 = 33002 + f(1)%c2 = [44001,44002,44003] + f(2)%c2 = [44011,44012,44013] + + allocate(g,h(2),i,j(2)) + + g%c1 = -601 + g%c2 = [-602,6703,-604] + h(1)%c1 = 35001 + h(2)%c1 = 35002 + h(1)%c2 = [45001,45002,45003] + h(2)%c2 = [45011,45012,45013] + + i%c1 = -501 + i%c2 = [-502,-503,-504] + j(1)%c1 = 36001 + j(2)%c1 = 36002 + j(1)%c2 = [46001,46002,46003] + j(2)%c2 = [46011,46012,46013] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml) + + ! RESET NAMELIST + a = [-1,-1] + ap = [-1, -1] + b = -1 + bp = -1 + c = -1 + d = [-1, -1, -1] + + e%c1 = -1 + e%c2 = [-1,-1,-1] + f(1)%c1 = -1 + f(2)%c1 = -1 + f(1)%c2 = [-1,-1,-1] + f(2)%c2 = [-1,-1,-1] + + g%c1 = -1 + g%c2 = [-1,-1,-1] + h(1)%c1 = -1 + h(2)%c1 = -1 + h(1)%c2 = [-1,-1,-1] + h(2)%c2 = [-1,-1,-1] + + i%c1 = -1 + i%c2 = [-1,-1,-1] + j(1)%c1 = -1 + j(2)%c1 = -1 + j(1)%c2 = [-1,-1,-1] + j(2)%c2 = [-1,-1,-1] + + ! Read back + read(str,nml=nml) + + ! Check result + if (any (a /= [1,2])) STOP 1 + if (any (ap /= [98, 99])) STOP 2 + if (b /= 7) STOP 3 + if (bp /= 101) STOP 4 + if (c /= 8) STOP 5 + if (any (d /= [-1, -2, -3])) STOP 6 + + if (e%c1 /= -701) STOP 7 + if (any (e%c2 /= [-702,-703,-704])) STOP 8 + if (f(1)%c1 /= 33001) STOP 9 + if (f(2)%c1 /= 33002) STOP 10 + if (any (f(1)%c2 /= [44001,44002,44003])) STOP 11 + if (any (f(2)%c2 /= [44011,44012,44013])) STOP 12 + + if (g%c1 /= -601) STOP 13 + if (any(g%c2 /= [-602,6703,-604])) STOP 14 + if (h(1)%c1 /= 35001) STOP 15 + if (h(2)%c1 /= 35002) STOP 16 + if (any (h(1)%c2 /= [45001,45002,45003])) STOP 17 + if (any (h(2)%c2 /= [45011,45012,45013])) STOP 18 + + if (i%c1 /= -501) STOP 19 + if (any (i%c2 /= [-502,-503,-504])) STOP 20 + if (j(1)%c1 /= 36001) STOP 21 + if (j(2)%c1 /= 36002) STOP 22 + if (any (j(1)%c2 /= [46001,46002,46003])) STOP 23 + if (any (j(2)%c2 /= [46011,46012,46013])) STOP 24 + + ! Check argument passing (dummy processing) + call test2(a,b,c,d,ap,bp,e,f,g,h,i,j,2) + +contains + subroutine test2(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n) + integer, allocatable :: x1(:) + integer, allocatable :: x2 + integer, pointer :: x1p(:) + integer, pointer :: x2p + integer :: x3 + integer :: x4(3) + integer :: n + integer :: x5(n) + type(t) :: x6,x7(2) + type(t),allocatable :: x8,x9(:) + type(t),pointer :: x10,x11(:) + type(t) :: x12(n) + + namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12 + + x5 = [ 42, 53 ] + + x12(1)%c1 = 37001 + x12(2)%c1 = 37002 + x12(1)%c2 = [47001,47002,47003] + x12(2)%c2 = [47011,47012,47013] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml2) + + ! RESET NAMELIST + x1 = [-1,-1] + x1p = [-1, -1] + x2 = -1 + x2p = -1 + x3 = -1 + x4 = [-1, -1, -1] + + x6%c1 = -1 + x6%c2 = [-1,-1,-1] + x7(1)%c1 = -1 + x7(2)%c1 = -1 + x7(1)%c2 = [-1,-1,-1] + x7(2)%c2 = [-1,-1,-1] + + x8%c1 = -1 + x8%c2 = [-1,-1,-1] + x9(1)%c1 = -1 + x9(2)%c1 = -1 + x9(1)%c2 = [-1,-1,-1] + x9(2)%c2 = [-1,-1,-1] + + x10%c1 = -1 + x10%c2 = [-1,-1,-1] + x11(1)%c1 = -1 + x11(2)%c1 = -1 + x11(1)%c2 = [-1,-1,-1] + x11(2)%c2 = [-1,-1,-1] + + x5 = [ -1, -1 ] + + x12(1)%c1 = -1 + x12(2)%c1 = -1 + x12(1)%c2 = [-1,-1,-1] + x12(2)%c2 = [-1,-1,-1] + + ! Read back + read(str,nml=nml2) + + ! Check result + if (any (x1 /= [1,2])) STOP 25 + if (any (x1p /= [98, 99])) STOP 26 + if (x2 /= 7) STOP 27 + if (x2p /= 101) STOP 28 + if (x3 /= 8) STOP 29 + if (any (x4 /= [-1, -2, -3])) STOP 30 + + if (x6%c1 /= -701) STOP 31 + if (any (x6%c2 /= [-702,-703,-704])) STOP 32 + if (x7(1)%c1 /= 33001) STOP 33 + if (x7(2)%c1 /= 33002) STOP 34 + if (any (x7(1)%c2 /= [44001,44002,44003])) STOP 35 + if (any (x7(2)%c2 /= [44011,44012,44013])) STOP 36 + + if (x8%c1 /= -601) STOP 37 + if (any(x8%c2 /= [-602,6703,-604])) STOP 38 + if (x9(1)%c1 /= 35001) STOP 39 + if (x9(2)%c1 /= 35002) STOP 40 + if (any (x9(1)%c2 /= [45001,45002,45003])) STOP 41 + if (any (x9(2)%c2 /= [45011,45012,45013])) STOP 42 + + if (x10%c1 /= -501) STOP 43 + if (any (x10%c2 /= [-502,-503,-504])) STOP 44 + if (x11(1)%c1 /= 36001) STOP 45 + if (x11(2)%c1 /= 36002) STOP 46 + if (any (x11(1)%c2 /= [46001,46002,46003])) STOP 47 + if (any (x11(2)%c2 /= [46011,46012,46013])) STOP 48 + + if (any (x5 /= [ 42, 53 ])) STOP 49 + + if (x12(1)%c1 /= 37001) STOP 50 + if (x12(2)%c1 /= 37002) STOP 51 + if (any (x12(1)%c2 /= [47001,47002,47003])) STOP 52 + if (any (x12(2)%c2 /= [47011,47012,47013])) STOP 53 + end subroutine test2 +end program nml_test Index: Fortran/gfortran/regression/namelist_70.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_70.f90 @@ -0,0 +1,442 @@ +! { dg-do run } +! +! PR fortran/47339 +! PR fortran/43062 +! +! Run-time test for Fortran 2003 NAMELISTS +! Version for non-strings +! +program nml_test + implicit none + + character(len=1000) :: str + + character(len=5), allocatable :: a(:) + character(len=5), allocatable :: b + character(len=5), pointer :: ap(:) + character(len=5), pointer :: bp + character(len=5) :: c + character(len=5) :: d(3) + + type t + character(len=5) :: c1 + character(len=5) :: c2(3) + end type t + type(t) :: e,f(2) + type(t),allocatable :: g,h(:) + type(t),pointer :: i,j(:) + + namelist /nml/ a, b, c, d, ap, bp,e,f,g,h,i,j + + a = ["aa01", "aa02"] + allocate(b,ap(2),bp) + ap = ['98', '99'] + b = '7' + bp = '101' + c = '8' + d = ['-1', '-2', '-3'] + + e%c1 = '-701' + e%c2 = ['-702','-703','-704'] + f(1)%c1 = '33001' + f(2)%c1 = '33002' + f(1)%c2 = ['44001','44002','44003'] + f(2)%c2 = ['44011','44012','44013'] + + allocate(g,h(2),i,j(2)) + + g%c1 = '-601' + g%c2 = ['-602','6703','-604'] + h(1)%c1 = '35001' + h(2)%c1 = '35002' + h(1)%c2 = ['45001','45002','45003'] + h(2)%c2 = ['45011','45012','45013'] + + i%c1 = '-501' + i%c2 = ['-502','-503','-504'] + j(1)%c1 = '36001' + j(2)%c1 = '36002' + j(1)%c2 = ['46001','46002','46003'] + j(2)%c2 = ['46011','46012','46013'] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml) + + ! RESET NAMELIST + a = repeat('X', len(a)) + ap = repeat('X', len(ap)) + b = repeat('X', len(b)) + bp = repeat('X', len(bp)) + c = repeat('X', len(c)) + d = repeat('X', len(d)) + + e%c1 = repeat('X', len(e%c1)) + e%c2 = repeat('X', len(e%c2)) + f(1)%c1 = repeat('X', len(f(1)%c1)) + f(2)%c1 = repeat('X', len(f(2)%c1)) + f(1)%c2 = repeat('X', len(f(1)%c2)) + f(2)%c2 = repeat('X', len(f(2)%c2)) + + g%c1 = repeat('X', len(g%c1)) + g%c2 = repeat('X', len(g%c1)) + h(1)%c1 = repeat('X', len(h(1)%c1)) + h(2)%c1 = repeat('X', len(h(1)%c1)) + h(1)%c2 = repeat('X', len(h(1)%c1)) + h(2)%c2 = repeat('X', len(h(1)%c1)) + + i%c1 = repeat('X', len(i%c1)) + i%c2 = repeat('X', len(i%c1)) + j(1)%c1 = repeat('X', len(j(1)%c1)) + j(2)%c1 = repeat('X', len(j(2)%c1)) + j(1)%c2 = repeat('X', len(j(1)%c2)) + j(2)%c2 = repeat('X', len(j(2)%c2)) + + ! Read back + read(str,nml=nml) + + ! Check result + if (any (a /= ['aa01','aa02'])) STOP 1 + if (any (ap /= ['98', '99'])) STOP 2 + if (b /= '7') STOP 3 + if (bp /= '101') STOP 4 + if (c /= '8') STOP 5 + if (any (d /= ['-1', '-2', '-3'])) STOP 6 + + if (e%c1 /= '-701') STOP 7 + if (any (e%c2 /= ['-702','-703','-704'])) STOP 8 + if (f(1)%c1 /= '33001') STOP 9 + if (f(2)%c1 /= '33002') STOP 10 + if (any (f(1)%c2 /= ['44001','44002','44003'])) STOP 11 + if (any (f(2)%c2 /= ['44011','44012','44013'])) STOP 12 + + if (g%c1 /= '-601') STOP 13 + if (any(g%c2 /= ['-602','6703','-604'])) STOP 14 + if (h(1)%c1 /= '35001') STOP 15 + if (h(2)%c1 /= '35002') STOP 16 + if (any (h(1)%c2 /= ['45001','45002','45003'])) STOP 17 + if (any (h(2)%c2 /= ['45011','45012','45013'])) STOP 18 + + if (i%c1 /= '-501') STOP 19 + if (any (i%c2 /= ['-502','-503','-504'])) STOP 20 + if (j(1)%c1 /= '36001') STOP 21 + if (j(2)%c1 /= '36002') STOP 22 + if (any (j(1)%c2 /= ['46001','46002','46003'])) STOP 23 + if (any (j(2)%c2 /= ['46011','46012','46013'])) STOP 24 + + ! Check argument passing (dummy processing) + call test2(a,b,c,d,ap,bp,e,f,g,h,i,j,2) + call test3(a,b,c,d,ap,bp,e,f,g,h,i,j,2,len(a)) + call test4(a,b,c,d,ap,bp,e,f,g,h,i,j,2) + +contains + subroutine test2(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n) + character(len=5), allocatable :: x1(:) + character(len=5), allocatable :: x2 + character(len=5), pointer :: x1p(:) + character(len=5), pointer :: x2p + character(len=5) :: x3 + character(len=5) :: x4(3) + integer :: n + character(len=5) :: x5(n) + type(t) :: x6,x7(2) + type(t),allocatable :: x8,x9(:) + type(t),pointer :: x10,x11(:) + type(t) :: x12(n) + + namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12 + + x5 = [ 'x5-42', 'x5-53' ] + + x12(1)%c1 = '37001' + x12(2)%c1 = '37002' + x12(1)%c2 = ['47001','47002','47003'] + x12(2)%c2 = ['47011','47012','47013'] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml2) + + ! RESET NAMELIST + x1 = repeat('X', len(x1)) + x1p = repeat('X', len(x1p)) + x2 = repeat('X', len(x2)) + x2p = repeat('X', len(x2p)) + x3 = repeat('X', len(x3)) + x4 = repeat('X', len(x4)) + + x6%c1 = repeat('X', len(x6%c1)) + x6%c2 = repeat('X', len(x6%c2)) + x7(1)%c1 = repeat('X', len(x7(1)%c1)) + x7(2)%c1 = repeat('X', len(x7(2)%c1)) + x7(1)%c2 = repeat('X', len(x7(1)%c2)) + x7(2)%c2 = repeat('X', len(x7(2)%c2)) + + x8%c1 = repeat('X', len(x8%c1)) + x8%c2 = repeat('X', len(x8%c1)) + x9(1)%c1 = repeat('X', len(x9(1)%c1)) + x9(2)%c1 = repeat('X', len(x9(1)%c1)) + x9(1)%c2 = repeat('X', len(x9(1)%c1)) + x9(2)%c2 = repeat('X', len(x9(1)%c1)) + + x10%c1 = repeat('X', len(x10%c1)) + x10%c2 = repeat('X', len(x10%c1)) + x11(1)%c1 = repeat('X', len(x11(1)%c1)) + x11(2)%c1 = repeat('X', len(x11(2)%c1)) + x11(1)%c2 = repeat('X', len(x11(1)%c2)) + x11(2)%c2 = repeat('X', len(x11(2)%c2)) + + x5 = repeat('X', len(x5)) + + x12(1)%c1 = repeat('X', len(x12(2)%c2)) + x12(2)%c1 = repeat('X', len(x12(2)%c2)) + x12(1)%c2 = repeat('X', len(x12(2)%c2)) + x12(2)%c2 = repeat('X', len(x12(2)%c2)) + + ! Read back + read(str,nml=nml2) + + ! Check result + if (any (x1 /= ['aa01','aa02'])) STOP 25 + if (any (x1p /= ['98', '99'])) STOP 26 + if (x2 /= '7') STOP 27 + if (x2p /= '101') STOP 28 + if (x3 /= '8') STOP 29 + if (any (x4 /= ['-1', '-2', '-3'])) STOP 30 + + if (x6%c1 /= '-701') STOP 31 + if (any (x6%c2 /= ['-702','-703','-704'])) STOP 32 + if (x7(1)%c1 /= '33001') STOP 33 + if (x7(2)%c1 /= '33002') STOP 34 + if (any (x7(1)%c2 /= ['44001','44002','44003'])) STOP 35 + if (any (x7(2)%c2 /= ['44011','44012','44013'])) STOP 36 + + if (x8%c1 /= '-601') STOP 37 + if (any(x8%c2 /= ['-602','6703','-604'])) STOP 38 + if (x9(1)%c1 /= '35001') STOP 39 + if (x9(2)%c1 /= '35002') STOP 40 + if (any (x9(1)%c2 /= ['45001','45002','45003'])) STOP 41 + if (any (x9(2)%c2 /= ['45011','45012','45013'])) STOP 42 + + if (x10%c1 /= '-501') STOP 43 + if (any (x10%c2 /= ['-502','-503','-504'])) STOP 44 + if (x11(1)%c1 /= '36001') STOP 45 + if (x11(2)%c1 /= '36002') STOP 46 + if (any (x11(1)%c2 /= ['46001','46002','46003'])) STOP 47 + if (any (x11(2)%c2 /= ['46011','46012','46013'])) STOP 48 + + if (any (x5 /= [ 'x5-42', 'x5-53' ])) STOP 49 + + if (x12(1)%c1 /= '37001') STOP 50 + if (x12(2)%c1 /= '37002') STOP 51 + if (any (x12(1)%c2 /= ['47001','47002','47003'])) STOP 52 + if (any (x12(2)%c2 /= ['47011','47012','47013'])) STOP 53 + end subroutine test2 + + subroutine test3(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n,ll) + integer :: n, ll + character(len=ll), allocatable :: x1(:) + character(len=ll), allocatable :: x2 + character(len=ll), pointer :: x1p(:) + character(len=ll), pointer :: x2p + character(len=ll) :: x3 + character(len=ll) :: x4(3) + character(len=ll) :: x5(n) + type(t) :: x6,x7(2) + type(t),allocatable :: x8,x9(:) + type(t),pointer :: x10,x11(:) + type(t) :: x12(n) + + namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12 + + x5 = [ 'x5-42', 'x5-53' ] + + x12(1)%c1 = '37001' + x12(2)%c1 = '37002' + x12(1)%c2 = ['47001','47002','47003'] + x12(2)%c2 = ['47011','47012','47013'] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml2) + + ! RESET NAMELIST + x1 = repeat('X', len(x1)) + x1p = repeat('X', len(x1p)) + + x2 = repeat('X', len(x2)) + x2p = repeat('X', len(x2p)) + x3 = repeat('X', len(x3)) + x4 = repeat('X', len(x4)) + + x6%c1 = repeat('X', len(x6%c1)) + x6%c2 = repeat('X', len(x6%c2)) + x7(1)%c1 = repeat('X', len(x7(1)%c1)) + x7(2)%c1 = repeat('X', len(x7(2)%c1)) + x7(1)%c2 = repeat('X', len(x7(1)%c2)) + x7(2)%c2 = repeat('X', len(x7(2)%c2)) + + x8%c1 = repeat('X', len(x8%c1)) + x8%c2 = repeat('X', len(x8%c1)) + x9(1)%c1 = repeat('X', len(x9(1)%c1)) + x9(2)%c1 = repeat('X', len(x9(1)%c1)) + x9(1)%c2 = repeat('X', len(x9(1)%c1)) + x9(2)%c2 = repeat('X', len(x9(1)%c1)) + + x10%c1 = repeat('X', len(x10%c1)) + x10%c2 = repeat('X', len(x10%c1)) + x11(1)%c1 = repeat('X', len(x11(1)%c1)) + x11(2)%c1 = repeat('X', len(x11(2)%c1)) + x11(1)%c2 = repeat('X', len(x11(1)%c2)) + x11(2)%c2 = repeat('X', len(x11(2)%c2)) + + x5 = repeat('X', len(x5)) + + x12(1)%c1 = repeat('X', len(x12(2)%c2)) + x12(2)%c1 = repeat('X', len(x12(2)%c2)) + x12(1)%c2 = repeat('X', len(x12(2)%c2)) + x12(2)%c2 = repeat('X', len(x12(2)%c2)) + + ! Read back + read(str,nml=nml2) + + ! Check result + if (any (x1 /= ['aa01','aa02'])) STOP 54 + if (any (x1p /= ['98', '99'])) STOP 55 + if (x2 /= '7') STOP 56 + if (x2p /= '101') STOP 57 + if (x3 /= '8') STOP 58 + if (any (x4 /= ['-1', '-2', '-3'])) STOP 59 + + if (x6%c1 /= '-701') STOP 60 + if (any (x6%c2 /= ['-702','-703','-704'])) STOP 61 + if (x7(1)%c1 /= '33001') STOP 62 + if (x7(2)%c1 /= '33002') STOP 63 + if (any (x7(1)%c2 /= ['44001','44002','44003'])) STOP 64 + if (any (x7(2)%c2 /= ['44011','44012','44013'])) STOP 65 + + if (x8%c1 /= '-601') STOP 66 + if (any(x8%c2 /= ['-602','6703','-604'])) STOP 67 + if (x9(1)%c1 /= '35001') STOP 68 + if (x9(2)%c1 /= '35002') STOP 69 + if (any (x9(1)%c2 /= ['45001','45002','45003'])) STOP 70 + if (any (x9(2)%c2 /= ['45011','45012','45013'])) STOP 71 + + if (x10%c1 /= '-501') STOP 72 + if (any (x10%c2 /= ['-502','-503','-504'])) STOP 73 + if (x11(1)%c1 /= '36001') STOP 74 + if (x11(2)%c1 /= '36002') STOP 75 + if (any (x11(1)%c2 /= ['46001','46002','46003'])) STOP 76 + if (any (x11(2)%c2 /= ['46011','46012','46013'])) STOP 77 + + if (any (x5 /= [ 'x5-42', 'x5-53' ])) STOP 78 + + if (x12(1)%c1 /= '37001') STOP 79 + if (x12(2)%c1 /= '37002') STOP 80 + if (any (x12(1)%c2 /= ['47001','47002','47003'])) STOP 81 + if (any (x12(2)%c2 /= ['47011','47012','47013'])) STOP 82 + end subroutine test3 + + subroutine test4(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n) + character(len=*), allocatable :: x1(:) + character(len=*), allocatable :: x2 + character(len=*), pointer :: x1p(:) + character(len=*), pointer :: x2p + character(len=*) :: x3 + character(len=*) :: x4(3) + integer :: n + character(len=5) :: x5(n) + type(t) :: x6,x7(2) + type(t),allocatable :: x8,x9(:) + type(t),pointer :: x10,x11(:) + type(t) :: x12(n) + + namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12 + + x5 = [ 'x5-42', 'x5-53' ] + + x12(1)%c1 = '37001' + x12(2)%c1 = '37002' + x12(1)%c2 = ['47001','47002','47003'] + x12(2)%c2 = ['47011','47012','47013'] + + ! SAVE NAMELIST + str = repeat('X', len(str)) + write(str,nml=nml2) + + ! RESET NAMELIST + x1 = repeat('X', len(x1)) + x1p = repeat('X', len(x1p)) + x2 = repeat('X', len(x2)) + x2p = repeat('X', len(x2p)) + x3 = repeat('X', len(x3)) + x4 = repeat('X', len(x4)) + + x6%c1 = repeat('X', len(x6%c1)) + x6%c2 = repeat('X', len(x6%c2)) + x7(1)%c1 = repeat('X', len(x7(1)%c1)) + x7(2)%c1 = repeat('X', len(x7(2)%c1)) + x7(1)%c2 = repeat('X', len(x7(1)%c2)) + x7(2)%c2 = repeat('X', len(x7(2)%c2)) + + x8%c1 = repeat('X', len(x8%c1)) + x8%c2 = repeat('X', len(x8%c1)) + x9(1)%c1 = repeat('X', len(x9(1)%c1)) + x9(2)%c1 = repeat('X', len(x9(1)%c1)) + x9(1)%c2 = repeat('X', len(x9(1)%c1)) + x9(2)%c2 = repeat('X', len(x9(1)%c1)) + + x10%c1 = repeat('X', len(x10%c1)) + x10%c2 = repeat('X', len(x10%c1)) + x11(1)%c1 = repeat('X', len(x11(1)%c1)) + x11(2)%c1 = repeat('X', len(x11(2)%c1)) + x11(1)%c2 = repeat('X', len(x11(1)%c2)) + x11(2)%c2 = repeat('X', len(x11(2)%c2)) + + x5 = repeat('X', len(x5)) + + x12(1)%c1 = repeat('X', len(x12(2)%c2)) + x12(2)%c1 = repeat('X', len(x12(2)%c2)) + x12(1)%c2 = repeat('X', len(x12(2)%c2)) + x12(2)%c2 = repeat('X', len(x12(2)%c2)) + + ! Read back + read(str,nml=nml2) + + ! Check result + if (any (x1 /= ['aa01','aa02'])) STOP 83 + if (any (x1p /= ['98', '99'])) STOP 84 + if (x2 /= '7') STOP 85 + if (x2p /= '101') STOP 86 + if (x3 /= '8') STOP 87 + if (any (x4 /= ['-1', '-2', '-3'])) STOP 88 + + if (x6%c1 /= '-701') STOP 89 + if (any (x6%c2 /= ['-702','-703','-704'])) STOP 90 + if (x7(1)%c1 /= '33001') STOP 91 + if (x7(2)%c1 /= '33002') STOP 92 + if (any (x7(1)%c2 /= ['44001','44002','44003'])) STOP 93 + if (any (x7(2)%c2 /= ['44011','44012','44013'])) STOP 94 + + if (x8%c1 /= '-601') STOP 95 + if (any(x8%c2 /= ['-602','6703','-604'])) STOP 96 + if (x9(1)%c1 /= '35001') STOP 97 + if (x9(2)%c1 /= '35002') STOP 98 + if (any (x9(1)%c2 /= ['45001','45002','45003'])) STOP 99 + if (any (x9(2)%c2 /= ['45011','45012','45013'])) STOP 100 + + if (x10%c1 /= '-501') STOP 101 + if (any (x10%c2 /= ['-502','-503','-504'])) STOP 102 + if (x11(1)%c1 /= '36001') STOP 103 + if (x11(2)%c1 /= '36002') STOP 104 + if (any (x11(1)%c2 /= ['46001','46002','46003'])) STOP 105 + if (any (x11(2)%c2 /= ['46011','46012','46013'])) STOP 106 + + if (any (x5 /= [ 'x5-42', 'x5-53' ])) STOP 107 + + if (x12(1)%c1 /= '37001') STOP 108 + if (x12(2)%c1 /= '37002') STOP 109 + if (any (x12(1)%c2 /= ['47001','47002','47003'])) STOP 110 + if (any (x12(2)%c2 /= ['47011','47012','47013'])) STOP 111 + end subroutine test4 +end program nml_test Index: Fortran/gfortran/regression/namelist_71.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_71.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR47778 Reading array of structures from namelist +! Test case derived from the reporters test case. +program test_nml +type field_descr + integer number +end type +type fsetup + type (field_descr), dimension(3) :: vel ! 3 velocity components + type (field_descr), dimension(3) :: scal ! 3 scalars +end type +type (fsetup) field_setup +namelist /nl_setup/ field_setup +field_setup%vel%number = 0 +field_setup%scal%number = 0 +! write(*,nml=nl_setup) +open(10, status="scratch") +write(10,'(a)') "&nl_setup" +write(10,'(a)') " field_setup%vel(1)%number= 3," +write(10,'(a)') " field_setup%vel(2)%number= 9," +write(10,'(a)') " field_setup%vel(3)%number= 27," +write(10,'(a)') " field_setup%scal(1)%number= 2," +write(10,'(a)') " field_setup%scal(2)%number= 4," +write(10,'(a)') " field_setup%scal(3)%number= 8," +write(10,'(a)') "/" +rewind(10) +read(10,nml=nl_setup) +if (field_setup%vel(1)%number .ne. 3) STOP 1 +if (field_setup%vel(2)%number .ne. 9) STOP 2 +if (field_setup%vel(3)%number .ne. 27) STOP 3 +if (field_setup%scal(1)%number .ne. 2) STOP 4 +if (field_setup%scal(2)%number .ne. 4) STOP 5 +if (field_setup%scal(3)%number .ne. 8) STOP 6 +!write(*,nml=nl_setup) +end program test_nml + Index: Fortran/gfortran/regression/namelist_72.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_72.f @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/49791 +! +! Contributed by Elliott Sales de Andrade +! + program namelist_test + + dimension xpos(5000), ypos(5000) + namelist /geometry/ xpos, ypos + + xpos = -huge(xpos) + ypos = -huge(ypos) + + open(unit=4,file='geometry.in') + write(4,'(a)') '$geometry' + write(4,'(a)') ' xpos(1)= 0.00, 0.10, 0.20, 0.30, 0.40,' + write(4,'(a)') ' ypos(1)= 0.50, 0.60, 0.70, 0.80, 0.90,' + write(4,'(a)') '$end' + + close(4) + + open (unit=4,file='geometry.in',status='old',form='formatted') + read (4,geometry) + close(4, status='delete') + + !print *, 'xpos', xpos(1:10), 'ypos', ypos(1:10) + + if (any (xpos(1:5) /= [0.00, 0.10, 0.20, 0.30, 0.40]))STOP 1 + if (any (ypos(1:5) /= [0.50, 0.60, 0.70, 0.80, 0.90]))STOP 2 + if (any (xpos(6:) /= -huge(xpos))) STOP 3 + if (any (ypos(6:) /= -huge(ypos))) STOP 4 + end Index: Fortran/gfortran/regression/namelist_73.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_73.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR fortran/50109 +! +! Contributed by Jim Hanson +! + program namelist_test + + integer nfp + namelist /indata/ nfp + + nfp = 99 + open(unit=4, status='scratch') + write(4,'(a)') '$indata' + write(4,'(a)') 'NFP = 5,' + write(4,'(a)') "! " + write(4,'(a)') "! " + write(4,'(a)') "! " + write(4,'(a)') '/' + + rewind(4) + read (4,nml=indata) + close(4) + +! write(*,*) nfp + if (nfp /= 5) STOP 1 + + end Index: Fortran/gfortran/regression/namelist_74.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_74.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/50556 +subroutine foo + save i + namelist /i/ ii ! { dg-error "cannot have the SAVE attribute" } +end subroutine foo +subroutine bar + namelist /i/ ii + save i ! { dg-error "cannot have the SAVE attribute" } +end subroutine bar Index: Fortran/gfortran/regression/namelist_75.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_75.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Tests a write-after-free memory error fix in gfc_undo_symbols + +program test_nml + + namelist /foo/ bar, baz + namelist /foo/ wrong, , ! { dg-error "Syntax error in NAMELIST" } + +end program test_nml Index: Fortran/gfortran/regression/namelist_76.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_76.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 55352: [4.7/4.8 Regression] Erroneous gfortran warning of unused module variable when variable is only used in namelist +! +! Contributed by + +module data + implicit none + integer :: a +end module data + +program test + use data, only: a + implicit none + a = 1 + call write_data() +end program test + +subroutine write_data() + use data, only: a + implicit none + namelist /write_data_list/ a + open(unit=10,form='formatted',status='replace',action='write',file='test.dat') + write(10, nml=write_data_list) + close(10) +end subroutine write_data Index: Fortran/gfortran/regression/namelist_77.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_77.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! PR libfortran/51825 - Fortran runtime error: Cannot match namelist object name +! Test case derived from PR. + +module local_mod + + type mytype1 + integer :: int1 + end type + + type mytype2 + integer :: n_x + integer :: n_px + end type + + type beam_init_struct + character(16) :: chars(1) = '' + type (mytype1) dummy + type (mytype2) grid(1) + end type + +end module + +program error_namelist + + use local_mod + + implicit none + + type (beam_init_struct) beam_init + + namelist / error_params / beam_init + + open (10, status='scratch') + write (10, '(a)') "&error_params" + write (10, '(a)') " beam_init%chars(1)='JUNK'" + write (10, '(a)') " beam_init%grid(1)%n_x=3" + write (10, '(a)') " beam_init%grid(1)%n_px=2" + write (10, '(a)') "/" + rewind(10) + read(10, nml=error_params) + close (10) + + if (beam_init%chars(1) /= 'JUNK') STOP 1 + if (beam_init%grid(1)%n_x /= 3) STOP 2 + if (beam_init%grid(1)%n_px /= 2) STOP 3 + +end program Index: Fortran/gfortran/regression/namelist_78.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_78.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR libfortran/51825 +! Test case regarding namelist problems with derived types + +program namelist + + type d1 + integer :: j = 0 + end type d1 + + type d2 + type(d1) k + end type d2 + + type d3 + type(d2) d(2) + end type d3 + + type(d3) der + namelist /nmlst/ der + + open (10, status='scratch') + write (10, '(a)') "&NMLST" + write (10, '(a)') " DER%D(1)%K%J = 1," + write (10, '(a)') " DER%D(2)%K%J = 2," + write (10, '(a)') "/" + rewind(10) + read(10, nml=nmlst) + close (10) + + if (der%d(1)%k%j /= 1) STOP 1 + if (der%d(2)%k%j /= 2) STOP 2 +end program namelist Index: Fortran/gfortran/regression/namelist_79.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_79.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR libfortran/52512 - Cannot match namelist object name +! Test case derived from PR. + +program testje + + implicit none + + integer :: getal, jn + type ptracer + character(len = 8) :: sname !: short name + logical :: lini !: read in a file or not + end type ptracer + type(ptracer) , dimension(3) :: tracer + namelist/namtoptrc/ getal,tracer + + ! standard values + getal = 9999 + do jn = 1, 3 + tracer(jn)%sname = 'default_name' + tracer(jn)%lini = .false. + end do + + open (10, status='scratch') + write (10, '(a)') "&namtoptrc" + write (10, '(a)') " getal = 7" + write (10, '(a)') " tracer(1) = 'DIC ', .true." + write (10, '(a)') " tracer(2) = 'Alkalini', .true." + write (10, '(a)') " tracer(3) = 'O2 ', .true." + write (10, '(a)') "/" + rewind(10) + read(10, nml=namtoptrc) + close (10) + + if (getal /= 7) STOP 1 + if (tracer(1)%sname /= 'DIC ') STOP 2 + if (tracer(2)%sname /= 'Alkalini') STOP 3 + if (tracer(3)%sname /= 'O2 ') STOP 4 + if (.not. tracer(1)%lini) STOP 5 + if (.not. tracer(2)%lini) STOP 6 + if (.not. tracer(3)%lini) STOP 7 + +end program testje Index: Fortran/gfortran/regression/namelist_80.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_80.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/56735 +! +! Contributed by Adam Williams +! + PROGRAM TEST + INTEGER int1,int2,int3 + NAMELIST /temp/ int1,int2,int3 + + int1 = -1; int2 = -2; int3 = -3 + + OPEN (53, STATUS='scratch') + WRITE (53, '(a)') ' ?' + WRITE (53, '(a)') + WRITE (53, '(a)') '$temp' + WRITE (53, '(a)') ' int1=1' + WRITE (53, '(a)') ' int2=2' + WRITE (53, '(a)') ' int3=3' + WRITE (53, '(a)') '$END' + REWIND(53) + + READ (53, temp) + CLOSE (53) + + if (int1 /= 1 .or. int2 /= 2 .or. int3 /= 3) STOP 1 + END PROGRAM Index: Fortran/gfortran/regression/namelist_81.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_81.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR56786 Error on embedded spaces +integer :: i(3) +namelist /nml/ i + +i = -42 +open(99,status='scratch') +write(99,'(a)') '&nml i(3 ) = 5 /' +rewind(99) +read(99,nml=nml) +close(99) +if (i(1)/=-42 .or. i(2)/=-42 .or. i(3)/=5) STOP 1 + +! Shorten the file so the read hits EOF + +open(99,status='scratch') +write(99,'(a)') '&nml i(3 ) = 5 ' +rewind(99) +read(99,nml=nml, end=30) +STOP 2 +! Shorten some more + 30 close(99) +open(99,status='scratch') +write(99,'(a)') '&nml i(3 ) =' +rewind(99) +read(99,nml=nml, end=40) +STOP 3 +! Shorten some more + 40 close(99) +open(99,status='scratch') +write(99,'(a)') '&nml i(3 )' +rewind(99) +read(99,nml=nml, end=50) +STOP 4 +! Shorten some more + 50 close(99) +open(99,status='scratch') +write(99,'(a)') '&nml i(3 ' +rewind(99) +read(99,nml=nml, end=60) +STOP 5 + 60 close(99) +end Index: Fortran/gfortran/regression/namelist_82.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_82.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR56660 Fails to read NAMELIST with certain form array syntax +type ptracer + character(len = 2) :: sname + logical :: lini +end type ptracer + +type(ptracer) , dimension(3) :: tracer +namelist/naml1/ tracer + +tracer(:) = ptracer('XXX', .false.) + +open (99, file='nml_82.dat', status="replace") +write(99,*) "&naml1" +!write(99,*) " tracer(2) = 'bb' , .true." +write(99,*) " tracer(:) = 'aa' , .true." +write(99,*) " tracer(2) = 'bb' , .true." +write(99,*) "/" +rewind(99) + +read (99, nml=naml1) +close (99, status="delete") + +if (tracer(1)%sname.ne.'aa') STOP 1 +if (.not.tracer(1)%lini) STOP 2 +if (tracer(2)%sname.ne.'bb') STOP 3 +if (.not.tracer(2)%lini) STOP 4 +if (tracer(3)%sname.ne.'XX') STOP 5 +if (tracer(3)%lini) STOP 6 + +!write (*, nml=naml1) + +end Index: Fortran/gfortran/regression/namelist_83.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_83.f90 @@ -0,0 +1,22 @@ +! { dg-do link } +! { dg-options "-g" } +! { dg-additional-sources namelist_83_2.f90 } +! +! Note: compilation would be sufficient, but "compile" cannot be combined +! with dg-additional-sources. +! +! PR fortran/59440 +! +! Contributed by Harald Anlauf +! +! Was ICEing during DWARF generation. +! +! This is the first file - dg-additional-sources contains the second one +! + +module mo_t_datum + implicit none + integer :: qbit_conv = 0 +end module mo_t_datum + +! { dg-final { cleanup-modules "gfcbug126" } } Index: Fortran/gfortran/regression/namelist_83_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_83_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile { target { ! *-*-* } } } +! +! To be compiled with "-g" via namelist_83.f90 +! +! PR fortran/59440 +! +! Contributed by Harald Anlauf +! +! Was ICEing during DWARF generation. +! +! This is the second file, the module is in namelist_83.f90 +! + +! +MODULE gfcbug126 + use mo_t_datum, only: qbit_conv + implicit none + namelist /OBSERVATIONS/ qbit_conv +end module gfcbug126 + +! As we have to link, add an empty main program: +end Index: Fortran/gfortran/regression/namelist_84.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_84.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +program namelist_delim_none + implicit none + character(512) :: internal_unit + character(5), dimension(5) :: mystring + real, dimension(4) :: somenum + integer :: i + namelist /mylist/ mystring, somenum + mystring(1)='mon' + mystring(2)='tue' + mystring(3)='wed' + mystring(4)='thu' + mystring(5)='fri' + somenum = reshape(source = (/ 2, 3, 5, 7 /), shape=shape(somenum)) + + open(unit=10,status='scratch',delim='none') + write(10, mylist) + rewind(10) + mystring = "xxxxx" + rewind(10) + do i=1,5 + read(10,'(a)') internal_unit + if (i.eq.2 .and. internal_unit .ne. " MYSTRING=mon tue wed thu fri ,") STOP 1 + if (scan(internal_unit,"""'").ne.0) print *, internal_unit + end do + close(10) +end program Index: Fortran/gfortran/regression/namelist_85.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_85.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options -std=gnu } +! PR55117 Programs fails namelist read (contains derived types objects) +program test_type_extension + + type tk_t + real :: x + end type tk_t + + type, extends(tk_t) :: tke_t + character(8) :: string + end type tke_t + + type, extends(tke_t) :: deep + integer :: int1 + real :: y + character(10) :: the_name + end type deep + + type other + integer :: one_oh + integer :: two_oh + end type other + + type plain_type + integer :: var1 + type(other) :: var2 + real :: var3 + end type plain_type + + type some_other + complex :: varx + type(tke_t) :: tke + type (plain_type) :: varpy + real :: vary + end type some_other + + type(deep) :: trouble + type(some_other) :: somethinelse + type(tke_t) :: tke + integer :: answer + + namelist /test_NML/ trouble, somethinelse, tke, answer + + tke%x = 0.0 + tke%string = "xxxxxxxx" + answer = 5 + trouble%x = 5.34 + trouble%y = 4.25 + trouble%string = "yyyy" + trouble%the_name = "mischief" + + open(10, status="scratch") + + write(10,*) "&TEST_NML" + write(10,*) "TKE%X= 3.14 ," + write(10,*) "TKE%STRING='kf7rcc'," + write(10,*) "ANSWER= 42," + write(10,*) "/" + rewind(10) + + read(10,NML=test_NML) + if (tke%x - 3.14000010 > .00001) STOP 1 + if (tke%string /= "kf7rcc") STOP 2 + if (answer /= 42) STOP 3! hitchkikers guide to the galaxy +end program test_type_extension Index: Fortran/gfortran/regression/namelist_86.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_86.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } +! PR65596 Namelist reads too far. +integer ,parameter :: CL=80 +integer ,parameter :: AL=4 + +character(CL) :: mode +character(CL) :: cats(AL) +character(CL) :: dogs(AL) +character(CL) :: rslt(AL) +integer :: ierr, k + +namelist / theList / cats, dogs, mode + +open(27,status="scratch") + +write(27,'(A)') "&theList" +write(27,'(A)') " mode = 'on'" +write(27,'(A)') " dogs = 'Rover'," +write(27,'(A)') " 'Spot'" +write(27,'(A)') " cats = 'Fluffy'," +write(27,'(A)') " 'Hairball'" +write(27,'(A)') "/" +rewind(27) + +mode = 'off' +cats(:) = '________' +dogs(:) = '________' + +read (27, nml=theList, iostat=ierr) + +if (ierr .ne. 0) STOP 1 + +rslt = ['Rover ','Spot ','________','________'] +if (any(dogs.ne.rslt)) STOP 2 + +rslt = ['Fluffy ','Hairball','________','________'] +if (any(cats.ne.rslt)) STOP 3 + +close(27) + +contains + +subroutine abort() + close(27) + stop 500 +end subroutine abort + +end Index: Fortran/gfortran/regression/namelist_87.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_87.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-add-options ieee } +! +! PR fortran/56743 +! +! Contributed by Kai Gallmeister +! +! Note that Fortran 2008 (Section 10.11.3.6) requires that there is +! a value separator between the value and the "!". Thus, all examples +! in this file are invalid; they should either be accepted as vendor +! extension or lead to a run-time error (iostat /=0). +! +! For the c1 and c2 character example, please note that the Fortran +! standard (F2008, 10.11.3.3) requires delimiters; accepting +! a single word (in spirit of list-directed I/O) would be possible +! as vendor extension. But the current run-time failure is fine as well. +! +! Note: After fixing this, warning or error is given with -pedantic -std=xxx +implicit none +integer :: i = -1 +real :: r1 = -2 +real :: r2 = -3 +real :: r3 = -4 +real :: r4 = -5 +real :: r5 = -6 +complex :: c = (-7,-7) +logical :: ll = .false. +character :: c1 = 'X' +character(3) :: c2 = 'YYY' +character(3) :: c3 = 'ZZZ' +namelist /nml/ i, r1,r2,r3,r4,r5,c,ll,c1,c2,c3 + +open (99, file='nml_87.dat', status="replace") +write(99,*) "&nml" +write(99,*) " i=42!11" ! Fixed BUG: wrong result: Unmodified, no error +write(99,*) " r1=43!11" ! Fixed BUG: wrong result: Unmodified, no error +write(99,*) " r2=43.!11" ! Fixed BUG: wrong result: Unmodified, no error +write(99,*) " r3=inf!11" ! OK: run-time error (Cannot match namelist object) +write(99,*) " r4=NaN(0x33)!11" ! OK: run-time error (Cannot match namelist object) +write(99,*) " r5=3.e5!11" ! Fixed BUG: wrong result: Unmodified, no error +write(99,*) " c=(4,2)!11" ! OK: value accepted as vendor extension +write(99,*) " ll=.true.!11" ! OK: value accepted as vendor extension +write(99,*) " c1='a'!11" ! OK: without quotes, run-time error (Cannot match namelist object) +write(99,*) " c2='bc'!11" ! OK: without quotes, run-time error (Cannot match namelist object) +write(99,*) " c3='ax'!11" ! OK: without quotes, run-time error (Cannot match namelist object) +write(99,*) "/" + +rewind(99) +read (99, nml=nml) +!write (*, nml=nml) +close (99, status="delete") + + if (r1 /= 43) STOP 1 + if (r2 /= 43) STOP 2 + if (r3 /= r3 .or. r3 <= huge(r3)) STOP 3 + if (r4 == r4) STOP 4 + if (r5 /= 300000) STOP 5 + if (c /= cmplx(4,2)) STOP 6 + if (.not. ll) STOP 7 + if (c1 /= "a") STOP 8 + if (c2 /= "bc") STOP 9 + if (c3 /= "ax") STOP 10 +end Index: Fortran/gfortran/regression/namelist_88.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_88.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR69668 Error reading namelist opened with DELIM='NONE' +program namelist + implicit none + + integer,parameter :: tabsz=10 + integer :: i + character(len=10),dimension(tabsz) :: tab + namelist/tab_nml/tab + + tab(:)='invalid' + + ! Create a temporary test namelist file + open(unit=23,status='scratch',delim='none') + write(23,*) "&tab_nml" + write(23,*) "tab(1)='in1'," + write(23,*) "tab(2)='in2'" + write(23,*) "/" + rewind(23) + + read(unit=23,nml=tab_nml) + + close(unit=23) + + if (tab(1).ne.'in1') STOP 1 + if (tab(2).ne.'in2') STOP 2 + if (any(tab(3:tabsz).ne.'invalid')) STOP 3 + +end program namelist Index: Fortran/gfortran/regression/namelist_89.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_89.f90 @@ -0,0 +1,47 @@ +! { dg-do run { target fd_truncate } } +! PR69456 Namelist value with trailing sign is ignored without error +implicit none +integer :: ios +character(256) :: errormsg +real :: r1 = -1 +real :: r2 = -1 +real :: r3 = -1 +real :: r4 = -1 +complex :: c1 = (-1,-1) +namelist /nml/ r1, r2, r3, r4, c1 + +open (99, status="scratch") + +write(99,*) "&nml" +write(99,*) " r1=1+1" ! Treated as 1e+1! +write(99,*) " r2=1-1" ! Treated as 1e-1! +write(99,*) " r3=1+1" ! Treated as 1e+1! +write(99,*) " r4=1-1" ! Treated as 1e-1! +write(99,*) " c1=(1-,1+1)" ! Should give error on item number 5 +write(99,*) "/" + +rewind(99) + +read (99, nml=nml, iostat=ios, iomsg=errormsg) +if (ios.ne.5010) STOP 1 +if (scan(errormsg, "5").ne.44) STOP 2 + +rewind(99) + +write(99,*) "&nml" +write(99,*) " r1=1+1" ! Treated as 1e+1! +write(99,*) " r2=1-" ! Should give error on item number 2 +write(99,*) " r3=1+1" ! Treated as 1e+1! +write(99,*) " r4=1-1" ! Treated as 1e-1! +write(99,*) " c1=(1-1,1+1)" ! Treated as (1e-1,1e+1)! +write(99,*) "/" + +rewind(99) + +read (99, nml=nml, iostat=ios, iomsg=errormsg) +if (ios.ne.5010) STOP 3 +if (scan(errormsg, "2").ne.25) STOP 4 + +close (99) + +end Index: Fortran/gfortran/regression/namelist_90.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_90.f @@ -0,0 +1,28 @@ +! { dg-do run } +! PR71123 Namelist read failure on Windows + implicit none + integer :: i, ierr + real(8), dimension(30) :: senid, res + character(2) :: crlf = char(13) // char(10) + namelist /fith/ senid + do i=1,30 + res(i) = i + enddo + senid = 99.0 + open(unit=7,file='test.out',form='formatted', + * status='new',action='readwrite', access='stream') + write(7,'(a)') "&fith" // crlf + write(7,'(a)') "senid= 1.0 , 2.0 , 3.0 , 4.0 , 5.0 ," // crlf + write(7,'(a)') "6.0 , 7.0 , 8.0 , 9.0 , 10.0 , 11.0 ," // crlf + write(7,'(a)') "12.0 , 13.0 , 14.0 , 15.0 , 16.0 , 17.0 ," // crlf + write(7,'(a)') "18.0 , 19.0 , 20.0 , 21.0 , 22.0 , 23.0 ," // crlf + write(7,'(a)') "24.0 , 25.0 , 26.0 , 27.0 , 28.0 , 29.0 ," // crlf + write(7,'(a)') "30.0 ," // crlf + write(7,'(a)') "/" // crlf + close(7) + open(unit=7,file='test.out',form='formatted') + read(7,nml=fith, iostat=ierr) + close(7, status="delete") + if (ierr.ne.0) STOP 1 + if (any(senid.ne.res)) STOP 2 + end Index: Fortran/gfortran/regression/namelist_91.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_91.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +program p + type t + integer :: k + end type + class(t), allocatable :: x + namelist /nml/ x +end Index: Fortran/gfortran/regression/namelist_92.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_92.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE ma + IMPLICIT NONE + TYPE :: ta + INTEGER, allocatable :: array(:) + END TYPE ta +END MODULE ma + +PROGRAM p + USE ma + type(ta):: x + NAMELIST /nml/ x + WRITE (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" } + READ (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" } +END PROGRAM p Index: Fortran/gfortran/regression/namelist_93.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_93.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE ma + IMPLICIT NONE + TYPE :: ta + INTEGER, allocatable :: array(:) + END TYPE ta +END MODULE ma + +PROGRAM p + USE ma + class(ta), allocatable :: x + NAMELIST /nml/ x + WRITE (*, nml)! { dg-error "is polymorphic and requires a defined input/output procedure" } + READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" } +END PROGRAM p Index: Fortran/gfortran/regression/namelist_94.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_94.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE m + IMPLICIT NONE + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + END TYPE +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c + print *, "what" + END SUBROUTINE +END MODULE + +PROGRAM p + USE m + IMPLICIT NONE + class(t), allocatable :: x + NAMELIST /nml/ x + x = t('a') + WRITE (*, nml) + READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" } +END Index: Fortran/gfortran/regression/namelist_95.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_95.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR83191 Writing a namelist with repeated complex + +program test + +implicit none + +integer, parameter :: UNIT = 1 +character(len=8), parameter :: FILE = "namelist" + +complex, dimension(3) :: a = (/ (0.0, 0.0), (0.0, 0.0), (3.0, 4.0) /) + +namelist /complex_namelist/ a + +open(UNIT, file=FILE) +write(UNIT, nml=complex_namelist) +close(UNIT) + +open(UNIT, file=FILE) +read(UNIT, nml=complex_namelist) +close(UNIT, status="delete") +if (any(a.ne.(/ (0.0, 0.0), (0.0, 0.0), (3.0, 4.0) /))) STOP 1 +end program test Index: Fortran/gfortran/regression/namelist_96.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_96.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +program pr88776 + implicit none + character(*), parameter :: file = "pr88776.dat" + type t_chan + integer :: ichan = -1 + character(len=8) :: flag = '' + integer :: band = -1 + end type t_chan + type(t_chan) :: chan + namelist /NML/ chan + open (11,file=file) + write(11,'(a)') trim("&nml chan = 1 '#1 ' 10 /") + write(11,'(a)') trim("&nml chan = 2 '#2 ' 42.36/") + write(11,'(a)') trim("&nml chan = 3 '#3 ' 30 /") + close(11) + call read (unit=10) ! No problem + call read (unit=5) ! problem, now fixed + open (11,file=file) + close (11, status="delete") +contains + subroutine read (unit) + integer, intent(in) :: unit + integer :: stat + open (unit, file=file, action="read") + chan = t_chan(-1,'',-1) + stat = 0 + read (unit, nml=NML, iostat=stat) + if (stat /= 0) stop 1 + chan = t_chan(-1,'',-1) + read (unit, nml=NML, iostat=stat) + if (stat == 0) stop 2 + if (chan% ichan /= 2) then + stop 3 + end if + close (unit) + end subroutine read +end program pr88776 Index: Fortran/gfortran/regression/namelist_97.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_97.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! PR95195 - improve runtime error when writing a namelist to an unformatted file + +program test + character(len=11) :: my_form = 'unformatted' + integer :: i = 1, j = 2, k = 3 + character(80) :: iomsg + namelist /nml1/ i, j, k + open (unit=10, file='namelist_97.dat', form=my_form) + write (unit=10, nml=nml1, iostat=iostat, iomsg=iomsg) + close (unit=10, status='delete') + if (iostat == 0) stop 1 + if (iomsg /= "Namelist formatting for unit connected with FORM='UNFORMATTED'") & + stop 2 +end program test Index: Fortran/gfortran/regression/namelist_98.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_98.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! pr98686 + implicit none + real :: x, m + namelist /NML/ x, m, q ! { dg-error "must be declared before the namelist*" } + integer :: q + x = 1.0 + m = 2.0 + q = 3 + write(*, nml=NML) +end Index: Fortran/gfortran/regression/namelist_args.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_args.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options -std=gnu } +! PR50555 synonymous namelist/statement function dummy argument not allowed +subroutine g(k1, k2, k3) + integer, intent(in) :: k1, k2, k3 + print *, k +end subroutine +function j(k1, k2, k3) + integer, intent(in) :: k1, k2, k3 + j = 25 * k +end function +program pr50555 + namelist /i/ j + call g(k,l,i) ! { dg-error "cannot be an argument" } + f(k,l,i)=0 ! { dg-error "cannot be an argument" } + h = j(k,l,i) ! { dg-error "cannot be an argument" } +end program +! Note: -std=gnu needed because line 15 function statement is obsolescent Index: Fortran/gfortran/regression/namelist_assumed_char.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_assumed_char.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR30481 Assumed size character is not allowed in namelist. +! Test case from PR, submitted by Jerry DeLisle +! +! Modifications for PR fortran/47339 / PR fortran/43062: +! Add -std=f95, add bar() +! +subroutine foo(c) + character*(*) c + namelist /abc/ c ! { dg-error "nonconstant character length in namelist" } +end subroutine + +subroutine bar(d,n) + integer :: n + character(len=n) d + namelist /abcd/ d ! { dg-error "nonconstant character length in namelist" } +end subroutine bar + Index: Fortran/gfortran/regression/namelist_blockdata.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_blockdata.f @@ -0,0 +1,7 @@ +! { dg-do compile } +! Tests fix for PR21565 - object cannot be in namelist and block data. + block data + common /foo/ a + namelist /foo_n/ a ! { dg-error "not allowed in BLOCK DATA" } + data a /1.0/ + end Index: Fortran/gfortran/regression/namelist_char_only.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_char_only.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-O0" } +! Test patch for PR24416.f90 - a used to come back from the read with var +! prepended. +! + IMPLICIT NONE + CHARACTER(len=10) :: var = "hello" + character(len=10) :: a = "" + NAMELIST /inx/ var + + OPEN(unit=11, status='scratch') + write (11, *) "&INX" + write (11, *) " var = 'goodbye'" + write (11, *) "&END" + rewind (11) + + READ(11,NML=inx) + CLOSE(11) + + OPEN(unit=11, status='scratch') + write (11, *) "alls_well" + rewind (11) + + READ(11,*) a + CLOSE(11) + + if (a /= "alls_well") STOP 1 + +END Index: Fortran/gfortran/regression/namelist_empty.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_empty.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! pr24584, segfault on namelist reading an empty string +! Contributed by Jerry DeLisle + implicit none + character*20 temp + character(len=10) var + namelist /input/ var + var = 'Howdy' + open(unit=7, status="scratch") + temp = ' var=''''' ! var='' in the file + write(7,'(A6)') '&INPUT' + write(7,'(A10)') temp + write(7,'(A1)') '/' + rewind(7) + read(7,NML=input) + close(7) + if (var.ne.'') STOP 1 + end Index: Fortran/gfortran/regression/namelist_internal.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_internal.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options " -std=f2003" } +! Checks internal file read/write of namelists +! (Fortran 2003 feature) +! PR fortran/28224 +program nml_internal + integer :: i, j + real :: r + namelist /nam/ i, j, r + character(len=250) :: str + + i = 42 + j = -718 + r = exp(1.0) + write(str,nml=nam) + i = -33 + j = 10 + r = sin(1.0) + read(str,nml=nam) + if(i /= 42 .or. j /= -718 .or. abs(r-exp(1.0)) > 1e-5) STOP 1 +end program nml_internal Index: Fortran/gfortran/regression/namelist_print_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_print_1.f @@ -0,0 +1,13 @@ +! Test Non standard PRINT namelist - PR21432 +! +! Contributor Paul Thomas +! +! { dg-do run } +! { dg-options "-std=gnu" } + + real x + namelist /mynml/ x + x = 1 +! { dg-output "^" } + print mynml ! { dg-output "&MYNML(\r*\n+) X= 1.00000000 ,(\r*\n+) /(\r*\n+)" } + end Index: Fortran/gfortran/regression/namelist_print_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_print_2.f @@ -0,0 +1,13 @@ +! Test Non standard PRINT namelist - PR21432 is +! not accepted by -std=f95 +! +! Contributor Paul Thomas +! +! { dg-do compile } +! { dg-options "-std=f95" } +! + real x + namelist /mynml/ x + x = 1 + print mynml ! { dg-error "PRINT namelist.*extension" } + end Index: Fortran/gfortran/regression/namelist_use.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_use.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! This tests the fix for PR22010, where namelists were not being written to +! and read back from modules. It has two namelists: one that is USE +! associated and another that is concatenated by USE and host association. +! +! Contributed by Paul Thomas pault@gcc.gnu.org +! +module global + character(4) :: aa + integer :: ii + real :: rr + namelist /nml1/ aa, ii, rr + namelist /nml2/ aa +end module global +program namelist_use + use global + real :: rrr +! Concatenate use and host associated variables - an extension. + namelist /nml2/ ii, rrr ! { dg-warning "already is USE associated" } + open (10, status="scratch") + write (10,*) "&NML1 aa='lmno' ii=1 rr=2.5 /" + write (10,*) "&NML2 aa='pqrs' ii=2 rrr=3.5 /" + rewind (10) + read (10,nml=nml1,iostat=i) + if ((i.ne.0).or.(aa.ne."lmno").or.(ii.ne.1).or.(rr.ne.2.5)) STOP 1 + + read (10,nml=nml2,iostat=i) + if ((i.ne.0).or.(aa.ne."pqrs").or.(ii.ne.2).or.(rrr.ne.3.5)) STOP 2 + + close (10) +end program namelist_use Index: Fortran/gfortran/regression/namelist_use_only.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_use_only.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! This tests the fix for PR22010, where namelists were not being written to +! and read back from modules. It checks that namelists from modules that are +! selected by an ONLY declaration work correctly, even when the variables in +! the namelist are not host associated. Note that renaming a namelist by USE +! association is not allowed by the standard and this is trapped in module.c. +! +! Contributed by Paul Thomas pault@gcc.gnu.org +! +module global + character*4 :: aa, aaa + integer :: ii, iii + real :: rr, rrr + namelist /nml1/ aa, ii, rr + namelist /nml2/ aaa, iii, rrr +contains + logical function foo() + foo = (aaa.ne."pqrs").or.(iii.ne.2).or.(rrr.ne.3.5) + end function foo +end module global +program namelist_use_only + use global, only : nml1, aa, ii, rr + use global, only : nml2, rrrr=>rrr, foo + open (10, status="scratch") + write (10,'(a)') "&NML1 aa='lmno' ii=1 rr=2.5 /" + write (10,'(a)') "&NML2 aaa='pqrs' iii=2 rrr=3.5 /" + rewind (10) + read (10,nml=nml1,iostat=i) + if ((i.ne.0).or.(aa.ne."lmno").or.(ii.ne.1).or.(rr.ne.2.5)) STOP 1 + + read (10,nml=nml2,iostat=i) + if ((i.ne.0).or.(rrrr.ne.3.5).or.foo()) STOP 2 + close (10) +end program namelist_use_only Index: Fortran/gfortran/regression/namelist_utf8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/namelist_utf8.f90 @@ -0,0 +1,30 @@ +! { dg-do run { xfail powerpc*-apple-darwin* } } +! PR52539 UTF-8 support for namelist read and write + +character(len=10, kind=4) :: str, str2 +character(len=25, kind=4) :: str3 + +namelist /nml/ str + +str = 4_'1a'//char (int (z'4F60'),4) & + //char (int (z'597D'), 4)//4_'b' +open(6, encoding='utf-8') +open(99, encoding='utf-8',form='formatted') +write(99, '(3a)') '&nml str = "', str, '" /' +write(99, '(a)') str +rewind(99) + +str = 4_'XXXX' +str2 = 4_'YYYY' +read(99,nml=nml) +read(99, *) str2 +if (str2 /= str) STOP 1 +rewind(99) + +read(99,'(A)') str3 +if (str3 /= 4_'&nml str = "' // str // 4_'" /') STOP 2 +read(99,*) str3 +if (str3 /= str) STOP 3 + +close(99, status='delete') +end Index: Fortran/gfortran/regression/nan_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_1.f90 @@ -0,0 +1,88 @@ +! Test if MIN and MAX intrinsics behave correctly when passed NaNs +! as arguments +! +! { dg-do run } +! { dg-add-options ieee } +! +module aux2 + interface isnan + module procedure isnan_r + module procedure isnan_d + end interface isnan + + interface isinf + module procedure isinf_r + module procedure isinf_d + end interface isinf +contains + + pure function isnan_r(x) result (isnan) + logical :: isnan + real, intent(in) :: x + + isnan = (.not.(x == x)) + end function isnan_r + + pure function isnan_d(x) result (isnan) + logical :: isnan + double precision, intent(in) :: x + + isnan = (.not.(x == x)) + end function isnan_d + + pure function isinf_r(x) result (isinf) + logical :: isinf + real, intent(in) :: x + + isinf = (x > huge(x)) .or. (x < -huge(x)) + end function isinf_r + + pure function isinf_d(x) result (isinf) + logical :: isinf + double precision, intent(in) :: x + + isinf = (x > huge(x)) .or. (x < -huge(x)) + end function isinf_d +end module aux2 + +program test + use aux2 + implicit none + real :: nan, large, inf + + ! Create a NaN and check it + nan = 0 + nan = nan / nan + if (nan == nan .or. nan > nan .or. nan < nan .or. nan >= nan & + .or. nan <= nan) STOP 1 + if (isnan (2.d0) .or. (.not. isnan(nan)) .or. & + (.not. isnan(real(nan,kind=kind(2.d0))))) STOP 2 + + ! Create an INF and check it + large = huge(large) + inf = 2 * large + if (isinf(nan) .or. isinf(large) .or. .not. isinf(inf)) STOP 3 + if (isinf(-nan) .or. isinf(-large) .or. .not. isinf(-inf)) STOP 4 + + ! Check that MIN and MAX behave correctly + + if (.not. isnan(min(nan,nan))) STOP 13 + if (.not. isnan(max(nan,nan))) STOP 14 + + ! Same thing, with more arguments + + if (.not. isnan(min(nan,nan,nan))) STOP 27 + if (.not. isnan(max(nan,nan,nan))) STOP 28 + if (.not. isnan(min(nan,nan,nan,nan))) STOP 29 + if (.not. isnan(max(nan,nan,nan,nan))) STOP 30 + if (.not. isnan(min(nan,nan,nan,nan,nan))) STOP 31 + if (.not. isnan(max(nan,nan,nan,nan,nan))) STOP 32 + + ! Large values, INF and NaNs + if (.not. isinf(max(large, inf))) STOP 33 + if (isinf(min(large, inf))) STOP 34 + + if (.not. isinf(min(-large, -inf))) STOP 41 + if (isinf(max(-large, -inf))) STOP 42 + +end program test Index: Fortran/gfortran/regression/nan_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_2.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! { dg-options "-fno-range-check -pedantic" } +! { dg-add-options ieee } +! +! PR fortran/34333 +! +! Check that (NaN /= NaN) == .TRUE. +! and some other NaN options. +! +! Contrary to nan_1.f90, PARAMETERs are used and thus +! the front end resolves the min, max and binary operators at +! compile time. +! + +module aux2 + interface isinf + module procedure isinf_r + module procedure isinf_d + end interface isinf +contains + pure function isinf_r(x) result (isinf) + logical :: isinf + real, intent(in) :: x + + isinf = (x > huge(x)) .or. (x < -huge(x)) + end function isinf_r + + pure function isinf_d(x) result (isinf) + logical :: isinf + double precision, intent(in) :: x + + isinf = (x > huge(x)) .or. (x < -huge(x)) + end function isinf_d +end module aux2 + +program test + use aux2 + implicit none + real, parameter :: nan = 0.0/0.0, large = huge(large), inf = 1.0/0.0 + + if (nan == nan .or. nan > nan .or. nan < nan .or. nan >= nan & + .or. nan <= nan) STOP 1 + if (isnan (2.d0) .or. (.not. isnan(nan)) .or. & + (.not. isnan(real(nan,kind=kind(2.d0))))) STOP 2 + + ! Create an INF and check it + if (isinf(nan) .or. isinf(large) .or. .not. isinf(inf)) STOP 3 + if (isinf(-nan) .or. isinf(-large) .or. .not. isinf(-inf)) STOP 4 + + ! Check that MIN and MAX behave correctly + if (max(2.0, nan) /= 2.0) STOP 5 + if (min(2.0, nan) /= 2.0) STOP 6 + if (max(nan, 2.0) /= 2.0) STOP 7 + if (min(nan, 2.0) /= 2.0) STOP 8 + + if (max(2.d0, nan) /= 2.d0) STOP 9! { dg-warning "Extension: Different type kinds" } + if (min(2.d0, nan) /= 2.d0) STOP 10! { dg-warning "Extension: Different type kinds" } + if (max(nan, 2.d0) /= 2.d0) STOP 11! { dg-warning "Extension: Different type kinds" } + if (min(nan, 2.d0) /= 2.d0) STOP 12! { dg-warning "Extension: Different type kinds" } + + if (.not. isnan(min(nan,nan))) STOP 13 + if (.not. isnan(max(nan,nan))) STOP 14 + + ! Same thing, with more arguments + + if (max(3.0, 2.0, nan) /= 3.0) STOP 15 + if (min(3.0, 2.0, nan) /= 2.0) STOP 16 + if (max(3.0, nan, 2.0) /= 3.0) STOP 17 + if (min(3.0, nan, 2.0) /= 2.0) STOP 18 + if (max(nan, 3.0, 2.0) /= 3.0) STOP 19 + if (min(nan, 3.0, 2.0) /= 2.0) STOP 20 + + if (max(3.d0, 2.d0, nan) /= 3.d0) STOP 21! { dg-warning "Extension: Different type kinds" } + if (min(3.d0, 2.d0, nan) /= 2.d0) STOP 22! { dg-warning "Extension: Different type kinds" } + if (max(3.d0, nan, 2.d0) /= 3.d0) STOP 23! { dg-warning "Extension: Different type kinds" } + if (min(3.d0, nan, 2.d0) /= 2.d0) STOP 24! { dg-warning "Extension: Different type kinds" } + if (max(nan, 3.d0, 2.d0) /= 3.d0) STOP 25! { dg-warning "Extension: Different type kinds" } + if (min(nan, 3.d0, 2.d0) /= 2.d0) STOP 26! { dg-warning "Extension: Different type kinds" } + + if (.not. isnan(min(nan,nan,nan))) STOP 27 + if (.not. isnan(max(nan,nan,nan))) STOP 28 + if (.not. isnan(min(nan,nan,nan,nan))) STOP 29 + if (.not. isnan(max(nan,nan,nan,nan))) STOP 30 + if (.not. isnan(min(nan,nan,nan,nan,nan))) STOP 31 + if (.not. isnan(max(nan,nan,nan,nan,nan))) STOP 32 + + ! Large values, INF and NaNs + if (.not. isinf(max(large, inf))) STOP 33 + if (isinf(min(large, inf))) STOP 34 + if (.not. isinf(max(nan, large, inf))) STOP 35 + if (isinf(min(nan, large, inf))) STOP 36 + if (.not. isinf(max(large, nan, inf))) STOP 37 + if (isinf(min(large, nan, inf))) STOP 38 + if (.not. isinf(max(large, inf, nan))) STOP 39 + if (isinf(min(large, inf, nan))) STOP 40 + + if (.not. isinf(min(-large, -inf))) STOP 41 + if (isinf(max(-large, -inf))) STOP 42 + if (.not. isinf(min(nan, -large, -inf))) STOP 43 + if (isinf(max(nan, -large, -inf))) STOP 44 + if (.not. isinf(min(-large, nan, -inf))) STOP 45 + if (isinf(max(-large, nan, -inf))) STOP 46 + if (.not. isinf(min(-large, -inf, nan))) STOP 47 + if (isinf(max(-large, -inf, nan))) STOP 48 + +end program test Index: Fortran/gfortran/regression/nan_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_3.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } +! +! PR fortran/34319 +! +! Check support of INF/NaN for I/O. +! +program main + implicit none + real :: r + complex :: z + character(len=30) :: str + + str = "nan" + read(str,*) r + if (.not.isnan(r)) STOP 1 + str = "(nan,4.0)" + read(str,*) z + if (.not.isnan(real(z)) .or. aimag(z) /= 4.0) STOP 2 + str = "(7.0,nan)" + read(str,*) z + if (.not.isnan(aimag(z)) .or. real(z) /= 7.0) STOP 3 + + str = "inFinity" + read(str,*) r + if (r <= huge(r)) STOP 4 + str = "(+inFinity,4.0)" + read(str,*) z + if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) STOP 5 + str = "(7.0,-inFinity)" + read(str,*) z + if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) STOP 6 + + str = "inf" + read(str,*) r + if (r <= huge(r)) STOP 7 + str = "(+inf,4.0)" + read(str,*) z + if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) STOP 8 + str = "(7.0,-inf)" + read(str,*) z + if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) STOP 9 + +end program main Index: Fortran/gfortran/regression/nan_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=gnu -fallow-invalid-boz" } +! { dg-add-options ieee } +! +! PR fortran/34398. +! +! Check for invalid numbers in bit-wise BOZ transfers +! +program test + implicit none + real(4), parameter :: r0 = z'FFFFFFFF' ! { dg-warning "BOZ literal constant" } + real(4) r + data r/z'FFFFFFFF'/ ! { dg-warning "BOZ literal constant" } + r = z'FFFFFFFF' ! { dg-warning "BOZ literal constant" } +end program test Index: Fortran/gfortran/regression/nan_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_5.f90 @@ -0,0 +1,27 @@ +! Check that we correctly simplify ISNAN +! +! { dg-do compile } +! +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } + + implicit none + real, parameter :: inf = 2 * huge(inf) + real, parameter :: nan1 = 0. / 0. + real, parameter :: nan2 = 1.5 * nan1 + real, parameter :: nan3 = inf / inf + real, parameter :: nan4 = inf - inf + real, parameter :: nan5 = 0. * inf + real, parameter :: normal = 42. + + integer(kind=merge(4, 0, isnan(nan1))) :: a + integer(kind=merge(4, 0, isnan(nan2))) :: b + integer(kind=merge(4, 0, isnan(nan3))) :: c + integer(kind=merge(4, 0, isnan(nan4))) :: d + integer(kind=merge(4, 0, isnan(nan5))) :: e + + integer(kind=merge(0, 4, isnan(inf))) :: f + integer(kind=merge(0, 4, isnan(-inf))) :: g + integer(kind=merge(0, 4, isnan(normal))) :: h + + end Index: Fortran/gfortran/regression/nan_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_6.f90 @@ -0,0 +1,98 @@ +! { dg-do run } +! { dg-add-options ieee } +! +! List-directed part of PR fortran/43298 +! and follow up to PR fortran/34319. +! +! Check handling of "NAN(alphanum)" +! +character(len=200) :: str +real :: r +complex :: z + +! read_real: + +r = 1.0 +str = 'INfinity' ; read(str,*) r +if (r < 0 .or. r /= r*1.1) STOP 1 + +r = 1.0 +str = '-INF' ; read(str,*) r +if (r > 0 .or. r /= r*1.1) STOP 2 + +r = 1.0 +str = '+INF' ; read(str,*) r +if (r < 0 .or. r /= r*1.1) STOP 3 + +r = 1.0 +str = '-inFiniTY' ; read(str,*) r +if (r > 0 .or. r /= r*1.1) STOP 4 + +r = 1.0 +str = 'NAN' ; read(str,*) r +if (.not. isnan(r)) STOP 5 + +r = 1.0 +str = '-NAN' ; read(str,*) r +if (.not. isnan(r)) STOP 6 + +r = 1.0 +str = '+NAN' ; read(str,*) r +if (.not. isnan(r)) STOP 7 + +r = 1.0 +str = 'NAN(0x111)' ; read(str,*) r +if (.not. isnan(r)) STOP 8 + +r = 1.0 +str = '-NAN(123)' ; read(str,*) r +if (.not. isnan(r)) STOP 9 + +r = 1.0 +str = '+NAN(0xFFE)' ; read(str,*) r +if (.not. isnan(r)) STOP 10 + + +! parse_real + +z = cmplx(-2.0,-4.0) +str = '(0.0,INfinity)' ; read(str,*) z +if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) STOP 11 + +z = cmplx(-2.0,-4.0) +str = '(-INF,0.0)' ; read(str,*) z +if (real(z) > 0 .or. real(z) /= real(z)*1.1) STOP 12 + +z = cmplx(-2.0,-4.0) +str = '(0.0,+INF)' ; read(str,*) z +if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) STOP 13 + +z = cmplx(-2.0,-4.0) +str = '(-inFiniTY,0.0)' ; read(str,*) z +if (real(z) > 0 .or. real(z) /= real(z)*1.1) STOP 14 + +z = cmplx(-2.0,-4.0) +str = '(NAN,0.0)' ; read(str,*) z +if (.not. isnan(real(z))) STOP 15 + +z = cmplx(-2.0,-4.0) +str = '(0.0,-NAN)' ; read(str,*) z +if (.not. isnan(aimag(z))) STOP 16 + +z = cmplx(-2.0,-4.0) +str = '(+NAN,0.0)' ; read(str,*) z +if (.not. isnan(real(z))) STOP 17 + +z = cmplx(-2.0,-4.0) +str = '(NAN(0x111),0.0)' ; read(str,*) z +if (.not. isnan(real(z))) STOP 18 + +z = cmplx(-2.0,-4.0) +str = '(0.0,-NaN(123))' ; read(str,*) z +if (.not. isnan(aimag(z))) STOP 19 + +z = cmplx(-2.0,-4.0) +str = '(+nan(0xFFE),0.0)' ; read(str,*) z +if (.not. isnan(real(z))) STOP 20 + +end Index: Fortran/gfortran/regression/nan_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nan_7.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! { dg-require-effective-target fortran_real_16 } +! { dg-require-effective-target fortran_integer_16 } +! { dg-skip-if "" { "powerpc*le-*-*" } } +! PR47293 NAN not correctly read +character(len=200) :: str +real(16) :: r +integer(16) :: k2 +integer(16), parameter :: quietnan = 170099645085600953110659059745250344960 +r = 1.0 +str = 'NAN' ; read(str,*) r +k2 = transfer(r,k2) +k2 = iand(k2, z'fff80000000000000000000000000000') +if (k2.ne.quietnan) STOP 1 +end Index: Fortran/gfortran/regression/nearest_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nearest_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-O0 -ffloat-store" } +! { dg-add-options ieee } +! PR fortran/27021 +! Original code submitted by Dominique d'Humieres +! Converted to Dejagnu for the testsuite by Steven G. Kargl +program chop + integer ix, iy + real o, t, td, tu, x, y + o = 1. + t = tiny(o) + td = nearest(t,-1.0) + x = td/2.0 + y = nearest(tiny(o),-1.0)/2.0 + ix = transfer(x,ix) + iy = transfer(y,iy) + if (ix /= iy) STOP 1 +end program chop + Index: Fortran/gfortran/regression/nearest_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nearest_2.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! { dg-add-options ieee } +! +! PR fortran/34192 +! +! Test compile-time implementation of NEAREST +! +program test + implicit none + +! Single precision + + ! 0+ > 0 + if (nearest(0.0, 1.0) & + <= 0.0) & + STOP 1 + ! 0++ > 0+ + if (nearest(nearest(0.0, 1.0), 1.0) & + <= nearest(0.0, 1.0)) & + STOP 2 + ! 0+++ > 0++ + if (nearest(nearest(nearest(0.0, 1.0), 1.0), 1.0) & + <= nearest(nearest(0.0, 1.0), 1.0)) & + STOP 3 + ! 0+- = 0 + if (nearest(nearest(0.0, 1.0), -1.0) & + /= 0.0) & + STOP 4 + ! 0++- = 0+ + if (nearest(nearest(nearest(0.0, 1.0), 1.0), -1.0) & + /= nearest(0.0, 1.0)) & + STOP 5 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(0.0, 1.0), 1.0), -1.0), -1.0) & + /= 0.0) & + STOP 6 + + ! 0- < 0 + if (nearest(0.0, -1.0) & + >= 0.0) & + STOP 7 + ! 0-- < 0+ + if (nearest(nearest(0.0, -1.0), -1.0) & + >= nearest(0.0, -1.0)) & + STOP 8 + ! 0--- < 0-- + if (nearest(nearest(nearest(0.0, -1.0), -1.0), -1.0) & + >= nearest(nearest(0.0, -1.0), -1.0)) & + STOP 9 + ! 0-+ = 0 + if (nearest(nearest(0.0, -1.0), 1.0) & + /= 0.0) & + STOP 10 + ! 0--+ = 0- + if (nearest(nearest(nearest(0.0, -1.0), -1.0), 1.0) & + /= nearest(0.0, -1.0)) & + STOP 11 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(0.0, -1.0), -1.0), 1.0), 1.0) & + /= 0.0) & + STOP 12 + + ! 42++ > 42+ + if (nearest(nearest(42.0, 1.0), 1.0) & + <= nearest(42.0, 1.0)) & + STOP 13 + ! 42-- < 42- + if (nearest(nearest(42.0, -1.0), -1.0) & + >= nearest(42.0, -1.0)) & + STOP 14 + ! 42-+ = 42 + if (nearest(nearest(42.0, -1.0), 1.0) & + /= 42.0) & + STOP 15 + ! 42+- = 42 + if (nearest(nearest(42.0, 1.0), -1.0) & + /= 42.0) & + STOP 16 + + ! INF+ = INF + if (nearest(1.0/0.0, 1.0) /= 1.0/0.0) STOP 17 + ! -INF- = -INF + if (nearest(-1.0/0.0, -1.0) /= -1.0/0.0) STOP 18 + ! NAN- = NAN + if (.not.isnan(nearest(0.0d0/0.0, 1.0))) STOP 19 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0d0/0.0, -1.0))) STOP 20 + +! Double precision + + ! 0+ > 0 + if (nearest(0.0d0, 1.0) & + <= 0.0d0) & + STOP 21 + ! 0++ > 0+ + if (nearest(nearest(0.0d0, 1.0), 1.0) & + <= nearest(0.0d0, 1.0)) & + STOP 22 + ! 0+++ > 0++ + if (nearest(nearest(nearest(0.0d0, 1.0), 1.0), 1.0) & + <= nearest(nearest(0.0d0, 1.0), 1.0)) & + STOP 23 + ! 0+- = 0 + if (nearest(nearest(0.0d0, 1.0), -1.0) & + /= 0.0d0) & + STOP 24 + ! 0++- = 0+ + if (nearest(nearest(nearest(0.0d0, 1.0), 1.0), -1.0) & + /= nearest(0.0d0, 1.0)) & + STOP 25 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(0.0d0, 1.0), 1.0), -1.0), -1.0) & + /= 0.0d0) & + STOP 26 + + ! 0- < 0 + if (nearest(0.0d0, -1.0) & + >= 0.0d0) & + STOP 27 + ! 0-- < 0+ + if (nearest(nearest(0.0d0, -1.0), -1.0) & + >= nearest(0.0d0, -1.0)) & + STOP 28 + ! 0--- < 0-- + if (nearest(nearest(nearest(0.0d0, -1.0), -1.0), -1.0) & + >= nearest(nearest(0.0d0, -1.0), -1.0)) & + STOP 29 + ! 0-+ = 0 + if (nearest(nearest(0.0d0, -1.0), 1.0) & + /= 0.0d0) & + STOP 30 + ! 0--+ = 0- + if (nearest(nearest(nearest(0.0d0, -1.0), -1.0), 1.0) & + /= nearest(0.0d0, -1.0)) & + STOP 31 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(0.0d0, -1.0), -1.0), 1.0), 1.0) & + /= 0.0d0) & + STOP 32 + + ! 42++ > 42+ + if (nearest(nearest(42.0d0, 1.0), 1.0) & + <= nearest(42.0d0, 1.0)) & + STOP 33 + ! 42-- < 42- + if (nearest(nearest(42.0d0, -1.0), -1.0) & + >= nearest(42.0d0, -1.0)) & + STOP 34 + ! 42-+ = 42 + if (nearest(nearest(42.0d0, -1.0), 1.0) & + /= 42.0d0) & + STOP 35 + ! 42+- = 42 + if (nearest(nearest(42.0d0, 1.0), -1.0) & + /= 42.0d0) & + STOP 36 + + ! INF+ = INF + if (nearest(1.0d0/0.0d0, 1.0) /= 1.0d0/0.0d0) STOP 37 + ! -INF- = -INF + if (nearest(-1.0d0/0.0d0, -1.0) /= -1.0d0/0.0d0) STOP 38 + ! NAN- = NAN + if (.not.isnan(nearest(0.0d0/0.0, 1.0))) STOP 39 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0d0/0.0, -1.0))) STOP 40 +end program test Index: Fortran/gfortran/regression/nearest_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nearest_3.f90 @@ -0,0 +1,338 @@ +! { dg-do run } +! { dg-add-options ieee } +! +! PR fortran/34209 +! +! Test run-time implementation of NEAREST +! +program test + implicit none + real(4), volatile :: r4 + real(8), volatile :: r8 + +! Single precision with single-precision sign + + r4 = 0.0_4 + ! 0+ > 0 + if (nearest(r4, 1.0) & + <= r4) & + STOP 1 + ! 0++ > 0+ + if (nearest(nearest(r4, 1.0), 1.0) & + <= nearest(r4, 1.0)) & + STOP 2 + ! 0+++ > 0++ + if (nearest(nearest(nearest(r4, 1.0), 1.0), 1.0) & + <= nearest(nearest(r4, 1.0), 1.0)) & + STOP 3 + ! 0+- = 0 + if (nearest(nearest(r4, 1.0), -1.0) & + /= r4) & + STOP 4 + ! 0++- = 0+ + if (nearest(nearest(nearest(r4, 1.0), 1.0), -1.0) & + /= nearest(r4, 1.0)) & + STOP 5 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(r4, 1.0), 1.0), -1.0), -1.0) & + /= r4) & + STOP 6 + + ! 0- < 0 + if (nearest(r4, -1.0) & + >= r4) & + STOP 7 + ! 0-- < 0+ + if (nearest(nearest(r4, -1.0), -1.0) & + >= nearest(r4, -1.0)) & + STOP 8 + ! 0--- < 0-- + if (nearest(nearest(nearest(r4, -1.0), -1.0), -1.0) & + >= nearest(nearest(r4, -1.0), -1.0)) & + STOP 9 + ! 0-+ = 0 + if (nearest(nearest(r4, -1.0), 1.0) & + /= r4) & + STOP 10 + ! 0--+ = 0- + if (nearest(nearest(nearest(r4, -1.0), -1.0), 1.0) & + /= nearest(r4, -1.0)) & + STOP 11 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(r4, -1.0), -1.0), 1.0), 1.0) & + /= r4) & + STOP 12 + + r4 = 42.0_4 + ! 42++ > 42+ + if (nearest(nearest(r4, 1.0), 1.0) & + <= nearest(r4, 1.0)) & + STOP 13 + ! 42-- < 42- + if (nearest(nearest(r4, -1.0), -1.0) & + >= nearest(r4, -1.0)) & + STOP 14 + ! 42-+ = 42 + if (nearest(nearest(r4, -1.0), 1.0) & + /= r4) & + STOP 15 + ! 42+- = 42 + if (nearest(nearest(r4, 1.0), -1.0) & + /= r4) & + STOP 16 + + r4 = 0.0 + ! INF+ = INF + if (nearest(1.0/r4, 1.0) /= 1.0/r4) STOP 17 + ! -INF- = -INF + if (nearest(-1.0/r4, -1.0) /= -1.0/r4) STOP 18 + ! NAN- = NAN + if (.not.isnan(nearest(0.0/r4, 1.0))) STOP 19 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0/r4, -1.0))) STOP 20 + +! Double precision with single-precision sign + + r8 = 0.0_8 + ! 0+ > 0 + if (nearest(r8, 1.0) & + <= r8) & + STOP 21 + ! 0++ > 0+ + if (nearest(nearest(r8, 1.0), 1.0) & + <= nearest(r8, 1.0)) & + STOP 22 + ! 0+++ > 0++ + if (nearest(nearest(nearest(r8, 1.0), 1.0), 1.0) & + <= nearest(nearest(r8, 1.0), 1.0)) & + STOP 23 + ! 0+- = 0 + if (nearest(nearest(r8, 1.0), -1.0) & + /= r8) & + STOP 24 + ! 0++- = 0+ + if (nearest(nearest(nearest(r8, 1.0), 1.0), -1.0) & + /= nearest(r8, 1.0)) & + STOP 25 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(r8, 1.0), 1.0), -1.0), -1.0) & + /= r8) & + STOP 26 + + ! 0- < 0 + if (nearest(r8, -1.0) & + >= r8) & + STOP 27 + ! 0-- < 0+ + if (nearest(nearest(r8, -1.0), -1.0) & + >= nearest(r8, -1.0)) & + STOP 28 + ! 0--- < 0-- + if (nearest(nearest(nearest(r8, -1.0), -1.0), -1.0) & + >= nearest(nearest(r8, -1.0), -1.0)) & + STOP 29 + ! 0-+ = 0 + if (nearest(nearest(r8, -1.0), 1.0) & + /= r8) & + STOP 30 + ! 0--+ = 0- + if (nearest(nearest(nearest(r8, -1.0), -1.0), 1.0) & + /= nearest(r8, -1.0)) & + STOP 31 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(r8, -1.0), -1.0), 1.0), 1.0) & + /= r8) & + STOP 32 + + r8 = 42.0_8 + ! 42++ > 42+ + if (nearest(nearest(r8, 1.0), 1.0) & + <= nearest(r8, 1.0)) & + STOP 33 + ! 42-- < 42- + if (nearest(nearest(r8, -1.0), -1.0) & + >= nearest(r8, -1.0)) & + STOP 34 + ! 42-+ = 42 + if (nearest(nearest(r8, -1.0), 1.0) & + /= r8) & + STOP 35 + ! 42+- = 42 + if (nearest(nearest(r8, 1.0), -1.0) & + /= r8) & + STOP 36 + + r4 = 0.0 + ! INF+ = INF + if (nearest(1.0/r4, 1.0) /= 1.0/r4) STOP 37 + ! -INF- = -INF + if (nearest(-1.0/r4, -1.0) /= -1.0/r4) STOP 38 + ! NAN- = NAN + if (.not.isnan(nearest(0.0/r4, 1.0))) STOP 39 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0/r4, -1.0))) STOP 40 + + +! Single precision with double-precision sign + + r4 = 0.0_4 + ! 0+ > 0 + if (nearest(r4, 1.0d0) & + <= r4) & + STOP 41 + ! 0++ > 0+ + if (nearest(nearest(r4, 1.0d0), 1.0d0) & + <= nearest(r4, 1.0d0)) & + STOP 42 + ! 0+++ > 0++ + if (nearest(nearest(nearest(r4, 1.0d0), 1.0d0), 1.0d0) & + <= nearest(nearest(r4, 1.0d0), 1.0d0)) & + STOP 43 + ! 0+- = 0 + if (nearest(nearest(r4, 1.0d0), -1.0d0) & + /= r4) & + STOP 44 + ! 0++- = 0+ + if (nearest(nearest(nearest(r4, 1.0d0), 1.0d0), -1.0d0) & + /= nearest(r4, 1.0d0)) & + STOP 45 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(r4, 1.0d0), 1.0d0), -1.0d0), -1.0d0) & + /= r4) & + STOP 46 + + ! 0- < 0 + if (nearest(r4, -1.0d0) & + >= r4) & + STOP 47 + ! 0-- < 0+ + if (nearest(nearest(r4, -1.0d0), -1.0d0) & + >= nearest(r4, -1.0d0)) & + STOP 48 + ! 0--- < 0-- + if (nearest(nearest(nearest(r4, -1.0d0), -1.0d0), -1.0d0) & + >= nearest(nearest(r4, -1.0d0), -1.0d0)) & + STOP 49 + ! 0-+ = 0 + if (nearest(nearest(r4, -1.0d0), 1.0d0) & + /= r4) & + STOP 50 + ! 0--+ = 0- + if (nearest(nearest(nearest(r4, -1.0d0), -1.0d0), 1.0d0) & + /= nearest(r4, -1.0d0)) & + STOP 51 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(r4, -1.0d0), -1.0d0), 1.0d0), 1.0d0) & + /= r4) & + STOP 52 + + r4 = 42.0_4 + ! 42++ > 42+ + if (nearest(nearest(r4, 1.0d0), 1.0d0) & + <= nearest(r4, 1.0d0)) & + STOP 53 + ! 42-- < 42- + if (nearest(nearest(r4, -1.0d0), -1.0d0) & + >= nearest(r4, -1.0d0)) & + STOP 54 + ! 42-+ = 42 + if (nearest(nearest(r4, -1.0d0), 1.0d0) & + /= r4) & + STOP 55 + ! 42+- = 42 + if (nearest(nearest(r4, 1.0d0), -1.0d0) & + /= r4) & + STOP 56 + + r4 = 0.0 + ! INF+ = INF + if (nearest(1.0d0/r4, 1.0d0) /= 1.0d0/r4) STOP 57 + ! -INF- = -INF + if (nearest(-1.0d0/r4, -1.0d0) /= -1.0d0/r4) STOP 58 + ! NAN- = NAN + if (.not.isnan(nearest(0.0/r4, 1.0d0))) STOP 59 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0/r4, -1.0d0))) STOP 60 + +! Double precision with double-precision sign + + r8 = 0.0_8 + ! 0+ > 0 + if (nearest(r8, 1.0d0) & + <= r8) & + STOP 61 + ! 0++ > 0+ + if (nearest(nearest(r8, 1.0d0), 1.0d0) & + <= nearest(r8, 1.0d0)) & + STOP 62 + ! 0+++ > 0++ + if (nearest(nearest(nearest(r8, 1.0d0), 1.0d0), 1.0d0) & + <= nearest(nearest(r8, 1.0d0), 1.0d0)) & + STOP 63 + ! 0+- = 0 + if (nearest(nearest(r8, 1.0d0), -1.0d0) & + /= r8) & + STOP 64 + ! 0++- = 0+ + if (nearest(nearest(nearest(r8, 1.0d0), 1.0d0), -1.0d0) & + /= nearest(r8, 1.0d0)) & + STOP 65 + ! 0++-- = 0 + if (nearest(nearest(nearest(nearest(r8, 1.0d0), 1.0d0), -1.0d0), -1.0d0) & + /= r8) & + STOP 66 + + ! 0- < 0 + if (nearest(r8, -1.0d0) & + >= r8) & + STOP 67 + ! 0-- < 0+ + if (nearest(nearest(r8, -1.0d0), -1.0d0) & + >= nearest(r8, -1.0d0)) & + STOP 68 + ! 0--- < 0-- + if (nearest(nearest(nearest(r8, -1.0d0), -1.0d0), -1.0d0) & + >= nearest(nearest(r8, -1.0d0), -1.0d0)) & + STOP 69 + ! 0-+ = 0 + if (nearest(nearest(r8, -1.0d0), 1.0d0) & + /= r8) & + STOP 70 + ! 0--+ = 0- + if (nearest(nearest(nearest(r8, -1.0d0), -1.0d0), 1.0d0) & + /= nearest(r8, -1.0d0)) & + STOP 71 + ! 0--++ = 0 + if (nearest(nearest(nearest(nearest(r8, -1.0d0), -1.0d0), 1.0d0), 1.0d0) & + /= r8) & + STOP 72 + + r8 = 42.0_8 + ! 42++ > 42+ + if (nearest(nearest(r8, 1.0d0), 1.0d0) & + <= nearest(r8, 1.0d0)) & + STOP 73 + ! 42-- < 42- + if (nearest(nearest(r8, -1.0d0), -1.0d0) & + >= nearest(r8, -1.0d0)) & + STOP 74 + ! 42-+ = 42 + if (nearest(nearest(r8, -1.0d0), 1.0d0) & + /= r8) & + STOP 75 + ! 42+- = 42 + if (nearest(nearest(r8, 1.0d0), -1.0d0) & + /= r8) & + STOP 76 + + r4 = 0.0 + ! INF+ = INF + if (nearest(1.0d0/r4, 1.0d0) /= 1.0d0/r4) STOP 77 + ! -INF- = -INF + if (nearest(-1.0d0/r4, -1.0d0) /= -1.0d0/r4) STOP 78 + ! NAN- = NAN + if (.not.isnan(nearest(0.0/r4, 1.0d0))) STOP 79 + ! NAN+ = NAN + if (.not.isnan(nearest(0.0/r4, -1.0d0))) STOP 80 + +end program test Index: Fortran/gfortran/regression/nearest_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nearest_4.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR33296 nearest(huge(1.0),1.0) gives an error +real x +x = nearest(-huge(1.0),-1.0) +print *, x +end Index: Fortran/gfortran/regression/nearest_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nearest_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +program a + real x, y(2) + x = 1./3. + y = [1, 2] / 3. + print *, nearest(x, 0.) ! { dg-error "shall not be zero" } + print *, nearest(y, 0.) ! { dg-error "shall not be zero" } + print *, nearest([1., 2.] / 3., 0.) ! { dg-error "shall not be zero" } + print *, nearest(1., 0.) ! { dg-error "shall not be zero" } +end program a Index: Fortran/gfortran/regression/negative-z-descriptor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative-z-descriptor.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR 22217: Z edit descriptor with negative numbers used to give lots of * + +program main + character(len=70) line + character(len=20) fmt + write(unit=line,fmt='(Z4)') -1_1 + if (line(1:4) .ne. ' FF') STOP 1 + write(unit=line,fmt='(Z5)') -1_2 + if (line(1:5) .ne. ' FFFF') STOP 2 + write(unit=line,fmt='(Z9)') -1_4 + if (line(1:9) .ne. ' FFFFFFFF') STOP 3 + write(unit=line,fmt='(Z17)') -2_8 + if (line(1:17) .ne. ' FFFFFFFFFFFFFFFE') STOP 4 + write(unit=line,fmt='(Z2)') 10_8 + if (line(1:2) .ne. ' A') STOP 5 + + write(unit=line,fmt='(Z8)') -43_8 + if (line(1:1) .ne. '*') STOP 6 + + write(unit=line,fmt='(B65)') -1_8 + if (line(1:2) .ne. ' 1') STOP 7 + if (line(64:66) .ne. '11 ') STOP 8 + + write(unit=line,fmt='(O4)') -2_1 + if (line(1:4) .ne. ' 376') STOP 9 +end Index: Fortran/gfortran/regression/negative_automatic_size.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_automatic_size.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-O2" } +! Tests the fix PR29451, in which the negative size of the +! automatic array 'jello' was not detected and the +! runtime error: Attempt to allocate a negative amount of memory +! resulted. +! +! Contributed by Philip Mason +! +program fred + call jackal (1, 0) + call jackal (2, 1) + call jackal (3, 0) +end + +subroutine jackal (b, c) + integer :: b, c + integer :: jello(b:c), cake(1:2, b:c), soda(b:c, 1:2) + if (lbound (jello, 1) <= ubound (jello, 1)) STOP 1 + if (size (jello) /= 0) STOP 2 + + if (.not.any(lbound (cake) <= ubound (cake))) STOP 3 + if (size (cake) /= 0) STOP 4 + + if ((lbound (soda, 1) > ubound (soda, 1)) .and. & + (lbound (soda, 2) > ubound (soda, 2))) STOP 5 + if (size (soda) /= 0) STOP 6 + +end subroutine jackal Index: Fortran/gfortran/regression/negative_stride_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_stride_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR fortran/102043 +! The middle-end used to conclude from array indexing that the index +! should be non-negative and thus that array accesses to reversed arrays +! (i.e. with negative strides) only access the last element of the array, +! as the access involves a pointer to array that is initialized to point +! to the last element in the case of a reversed array. + +program main + implicit none + integer :: a(3, 3) + integer :: i + a = 0 + call s(a(3:1:-1,:)) + if (any(a(:,1) /= (/ 7, 5, 3 /))) stop 1 + if (any(a(:,2) /= (/ 17, 13, 11 /))) stop 2 + if (any(a(:,3) /= (/ 29, 23, 19 /))) stop 3 +contains + subroutine s(b) + implicit none + integer, dimension(:,:) :: b + b = reshape((/ 3, 5, 7, 11, 13, 17, 19, 23, 29 /), (/ 3, 3 /)) + end subroutine s +end program main Index: Fortran/gfortran/regression/negative_unit.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_unit.f @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR libfortran/20660 and other bugs (not filed in bugzilla) relating +! to negative units +! PR 33055 Runtime error in INQUIRE unit existance with -fdefault-integer-8 +! Test case update by Jerry DeLisle +! +! Bugs submitted by Walt Brainerd + integer i,j + logical l + + i = -1 +! gfortran created a 'fort.-1' file and wrote "Hello" in it + write (unit=i, fmt=*, iostat=j) "Hello" + if (j <= 0) STOP 1 + + i = -11 + open (unit=i, file="xxx", iostat=j) + if (j <= 0) STOP 2 + + i = -42 + inquire (unit=i, exist=l) + if (l) STOP 3 + end Index: Fortran/gfortran/regression/negative_unit2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_unit2.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! Test case submitted by Dominique d'Humieres +program negative_unit2 + integer :: i, j + ! i should be <= NEWUNIT_FIRST in libgfortran/io/unit.c + i = -100 + write(unit=i,fmt=*, iostat=j) 10 + if (j == 0) STOP 1 +end program negative_unit2 Index: Fortran/gfortran/regression/negative_unit_check.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_unit_check.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! Test case from PR61933. + LOGICAL :: file_exists + INQUIRE(UNIT=-1,EXIST=file_exists)! { dg-error "cannot be -1" } + INQUIRE(UNIT=-2,EXIST=file_exists)! { dg-error "cannot be -2" } +END Index: Fortran/gfortran/regression/negative_unit_int8.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/negative_unit_int8.f @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! +! NOTE: This test is identical to negative_unit.f except -fdefault-integer-8 +! +! PR libfortran/20660 and other bugs (not filed in bugzilla) relating +! to negative units +! PR 33055 Runtime error in INQUIRE unit existance with -fdefault-integer-8 +! Test case update by Jerry DeLisle +! +! Bugs submitted by Walt Brainerd + integer i + integer, parameter ::ERROR_BAD_UNIT = 5005 + logical l + + i = -1 +! gfortran created a 'fort.-1' file and wrote "Hello" in it + write (unit=i, fmt=*, iostat=i) "Hello" + if (i <= 0) STOP 1 + + i = -11 + open (unit=i, file="xxx", iostat=i) + if (i <= 0) STOP 2 + + i = -42 + inquire (unit=i, exist=l) + if (l) STOP 3 + + i = 2_8*huge(0_4)+20_8 +! This one is nasty + inquire (unit=i, exist=l, iostat=i) + if (l) STOP 4 + if (i.ne.0) STOP 5 + + end Index: Fortran/gfortran/regression/nested_allocatables_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_allocatables_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR fortran/40850 +! The code freeing allocatable components used to be put after the code +! freeing the containing entity. +! +! Original test case by Marco Restelli +! Reduced by Daniel Franke +! and Janus Weil + + + type t + integer, allocatable :: d(:) + end type + type(t), allocatable :: a(:) + + ! Big enough to make it fail + allocate(a(2 * 1024)) + call sub( (/ a /) ) + +contains + + subroutine sub(b) + type(t) :: b(:) + end subroutine + +end + Index: Fortran/gfortran/regression/nested_array_constructor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! This test is run with result-checking and -fbounds-check as +! nested_array_constructor_2.f90 + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL. + +! Contributed by Tobias Burnus + +implicit none +character(len=2) :: c(3) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /) + +print *, c + +end Index: Fortran/gfortran/regression/nested_array_constructor_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL. + +! Contributed by Tobias Burnus + +implicit none +character(len=2) :: c(3) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /) + +print *, c + +if (c(1) /= 'ac' .or. c(2) /= 'ac' .or. c(3) /= 'cd') then + STOP 1 +end if + +end Index: Fortran/gfortran/regression/nested_array_constructor_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } + +! PR fortran/35846 +! Alternate test that also produced an ICE because of a missing length. + +PROGRAM test + IMPLICIT NONE + CHARACTER(LEN=2) :: x + + x = 'a' + CALL sub ( (/ TRIM(x), 'a' /) // 'c') +END PROGRAM + +SUBROUTINE sub(str) + IMPLICIT NONE + CHARACTER(LEN=*) :: str(2) + WRITE (*,*) str + + IF (str(1) /= 'ac' .OR. str(2) /= 'ac') THEN + STOP 1 + END IF +END SUBROUTINE sub Index: Fortran/gfortran/regression/nested_array_constructor_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_4.f90 @@ -0,0 +1,17 @@ +! { dg-do run } + +! PR fortran/35846 +! Alternate test that also produced an ICE because of a missing length. + +PROGRAM test + IMPLICIT NONE + CHARACTER(LEN=2) :: x + INTEGER :: length + + x = 'a' + length = LEN ( (/ TRIM(x), 'a' /) // 'c') + + IF (length /= 2) THEN + STOP 1 + END IF +END PROGRAM Index: Fortran/gfortran/regression/nested_array_constructor_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +! PR fortran/35846 +! This used to ICE because the charlength of the trim-expression was +! NULL, but it is switched around to test for the right operand of // being +! not a constant, too. + +implicit none +character(len=2) :: c(2) + +c = 'a' +c = (/ (/ trim(c(1)), 'a' /) // (/ trim(c(1)), 'a' /) /) + +print *, c + +end Index: Fortran/gfortran/regression/nested_array_constructor_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_array_constructor_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +! PR fortran/35846 +! Nested three levels deep. + +! Contributed by Tobias Burnus + +implicit none +character(len=3) :: c(3) +c = 'a' +c = (/ (/ 'A'//(/ trim(c(1)), 'a' /)/)//'c', 'dcd' /) +print *, c(1) +print *, c(2) +print *, c(3) +end Index: Fortran/gfortran/regression/nested_forall_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_forall_1.f @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! PR fortran/35820 +! +! Memory leak(s) while resolving forall constructs. +! +! Contributed by Dick Hendrickson + + MODULE TESTS + INTEGER,PARAMETER,PUBLIC :: I1_KV = KIND(1) + INTEGER,PARAMETER,PUBLIC :: R1_KV = KIND(1.0) + INTEGER, PRIVATE :: J1,J2 + INTEGER,PARAMETER,PUBLIC :: S1 = 10, S2 = 9 + CONTAINS + SUBROUTINE SA0136(RDA,IDA,BDA) + REAL(R1_KV) RDA(S1) + INTEGER(I1_KV) IDA(S1,S2) + INTEGER(I1_KV) ICA(S1,S2) + REAL(R1_KV) RCA(S1) +! T E S T S T A T E M E N T S + FORALL (J1 = 1:S1) + RDA(J1) = RCA(J1) + 1.0_R1_KV + FORALL (J2 = 1:S2) + IDA(J1,J2) = ICA(J1,J2) + 1 + END FORALL + FORALL (J2 = 1:S2) + IDA(J1,J2) = ICA(J1,J2) + END FORALL + ENDFORALL + FORALL (J1 = 1:S1) + RDA(J1) = RCA(J1) + FORALL (J2 = 1:S2) + IDA(J1,J2) = ICA(J1,J2) + END FORALL + END FORALL + END SUBROUTINE + END MODULE TESTS Index: Fortran/gfortran/regression/nested_modules_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! This tests that common blocks function with multiply nested modules. +! Contributed by Paul Thomas +! + module mod0 + complex(kind=8) FOO, KANGA + common /bar/ FOO, KANGA + contains + subroutine eyeore () + FOO = FOO + (1.0d0, 0.0d0) + KANGA = KANGA - (1.0d0, 0.0d0) + end subroutine eyeore + end module mod0 + module mod1 + use mod0 + complex ROBIN + common/owl/ROBIN + end module mod1 + module mod2 + use mod0 + use mod1 + real(kind=8) re1, im1, re2, im2, re, im + common /bar/ re1, im1, re2, im2 + equivalence (re1, re), (im1, im) + contains + subroutine tigger (w) + complex(kind=8) w + if (FOO.ne.(1.0d0, 1.0d0)) STOP 1 + if (KANGA.ne.(-1.0d0, -1.0d0)) STOP 2 + if (ROBIN.ne.(99.0d0, 99.0d0)) STOP 3 + if (w.ne.cmplx(re,im)) STOP 4 + end subroutine tigger + end module mod2 + + use mod2 + use mod0, only: w=>foo + w = (0.0d0, 1.0d0) ! Was foo but this is forbidden (11.3.2) + KANGA = (0.0d0, -1.0d0) + ROBIN = (99.0d0, 99.0d0) + call eyeore () + call tigger (w) + end Index: Fortran/gfortran/regression/nested_modules_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_2.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! This tests the patch for PR16861. +! +! Contributed by Paul Thomas +! +module foo +INTEGER :: i +end module foo + +module bar +contains +subroutine sub1 (j) + use foo + integer, dimension(i) :: j + j = 42 +end subroutine sub1 +subroutine sub2 (k) + use foo + integer, dimension(i) :: k + k = 84 +end subroutine sub2 +end module bar + +module foobar + use foo !This used to cause an ICE + use bar +end module foobar + +program testfoobar + use foobar + integer, dimension(3) :: l = 0 + i = 2 + call sub1 (l) + i = 1 + call sub2 (l) + if (any (l.ne.(/84,42,0/))) STOP 1 +end program testfoobar Index: Fortran/gfortran/regression/nested_modules_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_3.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! This tests the improved version of the patch for PR16861. Testing +! after committing the first version, revealed that this test did +! not work but was not regtested for, either. +! +! Contributed by Paul Thomas +! +MODULE foo + TYPE type1 + INTEGER i1 + END TYPE type1 +END MODULE + +MODULE bar +CONTAINS + SUBROUTINE sub1 (x, y) + USE foo + TYPE (type1) :: x + INTEGER :: y(x%i1) + y = 1 + END SUBROUTINE SUB1 + SUBROUTINE sub2 (u, v) + USE foo + TYPE (type1) :: u + INTEGER :: v(u%i1) + v = 2 + END SUBROUTINE SUB2 +END MODULE + +MODULE foobar + USE foo + USE bar +CONTAINS + SUBROUTINE sub3 (s, t) + USE foo + TYPE (type1) :: s + INTEGER :: t(s%i1) + t = 3 + END SUBROUTINE SUB3 +END MODULE foobar + +PROGRAM use_foobar + USE foo + USE foobar + INTEGER :: j(3) = 0 + TYPE (type1) :: z + z%i1 = 3 + CALL sub1 (z, j) + z%i1 = 2 + CALL sub2 (z, j) + z%i1 = 1 + CALL sub3 (z, j) + IF (ALL (j.ne.(/3,2,1/))) STOP 1 +END PROGRAM use_foobar Index: Fortran/gfortran/regression/nested_modules_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_4.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Test for the fix to PR24409 - the name clash between the module +! name and the interface formal argument would cause an ICE. +! +! Contributed by Paul Thomas +! +module string + interface + function lc(string ) + character(len=*), intent(in) :: string + character(len=len(string )) :: lc + end function lc + end interface +end module string + +module serial + use string +end module serial + + use serial + use string + character*15 :: buffer + buffer = lc ("Have a Nice DAY") + end Index: Fortran/gfortran/regression/nested_modules_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_5.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Test for supplementary fix to PR24409 - the name clash between the module +! variable and the interface formal argument would cause an ICE. +! +! Contributed by Paul Thomas +! +module anything + interface + function lc(string ) + character(len=*), intent(in) :: string + character(len=len(string )) :: lc + end function lc + end interface + character(len=12) :: string +end module anything + +module serial + use anything +end module serial + + use serial + use anything + character*15 :: buffer + buffer = lc ("Have a Nice DAY") + end Index: Fortran/gfortran/regression/nested_modules_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_modules_6.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! Test the patch for PR30084 in which the reference to SIZE +! in function diag caused a segfault in module.c. +! +! Contributed by Troban Trumsko +! and reduced by Steve Kargl +! +module tao_random_numbers + integer, dimension(10) :: s_buffer + integer :: s_last = size (s_buffer) +end module tao_random_numbers + +module linalg + contains + function diag (a) result (d) + real, dimension(:,:), intent(in) :: a + real, dimension(min(size(a,dim=1),size(a,dim=2))) :: d + integer :: i + do i = 1, min(size(a, dim = 1), size(a, dim = 2)) + d(i) = a(i,i) + end do + end function diag +end module linalg + +module vamp_rest + use tao_random_numbers + use linalg +end module vamp_rest + + use vamp_rest + real :: x(2, 2) = reshape ([1.,2.,3.,4.], [2,2]) + print *, s_last + print *, diag (x) +end Index: Fortran/gfortran/regression/nested_reshape.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nested_reshape.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 20436: This used to give a runtime error. +program nested_reshape + implicit none + real :: k(8,2) + real :: o(8,2) + + k = reshape((/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0, & + 9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0/), (/8,2/)) + + o = reshape(reshape(k, (/2,8/), order=(/2,1/)), (/8,2/)) +end program Index: Fortran/gfortran/regression/nesting_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nesting_1.f90 @@ -0,0 +1,18 @@ +! PR 18525 +! we used to incorrectly refer to n from a when resolving the call to +! c from b +! { dg-do run } +subroutine a(n) +call b(n+1) +contains + subroutine b(n) + call c(n) + end subroutine b + + subroutine c(m) + if (m/=1) STOP 1 + end subroutine c +end subroutine a + +call a(0) +end Index: Fortran/gfortran/regression/nesting_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nesting_2.f90 @@ -0,0 +1,16 @@ +! check to make the nested function dawsonseries_v gets the correct +! fake return decl and that the outer (dawson_v) has an assignment of +! just the fake return decl for real and not the inner's return decl. +! { dg-do compile } +FUNCTION dawson_v() + IMPLICIT NONE + REAL :: dawson_v + dawson_v = 1.0 + + CONTAINS + FUNCTION dawsonseries_v() + IMPLICIT NONE + REAL, DIMENSION(1) :: dawsonseries_v + dawsonseries_v=1.0 + END FUNCTION dawsonseries_v +END FUNCTION dawson_v Index: Fortran/gfortran/regression/nesting_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nesting_3.f90 @@ -0,0 +1,15 @@ +! check to make the nested function dawsonseries_v gets the correct +! fake return decl and that the outer (dawson_v) has an assignment of +! just the fake return decl for real and not the inner's return decl. +! { dg-do compile } +FUNCTION dawson_v() + IMPLICIT NONE + REAL,DIMENSION(1) :: dawson_v + dawson_v = 1.0 + CONTAINS + FUNCTION dawsonseries_v() + IMPLICIT NONE + REAL, DIMENSION(1) :: dawsonseries_v + dawsonseries_v=1.0 + END FUNCTION dawsonseries_v +END FUNCTION dawson_v Index: Fortran/gfortran/regression/new_line.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/new_line.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Checks Fortran 2003's new_line intrinsic function +! PR fortran/28585 +program new_line_check + implicit none + character(len=10) :: a1 + character(len=10) :: a2(2) + character(len=10), parameter :: a3 = "1234567890" + character(len=10), parameter :: a4(2) = "1234567890" + character(len=10), parameter :: a5(2) = repeat("1234567890",2) + + if(achar(10) /= new_line('a')) STOP 1 + + if (iachar(new_line(a1)) /= 10) STOP 2 + if (iachar(new_line(a2)) /= 10) STOP 3 + if (iachar(new_line(a3)) /= 10) STOP 4 + if (iachar(new_line(a4)) /= 10) STOP 5 + if (iachar(new_line(a5)) /= 10) STOP 6 + +end program new_line_check Index: Fortran/gfortran/regression/newunit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR40008 F2008: Add NEWUNIT= for OPEN statement +! Contributed by Jerry DeLisle +program newunit_1 + character(len=25) :: str + integer(1) :: myunit, myunit2 + myunit = 25 + str = "bad" + open(newunit=myunit, status="scratch") + open(newunit = myunit2, file="newunit_1file") + write(myunit,'(e24.15e2)') 1.0d0 + write(myunit2,*) "abcdefghijklmnop" + flush(myunit) + rewind(myunit) + rewind(myunit2) + read(myunit2,'(a)') str + if (str.ne." abcdefghijklmnop") STOP 1 + close(myunit) + close(myunit2, status="delete") +end program newunit_1 Index: Fortran/gfortran/regression/newunit_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR40008 F2008: Add NEWUNIT= for OPEN statement +! Check for rejection with pre-F2008 standard. + +! Contributed by Daniel Kraft, d@domob.eu. + +program main + character(len=25) :: str + integer(1) :: myunit + + open (newunit=myunit, file="some_file") ! { dg-error "Fortran 2008" } + close (unit=myunit) +end program main Index: Fortran/gfortran/regression/newunit_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_3.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR48960 On ERROR newunit should not modify user variable. +program test_newunit + integer :: st, un = 0 + open (newunit=un, file='nonexisting.dat', status='old', iostat=st) + if (un /= 0) STOP 1 +end program test_newunit Index: Fortran/gfortran/regression/newunit_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_4.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR69110 ICE with NEWUNIT +subroutine open_file_safe(fname, fstatus, faction, fposition, funit) + character(*), intent(in) :: fname, fstatus, faction, fposition + integer, intent(out) :: funit + open(newunit=funit, status=fstatus) +end subroutine open_file_safe Index: Fortran/gfortran/regression/newunit_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_5.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR83525 Combination of newunit and internal unit was failing. +program main + integer :: funit + logical :: isopen + integer :: this, another + character(len=:), allocatable :: message + + message = "12" + read(message, *) this + if (this.ne.12) STOP 1 + + open(newunit=funit, status="scratch") + write(funit, *) "13" + rewind(funit) + read(funit, *) another + !write(*,*) another + close(funit) + if (another.ne.13) STOP 2 +end Index: Fortran/gfortran/regression/newunit_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/newunit_6.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR fortran/83057 - OPEN without a filename and without STATUS='SCRATCH' +! could produce a warning + + open(newunit=iun,file="file") ! this is ok + open(newunit=jun,status="scratch") ! this too + open(newunit=lun) ! { dg-error "NEWUNIT specifier must have" } +end Index: Fortran/gfortran/regression/nint_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nint_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +program nint_1 + if (int(anint(8388609.0)) /= 8388609) STOP 1 + if (int(anint(0.49999997)) /= 0) STOP 2 + if (nint(8388609.0) /= 8388609) STOP 3 + if (nint(0.49999997) /= 0) STOP 4 + if (int(dnint(4503599627370497.0d0),8) /= 4503599627370497_8) STOP 5 + if (int(dnint(0.49999999999999994d0)) /= 0) STOP 6 + if (int(anint(-8388609.0)) /= -8388609) STOP 7 + if (int(anint(-0.49999997)) /= 0) STOP 8 + if (nint(-8388609.0) /= -8388609) STOP 9 + if (nint(-0.49999997) /= 0) STOP 10 + if (int(dnint(-4503599627370497.0d0),8) /= -4503599627370497_8) STOP 11 + if (int(dnint(-0.49999999999999994d0)) /= 0) STOP 12 +end program nint_1 Index: Fortran/gfortran/regression/nint_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nint_2.f90 @@ -0,0 +1,52 @@ +! Test that NINT gives right results even in corner cases +! +! PR 31202 +! http://gcc.gnu.org/ml/fortran/2005-04/msg00139.html +! +! { dg-do run } +! { dg-xfail-run-if "PR 33271, math library bug" { powerpc-ibm-aix* *-*-mingw* } { "-O0" } { "" } } + real(kind=8) :: a + integer(kind=8) :: i1, i2 + real :: b + integer :: j1, j2 + + a = nearest(0.5_8,-1.0_8) + i2 = nint(nearest(0.5_8,-1.0_8)) + i1 = nint(a) + if (i1 /= 0 .or. i2 /= 0) STOP 1 + + a = 0.5_8 + i2 = nint(0.5_8) + i1 = nint(a) + if (i1 /= 1 .or. i2 /= 1) STOP 2 + + a = nearest(0.5_8,1.0_8) + i2 = nint(nearest(0.5_8,1.0_8)) + i1 = nint(a) + if (i1 /= 1 .or. i2 /= 1) STOP 3 + + b = nearest(0.5,-1.0) + j2 = nint(nearest(0.5,-1.0)) + j1 = nint(b) + if (j1 /= 0 .or. j2 /= 0) STOP 4 + + b = 0.5 + j2 = nint(0.5) + j1 = nint(b) + if (j1 /= 1 .or. j2 /= 1) STOP 5 + + b = nearest(0.5,1.0) + j2 = nint(nearest(0.5,1.0)) + j1 = nint(b) + if (j1 /= 1 .or. j2 /= 1) STOP 6 + + a = 4503599627370497.0_8 + i1 = nint(a,kind=8) + i2 = nint(4503599627370497.0_8,kind=8) + if (i1 /= i2 .or. i1 /= 4503599627370497_8) STOP 7 + + a = -4503599627370497.0_8 + i1 = nint(a,kind=8) + i2 = nint(-4503599627370497.0_8,kind=8) + if (i1 /= i2 .or. i1 /= -4503599627370497_8) STOP 8 + end Index: Fortran/gfortran/regression/nint_p7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nint_p7.f90 @@ -0,0 +1,11 @@ +! Fortran +! { dg-do compile { target { powerpc*-*-* } } } +! { dg-require-effective-target powerpc_vsx_ok } +! { dg-options "-O2 -mdejagnu-cpu=power7 -ffast-math" } +! { dg-final { scan-assembler-times "xsrdpi" 2 } } + + subroutine test_nint(x4,x8) + real(4) x4 + real(8) x8 + print *, nint(x4), idnint(x8) + end subroutine test_nint Index: Fortran/gfortran/regression/no-automatic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no-automatic.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fno-automatic" } +! +! PR fortran/37835 +! Contributed by Tobias Burnus . +! +subroutine foo(n) + integer :: n + type t + integer :: i = 42 + end type t + type(t) :: myt + if(n==1) myt%i = 2 + print *, myt%i + if (n > 1 .and. myt%i /= 2) stop 1 +end subroutine foo + +call foo(1) +call foo(2) +end Index: Fortran/gfortran/regression/no_arg_check_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_arg_check_1.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_1.f90 +! +module mpi_interface + implicit none + + interface !mpi_send + subroutine MPI_Send (buf, count, datatype, dest, tag, comm, ierr) +!GCC$ attributes NO_ARG_CHECK :: buf + integer, intent(in) :: buf + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + + interface !mpi_send2 + subroutine MPI_Send2 (buf, count, datatype, dest, tag, comm, ierr) +!GCC$ attributes NO_ARG_CHECK :: buf + type(*), intent(in) :: buf(*) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + +end module + +use mpi_interface + real :: a(3) + integer :: b(3) + call foo(a) + call foo(b) + call foo(a(1:2)) + call foo(b(1:2)) + call MPI_Send(a, 1, 1,1,1,j,i) + call MPI_Send(b, 1, 1,1,1,j,i) + call MPI_Send2(a, 1, 1,1,1,j,i) + call MPI_Send2(b, 1, 1,1,1,j,i) +contains + subroutine foo(x) +!GCC$ attributes NO_ARG_CHECK :: x + real :: x(*) + call MPI_Send2(x, 1, 1,1,1,j,i) + end +end Index: Fortran/gfortran/regression/no_arg_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_arg_check_2.f90 @@ -0,0 +1,152 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_2.f90 +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr +!GCC$ attributes NO_ARG_CHECK :: x + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + integer(8), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt +!GCC$ attributes NO_ARG_CHECK :: arg1 + if (presnt .neqv. present (arg1)) STOP 1 + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_assumed (arg3) +!GCC$ attributes NO_ARG_CHECK :: arg3 + logical(1), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) +contains + subroutine sub(x) + integer :: x(:) + call sub_array_assumed (x) + end subroutine sub +end + +! { dg-final { scan-tree-dump-times "sub_scalar .0B," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 4 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 0 "original" } } + Index: Fortran/gfortran/regression/no_arg_check_2a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_arg_check_2a.f90 @@ -0,0 +1,121 @@ +! { dg-do run } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_2.f90 +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr +!GCC$ attributes NO_ARG_CHECK :: x + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + integer(8), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt +!GCC$ attributes NO_ARG_CHECK :: arg1 + if (presnt .neqv. present (arg1)) STOP 1 + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_assumed (arg3) +!GCC$ attributes NO_ARG_CHECK :: arg3 + logical(1), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) +contains + subroutine sub(x) + integer :: x(:) + call sub_array_assumed (x) + end subroutine sub +end Index: Fortran/gfortran/regression/no_arg_check_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_arg_check_3.f90 @@ -0,0 +1,124 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/39505 +! +! Test NO_ARG_CHECK +! Copied from assumed_type_2.f90 +! +subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, value :: a +end subroutine one + +subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, pointer :: a +end subroutine two + +subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer, allocatable :: a +end subroutine three + +subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a[*] +end subroutine four + +subroutine five(a) ! { dg-error "with NO_ARG_CHECK attribute shall either be a scalar or an assumed-size array" } +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a(3) +end subroutine five + +subroutine six() +!GCC$ attributes NO_ARG_CHECK :: nodum ! { dg-error "with NO_ARG_CHECK attribute shall be a dummy argument" } + integer :: nodum +end subroutine six + +subroutine seven(y) +!GCC$ attributes NO_ARG_CHECK :: y + integer :: y(*) + call a7(y(3:5)) ! { dg-error "with NO_ARG_CHECK attribute shall not have a subobject reference" } +contains + subroutine a7(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x(*) + end subroutine a7 +end subroutine seven + +subroutine nine() + interface one + subroutine okay(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine okay + end interface + interface two + subroutine ambig1(x) ! { dg-error "Ambiguous interfaces" } +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine ambig1 + subroutine ambig2(x) ! { dg-error "Ambiguous interfaces" } +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x(*) + end subroutine ambig2 + end interface + interface three + subroutine ambig3(x) ! { dg-error "Ambiguous interfaces" } +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + end subroutine ambig3 + subroutine ambig4(x) ! { dg-error "Ambiguous interfaces" } + integer :: x + end subroutine ambig4 + end interface +end subroutine nine + +subroutine ten() + interface + subroutine bar() + end subroutine + end interface + type t + contains + procedure, nopass :: proc => bar + end type + type(t) :: xx + call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" } +contains + subroutine sub(a) +!GCC$ attributes NO_ARG_CHECK :: a + integer :: a + end subroutine sub +end subroutine ten + +subroutine eleven(x) + external bar +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" } +end subroutine eleven + +subroutine twelf(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + call bar(x) ! { dg-error "Type mismatch in argument" } +contains + subroutine bar(x) + integer :: x + end subroutine bar +end subroutine twelf + +subroutine thirteen(x, y) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + integer :: y(:) + print *, ubound(y, dim=x) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" } +end subroutine thirteen + +subroutine fourteen(x) +!GCC$ attributes NO_ARG_CHECK :: x + integer :: x + x = x ! { dg-error "with NO_ARG_CHECK attribute may only be used as actual argument" } +end subroutine fourteen Index: Fortran/gfortran/regression/no_char_conversion_in_array_constructor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_char_conversion_in_array_constructor.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fdec-char-conversions" } + +program p + print *, -[integer :: 1, [integer(8) :: '2']] ! { dg-error "Cannot convert" } + print *, -[real :: 1, [real(8) :: '2']] ! { dg-error "Cannot convert" } + print *, -[complex :: 1, [complex(8) :: '2']] ! { dg-error "Cannot convert" } + print *, [logical :: 1, [logical(8) :: '2']] ! { dg-error "Cannot convert" } +end + Index: Fortran/gfortran/regression/no_char_to_numeric_assign.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_char_to_numeric_assign.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdec-char-conversions" } +! +! Test character variables can not be assigned to numeric and +! logical variables. +! +! Test case contributed by Mark Eggleston +! +program test + integer a + real b + complex c + logical d + character e + + e = "A" + a = e ! { dg-error "Cannot convert" } + b = e ! { dg-error "Cannot convert" } + c = e ! { dg-error "Cannot convert" } + d = e ! { dg-error "Cannot convert" } +end program Index: Fortran/gfortran/regression/no_overwrite_recursive_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_overwrite_recursive_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -frecursive" } +! +! Test case contributed by Mark Eggleston +! + +program test + ! do nothing +end program + +! { dg-warning "Flag '-fno-automatic' overwrites '-frecursive'" "warning" { target *-*-* } 0 } Index: Fortran/gfortran/regression/no_overwrite_recursive_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_overwrite_recursive_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -frecursive -Wno-overwrite-recursive" } +! +! Test case contributed by Mark Eggleston +! + +program test + ! do nothing +end program + Index: Fortran/gfortran/regression/no_range_check_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_range_check_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fno-range-check -O0" } +! +! This testcase arose from PR 31262 + integer :: a + integer(kind=8) :: b + b = -huge(b) / 7 + b = 7894_8 * b - 78941_8 + if (7894_8 * (-huge(b) / 7) - 78941_8 /= b) STOP 2 + + a = 1234789786453123 + if (a - 1234789786453123 /= a - (-426244989)) STOP 3 + end Index: Fortran/gfortran/regression/no_range_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_range_check_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! PR36515 Integer read a value overflow for an invalid integer. +! This tests that -fno-range-check allows this legacy behavior at runtime. +program int_range +character(25) :: inputline = "-2147483648" +integer*4 smallest +read(inputline,100) smallest +100 format(1i11) +if (smallest.ne.-2147483648) STOP 1 +end Index: Fortran/gfortran/regression/no_range_check_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_range_check_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +program test + integer(2) :: j, k + integer :: i + i = int(z'FFFFFFFF',kind(i)) + if (i /= -1) STOP 1 + if (int(z'FFFFFFFF',kind(i)) /= -1) STOP 2 + + if (popcnt(int(z'0F00F00080000001',8)) /= 10) STOP 3 + if (popcnt(int(z'800F0001',4)) /= 6) STOP 4 + + j = -1234_2 + k = int(z'FB2E',kind(j)) + if (k /= j) STOP 5 + if (int(z'FB2E',kind(j)) /= j) STOP 6 +end program test Index: Fortran/gfortran/regression/no_unit_error_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/no_unit_error_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! { dg-shouldfail "UNIT does not exist for FLUSH" } +! PR28335 Check for error on no unit. + close(88) + flush(88) ! { dg-output "Specified UNIT in FLUSH is not connected" } + end + Index: Fortran/gfortran/regression/noadv_size.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noadv_size.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 20774: Handle size parameter for non-advancing I/O correctly +program main + open(77,status='scratch') + write(77,'(A)') '123' + rewind(77) + read(77,'(2I2)',advance='no',iostat=k,size=n) i1,i2 + if (k >=0) STOP 1 + if (n /= 3) STOP 2 + if (i1 /= 12 .or. i2 /= 3) STOP 3 +end program main Index: Fortran/gfortran/regression/noinline.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noinline.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-dom2" } + +subroutine bar(n,m,p,s) +implicit none +integer :: n,m +real,intent(inout) :: p(n),s(*) +call foo(n,m,p,s) +call foo(n,m,p,s) +end subroutine bar + +subroutine foo(n,m,p,b) +implicit none +integer :: n,m,j +real,intent(inout) :: p(n),b(*) +!GCC$ ATTRIBUTES noinline :: foo +do j=1,n + b(m+j-1)=p(j) +enddo +m=m+n +end subroutine foo + +! { dg-final { scan-tree-dump-times "foo \\(" 4 "dom2"} } Index: Fortran/gfortran/regression/non_module_public.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/non_module_public.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR20837 - A symbol may not be declared PUBLIC or PRIVATE outside a module. +! Contributed by Joost VandeVondele +integer, parameter, public :: i=1 ! { dg-error "outside of the specification part of a module" } +END Index: Fortran/gfortran/regression/nonreturning_statements.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nonreturning_statements.f90 @@ -0,0 +1,25 @@ +! { dg-final { scan-assembler-not "should_be_noreturn" } } +! PR 17758 +! This checks that non-returning subroutines and statements +! really don't return by calling non-existing subroutines +! afterwards. These calls are supposed to be optimized away, so +! they won't show up in the generated assembly. +program main + character(len=5) :: c + c = '12345' + read(unit=c,fmt='(A)') i + select case(i) + case(1) + STOP 1 + call abort_should_be_noreturn + case(2) + stop 65 + call stop_numeric_should_be_noreturn + case(3) + stop "foobar" + call stop_string_should_be_noreturn + case(4) + call exit + call exit_should_be_noreturn + end select +end program main Index: Fortran/gfortran/regression/noreturn-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noreturn-1.f90 @@ -0,0 +1,62 @@ +! Check for various valid and erroneous "noreturn" cases. +! { dg-do compile } +! { dg-options "-O2" } + +module barbar +!GCC$ ATTRIBUTES noreturn :: bar1 +contains +subroutine bar1 +end subroutine bar1 ! { dg-warning "'noreturn' function does return" "detect falling off end of noreturn" } +end module + +subroutine foo1 +!GCC$ ATTRIBUTES noreturn :: foo1 +end subroutine foo1 ! { dg-warning "'noreturn' function does return" "detect falling off end of noreturn" } + +subroutine foo2 +!GCC$ ATTRIBUTES noreturn :: foo2 +call exit(0) +end subroutine foo2 ! { dg-bogus "warning:" "this function should not get any warnings" } + +subroutine foo3 +end subroutine foo3 ! { dg-bogus "warning:" "this function should not get any warnings" } + +subroutine foo4 +!GCC$ ATTRIBUTES noreturn :: foo4 +call foo2() +end subroutine foo4 ! { dg-bogus "warning:" "this function should not get any warnings" } + +subroutine foo5 +!GCC$ ATTRIBUTES noreturn :: foo5 +return ! { dg-warning "'noreturn' function does return" "detect invalid return" } +end subroutine foo5 + +subroutine foo6 +return +end subroutine foo6 ! { dg-bogus "warning:" "this function should not get any warnings" } + +subroutine foo7 +call foo6() +end subroutine foo7 ! { dg-bogus "warning:" "this function should not get any warnings" } + +subroutine foo8 +!GCC$ ATTRIBUTES noreturn :: foo8 +call foo7() +end subroutine foo8 ! { dg-warning "'noreturn' function does return" "detect return from tail call" } + +subroutine foo9 +!GCC$ ATTRIBUTES noreturn :: foo9 +interface +subroutine bar +!GCC$ ATTRIBUTES noreturn :: bar +end subroutine bar +end interface +call bar() +end subroutine foo9 ! { dg-bogus "warning:" "this function should not get any warnings" } + +function ffo1() +implicit none +!GCC$ ATTRIBUTES noreturn :: ffo1 +integer :: ffo1 +ffo1 = 0 +end function ffo1 ! { dg-warning "'noreturn' function does return" "detect falling off end of noreturn" } Index: Fortran/gfortran/regression/noreturn-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noreturn-2.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-O2 -Wuninitialized" } + +subroutine foo1 +implicit none +interface +subroutine bar1 +!GCC$ ATTRIBUTES noreturn :: bar1 +end subroutine +end interface +real,allocatable :: d(:) ! { dg-note "declared here" "note" } +d = 0. ! { dg-warning "used uninitialized" "uninitialized descriptor" } +call bar1() +d = 0. ! { dg-bogus "warning:" "not optimized out" } +end subroutine foo1 + +function foo2() +integer :: foo2 +interface +subroutine bar2 +!GCC$ ATTRIBUTES noreturn :: bar2 +end subroutine +end interface +call bar2 +return ! { dg-bogus "__result_foo2' is used uninitialized" "return" } +foo2 = 0 +end function foo2 + +subroutine foo3 +implicit none +integer :: i,j +interface +subroutine abort2 +!GCC$ ATTRIBUTES noreturn :: abort2 +end subroutine +end interface +call abort2() +do i=1,j-1 ; end do ! { dg-bogus "is used uninitialized" "uninitialized" } +end subroutine foo3 + +function foo4() +integer :: foo4 +!$GCC$ ATTRIBUTES noreturn :: foo4 +foo4 = 1 +end function + +subroutine foo5(k) +implicit none +integer :: i, k +!GCC$ ATTRIBUTES noreturn :: mpi_abort +call mpi_abort() +k = i +end subroutine Index: Fortran/gfortran/regression/noreturn-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noreturn-3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized -Wmaybe-uninitialized" } + +subroutine foo +implicit none +integer :: i +!GCC$ ATTRIBUTES noreturn :: mpi_abort +if (getpid() == 1) then + call mpi_abort() +else + i = 8 +endif +if (i > 0) print *, i +end subroutine Index: Fortran/gfortran/regression/noreturn-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noreturn-4.f90 @@ -0,0 +1,11 @@ +! { dg-do run { target { nonpic || pie_enabled } } } +! { dg-options "-O2" } + +program bar +call foo1() +call noreturn_autodetection_failed() ! check if optimized out +end program + +subroutine foo1 +stop 0 +end subroutine foo1 Index: Fortran/gfortran/regression/noreturn-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/noreturn-5.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-O2" } + +subroutine bar +!GCC$ ATTRIBUTES noreturn :: foo1 +call foo1() +call noreturn_autodetection_failed() +end subroutine +! /* { dg-final { scan-assembler-not "noreturn_autodetection_failed" } } */ Index: Fortran/gfortran/regression/norm2_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/norm2_1.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +real :: a(3) = [real :: 1, 2, huge(3.0)] +real :: b(3) = [real :: 1, 2, 3] +real :: c(4) = [real :: 1, 2, 3, -1] +real :: e(0) = [real :: ] +real :: f(4) = [real :: 0, 0, 3, 0 ] + +real :: d(4,1) = RESHAPE ([real :: 1, 2, 3, -1], [4,1]) +real :: g(4,1) = RESHAPE ([real :: 0, 0, 4, -1], [4,1]) + +! Check compile-time version + +if (abs (NORM2 ([real :: 1, 2, huge(3.0)]) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) STOP 1 + +if (abs (SNORM2([real :: 1, 2, huge(3.0)],3) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) STOP 2 + +if (abs (SNORM2([real :: 1, 2, 3],3) - NORM2([real :: 1, 2, 3])) & + > epsilon(0.0)*SNORM2([real :: 1, 2, 3],3)) STOP 3 + +if (NORM2([real :: ]) /= 0.0) STOP 4 +if (abs (NORM2([real :: 0, 0, 3, 0]) - 3.0) > epsilon(0.0)) STOP 5 + +! Check TREE version + +if (abs (NORM2 (a) - huge(3.0)) & + > epsilon(0.0)*huge(3.0)) STOP 6 + +if (abs (SNORM2(b,3) - NORM2(b)) & + > epsilon(0.0)*SNORM2(b,3)) STOP 7 + +if (abs (SNORM2(c,4) - NORM2(c)) & + > epsilon(0.0)*SNORM2(c,4)) STOP 8 + +if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) & + > epsilon(0.0))) STOP 9 + +! Check libgfortran version + +if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) & + > epsilon(0.0)*SNORM2(d,4))) STOP 10 + +if (abs (SNORM2(f,4) - NORM2(f, 1)) & + > epsilon(0.0)*SNORM2(d,4)) STOP 11 + +if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) & + > epsilon(0.0))) STOP 12 + +contains + ! NORM2 algorithm based on BLAS, cf. + ! http://www.netlib.org/blas/snrm2.f + REAL FUNCTION SNORM2 (X,n) + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: X(n) + + REAL :: absXi, scale, SSQ + INTEGER :: i + + INTRINSIC :: ABS, SQRT + + IF (N < 1) THEN + snorm2 = 0.0 + ELSE IF (N == 1) THEN + snorm2 = ABS(X(1)) + ELSE + scale = 0.0 + SSQ = 1.0 + + DO i = 1, N + IF (X(i) /= 0.0) THEN + absXi = ABS(X(i)) + IF (scale < absXi) THEN + SSQ = 1.0 + SSQ * (scale/absXi)**2 + scale = absXi + ELSE + SSQ = SSQ + (absXi/scale)**2 + END IF + END IF + END DO + snorm2 = scale * SQRT(SSQ) + END IF + END FUNCTION SNORM2 +end Index: Fortran/gfortran/regression/norm2_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/norm2_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +print *, norm2([1, 2]) ! { dg-error "must be REAL" } +print *, norm2([cmplx(1.0,2.0)]) ! { dg-error "must be REAL" } +print *, norm2(1.0) ! { dg-error "must be an array" } +print *, norm2([1.0, 2.0], dim=2) ! { dg-error "not a valid dimension index" } +end Index: Fortran/gfortran/regression/norm2_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/norm2_3.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +integer,parameter :: qp = selected_real_kind (precision (0.0d0)+1) + +real(qp) :: a(3) = [real(qp) :: 1, 2, huge(3.0_qp)] +real(qp) :: b(3) = [real(qp) :: 1, 2, 3] +real(qp) :: c(4) = [real(qp) :: 1, 2, 3, -1] +real(qp) :: e(0) = [real(qp) :: ] +real(qp) :: f(4) = [real(qp) :: 0, 0, 3, 0 ] + +real(qp) :: d(4,1) = RESHAPE ([real(qp) :: 1, 2, 3, -1], [4,1]) +real(qp) :: g(4,1) = RESHAPE ([real(qp) :: 0, 0, 4, -1], [4,1]) + +! Check compile-time version + +if (abs (NORM2 ([real(qp) :: 1, 2, huge(3.0_qp)]) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) STOP 1 + +if (abs (SNORM2([real(qp) :: 1, 2, huge(3.0_qp)],3) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) STOP 2 + +if (abs (SNORM2([real(qp) :: 1, 2, 3],3) - NORM2([real(qp) :: 1, 2, 3])) & + > epsilon(0.0_qp)*SNORM2([real(qp) :: 1, 2, 3],3)) STOP 3 + +if (NORM2([real(qp) :: ]) /= 0.0_qp) STOP 4 +if (abs (NORM2([real(qp) :: 0, 0, 3, 0]) - 3.0_qp) > epsilon(0.0_qp)) STOP 5 + +! Check TREE version + +if (abs (NORM2 (a) - huge(3.0_qp)) & + > epsilon(0.0_qp)*huge(3.0_qp)) STOP 6 + +if (abs (SNORM2(b,3) - NORM2(b)) & + > epsilon(0.0_qp)*SNORM2(b,3)) STOP 7 + +if (abs (SNORM2(c,4) - NORM2(c)) & + > epsilon(0.0_qp)*SNORM2(c,4)) STOP 8 + +if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) & + > epsilon(0.0_qp))) STOP 9 + +! Check libgfortran version + +if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) & + > epsilon(0.0_qp)*SNORM2(d,4))) STOP 10 + +if (abs (SNORM2(f,4) - NORM2(f, 1)) & + > epsilon(0.0_qp)*SNORM2(d,4)) STOP 11 + +if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) & + > epsilon(0.0_qp))) STOP 12 + +contains + ! NORM2 algorithm based on BLAS, cf. + ! http://www.netlib.org/blas/snrm2.f + REAL(qp) FUNCTION SNORM2 (X,n) + INTEGER, INTENT(IN) :: n + REAL(qp), INTENT(IN) :: X(n) + + REAL(qp) :: absXi, scale, SSQ + INTEGER :: i + + INTRINSIC :: ABS, SQRT + + IF (N < 1) THEN + snorm2 = 0.0_qp + ELSE IF (N == 1) THEN + snorm2 = ABS(X(1)) + ELSE + scale = 0.0_qp + SSQ = 1.0_qp + + DO i = 1, N + IF (X(i) /= 0.0_qp) THEN + absXi = ABS(X(i)) + IF (scale < absXi) THEN + SSQ = 1.0_qp + SSQ * (scale/absXi)**2 + scale = absXi + ELSE + SSQ = SSQ + (absXi/scale)**2 + END IF + END IF + END DO + snorm2 = scale * SQRT(SSQ) + END IF + END FUNCTION SNORM2 +end Index: Fortran/gfortran/regression/norm2_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/norm2_4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Check implementation of L2 norm (Euclidean vector norm) +! +implicit none + +print *, norm2([1.0, 2.0]) ! { dg-error "has no IMPLICIT type" } +end Index: Fortran/gfortran/regression/norm2_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/norm2_5.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Testcase from PR 54656 +! Checking for NORM2 for large float kinds +! +program test + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: d1(10), z1 + real(kind=k2) :: d2(10), z2 + d1 = 1 ; d2 = 1 + z1 = norm2 (d1) + z2 = norm2 (d2) + + print *, z1, z2 +end program test Index: Fortran/gfortran/regression/nosigned_zero_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nosigned_zero_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR fortran/40675 +! +! Fortran 77 just had: "The value of a signed zero is the same as +! the value of an unsigned zero." and g77 returned for SIGN(1.0, -0.0) = 1.0 +! +! Fortran 95+ has for SIGN: "Case (iv): If B is of type real and is zero, +! then ... (c) If B is negative real zero, the value of the result is -|A|". +! On architectures, where signed zeros are supported, gfortran's SIGN thus +! returns for B=-0.0 the -|A|. +! +program s + x = sign(1.,0.) + y = sign(1.,-0.) + if (x /= 1.) STOP 1 + if (y /= -1.) STOP 2 + x = 1. + y = 0. + x = sign(x, y) + y = sign(x, -y) + if (x /= 1.) STOP 3 + if (y /= -1.) STOP 4 +end program s Index: Fortran/gfortran/regression/nosigned_zero_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nosigned_zero_2.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fno-sign-zero" } +! +! PR fortran/40675 +! +! Fortran 77 just had: "The value of a signed zero is the same as +! the value of an unsigned zero." and g77 returned for SIGN(1.0, -0.0) = 1.0 +! +! Fortran 95+ has for SIGN: "Case (iv): If B is of type real and is zero, +! then ... (c) If B is negative real zero, the value of the result is -|A|". +! On architectures, where signed zeros are supported, gfortran's SIGN thus +! returns for B=-0.0 the -|A|. +! +program s + x = sign(1.,0.) + y = sign(1.,-0.) + if (x /= 1.) STOP 1 + if (y /= 1.) STOP 2 + x = 1. + y = 0. + x = sign(x, y) + y = sign(x, -y) + if (x /= 1.) STOP 3 + if (y /= 1.) STOP 4 +end program s Index: Fortran/gfortran/regression/nosigned_zero_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nosigned_zero_3.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fno-sign-zero" } +! +! PR fortran/55539 +! +program nosigned_zero_3 + implicit none + character(len=20) :: s + real(4) :: x = -1.2e-3 + real(8) :: y = -1.2e-3 + write(s,'(7f10.3)') x + if (trim(adjustl(s)) /= "-0.001") STOP 1 + write(s, '(7f10.3)') y + if (trim(adjustl(s)) /= "-0.001") STOP 2 +end program nosigned_zero_3 Index: Fortran/gfortran/regression/null1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/66045 +! +! Original code from Gerhard Steinmetz +! +program p + contains + integer :: null=null() ! { dg-error "NULL appears on right-hand side" } +end Index: Fortran/gfortran/regression/null_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/20858 +! If we have "x = null(i)", then "null()" acquires the type, kind type, +! and rank of i and these need to match those of x. +program null_1 + integer, parameter :: sp = kind(1.e0), dp = kind(1.d0) + integer, pointer :: i => null() + real(sp), pointer :: x => null() + real(dp), pointer :: y => null() + real(sp), pointer :: z(:) => null() + x => null(i) ! { dg-error "types in pointer assignment" } + x => null(y) ! { dg-error "types in pointer assignment" } + z => null(i) ! { dg-error "types in pointer assignment" } + z => null(y) ! { dg-error "types in pointer assignment" } + x => null(z) ! { dg-error "ranks in pointer assignment" } + z => null(x) ! { dg-error "ranks in pointer assignment" } + z => null(z) + nullify(i, x, y, z) +end program null_1 Index: Fortran/gfortran/regression/null_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_10.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 71860 - this used to ICE +! Original test case by Gerhard Steinmetz +program p + class(*), pointer :: z + z => null(z) +end Index: Fortran/gfortran/regression/null_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_11.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/99651 +! +module m + type :: CHAR_STAR + character(len=1),dimension(:),pointer :: ptr + end type + type(CHAR_STAR), parameter ::CHAR_STAR_NULL = CHAR_STAR(NULL()) +end module m + +use m +type typeNode + type(typeNode), pointer :: Next => null() +end type typeNode +end Index: Fortran/gfortran/regression/null_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! NULL(...) pointer is not allowed as operand +! PR fortran/20888 +! +! Contributed by Joost VandeVondele +! +PROGRAM main + IMPLICIT NONE + REAL, POINTER :: TEST + NULLIFY(TEST) + TEST => -NULL(TEST) ! { dg-error "Invalid context for NULL" } + IF (TEST .EQ. NULL(TEST)) TEST=>NULL() ! { dg-error "Invalid context for NULL" } + IF (NULL(TEST) .EQ. TEST) TEST=>NULL() ! { dg-error "Invalid context for NULL" } +END PROGRAM main Index: Fortran/gfortran/regression/null_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! This checks the fix for PR34813 in which the error at line 17 +! was not detected. +! +! Contributed by Daniel Franke +! +SUBROUTINE kd_tree_init_default() + TYPE :: kd_tree_node + INTEGER :: dummy + END TYPE + + TYPE :: kd_tree + TYPE(kd_tree_node) :: root + END TYPE + + TYPE(kd_tree) :: tree + tree = kd_tree(null()) ! { dg-error "neither a POINTER nor ALLOCATABLE" } +END SUBROUTINE Index: Fortran/gfortran/regression/null_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! +! PR fortran/42936 +! +! Contributed by Mat Cross +! +PROGRAM PASSES_NULL + CALL SUB(NULL()) +CONTAINS + SUBROUTINE SUB(I) + INTEGER, POINTER :: I(:,:,:) + IF (ASSOCIATED (I)) STOP 1 + END SUBROUTINE SUB +END PROGRAM PASSES_NULL Index: Fortran/gfortran/regression/null_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_5.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/34547 +! PR fortran/50375 + +subroutine test_PR50375_1 () + ! Contributed by Vittorio Zecca + interface gen1 + subroutine s11 (pi) + integer, pointer :: pi + end subroutine + subroutine s12 (pr) + real, pointer :: pr + end subroutine + end interface + call gen1 (null ()) ! { dg-error "MOLD= required in NULL|There is no specific subroutine" } +end subroutine test_PR50375_1 + +subroutine test_PR50375_2 () + interface gen2 + subroutine s21 (pi) + integer, pointer :: pi + end subroutine + subroutine s22 (pr) + real, optional :: pr + end subroutine + end interface + call gen2 (null ()) ! OK in F95/F2003 (but not in F2008) +end subroutine test_PR50375_2 + +subroutine test_PR34547_1 () + call proc (null ()) ! { dg-error "MOLD argument to NULL required" } +end subroutine test_PR34547_1 + +subroutine test_PR34547_2 () + print *, null () ! { dg-error "Invalid context" } +end subroutine test_PR34547_2 + +subroutine test_PR34547_3 () + integer, allocatable :: i(:) + print *, NULL(i) ! { dg-error "Fortran 2003: NULL intrinsic with allocatable MOLD" } +end subroutine test_PR34547_3 Index: Fortran/gfortran/regression/null_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_6.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/34547 +! PR fortran/50375 + +subroutine test_PR50375_3 () + interface gen3 + subroutine s31 (pi) + integer, pointer :: pi + end subroutine + subroutine s32 (pr) + real, allocatable :: pr(:) + end subroutine + end interface + call gen3 (null ()) ! OK +end subroutine test_PR50375_3 + +subroutine test_PR50375_2 () + interface gen2 + subroutine s21 (pi) + integer, pointer :: pi + end subroutine + subroutine s22 (pr) + real, optional :: pr + end subroutine + end interface + call gen2 (null ()) ! { dg-error "MOLD= required in NULL|There is no specific subroutine" } +end subroutine test_PR50375_2 + +subroutine test_PR34547_3 () + integer, allocatable :: i(:) + print *, NULL(i) ! { dg-error "Invalid context for NULL" } +end subroutine test_PR34547_3 Index: Fortran/gfortran/regression/null_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_7.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/55763 +! + +implicit none +integer, pointer :: x +class(*), pointer :: y +integer, pointer :: p1 => null(x) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } +integer, pointer :: p2 => null(mold=x) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } +class(*), pointer :: p3 =>null(x) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } +type t + real, pointer :: a1 => null(x) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } + real, pointer :: a2 => null ( mold = x) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } + class(*), pointer :: a3 => null(mold = x ) ! { dg-error "NULL.. initialization at .1. may not have MOLD" } +end type t + +x => null(x) ! OK +y => null(y) ! OK +end Index: Fortran/gfortran/regression/null_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_8.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/57141 +! +! Contributed by Roger Ferrer Ibanez +! +MODULE M + INTRINSIC :: NULL +END MODULE M + +MODULE M_INTERN + USE M + IMPLICIT NONE + REAL, POINTER :: ARR(:) => NULL() +END MODULE M_INTERN Index: Fortran/gfortran/regression/null_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_9.f90 @@ -0,0 +1,30 @@ +! { dg-do run } + +MODULE fold_convert_loc_ice + IMPLICIT NONE + PRIVATE + + TYPE, PUBLIC :: ta + PRIVATE + INTEGER :: a_comp + END TYPE ta + + TYPE, PUBLIC :: tb + TYPE(ta), ALLOCATABLE :: b_comp + END TYPE tb + + PUBLIC :: proc +CONTAINS + SUBROUTINE proc + TYPE(tb) :: b + + b = tb(null()) + if (allocated( b%b_comp )) STOP 1 + END SUBROUTINE proc +END MODULE fold_convert_loc_ice + + USE fold_convert_loc_ice + + call proc() +END + Index: Fortran/gfortran/regression/null_actual.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_actual.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! NULL() actual argument to non-pointer dummies +! + +call f(null()) ! { dg-error "Fortran 2008: Null pointer at .1. to non-pointer dummy" } +call g(null()) ! { dg-error "Unexpected NULL.. intrinsic at .1. to dummy" } +call h(null()) ! { dg-error "Unexpected NULL.. intrinsic at .1. to dummy" } +contains +subroutine f(x) + integer, optional :: x +end subroutine f +subroutine g(x) + integer, optional, allocatable :: x +end subroutine g +subroutine h(x) + integer :: x +end subroutine h +end Index: Fortran/gfortran/regression/null_actual_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_actual_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/104126 +! +! Contributed by G. Steinmetz +! +program p + use iso_c_binding, only: c_char + character(len=:,kind=c_char), pointer :: d + call s(null(d)) + call s(null()) +contains + subroutine s(x) bind(c) + character(len=:, kind=c_char), pointer, intent(in) :: x + end +end Index: Fortran/gfortran/regression/null_actual_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/null_actual_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fallow-argument-mismatch -w" } +! PR fortran/107576 +! Contributed by G.Steinmetz + +program p + implicit none + interface + subroutine r(y) + integer, pointer :: y(:) + end subroutine r + end interface + integer, pointer :: z(:) => null() + call r(z) + call s(z) + call r(null(z)) + call s(null(z)) ! { dg-error "requires an explicit interface" } +end Index: Fortran/gfortran/regression/nullify_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nullify_1.f @@ -0,0 +1,11 @@ +C { dg-do compile } +C PR 18993 +C we didn't match the end of statement following NULLIFY () +C this lead to weird error messages + subroutine ordern( ) + real, pointer :: aux(:,:) +C Nullify pointers + nullify(aux) +C Set default sizes for order N arrays + end subroutine ordern + Index: Fortran/gfortran/regression/nullify_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nullify_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/25146 +program i + implicit none + TYPE (a) t1 ! { dg-error "is being used before" } + nullify(t1%x) ! { dg-error "Symbol 't1' at .1. has no IMPLICIT type" } +end program Index: Fortran/gfortran/regression/nullify_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nullify_3.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-O0 -fbounds-check" } +! Tests patch for PR29371, in which the null pointer +! assignment would cause a segfault with the bounds +! check on. +! +! Contributed by Tobias Burnus +! +program test + implicit none + type projector_t + real, pointer :: ket(:, :), bra(:, :) + end type projector_t + + type(projector_t),pointer, dimension(:) :: p + integer :: stat,i + allocate(p(2),stat=stat) + do i = 1, 2 + nullify(p(i)%bra) + nullify(p(i)%ket) + end do + do i = 1, 2 + if (associated (p(i)%bra)) STOP 1 + if (associated (p(i)%ket)) STOP 2 + end do +end program Index: Fortran/gfortran/regression/nullify_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/nullify_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/40246 +! +! Check error recovery; was crashing before. +! +real, pointer :: ptr +nullify(ptr, mesh%coarser) ! { dg-error "Symbol 'mesh' at .1. has no IMPLICIT type" } +end Index: Fortran/gfortran/regression/num_images_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/num_images_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! PR Fortran/80768 +! Reported by Vittorio Zecca. +program foo + implicit none + integer k5 + k5 = num_images(failed=.false.) ! { dg-error "argument to NUM_IMAGES" } +end program foo Index: Fortran/gfortran/regression/o_fast_stacksize.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/o_fast_stacksize.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Ofast -fmax-stack-var-size=100 -fdump-tree-original" } +MODULE foo +CONTAINS + SUBROUTINE mysum(a) + INTEGER :: a(:) + WRITE(6,*) SUM(a) + END SUBROUTINE +END MODULE foo + +USE foo +INTEGER, ALLOCATABLE :: a(:) +INTEGER, PARAMETER :: N=2**26 ! 256Mb array +ALLOCATE(a(N)) ; a=1 +CALL mysum(a*a) +END +! { dg-final { scan-tree-dump-times "__builtin_malloc" 2 "original" } } Index: Fortran/gfortran/regression/old_style_init.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/old_style_init.f90 @@ -0,0 +1,15 @@ +!{ dg-do compile } +! this routine tests all the execution paths +! through the routine known as match_old_style_init() +! it does not make sense in any other context !! + subroutine sub1(Z) !{ dg-error "DATA attribute conflicts" } + integer Z/10/!{ dg-error "DATA"} + end + pure function pi(k) + integer ,intent(in) :: k + integer i / 10 / !{ dg-error "Initialization at " } + pi=3.0 + end function pi + subroutine sub2 + integer I / /!{ dg-error "Syntax error in DATA" } + end Index: Fortran/gfortran/regression/oldstyle_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/oldstyle_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } + integer i, j /1/, g/2/, h ! { dg-warning "" } + integer k, l(3) /2*2,1/ ! { dg-warning "" } + real pi /3.1416/, e ! { dg-warning "" } + + if (j /= 1) STOP 1 + if (g /= 2) STOP 2 + if (any(l /= (/2,2,1/))) STOP 3 + if (pi /= 3.1416) STOP 4 + end Index: Fortran/gfortran/regression/oldstyle_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/oldstyle_2.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +subroutine foo(i) ! { dg-error "DATA attribute" } + integer i /10/ +end subroutine foo Index: Fortran/gfortran/regression/oldstyle_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/oldstyle_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Suppress the warning about an old-style initializer; +! { dg-options "" } +! This tests the fix for PR29052 in which the error below would cause a seg-fault +! because the locus of the initializer was never set. +! +! Contributed by Bud Davis +! + character*10 a(4,2) /'aaa','bbb','ccc','ddd'/ ! { dg-error "more variables than values" } + end Index: Fortran/gfortran/regression/oldstyle_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/oldstyle_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/52101 +! +! Contributed by John Harper +! +program foo + character*10 s ! { dg-warning "Obsolescent feature: Old-style character length" } + character t*10 ! Still okay + s = 'foo' + t = 'bar' +end program foo Index: Fortran/gfortran/regression/oldstyle_5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/oldstyle_5.f @@ -0,0 +1,8 @@ +C { dg-do compile } + TYPE T + INTEGER A(2)/1,2/ ! { dg-error "Invalid old style initialization for derived type component" } + END TYPE + TYPE S + INTEGER B/1/ ! { dg-error "Invalid old style initialization for derived type component" } + END TYPE + END Index: Fortran/gfortran/regression/only_clause_main.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/only_clause_main.c @@ -0,0 +1,12 @@ +/* this is an f90 function */ +void testOnly(int *cIntPtr); + +int main(int argc, char **argv) +{ + int myCInt; + + myCInt = -11; + testOnly(&myCInt); + + return 0; +}/* end main() */ Index: Fortran/gfortran/regression/open-options-blanks.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open-options-blanks.f @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 20163, first half: Trailing blanks on an option to +! open used to cause an error + CHARACTER*8 ST + ST = 'SCRATCH ' + OPEN(UNIT=10,STATUS=ST) + END Index: Fortran/gfortran/regression/open_access_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_access_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + + real :: a + a = 6.0 + open (unit = 6, file = 'foo', access = a) ! { dg-error "must be of type CHARACTER" } +end Index: Fortran/gfortran/regression/open_access_append_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_access_append_1.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Testcase for the GNU extension OPEN(...,ACCESS="APPEND") + open (10,file="foo") + close (10,status="delete") + + open (10,file="foo",access="append") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + write (10,*) 42 + close (10,status="keep") + open (10,file="foo",access="append") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + write (10,*) -42 + close (10,status="keep") + + open (10,file="foo") + read (10,*) i + if (i /= 42) STOP 1 + read (10,*) i + if (i /= -42) STOP 2 + close (10,status="delete") + + end +! { dg-output ".*Extension.*Extension" } Index: Fortran/gfortran/regression/open_access_append_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_access_append_2.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! Testcase for the GNU extension OPEN(...,ACCESS="APPEND") + open (10,err=900,access="append",position="asis") ! { dg-warning "Extension: ACCESS specifier in OPEN statement" } + STOP 1 + 900 end +! { dg-output ".*Extension.*" } Index: Fortran/gfortran/regression/open_errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_errors.f90 @@ -0,0 +1,43 @@ +! { dg-do run { target { ! { *-*-mingw* *-*-cygwin* } } } } +! PR30005 Enhanced error messages for OPEN +! Submitted by Jerry DeLisle +! See PR38956. Test fails on cygwin when user has Administrator rights +! As of the fix for PR 65200, the error message is partly generated by +! strerror*(), so can depend on the target and the locale, so check +! only the beginning of the error string, which should be constant. +character(60) :: msg +character(25) :: n = "temptestfile" +logical :: there +inquire(file=n, exist=there) +if (.not.there) then + open(77,file=n,status="new") + close(77, status="keep") +endif +msg="" +open(77,file=n,status="new", iomsg=msg, iostat=i) +if (i == 0) STOP 1 +if (msg(1:33) /= "Cannot open file 'temptestfile': ") STOP 2 + +open(77,file=n,status="old") +close(77, status="delete") +open(77,file=n,status="old", iomsg=msg, iostat=i) +if (i == 0) STOP 3 +if (msg(1:33) /= "Cannot open file 'temptestfile': ") STOP 4 + +open(77,file="./", iomsg=msg, iostat=i) +if (msg(1:23) /= "Cannot open file './': " & + .and. msg /= "Invalid argument") STOP 5 + +open(77,file=n,status="new") +i = chmod(n, "-w") +if (i == 0 .and. getuid() /= 0) then + close(77, status="keep") + open(77,file=n, iomsg=msg, iostat=i, action="write") + if (i == 0) STOP 6 + if (msg(1:33) /= "Cannot open file 'temptestfile': ") STOP 7 +endif + +i = chmod(n,"+w") +open(77,file=n, iomsg=msg, iostat=i, action="read") +close(77, status="delete") +end Index: Fortran/gfortran/regression/open_errors_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_errors_2.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-std=f2008" } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 14.*File already opened" } + +! PR 65563 - this used to segfault for some versions. + variable_1 = 0 + open(345,iostat=ios, form='unformatted') + read(345, err=37, end=37) variable_1 + close(345) + go to 38 +37 continue +38 continue + open(522, file="fort.345", form='unformatted') + write(522) variable_1 + rewind(522) + close(522) +end program +! { dg-final { remote_file build delete "fort.345" } } Index: Fortran/gfortran/regression/open_errors_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_errors_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 90461 Open file on multiple units as of F2018 +program openmult + implicit none + character(len=*), parameter :: fname="pr90461.dat" + open(10, file=fname, form="unformatted") + open(11, file=fname, form="unformatted") + close(11) + close(10, status="delete") +end program openmult +! { dg-final { remote_file build delete "pr90461.dat" } } Index: Fortran/gfortran/regression/open_negative_unit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_negative_unit_1.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR48618 - Negative unit number in OPEN(...) is sometimes allowed +! +! Test originally from Janne Blomqvist in PR: +! http://gcc.gnu.org/bugzilla/show_bug.cgi?id=48618 + +program nutest + implicit none + logical l + integer id, ios + + open(newunit=id, file="foo_open_negative_unit_1.txt", iostat=ios) + if (ios /= 0) STOP 1 + + open(id, file="bar.txt", iostat=ios) + if (ios /= 0) STOP 2 + + close(id, status="delete") + + open(unit=10, file="foo_open_negative_unit_1.txt", status="old", iostat=ios) + if (ios /= 0) STOP 3 + + close(10, status="delete") + + open(-10, file="foo_open_negative_unit_1.txt", iostat=ios) + if (ios == 0) STOP 4 + + inquire(file="foo_open_negative_unit_1.txt", exist=l) + if (l) STOP 5 +end program nutest Index: Fortran/gfortran/regression/open_new.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_new.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 18982: verifies that opening an existing file with +! status="new" is an error +program main + nout = 10 + open(nout, file="foo_open_new.dat", status="replace") ! make sure foo_open_new.dat exists + close(nout) + open(nout, file="foo_open_new.dat", status="new",err=100) + STOP 1! This should never happen +100 call unlink ("foo_open_new.dat") +end program main Index: Fortran/gfortran/regression/open_new_segv.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_new_segv.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-shouldfail "Cannot open file" } +! PR 64770 SIGSEGV when trying to open an existing file with status="new" +program pr64770 + implicit none + ! Make sure pr64770test.dat exists + open(99, file="pr64770test.dat", status="replace") + close(99) + open(99, file="pr64770test.dat", access="stream", form="unformatted", & + status="new") +end program pr64770 +! { dg-output "At line 10 of file.*" } +! { dg-output "Fortran runtime error: Cannot open file .pr64770test.dat.:" } +! { dg-final { remote_file build delete "pr64770test.dat" } } Index: Fortran/gfortran/regression/open_nounit.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_nounit.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR43832 Missing UNIT in OPEN + open () ! { dg-error "must have UNIT" } + open (file="test") ! { dg-error "must have UNIT" } + end + Index: Fortran/gfortran/regression/open_readonly_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_readonly_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run { target fd_truncate } } +! PR19451 +! Writing to a non-empty readonly file caused a segfault. +! We were still trying to write the EOR after an error ocurred +program prog + open (unit=10, file='PR19451.dat') + write (10,*) "Hello World" + close (10) + open (unit=10, file='PR19451.dat', action="read") + write (10,*,err=20) "Hello World" + STOP 1 + 20 close (10, status='delete') +end program + Index: Fortran/gfortran/regression/open_status_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_status_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! Test reopening with io status='old' +program iostatus + open (1, file='foo', status='replace') ! Make sure file exists. + open (1, file='foo', status='old') + open (1, file='foo', status='old') + close (1, status='delete') +end program iostatus Index: Fortran/gfortran/regression/open_status_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_status_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 24945 +! Test reopening file without status specifier or with +! status='unknown'. The standard says that these two must behave +! identically, but the actual behavior is processor dependent. +program open_status_2 + open(10, file="f", form='unformatted', status='unknown') + open(10, file="f", form='unformatted', status='unknown') + open(10, file="f", form='unformatted') + close(10, status='delete') +end program open_status_2 + Index: Fortran/gfortran/regression/open_status_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/open_status_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR27704 Incorrect runtime error on multiple OPEN. +! Test case contribyted by Jerry DeLisle + OPEN(8, FORM = 'unformatted', STATUS = 'scratch') + OPEN(8, FORM = 'unformatted', status = 'scratch') + close(8) + open(8) + open(8, status = 'old') + close(8, status="delete") + end + Index: Fortran/gfortran/regression/openacc-define-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openacc-define-1.f90 @@ -0,0 +1,7 @@ +! { dg-options "-cpp" } +! { dg-do preprocess } +! { dg-require-effective-target fopenacc } + +#ifdef _OPENACC +# error _OPENACC defined +#endif Index: Fortran/gfortran/regression/openacc-define-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openacc-define-2.f90 @@ -0,0 +1,7 @@ +! { dg-options "-cpp -fno-openacc" } +! { dg-do preprocess } +! { dg-require-effective-target fopenacc } + +#ifdef _OPENACC +# error _OPENACC defined +#endif Index: Fortran/gfortran/regression/openacc-define-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openacc-define-3.f90 @@ -0,0 +1,11 @@ +! { dg-options "-cpp -fopenacc" } +! { dg-do preprocess } +! { dg-require-effective-target fopenacc } + +#ifndef _OPENACC +# error _OPENACC not defined +#endif + +#if _OPENACC != 201711 +# error _OPENACC defined to wrong value +#endif Index: Fortran/gfortran/regression/openmp-define-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openmp-define-1.f90 @@ -0,0 +1,7 @@ +! { dg-options "-cpp" } +! { dg-do preprocess } +! { dg-require-effective-target fopenmp } + +#ifdef _OPENMP +# error _OPENMP defined +#endif Index: Fortran/gfortran/regression/openmp-define-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openmp-define-2.f90 @@ -0,0 +1,7 @@ +! { dg-options "-cpp -fno-openmp" } +! { dg-do preprocess } +! { dg-require-effective-target fopenmp } + +#ifdef _OPENMP +# error _OPENMP defined +#endif Index: Fortran/gfortran/regression/openmp-define-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/openmp-define-3.f90 @@ -0,0 +1,11 @@ +! { dg-options "-cpp -fopenmp" } +! { dg-do preprocess } +! { dg-require-effective-target fopenmp } + +#ifndef _OPENMP +# error _OPENMP not defined +#endif + +#if _OPENMP != 201511 +# error _OPENMP defined to wrong value +#endif Index: Fortran/gfortran/regression/operator_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_1.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! Test the extension of intrinsic operators +module m1 + interface operator(*) + module procedure f1 + module procedure f2 + module procedure f3 + end interface + + interface operator(.or.) + module procedure g1 + end interface + + interface operator(//) + module procedure g1 + end interface + +contains + + function f1(a,b) result (c) + integer, dimension(2,2), intent(in) :: a + integer, dimension(2), intent(in) :: b + integer, dimension(2) :: c + c = matmul(a,b) + end function f1 + function f2(a,b) result (c) + real, dimension(2,2), intent(in) :: a + real, dimension(2), intent(in) :: b + real, dimension(2) :: c + c = matmul(a,b) + end function f2 + function f3(a,b) result (c) + complex, dimension(2,2), intent(in) :: a + complex, dimension(2), intent(in) :: b + complex, dimension(2) :: c + c = matmul(a,b) + end function f3 + + elemental function g1(a,b) result (c) + integer, intent(in) :: a, b + integer :: c + c = a + b + end function g1 + +end module m1 + + use m1 + implicit none + + integer, dimension(2,2) :: ai + integer, dimension(2) :: bi, ci + real, dimension(2,2) :: ar + real, dimension(2) :: br, cr + complex, dimension(2,2) :: ac + complex, dimension(2) :: bc, cc + + ai = reshape((/-2,-4,7,8/),(/2,2/)) ; bi = 3 + if (any((ai*bi) /= matmul(ai,bi))) STOP 1 + if (any((ai .or. ai) /= ai+ai)) STOP 2 + if (any((ai // ai) /= ai+ai)) STOP 3 + + ar = reshape((/-2,-4,7,8/),(/2,2/)) ; br = 3 + if (any((ar*br) /= matmul(ar,br))) STOP 4 + + ac = reshape((/-2,-4,7,8/),(/2,2/)) ; bc = 3 + if (any((ac*bc) /= matmul(ac,bc))) STOP 5 + +end Index: Fortran/gfortran/regression/operator_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Test that we can't override intrinsic operators in invalid ways +module foo + + interface operator(*) + module procedure f1 ! { dg-error "conflicts with intrinsic interface" } + end interface + + interface operator(>) + module procedure f2 ! { dg-error "conflicts with intrinsic interface" } + end interface + + interface operator(/) + module procedure f3 + end interface + +contains + + function f1(a,b) result (c) + integer, intent(in) :: a + integer, dimension(:), intent(in) :: b + integer, dimension(size(b,1)) :: c + c = 0 + end function f1 + + function f2(a,b) + character(len=*), intent(in) :: a + character(len=*), intent(in) :: b + logical :: f2 + f2 = .false. + end function f2 + + function f3(a,b) result (c) + integer, dimension(:,:), intent(in) :: a + integer, dimension(:), intent(in) :: b + integer, dimension(size(b,1)) :: c + c = 0 + end function f3 + +end Index: Fortran/gfortran/regression/operator_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/31580 +! +! Testcase contributed by Tobias Burnus +! +PROGRAM test + real :: a,b + if(a .nonex. b) stop ! { dg-error "Unknown operator" } +end program Index: Fortran/gfortran/regression/operator_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_4.f90 @@ -0,0 +1,98 @@ +! PR 17711 : Verify error message text meets operator in source +! { dg-do compile } + +MODULE mod_t + type :: t + integer :: x + end type + + INTERFACE OPERATOR(==) + MODULE PROCEDURE t_eq + END INTERFACE + + INTERFACE OPERATOR(/=) + MODULE PROCEDURE t_ne + END INTERFACE + + INTERFACE OPERATOR(>) + MODULE PROCEDURE t_gt + END INTERFACE + + INTERFACE OPERATOR(>=) + MODULE PROCEDURE t_ge + END INTERFACE + + INTERFACE OPERATOR(<) + MODULE PROCEDURE t_lt + END INTERFACE + + INTERFACE OPERATOR(<=) + MODULE PROCEDURE t_le + END INTERFACE + +CONTAINS + LOGICAL FUNCTION t_eq(this, other) + TYPE(t), INTENT(in) :: this, other + t_eq = (this%x == other%x) + END FUNCTION + + LOGICAL FUNCTION t_ne(this, other) + TYPE(t), INTENT(in) :: this, other + t_ne = (this%x /= other%x) + END FUNCTION + + LOGICAL FUNCTION t_gt(this, other) + TYPE(t), INTENT(in) :: this, other + t_gt = (this%x > other%x) + END FUNCTION + + LOGICAL FUNCTION t_ge(this, other) + TYPE(t), INTENT(in) :: this, other + t_ge = (this%x >= other%x) + END FUNCTION + + LOGICAL FUNCTION t_lt(this, other) + TYPE(t), INTENT(in) :: this, other + t_lt = (this%x < other%x) + END FUNCTION + + LOGICAL FUNCTION t_le(this, other) + TYPE(t), INTENT(in) :: this, other + t_le = (this%x <= other%x) + END FUNCTION +END MODULE + +PROGRAM pr17711 + USE mod_t + + LOGICAL :: A + INTEGER :: B + TYPE(t) :: C + + A = (A == B) ! { dg-error "comparison operator '=='" } + A = (A.EQ.B) ! { dg-error "comparison operator '.eq.'" } + A = (A /= B) ! { dg-error "comparison operator '/='" } + A = (A.NE.B) ! { dg-error "comparison operator '.ne.'" } + A = (A <= B) ! { dg-error "comparison operator '<='" } + A = (A.LE.B) ! { dg-error "comparison operator '.le.'" } + A = (A < B) ! { dg-error "comparison operator '<'" } + A = (A.LT.B) ! { dg-error "comparison operator '.lt.'" } + A = (A >= B) ! { dg-error "comparison operator '>='" } + A = (A.GE.B) ! { dg-error "comparison operator '.ge.'" } + A = (A > B) ! { dg-error "comparison operator '>'" } + A = (A.GT.B) ! { dg-error "comparison operator '.gt.'" } + + ! this should also work with user defined operators + A = (A == C) ! { dg-error "comparison operator '=='" } + A = (A.EQ.C) ! { dg-error "comparison operator '.eq.'" } + A = (A /= C) ! { dg-error "comparison operator '/='" } + A = (A.NE.C) ! { dg-error "comparison operator '.ne.'" } + A = (A <= C) ! { dg-error "comparison operator '<='" } + A = (A.LE.C) ! { dg-error "comparison operator '.le.'" } + A = (A < C) ! { dg-error "comparison operator '<'" } + A = (A.LT.C) ! { dg-error "comparison operator '.lt.'" } + A = (A >= C) ! { dg-error "comparison operator '>='" } + A = (A.GE.C) ! { dg-error "comparison operator '.ge.'" } + A = (A > C) ! { dg-error "comparison operator '>'" } + A = (A.GT.C) ! { dg-error "comparison operator '.gt.'" } +END PROGRAM Index: Fortran/gfortran/regression/operator_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_5.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-c" } + +MODULE mod_t + type :: t + integer :: x + end type + + ! user defined operator + INTERFACE OPERATOR(.FOO.) + MODULE PROCEDURE t_foo + END INTERFACE + + INTERFACE OPERATOR(.FOO.) + MODULE PROCEDURE t_foo ! { dg-error "already present" } + END INTERFACE + + INTERFACE OPERATOR(.FOO.) + MODULE PROCEDURE t_bar + END INTERFACE + + ! intrinsic operator + INTERFACE OPERATOR(==) + MODULE PROCEDURE t_foo + END INTERFACE + + INTERFACE OPERATOR(.eq.) + MODULE PROCEDURE t_foo ! { dg-error "already present" } + END INTERFACE + + INTERFACE OPERATOR(==) + MODULE PROCEDURE t_bar + END INTERFACE + + INTERFACE OPERATOR(.eq.) + MODULE PROCEDURE t_bar ! { dg-error "already present" } + END INTERFACE + +CONTAINS + LOGICAL FUNCTION t_foo(this, other) ! { dg-error "Ambiguous interfaces" } + TYPE(t), INTENT(in) :: this, other + t_foo = .FALSE. + END FUNCTION + + LOGICAL FUNCTION t_bar(this, other) ! { dg-error "Ambiguous interfaces" } + TYPE(t), INTENT(in) :: this, other + t_bar = .FALSE. + END FUNCTION +END MODULE Index: Fortran/gfortran/regression/operator_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/29876 ICE on bad operator in ONLY clause of USE statement +! Testcase contributed by Francois-Xavier Coudert +! +module foo +end module foo + +program test + use foo, only : operator(.none.) ! { dg-error "not found in module" } + end program test Index: Fortran/gfortran/regression/operator_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_7.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/45786 - operators were not correctly marked as public +! if the alternative form was used. +! Test case contributed by Neil Carlson. +module foo_type + private + public :: foo, operator(==) + type :: foo + integer :: bar + end type + interface operator(.eq.) + module procedure eq_foo + end interface +contains + logical function eq_foo (a, b) + type(foo), intent(in) :: a, b + eq_foo = (a%bar == b%bar) + end function +end module + + subroutine use_it (a, b) + use foo_type + type(foo) :: a, b + print *, a == b +end subroutine Index: Fortran/gfortran/regression/operator_c1202.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/operator_c1202.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +module op + + implicit none + + type a + integer i + end type a + + type b + real i + end type b + + interface operator(==) + module procedure f1 + end interface operator(.eq.) + interface operator(.eq.) + module procedure f2 + end interface operator(==) + + interface operator(/=) + module procedure f1 + end interface operator(.ne.) + interface operator(.ne.) + module procedure f2 + end interface operator(/=) + + interface operator(<=) + module procedure f1 + end interface operator(.le.) + interface operator(.le.) + module procedure f2 + end interface operator(<=) + + interface operator(<) + module procedure f1 + end interface operator(.lt.) + interface operator(.lt.) + module procedure f2 + end interface operator(<) + + interface operator(>=) + module procedure f1 + end interface operator(.ge.) + interface operator(.ge.) + module procedure f2 + end interface operator(>=) + + interface operator(>) + module procedure f1 + end interface operator(.gt.) + interface operator(.gt.) + module procedure f2 + end interface operator(>) + + contains + + function f2(x,y) + logical f2 + type(a), intent(in) :: x, y + end function f2 + + function f1(x,y) + logical f1 + type(b), intent(in) :: x, y + end function f1 + +end module op Index: Fortran/gfortran/regression/optional_absent_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_1.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } +! +! Passing a null pointer or deallocated variable to an +! optional, non-pointer, non-allocatable dummy. +! +program test + implicit none + integer, pointer :: ps => NULL(), pa(:) => NULL() + integer, allocatable :: as, aa(:) + + call scalar(ps) + call scalar(as) + call scalar() + call scalar(NULL()) + + call assumed_size(pa) + call assumed_size(aa) + call assumed_size() + call assumed_size(NULL(pa)) + + call assumed_shape(pa) + call assumed_shape(aa) + call assumed_shape() + call assumed_shape(NULL()) + + call ptr_func(.true., ps) + call ptr_func(.true., null()) + call ptr_func(.false.) +contains + subroutine scalar(a) + integer, optional :: a + if (present(a)) STOP 1 + end subroutine scalar + subroutine assumed_size(a) + integer, optional :: a(*) + if (present(a)) STOP 2 + end subroutine assumed_size + subroutine assumed_shape(a) + integer, optional :: a(:) + if (present(a)) STOP 3 + end subroutine assumed_shape + subroutine ptr_func(is_psnt, a) + integer, optional, pointer :: a + logical :: is_psnt + if (is_psnt .neqv. present(a)) STOP 4 + end subroutine ptr_func +end program test Index: Fortran/gfortran/regression/optional_absent_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_2.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/51758 +! +! Contributed by Mikael Morin +! +! Check whether passing NULL() to an elemental procedure works, +! where NULL() denotes an absent optional argument. +! +program p + + integer :: a(2) + integer :: b + + a = 0 + a = foo((/ 1, 1 /), null()) +! print *, a + if (any(a /= 2)) STOP 1 + + a = 0 + a = bar((/ 1, 1 /), null()) +! print *, a + if (any(a /= 2)) STOP 2 + + b = 0 + b = bar(1, null()) +! print *, b + if (b /= 2) STOP 3 + +contains + + function foo(a, b) + integer :: a(:) + integer, optional :: b(:) + integer :: foo(size(a)) + + if (present(b)) STOP 4 + + foo = 2 + end function foo + + elemental function bar(a, b) + integer, intent(in) :: a + integer, intent(in), optional :: b + integer :: bar + + bar = 2 + + if (present(b)) bar = 1 + + end function bar + +end program p Index: Fortran/gfortran/regression/optional_absent_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_3.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! PR fortran/35203 +! +! Test VALUE + OPTIONAL +! for integer/real/complex/logical which are passed by value +! +program main + implicit none + call value_test () +contains + subroutine value_test (ii, rr, cc, ll, ii2, rr2, cc2, ll2) + integer, optional :: ii, ii2 + real, optional :: rr, rr2 + complex, optional :: cc, cc2 + logical, optional :: ll, ll2 + value :: ii, rr, cc, ll + + call int_test (.false., 0) + call int_test (.false., 0, ii) + call int_test (.false., 0, ii2) + call int_test (.true., 0, 0) + call int_test (.true., 2, 2) + + call real_test (.false., 0.0) + call real_test (.false., 0.0, rr) + call real_test (.false., 0.0, rr2) + call real_test (.true., 0.0, 0.0) + call real_test (.true., 2.0, 2.0) + + call cmplx_test (.false., cmplx (0.0)) + call cmplx_test (.false., cmplx (0.0), cc) + call cmplx_test (.false., cmplx (0.0), cc2) + call cmplx_test (.true., cmplx (0.0), cmplx (0.0)) + call cmplx_test (.true., cmplx (2.0), cmplx (2.0)) + + call bool_test (.false., .false.) + call bool_test (.false., .false., ll) + call bool_test (.false., .false., ll2) + call bool_test (.true., .false., .false.) + call bool_test (.true., .true., .true.) + end subroutine value_test + + subroutine int_test (ll, val, x) + logical, value :: ll + integer, value :: val + integer, value, optional :: x + if (ll .neqv. present(x)) STOP 1 + if (present(x)) then + if (x /= val) STOP 1 + endif + end subroutine int_test + + subroutine real_test (ll, val, x) + logical, value :: ll + real, value :: val + real, value, optional :: x + if (ll .neqv. present(x)) STOP 2 + if (present(x)) then + if (x /= val) STOP 2 + endif + end subroutine real_test + + subroutine cmplx_test (ll, val, x) + logical, value :: ll + complex, value :: val + complex, value, optional :: x + if (ll .neqv. present(x)) STOP 3 + if (present(x)) then + if (x /= val) STOP 3 + endif + end subroutine cmplx_test + + subroutine bool_test (ll, val, x) + logical, value :: ll + logical, value :: val + logical, value, optional :: x + if (ll .neqv. present(x)) STOP 4 + if (present(x)) then + if (x .neqv. val) STOP 4 + endif + end subroutine bool_test +end program main Index: Fortran/gfortran/regression/optional_absent_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_4.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! PR 82995 - segfault passing on an optional argument; +! this tests the inline versions. +module y + implicit none +contains + + function sum_1 (input, mask) + logical, intent(in), optional :: mask(:) + integer, intent(in) :: input(:) + integer :: sum_1 + sum_1 = sum (input, mask) + end function sum_1 + + function sum_2 (input, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:) + integer :: sum_2 + sum_2 = sum(input, mask) + end function sum_2 + + function sum_3 (input, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer :: sum_3 + sum_3 = sum (input, mask) + end function sum_3 + + function minval_1 (input, mask) + logical, intent(in), optional :: mask(:,:) + real, intent(in) :: input(:,:) + real :: minval_1 + minval_1 = minval (input, mask) + end function minval_1 + + function maxval_1 (input, mask) + logical, intent(in), optional :: mask + real, intent(in) :: input(:,:) + real :: maxval_1 + maxval_1 = maxval (input, mask) + end function maxval_1 + + function maxloc_1 (input, mask) + logical, intent(in), optional :: mask(:) + real, intent(in) :: input(:) + integer :: maxloc_1 + + maxloc_1 = maxloc(input, dim=1, mask=mask) + end function maxloc_1 + + function findloc_1 (input, val, mask) + logical, intent(in), optional :: mask (:) + integer, intent(in) :: input(:) + integer, intent(in) :: val + integer :: findloc_1 + + findloc_1 = findloc(input, val, dim=1, mask=mask) + end function findloc_1 + + function findloc_2 (input, val, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:) + integer, intent(in) :: val + integer :: findloc_2 + + findloc_2 = findloc(input, val, dim=1, mask=mask) + end function findloc_2 + +end module y + +program test_sum_1 + use y + implicit none + integer :: input(5) = [1,2,4,8,16] + integer :: i2(2,3) = reshape([1,2,4,8,16,32], [2,3]) + real :: r2(2,3) = reshape ([32.,16.,8.,4.,2.,1.], [2,3]) + real :: r1(6) = [2.,4.,8.,32.,1.,16.] + integer :: res + real :: rres + res = sum_1(input) + if (res /= 31) stop 1 + res = sum_2 (input) + if (res /= 31) stop 2 + res = sum_3 (i2) + if (res /= 63) stop 3 + rres = minval_1 (r2) + if (rres /= 1.0) stop 4 + rres = maxval_1 (r2) + if (rres /= 32.) stop 5 + res = maxloc_1 (r1) + if (res /= 4) stop 6 + res = findloc_1 (input, 8) + if (res /= 4) stop 7 + res = findloc_2 (input, 2) + if (res /= 2) stop 8 +end program test_sum_1 Index: Fortran/gfortran/regression/optional_absent_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_5.f90 @@ -0,0 +1,144 @@ +! { dg-do run } +! PR 82995 - segfault passing on an optional argument; +! this tests the library versions. +module z + implicit none +contains + subroutine sum_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = sum (input, dim=1, mask=mask) + end subroutine sum_1 + + subroutine sum_2 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = sum (input, dim=1, mask=mask) + end subroutine sum_2 + + subroutine maxloc_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = maxloc (input, dim=1, mask=mask) + end subroutine maxloc_1 + + subroutine minloc_1 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = minloc (input, dim=1, mask=mask) + end subroutine minloc_1 + + subroutine maxloc_2 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n + n = 1 + res = maxloc (input, dim=n, mask=mask) + end subroutine maxloc_2 + + subroutine findloc_1 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val) + end subroutine findloc_1 + + subroutine findloc_2 (input, val, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val) + end subroutine findloc_2 + + subroutine findloc_3 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val, dim=1) + end subroutine findloc_3 + + subroutine findloc_4 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + integer :: n = 1 + res = findloc(input, val, dim=n) + end subroutine findloc_4 + + subroutine maxval_1 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = maxval (input, dim=1, mask=mask) + end subroutine maxval_1 + + subroutine maxval_2 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n = 1 + res = maxval (input, dim=n, mask=mask) + end subroutine maxval_2 + + subroutine minval_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = minval (input, dim=1, mask=mask) + end subroutine minval_1 + + subroutine minval_2 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n = 1 + res = minval (input, dim=n, mask=mask) + end subroutine minval_2 + +end module z + +program main + use z + implicit none + integer :: i2(2,3) = reshape([1,2,4,8,16,32], [2,3]) + integer, dimension(3) :: res3 + integer, dimension(2) :: res2 + call sum_1 (i2, res3) + if (any (res3 /= [3, 12, 48])) stop 1 + res3 = -2 + call sum_2 (i2, res3) + if (any (res3 /= [3, 12, 48])) stop 2 + call maxloc_1 (i2, res3) + if (any (res3 /= 2)) stop 3 + call minloc_1 (i2, res3) + if (any (res3 /= 1)) stop 4 + call maxloc_2 (i2, res3) + if (any (res3 /= 2)) stop 5 + call findloc_1 (i2, 4, res2) + if (any(res2 /= [1,2])) stop 6 + res2 = -1234 + call findloc_2 (i2, 4, res2) + if (any(res2 /= [1,2])) stop 7 + call findloc_3 (i2, 4, res3) + if (any(res3 /= [0,1,0])) stop 8 + call findloc_4 (i2, 4, res3) + if (any(res3 /= [0,1,0])) stop 9 + call maxval_1 (i2, res3) + if (any (res3 /= [2,8,32])) stop 10 + call minval_1 (i2, res3) + if (any (res3 /= [1,4,16])) stop 11 + call maxval_2 (i2, res3) + if (any (res3 /= [2,8,32])) stop 12 + call minval_2 (i2, res3) + if (any (res3 /= [1,4,16])) stop 13 + +end program main Index: Fortran/gfortran/regression/optional_absent_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_6.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! PR fortran/107441 +! +! Test VALUE + OPTIONAL for integer/real/... +! in the presence of non-optional character dummies + +program bugdemo + implicit none + character :: s = 'a' + integer :: t + + t = testoptional(s) + call test2 (s) + call test3 (s) + call test4 (w='123',x=42) + +contains + + function testoptional (w, x) result(t) + character, intent(in) :: w + integer, intent(in), value, optional :: x + integer :: t + print *, 'present(x) is', present(x) + t = 0 + if (present (x)) stop 1 + end function testoptional + + subroutine test2 (w, x) + character, intent(in) :: w + integer, intent(in), value, optional :: x + print*, 'present(x) is', present(x) + if (present (x)) stop 2 + end subroutine test2 + + subroutine test3 (w, x) + character, intent(in), optional :: w + integer, intent(in), value, optional :: x + print *, 'present(w) is', present(w) + print *, 'present(x) is', present(x) + if (.not. present (w)) stop 3 + if (present (x)) stop 4 + end subroutine test3 + + subroutine test4 (r, w, x) + real, value, optional :: r + character(*), intent(in), optional :: w + integer, value, optional :: x + print *, 'present(r) is', present(r) + print *, 'present(w) is', present(w) + print *, 'present(x) is', present(x) + if (present (r)) stop 5 + if (.not. present (w)) stop 6 + if (.not. present (x)) stop 7 + print *, 'x=', x + print *, 'len(w)=', len(w) + if (len(w) /= 3) stop 8 + if (x /= 42) stop 9 + end subroutine test4 + +end program bugdemo Index: Fortran/gfortran/regression/optional_absent_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_7.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/107441 +! Check that procedure types and procedure decls match when the procedure +! has both character-typed and optional value args. +! +! Contributed by M.Morin + +program p + interface + subroutine i(c, o) + character(*) :: c + integer, optional, value :: o + end subroutine i + end interface + procedure(i), pointer :: pp + pp => s + call pp("abcd") +contains + subroutine s(c, o) + character(*) :: c + integer, optional, value :: o + if (present(o)) stop 1 + if (len(c) /= 4) stop 2 + if (c /= "abcd") stop 3 + end subroutine s +end program p + +! { dg-final { scan-tree-dump "void s .* c, .* o, logical.* \.o, integer.* _c" "original" } } +! { dg-final { scan-tree-dump ", integer.*, logical.*, integer.* pp" "original" } } Index: Fortran/gfortran/regression/optional_absent_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_absent_8.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR fortran/107444 +! +! Check that procedures with optional arguments that have the value attribute +! work for intrinsic types including character, and that the presence check +! works. +! +! Co-contributed by M.Morin + +program p + implicit none + interface + subroutine i(c, o) + character(*) :: c + character(3), optional, value :: o + end subroutine i + end interface + procedure(i), pointer :: pp + call s([.false.,.false.,.false.], 0) + call s([.true., .false.,.false.], 10, i=7) + call s([.false.,.true. ,.false.], 20, c='abc') + call s([.false.,.false.,.true. ], 30, r=3.0) + pp => f + call pp ("abcd", "xyz") +contains + subroutine s (expect,code,i,c,r) + logical, intent(in) :: expect(:) + integer, intent(in) :: code + integer , value, optional :: i + character(3), value, optional :: c + real , value, optional :: r + if (expect(1) .neqv. present (i)) stop 1+code + if (expect(2) .neqv. present (c)) stop 2+code + if (expect(3) .neqv. present (r)) stop 3+code + if (present (i)) then + if (i /= 7) stop 4+code + end if + if (present (c)) then + if (c /= "abc") stop 5+code + end if + if (present (r)) then + if (r /= 3.0) stop 6+code + end if + end subroutine s + subroutine f (c, o) + character(*) :: c + character(3), optional, value :: o + if (c /= "abcd") stop 41 + if (len (c) /= 4) stop 42 + if (.not. present (o)) stop 43 + if (o /= "xyz") stop 44 + end subroutine f +end Index: Fortran/gfortran/regression/optional_assumed_charlen_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_assumed_charlen_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Tests the fix for PR29284 in which an ICE would occur in converting +! the call to a suboutine with an assumed character length, optional +! dummy that is not present. +! +! Contributed by Rakuen Himawari +! + MODULE foo + CONTAINS + SUBROUTINE sub1(a) + CHARACTER (LEN=*), OPTIONAL :: a + WRITE(*,*) 'foo bar' + END SUBROUTINE sub1 + + SUBROUTINE sub2 + CALL sub1() + END SUBROUTINE sub2 + + END MODULE foo Index: Fortran/gfortran/regression/optional_assumed_charlen_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_assumed_charlen_2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! PR fortran/94672 +! +! Contributed by Tomáš Trnka +! +module m + implicit none (type,external) + type t + integer :: i = 5 + end type t +contains +subroutine bar(x, y, z, n) + integer, value :: n + type(t), intent(out), optional :: x(:), y(n), z(:) + allocatable :: z +end subroutine bar + +subroutine foo (n, nFound, sVal) + integer, value :: n + integer, intent(out) :: nFound + character(*), optional, intent(out) :: sVal(n) + + nFound = 0 + + if (present(sVal)) then + nFound = nFound + 1 + end if +end subroutine +end + +use m +implicit none (type,external) +type(t) :: a(7), b(7), c(:) +allocatable :: c +integer :: nn, nf +character(len=4) :: str + +allocate(c(7)) +call bar(a,b,c,7) +if (any(a(:)%i /= 5)) stop 1 +if (any(b(:)%i /= 5)) stop 2 +if (allocated(c)) stop 3 + +call foo(7, nf, str) +if (nf /= 1) stop 4 +call foo(7, nf) +if (nf /= 0) stop 5 +end Index: Fortran/gfortran/regression/optional_class_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_class_1.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR fortran/57445 +! +! Contributed by Tobias Burnus +! +! Spurious assert was added at revision 192495 +! +module m + implicit none + type t + integer :: i + end type t +contains + subroutine opt(xa, xc, xaa, xca) + type(t), allocatable, intent(out), optional :: xa + class(t), allocatable, intent(out), optional :: xc + type(t), allocatable, intent(out), optional :: xaa(:) + class(t), allocatable, intent(out), optional :: xca(:) + if (present (xca)) call foo_opt(xca=xca) + end subroutine opt + subroutine foo_opt(xa, xc, xaa, xca) + type(t), allocatable, intent(out), optional :: xa + class(t), allocatable, intent(out), optional :: xc + type(t), allocatable, intent(out), optional :: xaa(:) + class(t), allocatable, intent(out), optional :: xca(:) + if (present (xca)) then + if (allocated (xca)) deallocate (xca) + allocate (xca(3), source = [t(9),t(99),t(999)]) + end if + end subroutine foo_opt +end module m + use m + class(t), allocatable :: xca(:) + allocate (xca(1), source = t(42)) + select type (xca) + type is (t) + if (any (xca%i .ne. [42])) STOP 1 + end select + call opt (xca = xca) + select type (xca) + type is (t) + if (any (xca%i .ne. [9,99,999])) STOP 2 + end select +end Index: Fortran/gfortran/regression/optional_dim.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_dim.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +subroutine foo(a,n) + real, dimension(2) :: a + integer, optional :: n + print *,maxloc(a,dim=n) ! { dg-error "must not be OPTIONAL" } + print *,maxloc(a,dim=4) ! { dg-error "is not a valid dimension index" } + print *,maxval(a,dim=n) ! { dg-error "must not be OPTIONAL" } + print *,maxval(a,dim=4) ! { dg-error "is not a valid dimension index" } +end subroutine foo + Index: Fortran/gfortran/regression/optional_dim_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_dim_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR33317 CSHIFT/EOSHIFT: Rejects optional dummy for DIM= +! Test case submitted by Jerry DeLisle +program test + implicit none + call sub(bound=.false., dimmy=1_8) + call sub() +contains + subroutine sub(bound, dimmy) + integer(kind=8), optional :: dimmy + logical, optional :: bound + logical :: lotto(4) + character(20) :: testbuf + lotto = .false. + lotto = cshift((/.true.,.false.,.true.,.false./),1,dim=dimmy) + write(testbuf,*) lotto + if (trim(testbuf).ne." F T F T") STOP 1 + lotto = .false. + lotto = eoshift((/.true.,.true.,.true.,.true./),1,boundary=bound,dim=dimmy) + lotto = eoshift(lotto,1,dim=dimmy) + write(testbuf,*) lotto + if (trim(testbuf).ne." T T F F") STOP 2 + end subroutine +end program test \ No newline at end of file Index: Fortran/gfortran/regression/optional_dim_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_dim_3.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! PR34540 cshift, eoshift, kind=1 and kind=2 arguments. +! Test case thanks to Thomas Koenig. +module tst_foo + implicit none +contains + subroutine tst_optional(a,n1,n2) + integer(kind=1), intent(in), optional:: n1 + integer(kind=2), intent(in), optional:: n2 + integer(kind=1), dimension(2) :: s1 + character(64) :: testbuf + real, dimension(:,:) :: a + s1 = (/1, 1/) + write(testbuf,'(4F10.2)') cshift(a, shift=s1) + if (testbuf /= " 2.00 1.00 4.00 3.00") STOP 1 + write(testbuf,'(4F10.2)') cshift(a,shift=s1,dim=n2) + if (testbuf /= " 2.00 1.00 4.00 3.00") STOP 2 + write(testbuf,'(4F10.2)') eoshift(a,shift=s1,dim=n1) + if (testbuf /= " 2.00 0.00 4.00 0.00") STOP 3 + write(testbuf,'(4F10.2)') eoshift(a,shift=s1,dim=n2) + if (testbuf /= " 2.00 0.00 4.00 0.00") STOP 4 + end subroutine tst_optional + subroutine sub(bound, dimmy) + integer(kind=8), optional :: dimmy + logical, optional :: bound + logical :: lotto(4) + character(20) :: testbuf + lotto = .false. + lotto = cshift((/.true.,.false.,.true.,.false./),1,dim=dimmy) + write(testbuf,*) lotto + if (trim(testbuf).ne." F T F T") STOP 5 + lotto = .false. + lotto = eoshift((/.true.,.true.,.true.,.true./),1,boundary=bound,dim=dimmy) + lotto = eoshift(lotto,1,dim=dimmy) + write(testbuf,*) lotto + if (trim(testbuf).ne." T T F F") STOP 6 + end subroutine +end module tst_foo + +program main + use tst_foo + implicit none + real, dimension(2,2) :: r + integer(kind=1) :: d1 + integer(kind=2) :: d2 + data r /1.0, 2.0, 3.0, 4.0/ + d1 = 1_1 + d2 = 1_2 + call tst_optional(r,d1, d2) + call sub(bound=.false., dimmy=1_8) + call sub() +end program main Index: Fortran/gfortran/regression/optional_mask.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/optional_mask.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Bug 45794 - ICE: Segmentation fault in gfc_conv_procedure_call +subroutine foo (vector, mask) + real :: vector(:) + logical, optional :: mask(:) + integer :: loc(1) + if (present(mask)) then + loc = maxloc(vector, mask) + end if +end subroutine Index: Fortran/gfortran/regression/output_exponents_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/output_exponents_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 21376 +! we used to take the logarithm of zero in this special case + character*10 c + write (c,'(e10.4)') 1.0 + if(c /= "0.1000E+01") STOP 1 + write (c,'(e10.4)') 0.0 + if(c /= "0.0000E+00") STOP 2 + write (c,'(e10.4)') 1.0d100 + if(c /= "0.1000+101") STOP 3 + write (c,'(e10.4)') 1.0d-102 + if(c /= "0.1000-101") STOP 4 +end Index: Fortran/gfortran/regression/overload_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/overload_1.f90 @@ -0,0 +1,181 @@ +! { dg-do run } +! tests that operator overloading works correctly for operators with +! different spellings +module m + type t + integer :: i + end type t + + interface operator (==) + module procedure teq + end interface + + interface operator (/=) + module procedure tne + end interface + + interface operator (>) + module procedure tgt + end interface + + interface operator (>=) + module procedure tge + end interface + + interface operator (<) + module procedure tlt + end interface + + interface operator (<=) + module procedure tle + end interface + + type u + integer :: i + end type u + + interface operator (.eq.) + module procedure ueq + end interface + + interface operator (.ne.) + module procedure une + end interface + + interface operator (.gt.) + module procedure ugt + end interface + + interface operator (.ge.) + module procedure uge + end interface + + interface operator (.lt.) + module procedure ult + end interface + + interface operator (.le.) + module procedure ule + end interface + +contains + function teq (a, b) + logical teq + type (t), intent (in) :: a, b + + teq = a%i == b%i + end function teq + + function tne (a, b) + logical tne + type (t), intent (in) :: a, b + + tne = a%i /= b%i + end function tne + + function tgt (a, b) + logical tgt + type (t), intent (in) :: a, b + + tgt = a%i > b%i + end function tgt + + function tge (a, b) + logical tge + type (t), intent (in) :: a, b + + tge = a%i >= b%i + end function tge + + function tlt (a, b) + logical tlt + type (t), intent (in) :: a, b + + tlt = a%i < b%i + end function tlt + + function tle (a, b) + logical tle + type (t), intent (in) :: a, b + + tle = a%i <= b%i + end function tle + + function ueq (a, b) + logical ueq + type (u), intent (in) :: a, b + + ueq = a%i == b%i + end function ueq + + function une (a, b) + logical une + type (u), intent (in) :: a, b + + une = a%i /= b%i + end function une + + function ugt (a, b) + logical ugt + type (u), intent (in) :: a, b + + ugt = a%i > b%i + end function ugt + + function uge (a, b) + logical uge + type (u), intent (in) :: a, b + + uge = a%i >= b%i + end function uge + + function ult (a, b) + logical ult + type (u), intent (in) :: a, b + + ult = a%i < b%i + end function ult + + function ule (a, b) + logical ule + type (u), intent (in) :: a, b + + ule = a%i <= b%i + end function ule +end module m + + +program main + call checkt + call checku + +contains + + subroutine checkt + use m + + type (t) :: a, b + logical :: r1(6), r2(6) + a%i = 0; b%i = 1 + + r1 = (/ a == b, a /= b, a < b, a <= b, a > b, a >= b /) + r2 = (/ a.eq.b, a.ne.b, a.lt.b, a.le.b, a.gt.b, a.ge.b /) + if (any (r1.neqv.r2)) STOP 1 + if (any (r1.neqv. & + (/ .false.,.true.,.true., .true., .false.,.false. /) )) STOP 1 + end subroutine checkt + + subroutine checku + use m + + type (u) :: a, b + logical :: r1(6), r2(6) + a%i = 0; b%i = 1 + + r1 = (/ a == b, a /= b, a < b, a <= b, a > b, a >= b /) + r2 = (/ a.eq.b, a.ne.b, a.lt.b, a.le.b, a.gt.b, a.ge.b /) + if (any (r1.neqv.r2)) STOP 2 + if (any (r1.neqv. & + (/ .false.,.true.,.true., .true., .false.,.false. /) )) STOP 2 + end subroutine checku +end program main Index: Fortran/gfortran/regression/overload_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/overload_2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Test the fix for PR32157, in which overloading 'LEN', as +! in 'test' below would cause a compile error. +! +! Contributed by Michael Richmond +! +subroutine len(c) + implicit none + character :: c + c = "X" +end subroutine len + +subroutine test() + implicit none + character :: str + external len + call len(str) + if(str /= "X") STOP 1 +end subroutine test + +PROGRAM VAL + implicit none + external test + intrinsic len + call test() + if(len(" ") /= 1) STOP 2 +END Index: Fortran/gfortran/regression/overload_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/overload_3.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! { dg-options "-fno-tree-vrp" } +! PR fortran/89282 +! Contributed by Federico Perini. +! +module myclass + use iso_fortran_env, only: real64 + implicit none + + ! My generic type + type :: t + + integer :: n=0 + real(real64), allocatable :: x(:) + + contains + + procedure :: init => t_init + procedure :: destroy => t_destroy + procedure :: print => t_print + + procedure, private, pass(this) :: x_minus_t + generic :: operator(-) => x_minus_t + + + end type t + + contains + + elemental subroutine t_destroy(this) + class(t), intent(inout) :: this + this%n=0 + if (allocated(this%x)) deallocate(this%x) + end subroutine t_destroy + + subroutine t_init(this,n) + class(t), intent(out) :: this + integer, intent(in) :: n + call this%destroy() + this%n=n + allocate(this%x(n)) + end subroutine t_init + + type(t) function x_minus_t(x,this) result(xmt) + real(real64), intent(in) :: x + class(t), intent(in) :: this + call xmt%init(this%n) + xmt%x(:) = x-this%x(:) + end function x_minus_t + + subroutine t_print(this,msg) + class(t), intent(in) :: this + character(*), intent(in) :: msg + + integer :: i + + print "('type(t) object <',a,'>, size=',i0)", msg,this%n + do i=1,this%n + print "(' x(',i0,') =',1pe12.5)",i,this%x(i) + end do + + end subroutine t_print + +end module myclass + + +program test_overloaded + use myclass + implicit none + + type(t) :: t1,r1 + + ! Error with result (5) + call t1%init(5); t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1 + if (any(r1%x /= 2.0)) stop 1 +! call r1%print('r1') + + ! No errors + call t1%init(6); t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1 + if (any(r1%x /= 2.0)) stop 2 +! call r1%print('r1') + return + +end program test_overloaded Index: Fortran/gfortran/regression/overload_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/overload_4.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-options "-Wno-intrinsic-shadow" } +! PR fortran/103782 - ICE overloading an intrinsic like dble or real +! Contributed by Urban Jost + +program runtest + implicit none + interface dble + procedure to_double + end interface dble + interface real + procedure floor ! not really FLOOR... + end interface real + if (any (dble ([10.0d0,20.0d0]) - [10.0d0,20.0d0] /= 0.d0)) stop 1 + if (any (real ([1.5,2.5]) - [1.5,2.5] /= 0.0 )) stop 2 +contains + elemental function to_double (valuein) result(d_out) + doubleprecision,intent(in) :: valuein + doubleprecision :: d_out + d_out=valuein + end function to_double + elemental function floor (valuein) result(d_out) ! not really FLOOR... + real, intent(in) :: valuein + real :: d_out + d_out=valuein + end function floor +end program runtest Index: Fortran/gfortran/regression/overwrite_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/overwrite_1.f @@ -0,0 +1,20 @@ +! { dg-do run { target fd_truncate } } +! PR 19872 - closed and re-opened file not overwriten + implicit none + integer i(4) + data i / 4 * 0 / + open(1,form='FORMATTED',status='UNKNOWN') + write(1,'("1 2 3 4 5 6 7 8 9")') + close(1) + open(1,form='FORMATTED') + write(1,'("9 8 7 6")') + close(1) + open(1,form='FORMATTED') + read(1,*)i + if(i(1).ne.9.and.i(2).ne.8.and.i(3).ne.7.and.i(4).ne.9)STOP 1 + read(1,*,end=200)i +! should only be able to read one line from the file + STOP 2 + 200 continue + close(1,STATUS='DELETE') + end Index: Fortran/gfortran/regression/pack_assign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pack_assign_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR32890 - compile-time checks for assigments + +INTEGER :: it, neighbrs(42) ! anything but 30 + +neighbrs = PACK((/ (it, it=1,30) /), (/ (it, it=1,30) /) < 3, (/ (0,it=1,30) /) ) ! { dg-error "Different shape" } + +END Index: Fortran/gfortran/regression/pack_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pack_bounds_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of PACK intrinsic; is 4, should be 5" } +! PR 30814 - a bounds error with pack was not caught. +program main + integer :: a(2,2), b(5) + a = reshape((/ 1, -1, 1, -1 /), shape(a)) + b = pack(a, a /= 0) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of PACK intrinsic; is 4, should be 5" } Index: Fortran/gfortran/regression/pack_mask_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pack_mask_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR 32721 - missing conversion for kind=1 and kind=2 masks for pack +program main + real, dimension(2,2) :: a + real, dimension(4) :: b + call random_number(a) + b = pack(a,logical(a>0,kind=1)) + b = pack(a,logical(a>0,kind=2)) +end program main Index: Fortran/gfortran/regression/pack_simplify_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pack_simplify_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/106049 - ICE in gfc_simplify_pack +! Contributed by G.Steinmetz + +program p + type t + end type + logical, parameter :: m(0) = [ logical :: ] + type(t), parameter :: a(0) = [ t :: ] + type(t), parameter :: b(1) = [ t() ] + type(t), parameter :: c(1) = [ t :: ] ! { dg-error "Different shape" } + type(t), parameter :: d(0) = pack(a, m) + type(t), parameter :: e(1) = pack(b, [.true.]) + type(t), parameter :: f(1) = pack(c, [.true.]) +end Index: Fortran/gfortran/regression/pack_vector_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pack_vector_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Check that the VECTOR argument of the PACK intrinsic has at least +! as many elements as the MASK has .TRUE. values. +! + + INTEGER :: res(2) + res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), SHAPE(1)) !{ dg-error "must provide at least as many" } + res = PACK ((/ 1, 2, 3 /), (/.TRUE., .TRUE., .FALSE. /), (/ -1 /)) !{ dg-error "must provide at least as many" } +END Index: Fortran/gfortran/regression/pad_no.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_no.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! Test correct operation for pad='no'. +program main + character(len=1) line(2) + line = 'x' + open(77,status='scratch',pad='no') + write(77,'(A)') 'a','b' + rewind(77) + read(77,'(2A)',iostat=i) line(1) + if (line(1) /= 'a' .or. line(2) /= 'x') STOP 1 + rewind(77) + line = 'y' + read(77,'(2A)',iostat=i,advance='no') line + if (line(1) /= 'a' .or. line(2) /= 'y') STOP 2 +end program main Index: Fortran/gfortran/regression/pad_source_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_source_1.f @@ -0,0 +1,8 @@ +c { dg-do run } +c { dg-skip-if "non-standard options" { *-*-* } { "-ffixed-line-length*" "-f*pad-source" } } + character(80) a + a = 'abc + +def' + if (a(:61) .ne. 'abc') stop 1 + if (a(62:) .ne. 'def') stop 2 + end Index: Fortran/gfortran/regression/pad_source_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_source_2.f @@ -0,0 +1,9 @@ +c { dg-do run } +c { dg-skip-if "non-standard options" { *-*-* } { "-ffixed-line-length*" } } +c { dg-options "-fpad-source" } + character(80) a + a = 'abc + +def' + if (a(:61) .ne. 'abc') stop 1 + if (a(62:) .ne. 'def') stop 2 + end Index: Fortran/gfortran/regression/pad_source_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_source_3.f @@ -0,0 +1,8 @@ +c { dg-do run } +c { dg-skip-if "non-standard options" { *-*-* } { "-ffixed-line-length*" } } +c { dg-options "-fno-pad-source" } + character(80) a + a = 'abc + +def' + if (a .ne. 'abcdef') stop 1 + end Index: Fortran/gfortran/regression/pad_source_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_source_4.f @@ -0,0 +1,7 @@ +c { dg-do run } +c { dg-options "-ffixed-line-length-none" } + character(80) a + a = 'abc + +def' + if (a .ne. 'abcdef') stop 1 + end Index: Fortran/gfortran/regression/pad_source_5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pad_source_5.f @@ -0,0 +1,7 @@ +c { dg-do run } +c { dg-options "-ffixed-line-length-0" } + character(80) a + a = 'abc + +def' + if (a .ne. 'abcdef') stop 1 + end Index: Fortran/gfortran/regression/parameter_array_dummy.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_dummy.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR fortran/31188 +program foo_mod + implicit none + character (len=1), parameter :: letters(2) = (/"a","b"/) + call concat(1, [1]) + call concat(2, [2]) + call concat(3, [1,2]) + call concat(4, [2,1]) + call concat(5, [2,2,2]) +contains + subroutine concat(i, ivec) + integer, intent(in) :: i, ivec(:) + write (*,*) i, "a" // letters(ivec) + end subroutine concat +end program foo_mod +! { dg-output " *1 aa(\r*\n+)" } +! { dg-output " *2 ab(\r*\n+)" } +! { dg-output " *3 aaab(\r*\n+)" } +! { dg-output " *4 abaa(\r*\n+)" } +! { dg-output " *5 ababab(\r*\n+)" } Index: Fortran/gfortran/regression/parameter_array_element_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_element_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! Tests the fix for PR 30872, in which the array element references bo(1,1) etc. +! would be wrong for rank > 1. +! +! Contributed by Joost VandeVondele +! + INTEGER, PARAMETER, DIMENSION(2,3) :: bo= & + RESHAPE((/-1,1,-2,2,-3,3/),(/2,3/)) + REAL(kind=8), DIMENSION( & + bo(1,1):bo(2,1), & + bo(1,2):bo(2,2), & + bo(1,3):bo(2,3)) :: out_val + out_val=0.0 +END +! Scan for the 105 in the declaration real8 out_val[105]; +! { dg-final { scan-tree-dump-times "105" 1 "original" } } + Index: Fortran/gfortran/regression/parameter_array_element_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_element_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/48831 +! Contributed by Tobias Burnus + +program p1 + implicit none + integer, parameter :: i1 = kind(0) + integer, parameter :: i2(1) = [i1] + integer(kind=i2(1)) :: i3 + + i3 = int(0, i1) + print *, i3 + + i3 = int(0, i2(1)) ! This line gives an error when compiling. + print *, i3 +end program p1 Index: Fortran/gfortran/regression/parameter_array_element_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_element_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 51260 - an unneeded parameter found its way into the +! assembly code. Original test case by Tobias Burnus. +module x +contains + subroutine foo(i) + integer, intent(in) :: i + end subroutine foo +end module x + +program main + use x + integer, parameter:: unneeded_parameter (10000)=(/(i,i=1,10000)/) + call foo(unneeded_parameter (1)) + print *,unneeded_parameter (1) +end program +! { dg-final { scan-assembler-times "unneeded_parameter" 0 } } Index: Fortran/gfortran/regression/parameter_array_error_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_error_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR68567 +! Contributed by Gerhard Steinmetz +! +program p + integer, parameter :: a(:) = [2, 1] ! { dg-error "cannot be automatic or of deferred shape" } +end Index: Fortran/gfortran/regression/parameter_array_format.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_format.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR fortran/66709 +! Check that parameter formats are handled correctly. +! Original test case by Gerhard Steinmetz. +program main + character(len=2), dimension(9), parameter :: f = ['("','He','ll','lo',', ','wo','rl','d!','")'] + character(len=2), dimension(9) :: g = ['("','He','ll','lo',', ','wo','rl','d!','")'] + character (len=20) :: line + write (unit=line,fmt=f) + if (line /= "Helllo, world!") STOP 1 + line = " " + write (unit=line,fmt=g) + if (line /= "Helllo, world!") STOP 2 +end program main Index: Fortran/gfortran/regression/parameter_array_init_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! tests the fix for PR29397, in which the initializer for the parameter +! 'J' was not expanded into an array. +! +! Contributed by Francois-Xavier Coudert +! + INTEGER :: K(3) = 1 + INTEGER, PARAMETER :: J(3) = 2 + IF (ANY (MAXLOC (K, J<3) .NE. 1)) STOP 1 + IF (ANY (J .NE. 2)) STOP 2 +END Index: Fortran/gfortran/regression/parameter_array_init_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_2.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-std=gnu" } ! suppress the warning about line 15 +! Thrashes the fix for PR29400, where the scalar initializers +! were not expanded to arrays with the appropriate shape. +! +! Contributed by Francois-Xavier Coudert +! + integer,parameter :: i(1,1) = 0, j(2) = 42 + + if (any (maxloc(j+j,mask=(j==2)) .ne. 0)) STOP 1 + if (size(j+j) .ne. 2) STOP 2 + if (minval(j+j) .ne. 84) STOP 3 + if (minval(j,mask=(j==2)) .ne. huge (j)) STOP 4 + if (maxval(j+j) .ne. 84) STOP 5 + if (maxval(j,mask=(j==2)) .ne. -huge (j)-1) STOP 6 + if (sum(j,mask=j==2) .ne. 0) STOP 7 + if (sum(j+j) .ne. 168) STOP 8 + if (product(j+j) .ne. 7056) STOP 9 + if (any(ubound(j+j) .ne. 2)) STOP 10 + if (any(lbound(j+j) .ne. 1)) STOP 11 + if (dot_product(j+j,j) .ne. 7056) STOP 12 + if (dot_product(j,j+j) .ne. 7056) STOP 13 + if (count(i==1) .ne. 0) STOP 14 + if (any(i==1)) STOP 15 + if (all(i==1)) STOP 16 + end Index: Fortran/gfortran/regression/parameter_array_init_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Test the fix for PR34476 in which an 'out of bounds' error would be +! generated for the array initializations AND the implicit index 'i' +! would be rejected. +! +! Reported by Tobias Burnus following a thread +! on comp.lang.fortran (see PR) +! +module abuse_mod + implicit none + integer i + character(8), parameter :: HEX1 = '40490FDB' + integer(1), parameter :: MSKa1(len(HEX1)) = [(1,i=1,len(HEX1))] + integer(1), parameter :: ARR1(len(HEX1)) = [( MSKa1(i), i=1,len(HEX1) )] +end module abuse_mod Index: Fortran/gfortran/regression/parameter_array_init_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_4.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! PR fortran/36476 +! +IMPLICIT NONE +CHARACTER (len=*) MY_STRING(1:3), my_string_s +PARAMETER ( MY_STRING = (/ "A" , "B", "C" /) ) +PARAMETER ( MY_STRING_S = "AB C" ) +character(len=*), parameter :: str(2) = [ 'Ac','cc'] +character(len=*), parameter :: str_s = 'Acc' + +CHARACTER (kind=1,len=*) MY_STRING1(1:3), my_string_s1 +PARAMETER ( MY_STRING1 = (/ "A" , "B", "C" /) ) +PARAMETER ( MY_STRING_S1 = "AB C" ) +character(kind=1,len=*), parameter :: str1(2) = [ 1_'Ac',1_'cc'] +character(kind=1,len=*), parameter :: str_s1 = 'Acc' + +CHARACTER (kind=4,len=*) MY_STRING4(1:3), my_string_s4 +PARAMETER ( MY_STRING4 = (/ 4_"A" , 4_"B", 4_"C" /) ) +PARAMETER ( MY_STRING_S4 = 4_"AB C" ) +character(kind=4,len=*), parameter :: str4(2) = [ 4_'Ac',4_'cc'] +character(kind=4,len=*), parameter :: str_s4 = 4_'Acc' + +if(len(MY_STRING) /= 1) STOP 1 +if( MY_STRING(1) /= "A" & + .or.MY_STRING(2) /= "B" & + .or.MY_STRING(3) /= "C") STOP 2 +if(len(MY_STRING_s) /= 4) STOP 3 +if(MY_STRING_S /= "AB C") STOP 4 +if(len(str) /= 2) STOP 5 +if(str(1) /= "Ac" .or. str(2) /= "cc") STOP 6 +if(len(str_s) /= 3) STOP 7 +if(str_s /= 'Acc') STOP 8 + +if(len(MY_STRING1) /= 1) STOP 9 +if( MY_STRING1(1) /= 1_"A" & + .or.MY_STRING1(2) /= 1_"B" & + .or.MY_STRING1(3) /= 1_"C") STOP 10 +if(len(MY_STRING_s1) /= 4) STOP 11 +if(MY_STRING_S1 /= 1_"AB C") STOP 12 +if(len(str1) /= 2) STOP 13 +if(str1(1) /= 1_"Ac" .or. str1(2) /= 1_"cc") STOP 14 +if(len(str_s1) /= 3) STOP 15 +if(str_s1 /= 1_'Acc') STOP 16 + +if(len(MY_STRING4) /= 1) STOP 17 +if( MY_STRING4(1) /= 4_"A" & + .or.MY_STRING4(2) /= 4_"B" & + .or.MY_STRING4(3) /= 4_"C") STOP 18 +if(len(MY_STRING_s4) /= 4) STOP 19 +if(MY_STRING_S4 /= 4_"AB C") STOP 20 +if(len(str4) /= 2) STOP 21 +if(str4(1) /= 4_"Ac" .or. str4(2) /= 4_"cc") STOP 22 +if(len(str_s4) /= 3) STOP 23 +if(str_s4 /= 4_'Acc') STOP 24 +end Index: Fortran/gfortran/regression/parameter_array_init_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_5.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR fortran/41515 +! Contributed by ros@rzg.mpg.de. +! +! Before, the "parm' string array was never initialized. +! +Module BUG3 +contains + Subroutine SR + character(3) :: parm(5) + character(20) :: str + parameter(parm=(/'xo ','yo ','ag ','xr ','yr '/)) + + str = 'XXXXXXXXXXXXXXXXXXXX' + if(str /='XXXXXXXXXXXXXXXXXXXX') STOP 1 + write(str,*) parm + if(str /= ' xo yo ag xr yr') STOP 2 + end subroutine SR +end Module BUG3 +! +program TEST + use bug3 + call sr +end program TEST Index: Fortran/gfortran/regression/parameter_array_init_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_6.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/44742 +! +! Test case based on Juergen Reuter's and reduced by +! Janus Weil. +! +! The program creates a large array constructor, which +! exceeds -fmax-array-constructor - and caused an ICE. +! + +module proc8 + implicit none + integer, parameter :: N = 256 + logical, dimension(N**2), parameter :: A = .false. + logical, dimension(N,N), parameter :: B & + = reshape ( (/ A /), (/ N, N /) ) ! { dg-error "array constructor at .1. requires an increase" } +end module Index: Fortran/gfortran/regression/parameter_array_init_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR68566 ICE on using unusable array in reshape +program p + integer, parameter :: n = 2 + integer, parameter :: a(:) = 0 !{ dg-error "automatic or of deferred shape" } + integer, parameter :: b(n, n) = reshape([a, 1+a], [n, n]) +end + Index: Fortran/gfortran/regression/parameter_array_init_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_init_8.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR fortran/99348 +! PR fortran/102521 +! Check simplifications for initialization of DT parameter arrays + +program p + type t + integer :: n + end type + type(t), parameter :: a(4) = t(1) + type(t), parameter :: d(*) = a + type(t), parameter :: b(2,2) = reshape(d, [2,2]) + integer, parameter :: nn = b(2,2)% n + type u + character(3) :: c + end type + type(u), parameter :: x(2,3) = u('ab') + type(u), parameter :: y(*,*) = transpose (x) + character(*), parameter :: c = y(3,2)% c + integer, parameter :: lc = c% len + integer, parameter :: lyc = len (y(3,2)% c) +! integer, parameter :: lxc = x(1,1)% c% len ! fails (pr101735?) + if (nn /= 1) stop 1 + if (lc /= 3 .or. lyc /= 3 .or. c /= "ab ") stop 2 +end Index: Fortran/gfortran/regression/parameter_array_ref_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_ref_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/32906 - Parameter array ... cannot be automatic or assumed shape +! +! Testcase contributed by Florian Ladstaedter +! +program test_program + integer, parameter :: len = 1 + integer, parameter :: arr(max(len,1)) = (/1/) + + character(len=*), dimension (1), parameter :: specStr = (/'string'/) + double precision, dimension (size(specStr)), parameter :: specNum = (/99.0d0/) +end Index: Fortran/gfortran/regression/parameter_array_ref_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_ref_2.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Test the fix for the problems in PR41044 +! +! Contributed by +! Reduced by Joos VandeVondele +! + Subroutine PS_INIT (bkgd, punit, pform, psize, rot90, bbox, clip, eps, & + caller) + type psfd ! paper size and frame defaults + character(3) :: n + real :: p(2) + real :: f(4) + end type psfd + character(4) :: fn, orich, pfmt + type(psfd), parameter :: pfd(0:11)=(/ & + psfd(' ',(/ 0.0, 0.0/),(/200.,120.,800.,560./)), & ! A0_L + psfd('A0 ',(/ 840.9,1189.2/),(/140., 84.,560.,400./)), & ! A0_P + psfd('A1 ',(/ 594.6, 840.9/),(/100., 60.,400.,280./)), & ! A1_P + psfd('A2 ',(/ 420.4, 594.6/),(/ 70., 42.,280.,200./)), & ! A2_P + psfd('A3 ',(/ 297.3, 420.4/),(/ 50., 30.,200.,140./)), & ! A3_P + psfd('A4 ',(/ 210.2, 297.3/),(/ 35., 21.,140.,100./)), & ! A4_P + psfd('A5 ',(/ 148.7, 210.2/),(/ 25., 15.,100., 70./)), & ! A5_P + psfd('A6 ',(/ 105.1, 148.7/),(/ 18., 11., 70., 50./)), & ! A6_P + psfd(' ',(/ 0.0, 0.0/),(/ 50., 30.,200.,140./)), & ! Letter_L + psfd('LET',(/ 215.9, 279.4/),(/ 35., 21.,140.,100./)), & ! Letter_P + psfd(' ',(/ 0.0, 0.0/),(/ 50., 30.,200.,140./)), & ! Legal_L + psfd('LEG',(/ 215.9, 355.6/),(/ 35., 21.,140.,100./))/) ! Legal_P + if (len_trim(pfmt) > 0) then ! set paper format + idx=sum(maxloc(index(pfd%n,pfmt(1:3))))-1 + end if + end subroutine PS_INIT + +! This, additional problem, was posted as comment #8 by Tobias Burnus + type t + integer :: i + end type t + type(t), parameter :: a(1) = t(4) ! [t(4)] worked OK + real(a(1)%i) :: b +end Index: Fortran/gfortran/regression/parameter_array_section_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_section_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Tests the fix for PR29821, which was due to failure to simplify the +! array section, since the section is not constant, provoking failure +! to resolve the argument of SUM and therefore to resolve SUM itself. +! +! Contributed by Harald Anlauf +! +module gfcbug45 + implicit none +contains + subroutine foo + real, external :: mysum + integer :: i + real :: a + real, parameter :: eps(2) = (/ 1, 99 /) + i = 1 + a = sum (eps(i:i+1) * eps) + print *, a + end subroutine foo +end module gfcbug45 + use gfcbug45 + call foo +end Index: Fortran/gfortran/regression/parameter_array_section_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_array_section_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-O" } +! Test the fix for PR31011 in which the length of the array sections +! with stride other than unity were incorrectly calculated. +! +! Contributed by +! +program PotentialMatrix + implicit none + real(kind=8),dimension(2),parameter::v2=(/1,2/) + real(kind=8),dimension(4),parameter::v4=(/1,2,3,4/) + if (any (v2*v4(1:3:2) .ne. (/1,6/))) STOP 1 + if (any (v2*v4(3:1:-2) .ne. (/3,2/))) STOP 2 +end Index: Fortran/gfortran/regression/parameter_data.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_data.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/49278 - ICE when combining DATA with default initialization + +program p + implicit none + type t + real :: a + end type t + integer, parameter :: b = 42 + type(t), parameter :: z = t(4.0) + data b / 666 / ! { dg-error "shall not appear in a DATA statement" } + data z%a / 3.0 / ! { dg-error "shall not appear in a DATA statement" } +end Index: Fortran/gfortran/regression/parameter_data0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_data0.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/102595 Similar to 88048 with a zero sized array +program p + complex, parameter:: x(0) = 2 + data x%im /3.0/ ! { dg-error "shall not appear in a DATA statement" } +end Index: Fortran/gfortran/regression/parameter_save.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_save.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 20848 - parameter and save should conflict. + integer, parameter, save :: x=0 ! { dg-error "conflicts" } + integer, save :: y + parameter (y=42) ! { dg-error "conflicts" } +end Index: Fortran/gfortran/regression/parameter_unused.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parameter_unused.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wunused-parameter" } +! +! PR fortran/31129 - No warning on unused parameters +! +program fred +integer,parameter :: j = 9 ! { dg-warning "Unused parameter" } +end + Index: Fortran/gfortran/regression/parens_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_1.f90 @@ -0,0 +1,8 @@ +! PR 20894 +! { dg-do compile } +! Originally contributed by Joost VandeVondele +INTEGER, POINTER :: I,J +INTEGER :: K +ALLOCATE(I) +J=>(I) ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" } +END Index: Fortran/gfortran/regression/parens_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_2.f90 @@ -0,0 +1,11 @@ +! PR 25048 +! { dg-do compile } +! Originally contributed by Joost VandeVondele +INTEGER, POINTER :: I +CALL S1((I)) ! { dg-error "Actual argument for .i. at .1. must be a pointer or a valid target" } +CONTAINS + SUBROUTINE S1(I) + INTEGER, POINTER ::I + END SUBROUTINE S1 +END + Index: Fortran/gfortran/regression/parens_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_3.f90 @@ -0,0 +1,48 @@ +! PR 14771 +! { dg-do run } +! Originally contributed by Walt Brainerd, modified for the testsuite + PROGRAM fc107 + +! Submitted by Walt Brainerd, The Fortran Company +! GNU Fortran 95 (GCC 4.1.0 20050322 (experimental)) +! Windows XP + +! Return value should be 3 + + INTEGER I, J, M(2), N(2) + integer, pointer :: k + integer, target :: l + INTEGER TRYME + + interface + FUNCTION TRYyou(RTNME,HITME) + INTEGER RTNME(2),HITME(2), tryyou(2) + END function tryyou + end interface + + m = 7 + l = 5 + I = 3 + k => l + + j = tryme((i),i) + if (j .ne. 3) STOP 1 + + j = tryme((k),k) + if (j .ne. 5) STOP 2 + + n = tryyou((m),m) + if (any(n .ne. 7)) STOP 3 + END + + INTEGER FUNCTION TRYME(RTNME,HITME) + INTEGER RTNME,HITME + HITME = 999 + TRYME = RTNME + END + + FUNCTION TRYyou(RTNME,HITME) + INTEGER RTNME(2),HITME(2), tryyou(2) + HITME = 999 + TRYyou = RTNME + END Index: Fortran/gfortran/regression/parens_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Fallout from the patch for PR 14771 +! Testcase by Erik Zeek +program test + call bob(5) +contains + subroutine bob(n) + integer, intent(in) :: n + character(len=n) :: temp1 + character(len=(n)) :: temp2 ! Fails here + end subroutine bob +end program test Index: Fortran/gfortran/regression/parens_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_5.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Another case of fallout from the original patch for PR14771 +! Testcase by Erik Zeek +module para +contains + function bobo(n) + integer, intent(in) :: n + character(len=(n)) :: bobo ! Used to fail here + bobo = "1234567890" + end function bobo +end module para + +program test + use para + implicit none + character*5 c + c = bobo(5) + if (c .ne. "12345") STOP 1 +end program test Index: Fortran/gfortran/regression/parens_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_6.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR fortran/33626 +! Types were not always propagated correctly + logical(kind=1) :: i, j + integer(kind=1) :: a, b + character*1 :: c, d + if (any( (/ kind(i .and. j), kind(.not. (i .and. j)), kind((a + b)), & + kind((42_1)), kind((j .and. i)), kind((.true._1)), & + kind(c // d), kind((c) // d), kind((c//d)) /) /= 1 )) STOP 1 + if (any( (/ len(c // d), len((c) // d), len ((c // d)) /) /= 2)) STOP 2 +end Index: Fortran/gfortran/regression/parens_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parens_7.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR34432 integer(kind=init_expression) function is rejected +module m + integer, parameter :: int_t = 4 +end module m + +program test + print *, test4() +contains + +integer(kind=(int_t)) function test4() ! This failed before patch + use m + test4 = 345 +end function test4 + + +end program test Index: Fortran/gfortran/regression/parent_result_ref_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parent_result_ref_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Tests the fix for PR19546 in which an ICE would result from +! setting the parent result in a contained procedure. +! From the testcase of Francois-Xavier Coudert/Tobias Schlueter +! +function f() + integer :: f + f = 42 + call sub () + if (f.eq.1) f = f + 1 +contains + subroutine sub + if (f.eq.42) f = f - 41 + end subroutine sub +end function f + + integer, external :: f + if (f ().ne.2) STOP 1 +end Index: Fortran/gfortran/regression/parent_result_ref_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parent_result_ref_2.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Tests the fix for PR19546 in which an ICE would result from +! setting the parent result in a contained procedure. +! This case tests character results. +! +function f() + character(4) :: f + f = "efgh" + call sub () + if (f.eq."iklm") f = "abcd" + call sub () +contains + subroutine sub + f = "wxyz" + if (f.eq."efgh") f = "iklm" + end subroutine sub +end function f + +function g() ! { dg-warning "Obsolescent feature" } + character(*) :: g + g = "efgh" + call sub () + if (g.eq."iklm") g = "ABCD" + call sub () +contains + subroutine sub + g = "WXYZ" + if (g.eq."efgh") g = "iklm" + end subroutine sub +end function g + + character(4), external :: f, g + if (f ().ne."wxyz") STOP 1 + if (g ().ne."WXYZ") STOP 2 +end Index: Fortran/gfortran/regression/parent_result_ref_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parent_result_ref_3.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Tests the fix for PR19546 in which an ICE would result from +! setting the parent result in a contained procedure. +! Check that parent alternate entry results can be referenced. +! +function f() + integer :: f, g + f = 42 + call sub1 () + if (f.eq.1) f = 2 + return +entry g() + g = 99 + call sub2 () + if (g.eq.77) g = 33 +contains + subroutine sub1 + if (f.eq.42) f = 1 + end subroutine sub1 + subroutine sub2 + if (g.eq.99) g = g - 22 + end subroutine sub2 +end function f + + integer, external :: f, g + if (f ().ne.2) STOP 1 + if (g ().ne.33) STOP 2 +end Index: Fortran/gfortran/regression/parent_result_ref_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parent_result_ref_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Tests the fix for PR19546 in which an ICE would result from +! setting the parent result in a contained procedure. +! Check that parent function results can be referenced in modules. +! +module m +contains + function f() + integer :: f + f = 42 + call sub () + if (f.eq.1) f = f + 1 + contains + subroutine sub + if (f.eq.42) f = f - 41 + end subroutine sub + end function f +end module m + + use m + if (f ().ne.2) STOP 1 +end Index: Fortran/gfortran/regression/parity_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parity_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none + +integer :: i +logical :: Lt(1) = [ .true. ] +logical :: Lf(1) = [ .false.] +logical :: Ltf(2) = [ .true., .false. ] +logical :: Ltftf(4) = [.true., .false., .true.,.false.] + +if (parity([logical ::]) .neqv. .false.) STOP 1 +if (parity([.true., .false.]) .neqv. .true.) STOP 2 +if (parity([.true.]) .neqv. .true.) STOP 3 +if (parity([.false.]) .neqv. .false.) STOP 4 +if (parity([.true., .false., .true.,.false.]) .neqv. .false.) STOP 5 +if (parity(reshape([.true., .false., .true.,.false.],[2,2])) & + .neqv. .false.) STOP 6 +if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=1) & + .neqv. [.true., .true.])) STOP 7 +if (any (parity(reshape([.true., .false., .true.,.false.],[2,2]),dim=2) & + .neqv. [.false., .false.])) STOP 8 + +i = 0 +if (parity(Lt(1:i)) .neqv. .false.) STOP 9 +if (parity(Ltf) .neqv. .true.) STOP 10 +if (parity(Lt) .neqv. .true.) STOP 11 +if (parity(Lf) .neqv. .false.) STOP 12 +if (parity(Ltftf) .neqv. .false.) STOP 13 +if (parity(reshape(Ltftf,[2,2])) & + .neqv. .false.) STOP 14 +if (any (parity(reshape(Ltftf,[2,2]),dim=1) & + .neqv. [.true., .true.])) STOP 15 +if (any (parity(reshape(Ltftf,[2,2]),dim=2) & + .neqv. [.false., .false.])) STOP 16 + +end Index: Fortran/gfortran/regression/parity_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parity_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none +print *, parity([real ::]) ! { dg-error "must be LOGICAL" }) +print *, parity([integer ::]) ! { dg-error "must be LOGICAL" } +print *, parity([logical ::]) +print *, parity(.true.) ! { dg-error "must be an array" } +end Index: Fortran/gfortran/regression/parity_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parity_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Check implementation of PARITY +! +implicit none +print *, parity([.true.]) ! { dg-error "has no IMPLICIT type" } +end Index: Fortran/gfortran/regression/parloops-exit-first-loop-alt-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parloops-exit-first-loop-alt-2.f95 @@ -0,0 +1,19 @@ +! { dg-additional-options "-O2" } +! { dg-require-effective-target pthread } +! { dg-additional-options "-ftree-parallelize-loops=2" } +! { dg-additional-options "-fdump-tree-parloops2-details" } + +! Constant bound, vector addition. + +subroutine foo () + integer, parameter :: n = 1000 + integer, dimension (0:n-1) :: a, b, c + common a, b, c + integer :: ii + + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + 25 + end do +end subroutine foo + +! { dg-final { scan-tree-dump-times "alternative exit-first loop transform succeeded" 1 "parloops2" } } Index: Fortran/gfortran/regression/parloops-exit-first-loop-alt.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/parloops-exit-first-loop-alt.f95 @@ -0,0 +1,21 @@ +! { dg-additional-options "-O2" } +! { dg-require-effective-target pthread } +! { dg-additional-options "-ftree-parallelize-loops=2" } +! { dg-additional-options "-fdump-tree-parloops2-details" } + +! Variable bound, vector addition. + +subroutine foo (nr) + integer, intent(in) :: nr + integer, parameter :: n = 1000 + integer, dimension (0:n-1) :: a, b, c + common a, b, c + integer :: ii + + do ii = 0, nr - 1 + c(ii) = a(ii) + b(ii) + 25 + end do +end subroutine foo + +! { dg-final { scan-tree-dump-times "alternative exit-first loop transform succeeded" 1 "parloops2" } } + Index: Fortran/gfortran/regression/past_eor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/past_eor.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test of the fix to the bug triggered by NIST fm908.for. +! Contributed by Paul Thomas +! +program past_eor + character(len=82) :: buffer + real :: a(2), b(2), c(2), d(2), e(2) + + e = (/2.34,2.456/) + +! tests 28-31 from fm908.for + + buffer = ' 2.34 , 2.456 2.34 , 2.456 0.234E01, 2.456E00& + & 0.234E+001, 2.456E-000' + + READ (UNIT=buffer,FMT=10) a, b, c, d +10 FORMAT (2(2(G7.5,1X),2X),2(G10.4E2,1X),1X,2(G11.7E4,1X)) + + if (any (a.ne.e).or.any (b.ne.e).or.any (c.ne.e).or.any (d.ne.e)) STOP 1 + +end program past_eor + Index: Fortran/gfortran/regression/pdt_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_1.f03 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! Basic check of Parameterized Derived Types. +! +! -fcheck=all is used here to ensure that when the parameter +! 'b' of the dummy in 'foo' is assumed, there is no error. +! Likewise in 'bar' and 'foobar', when 'b' has the correct +! explicit value. +! + implicit none + integer, parameter :: ftype = kind(0.0e0) + integer :: pdt_len = 4 + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0d0) + integer, LEN :: b + integer :: i + real(kind = a) :: d(b, b) + character (len = b*b) :: chr + end type + + type(mytype(b=4)) :: z(2) + type(mytype(ftype, 4)) :: z2 + + z(1)%i = 1 + z(2)%i = 2 + z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4]) + z(2)%d = 10*z(1)%d + z(1)%chr = "hello pdt" + z(2)%chr = "goodbye pdt" + + z2%d = z(1)%d * 10 - 1 + z2%chr = "scalar pdt" + + call foo (z) + call bar (z) + call foobar (z2) +contains + elemental subroutine foo (arg) + type(mytype(8,*)), intent(in) :: arg + if (arg%i .eq. 1) then + if (trim (arg%chr) .ne. "hello pdt") error stop + if (int (sum (arg%d)) .ne. 136) error stop + else if (arg%i .eq. 2 ) then + if (trim (arg%chr) .ne. "goodbye pdt") error stop + if (int (sum (arg%d)) .ne. 1360) error stop + else + error stop + end if + end subroutine + subroutine bar (arg) + type(mytype(b=4)) :: arg(:) + if (int (sum (arg(1)%d)) .ne. 136) STOP 1 + if (trim (arg(2)%chr) .ne. "goodbye pdt") STOP 2 + end subroutine + subroutine foobar (arg) + type(mytype(ftype, pdt_len)) :: arg + if (int (sum (arg%d)) .ne. 1344) STOP 3 + if (trim (arg%chr) .ne. "scalar pdt") STOP 4 + end subroutine +end Index: Fortran/gfortran/regression/pdt_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_10.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Fixes problem setting CHARACTER KIND expressions in PDT components +! and resolution of intrinsic functions and numeric expressions. +! +! Contributed by FortranFan on clf thread "Parameterized Derived Types +! make first appearance in gfortran 8.0.0" +! +program p + use, intrinsic :: iso_fortran_env, only : CK => character_kinds + implicit none + character(kind = 4), parameter :: c = 'a' + character(kind = 4), parameter :: hello = "Hello World!" + type :: pdt_t(k,l) + integer, kind :: k = CK(1) + integer, len :: l + character(kind=k,len=l) :: s + end type + type(pdt_t(l=12)) :: foo + type(pdt_t(k = kind (c), l=12)) :: foo_4 + + foo%s = "Hello World!" + if (foo%s .ne. "Hello World!") STOP 1 + if (KIND (foo%s) .ne. 1) STOP 2 + if (len (foo%s) .ne. 12) STOP 3 + + foo_4%s = hello + if (foo_4%s .ne. hello) STOP 4 + if (KIND (foo_4%s) .ne. 4) STOP 5 + if (len (foo_4%s) .ne. 12) STOP 6 +end program Index: Fortran/gfortran/regression/pdt_11.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_11.f03 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Rolls together 'len_par_06_pos.f90' and 'len_par_07_pos.f90', both of which +! failed to compile. +! +! Contributed by Reinhold Bader +! +module m_type_decs + + implicit none + + type :: matrix(rk, n, m) + integer, kind :: rk + integer, len :: n = 15, m = 20 + real(rk) :: entry(n, m) + end type matrix + + type :: fdef(rk, n) + integer, kind :: rk = kind(1.0) + integer, len :: n = 15 + end type + +end module + +program test + + use m_type_decs + implicit none + integer, parameter :: rk1=kind(1.d0) + type(matrix(rk1,:,:)), allocatable :: o_matrix + type(fdef(n=:)), allocatable :: o_fdef + + allocate(matrix(rk=rk1)::o_matrix) + + if (o_matrix%n == 15 .and. o_matrix%m == 20) then + write(*,*) 'o_matrix OK' + else + write(*,*) 'o_matrix FAIL' + STOP 1 + end if + + allocate(fdef(n=12)::o_fdef) + + if (o_fdef%n == 12) then + write(*,*) 'o_fdef OK' + else + write(*,*) 'o_fdef FAIL' + STOP 2 + end if +end program test + + Index: Fortran/gfortran/regression/pdt_12.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_12.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Checks PDTs with ASSOCIATE. +! Was failing for same reason as PR60483. +! +! Contributed by Reinhold Bader +! +module matrix_mod_assumed_05 + + implicit none + + type :: matrix(rk, n, m) + integer, kind :: rk + integer, len :: n, m + real(rk) :: entry(n, m) + end type matrix + integer, parameter :: rk=kind(1.d0) + integer :: mm=20, nn=15 + +contains + function factory() + type(matrix(rk, :, :)), allocatable :: factory + allocate(matrix(rk, nn, mm) :: factory) + end function +end module + +program test + + use matrix_mod_assumed_05 + implicit none + + associate (o_matrix => factory()) + if (o_matrix%n == nn .and. o_matrix%m == mm) then ! Symbol 'o_matrix' at (1) has no IMPLICIT type + write(*,*) 'OK' + else + write(*,*) 'FAIL' + STOP 1 + end if + end associate + +end program test + Index: Fortran/gfortran/regression/pdt_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_13.f03 @@ -0,0 +1,92 @@ +! { dg-do run } +! +! Test the fix for PR82375 +! +! Based on contribution by Ian Chivers +! +module precision_module + implicit none + integer, parameter :: sp = selected_real_kind(6, 37) + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: qp = selected_real_kind( 30, 291) +end module precision_module + +module link_module + use precision_module + + type link(real_kind) + integer, kind :: real_kind + real (kind=real_kind) :: n + type (link(real_kind)), pointer :: next => NULL() + end type link + +contains + + function push_8 (self, arg) result(current) + real(dp) :: arg + type (link(real_kind=dp)), pointer :: self + type (link(real_kind=dp)), pointer :: current + + if (associated (self)) then + current => self + do while (associated (current%next)) + current => current%next + end do + + allocate (current%next) + current => current%next + else + allocate (current) + self => current + end if + + current%n = arg + current%next => NULL () + end function push_8 + + function pop_8 (self) result(res) + type (link(real_kind=dp)), pointer :: self + type (link(real_kind=dp)), pointer :: current => NULL() + type (link(real_kind=dp)), pointer :: previous => NULL() + real(dp) :: res + + res = 0.0_8 + if (associated (self)) then + current => self + do while (associated (current) .and. associated (current%next)) + previous => current + current => current%next + end do + + previous%next => NULL () + + res = current%n + if (associated (self, current)) then + deallocate (self) + else + deallocate (current) + end if + + end if + end function pop_8 + +end module link_module + +program ch2701 + use precision_module + use link_module + implicit none + integer, parameter :: wp = dp + type (link(real_kind=wp)), pointer :: root => NULL() + type (link(real_kind=wp)), pointer :: current + + current => push_8 (root, 1.0_8) + current => push_8 (root, 2.0_8) + current => push_8 (root, 3.0_8) + + if (int (pop_8 (root)) .ne. 3) STOP 1 + if (int (pop_8 (root)) .ne. 2) STOP 2 + if (int (pop_8 (root)) .ne. 1) STOP 3 + if (int (pop_8 (root)) .ne. 0) STOP 4 + +end program ch2701 Index: Fortran/gfortran/regression/pdt_14.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_14.f03 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! Test the fix for PR82375. This is the allocatable version of pdt_13.f03. +! +! Based on contribution by Ian Chivers +! +module precision_module + implicit none + integer, parameter :: sp = selected_real_kind(6, 37) + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: qp = selected_real_kind( 30, 291) +end module precision_module + +module link_module + use precision_module + + type link(real_kind) + integer, kind :: real_kind + real (kind=real_kind) :: n + type (link(real_kind)), allocatable :: next + end type link + +contains + + function push_8 (self, arg) result(current) + real(dp) :: arg + type (link(real_kind=dp)), allocatable, target :: self + type (link(real_kind=dp)), pointer :: current + + if (allocated (self)) then + current => self + do while (allocated (current%next)) + current => current%next + end do + + allocate (current%next) + current => current%next + else + allocate (self) + current => self + end if + + current%n = arg + + end function push_8 + + function pop_8 (self) result(res) + type (link(real_kind=dp)), allocatable, target :: self + type (link(real_kind=dp)), pointer:: current + type (link(real_kind=dp)), pointer :: previous + real(dp) :: res + + res = 0.0_8 + if (allocated (self)) then + current => self + previous => self + do while (allocated (current%next)) + previous => current + current => current%next + end do + res = current%n + if (.not.allocated (previous%next)) then + deallocate (self) + else + deallocate (previous%next) + end if + + end if + end function pop_8 + +end module link_module + +program ch2701 + use precision_module + use link_module + implicit none + integer, parameter :: wp = dp + type (link(real_kind=wp)), allocatable :: root + type (link(real_kind=wp)), pointer :: current + + current => push_8 (root, 1.0_8) + current => push_8 (root, 2.0_8) + current => push_8 (root, 3.0_8) + + if (int (pop_8 (root)) .ne. 3) STOP 1 + if (int (pop_8 (root)) .ne. 2) STOP 2 + if (int (pop_8 (root)) .ne. 1) STOP 3 + if (int (pop_8 (root)) .ne. 0) STOP 4 + +end program ch2701 Index: Fortran/gfortran/regression/pdt_15.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_15.f03 @@ -0,0 +1,106 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR82375. This is a wrinkle on the allocatable +! version of pdt_13.f03, pdt_14.f03, whereby 'root' is now declared +! in a subroutine so that it should be cleaned up automatically. This +! is best tested with valgrind or its like. +! In addition, the field 'n' has now become a parameterized length +! array to verify that the combination of allocatable components and +! parameterization works correctly. +! +! Based on contribution by Ian Chivers +! +module precision_module + implicit none + integer, parameter :: sp = selected_real_kind(6, 37) + integer, parameter :: dp = selected_real_kind(15, 307) + integer, parameter :: qp = selected_real_kind( 30, 291) +end module precision_module + +module link_module + use precision_module + + type link(real_kind, mat_len) + integer, kind :: real_kind + integer, len :: mat_len + real (kind=real_kind) :: n(mat_len) + type (link(real_kind, :)), allocatable :: next + end type link + +contains + + function push_8 (self, arg) result(current) + real(dp) :: arg + type (link(real_kind=dp, mat_len=:)), allocatable, target :: self + type (link(real_kind=dp, mat_len=:)), pointer :: current + + if (allocated (self)) then + current => self + do while (allocated (current%next)) + current => current%next + end do + + allocate (link(real_kind=dp, mat_len=1) :: current%next) + current => current%next + else + allocate (link(real_kind=dp, mat_len=1) :: self) + current => self + end if + + current%n(1) = arg + + end function push_8 + + function pop_8 (self) result(res) + type (link(real_kind=dp, mat_len=:)), allocatable, target :: self + type (link(real_kind=dp, mat_len=:)), pointer:: current => NULL() + type (link(real_kind=dp, mat_len=:)), pointer :: previous => NULL() + real(dp) :: res + + res = 0.0_8 + if (allocated (self)) then + current => self + previous => self + do while (allocated (current%next)) + previous => current + current => current%next + end do + res = current%n(1) + if (.not.allocated (previous%next)) then + deallocate (self) + else + deallocate (previous%next) + end if + + end if + end function pop_8 + +end module link_module + +program ch2701 + use precision_module + use link_module + implicit none + integer, parameter :: wp = dp + + call foo +contains + + subroutine foo + type (link(real_kind=wp, mat_len=:)), allocatable :: root + type (link(real_kind=wp, mat_len=:)), pointer :: current => NULL() + + current => push_8 (root, 1.0_8) + current => push_8 (root, 2.0_8) + current => push_8 (root, 3.0_8) + + if (int (pop_8 (root)) .ne. 3) STOP 1 + if (int (pop_8 (root)) .ne. 2) STOP 2 + if (int (pop_8 (root)) .ne. 1) STOP 3 +! if (int (pop_8 (root)) .ne. 0) STOP 4 + end subroutine +end program ch2701 +! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } } +! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } } Index: Fortran/gfortran/regression/pdt_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_16.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Test the fix for all three errors in PR82586 +! +! Contributed by G Steinmetz +! +module m + type t(a) ! { dg-error "does not have a component" } + end type +end + +program p + type t(a ! { dg-error "Expected parameter list" } + integer, kind :: a + end type + type u(a, a) ! { dg-error "Duplicate name" } + integer, kind :: a ! { dg-error "already declared" } + integer, len :: a ! { dg-error "already declared" } + end type +end Index: Fortran/gfortran/regression/pdt_17.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_17.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Test the fix for PR82587 +! +! Contributed by G Steinmetz +! +program p + type t(a) ! { dg-error "does not have a component" } + integer(kind=t()) :: x ! { dg-error "used before it is defined" } + end type +end Index: Fortran/gfortran/regression/pdt_18.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_18.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Test the fix for PR82589 +! +! Contributed by G Steinmetz +! +module m + type t(a) + integer, KIND, private :: a ! { dg-error "attribute conflicts with" } + integer, KIND, allocatable :: a ! { dg-error "attribute conflicts with" } + integer, KIND, POINTER :: a ! { dg-error "attribute conflicts with" } + integer, KIND, dimension(2) :: a ! { dg-error "attribute conflicts with" } + integer, len, private :: a ! { dg-error "attribute conflicts with" } + integer, len, allocatable :: a ! { dg-error "attribute conflicts with" } + integer, len, POINTER :: a ! { dg-error "attribute conflicts with" } + integer, len, dimension(2) :: a ! { dg-error "attribute conflicts with" } + integer, kind :: a + end type +end Index: Fortran/gfortran/regression/pdt_19.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_19.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Tests the fix for PR82606. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a, b) + integer, len :: b ! Note different order of component declarations + integer, kind :: a ! compared with the type_spec_list order. + real(a) :: r(b) + end type + type(t(8, :)), allocatable :: x + real(x%a) :: y ! Used to die here because initializers were mixed up. + allocate(t(8, 2) :: x) + if (kind(y) .ne. x%a) STOP 1 + deallocate(x) +end Index: Fortran/gfortran/regression/pdt_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_2.f03 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! { dg-shouldfail "value of the PDT LEN parameter" } +! +! Reduced version of pdt_1.f03 to check that an incorrect +! value for the parameter 'b' in the dummy is picked up. +! + implicit none + integer, parameter :: ftype = kind(0.0e0) + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0d0) + integer, LEN :: b + integer :: i + real(kind = a) :: d(b, b) + character (len = b*b) :: chr + end type + + type(mytype(ftype, 4)) :: z2 + call foobar (z2) +contains + subroutine foobar (arg) + type(mytype(ftype, 8)) :: arg + print *, arg%i + end subroutine +end Index: Fortran/gfortran/regression/pdt_20.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_20.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Tests the fix for PR82622. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a) + integer, len :: a + end type + type t2(b) + integer, len :: b + type(t(1)) :: r(b) + end type + type(t2(:)), allocatable :: x + allocate (t2(3) :: x) ! Used to segfault in trans-array.c. + if (x%b .ne. 3) STOP 1 + if (x%b .ne. size (x%r, 1)) STOP 2 + if (any (x%r%a .ne. 1)) STOP 3 +end Index: Fortran/gfortran/regression/pdt_21.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_21.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Tests the fix for PR82606 comment #1. +! +! Contributed by Gerhard Steinmetz +! +program p + type t(a, b, *) ! { dg-error "A parameter name is required" } + integer, kind :: a + integer, len :: b + real(a) :: r(b) + end type + type(t(8, 3)) :: x + real(x%a) :: y +end Index: Fortran/gfortran/regression/pdt_22.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_22.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Tests the fix for PR82622 comment #1, where the declaration of +! 'x' choked during initialization. Once fixed, it was found that +! IO was not working correctly for PDT array components. +! +! Contributed by Gerhard Steinmetz +! +program p + character(120) :: buffer + integer :: i(4) + type t(a) + integer, len :: a + end type + type t2(b) + integer, len :: b + type(t(1)) :: r(b) + end type + type(t2(3)) :: x + write (buffer,*) x + read (buffer,*) i + if (any (i .ne. [3,1,1,1])) STOP 1 +end Index: Fortran/gfortran/regression/pdt_23.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_23.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! Tests the fixes for PR82719 and PR82720. +! +! Contributed by Gerhard Steinmetz +! +program p + character(120) :: buffer + character(3) :: chr + integer :: i + type t(a) + integer, len :: a + character(len=a) :: c + end type + type(t(:)), allocatable :: x + allocate (t(2) :: x) + + x = t(2,'ab') + write (buffer, *) x%c ! Tests the fix for PR82720 + read (buffer, *) chr + if (trim (chr) .ne. 'ab') STOP 1 + + x = t(3,'xyz') + if (len (x%c) .ne. 3) STOP 2 + write (buffer, *) x ! Tests the fix for PR82719 + read (buffer, *) i, chr + if (i .ne. 3) STOP 3 + if (chr .ne. 'xyz') STOP 4 + + buffer = " 3 lmn" + read (buffer, *) x ! Some thought will be needed for PDT reads. + if (x%c .ne. 'lmn') STOP 5 +end Index: Fortran/gfortran/regression/pdt_24.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_24.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Tests the fixes for PR82866. +! +! Contributed by Gerhard Steinmetz +! +module s + type t(*, a, :) ! { dg-error "A parameter name is required" } + integer, len :: a + end type +end Index: Fortran/gfortran/regression/pdt_25.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_25.f03 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Tests the fix for PR82978 in which all the parameterized string +! lengths with the same value of parameter 'k' had the same value +! regardless of the value of 'l'. In this testcase, the length for +! 'l' = 5 was taken. +! +! Contributed by Fritz Reese +! + implicit none + + type :: pdt_t(k, l) + integer, kind :: k + integer, len :: l + character(kind=k,len=l) :: chr + integer :: i(l) + end type + + type(pdt_t(1, 4)) :: x1 + type(pdt_t(1, 5)) :: x2 + type(pdt_t(4, 5)) :: x3 + + call test (x1, 4) + call test (x2, 5) + +! Kind tests appear because of problem identified in comment #! +! due to Dominque d'Humieres + + if (kind (x2%chr) .ne. 1) STOP 1 + if (kind (x3%chr) .ne. 4) STOP 2 + +contains + + subroutine test (x, i) + type(pdt_t(1, *)) :: x + integer :: i + + if (x%l .ne. i) STOP 3 + if (len(x%chr) .ne. i) STOP 4 + if (size(x%i,1) .ne. i) STOP 5 + end subroutine + +end Index: Fortran/gfortran/regression/pdt_26.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_26.f03 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR83567 in which the parameterized component 'foo' was +! being deallocated before return from 'addw', with consequent segfault in +! the main program. +! +! Contributed by Berke Durak +! The function 'addvv' has been made elemental so that the test can check that +! arrays are correctly treated and that no memory leaks occur. +! +module pdt_m + implicit none + type :: vec(k) + integer, len :: k=3 + integer :: foo(k)=[1,2,3] + end type vec +contains + elemental function addvv(a,b) result(c) + type(vec(k=*)), intent(in) :: a + type(vec(k=*)), intent(in) :: b + type(vec(k=a%k)) :: c + + c%foo=a%foo+b%foo + end function +end module pdt_m + +program test_pdt + use pdt_m + implicit none + type(vec) :: u,v,w, a(2), b(2), c(2) + integer :: i + + u%foo=[1,2,3] + v%foo=[2,3,4] + w=addvv(u,v) + if (any (w%foo .ne. [3,5,7])) STOP 1 + do i = 1 , a(1)%k + a%foo(i) = i + 4 + b%foo(i) = i + 7 + end do + c = addvv(a,b) + if (any (c(1)%foo .ne. [13,15,17])) STOP 2 +end program test_pdt +! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } Index: Fortran/gfortran/regression/pdt_27.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_27.f03 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Test the fix for PR83611, in which the assignment caused a +! double free error and the initialization of 'foo' was not done. +! +module pdt_m + implicit none + type :: vec(k) + integer, len :: k=3 + integer :: foo(k)=[1,2,3] + end type vec +end module pdt_m + +program test_pdt + use pdt_m + implicit none + type(vec) :: u,v + if (any (u%foo .ne. [1,2,3])) STOP 1 + u%foo = [7,8,9] + v = u + if (any (v%foo .ne. [7,8,9])) STOP 2 +end program test_pdt Index: Fortran/gfortran/regression/pdt_28.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_28.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! Test the fix for PR83731, where the following failed on the check for the +! value of the parameter 'k'. +! +! Contributed by Berke Durak +! +module pdt_m + implicit none + type :: vec(k) + integer, len :: k=10 + integer :: foo(k) + end type vec +contains + function total(a) + type(vec(k=*)), intent(in) :: a ! Would compare with the default initializer. + integer :: total + + total=sum(a%foo) + end function total +end module pdt_m + +program test_pdt + use pdt_m + implicit none + type(vec(k=123)) :: u + + u%foo=1 + if (total(u) .ne. u%k) STOP 1 +end program test_pdt Index: Fortran/gfortran/regression/pdt_29.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_29.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Test the fix for PR83866.f90 +! +! Contributed by G Steinmetz +! +program p + type private + end type + type t + class(t), pointer :: a + end type + type extends(t) :: t2 ! { dg-error "Garbage after | does not have a component" } + end type +end Index: Fortran/gfortran/regression/pdt_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_3.f03 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Check PDT type extension and simple OOP. +! +module vars + integer :: d_dim = 4 + integer :: mat_dim = 256 + integer, parameter :: ftype = kind(0.0d0) +end module + + use vars + implicit none + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type + + type, extends(mytype) :: thytype(h) + integer, kind :: h + integer(kind = h) :: j + end type + + type x (q, r, s) + integer, kind :: q + integer, kind :: r + integer, LEN :: s + integer(kind = q) :: idx_mat(2,2) ! check these do not get treated as pdt_arrays. + type (mytype (b=s)) :: mat1 + type (mytype (b=s*2)) :: mat2 + end type x + + real, allocatable :: matrix (:,:) + type(thytype(ftype, 4, 4)) :: w + type(x(8,4,256)) :: q + class(mytype(ftype, :)), allocatable :: cz + + w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) + +! Make sure that the type extension is ordering the parameters correctly. + if (w%a .ne. ftype) STOP 1 + if (w%b .ne. 4) STOP 2 + if (w%h .ne. 4) STOP 3 + if (size (w%d) .ne. 16) STOP 4 + if (int (w%d(2,4)) .ne. 14) STOP 5 + if (kind (w%j) .ne. w%h) STOP 6 + +! As a side issue, ensure PDT components are OK + if (q%mat1%b .ne. q%s) STOP 7 + if (q%mat2%b .ne. q%s*2) STOP 8 + if (size (q%mat1%d) .ne. mat_dim**2) STOP 9 + if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10 + +! Now check some basic OOP with PDTs + matrix = w%d + +! TODO - for some reason, using w%d directly in the source causes a seg fault. + allocate (cz, source = mytype(ftype, d_dim, 0, matrix)) + select type (cz) + type is (mytype(ftype, *)) + if (int (sum (cz%d)) .ne. 136) STOP 11 + type is (thytype(ftype, *, 8)) + STOP 12 + end select + deallocate (cz) + + allocate (thytype(ftype, d_dim*2, 8) :: cz) + cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) + select type (cz) + type is (mytype(ftype, *)) + STOP 13 + type is (thytype(ftype, *, 8)) + if (int (sum (cz%d)) .ne. 20800) STOP 14 + end select + + deallocate (cz) +end Index: Fortran/gfortran/regression/pdt_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_30.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 89601: [8/9 Regression] [PDT] ICE: Segmentation fault (in resolve_component) +! +! Contributed by Arseny Solokha + +program vw + interface + real function ul (ki) + real :: ki + end function ul + end interface + type :: q8 () ! { dg-error "A type parameter list is required" } + procedure (ul), pointer, nopass :: pj + end type q8 + type (q8) :: ki +end program vw Index: Fortran/gfortran/regression/pdt_31.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_31.f03 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Test the fix for PR100110, in which 'obj' was not being initialized. +! +! Contributed by Xiao Liu +! +program p + implicit none + type t(n) + integer, len :: n + integer :: arr(n, n) + end type + + type(t(2)) :: obj + + obj%arr = reshape ([1,2,3,4],[2,2]) + if (obj%n .ne. 2) stop 1 + if (any (shape(obj%arr) .ne. [2,2])) stop 2 + call test() +contains + subroutine test() + if (obj%n .ne. 2) stop 3 + if (any (shape(obj%arr) .ne. [2,2])) stop 4 + if (any (reshape (obj%arr, [4]) .ne. [1,2,3,4])) stop 5 + end subroutine +end program Index: Fortran/gfortran/regression/pdt_32.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_32.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/102956 +! PDT KIND and LEN type parameters are mutually exclusive (F2018:R734) +! +module m + type :: good_pdt (k,l) + integer, kind :: k = 1 + integer, len :: l = 1 + character(kind=k,len=l) :: c + end type good_pdt + + type :: bad_pdt (k,l) ! { dg-error "does not have a component" } + integer, kind, len :: k = 1 ! { dg-error "attribute conflicts with" } + integer, len, kind :: l = 1 ! { dg-error "attribute conflicts with" } + character(kind=k,len=l) :: c ! { dg-error "has not been declared" } + end type bad_pdt +end Index: Fortran/gfortran/regression/pdt_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_4.f03 @@ -0,0 +1,105 @@ +! { dg-do compile } +! +! Test bad PDT coding: Based on pdt_3.f03 +! +module m + integer :: d_dim = 4 + integer :: mat_dim = 256 + integer, parameter :: ftype = kind(0.0d0) + type :: modtype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type +end module + +module bad_vars + use m + type(modtype(8,mat_dim)) :: mod_q ! { dg-error "must not have the SAVE attribute" } + type(modtype(8,*)) :: mod_r ! { dg-error "ASSUMED type parameters" } +end module + + use m + implicit none + integer :: i + integer, kind :: bad_kind ! { dg-error "not allowed outside a TYPE definition" } + integer, len :: bad_len ! { dg-error "not allowed outside a TYPE definition" } + + type :: bad_pdt (a,b, c, d) ! { dg-error "does not have a component" } + real, kind :: a ! { dg-error "must be INTEGER" } + INTEGER(8), kind :: b + real, LEN :: c ! { dg-error "must be INTEGER" } + INTEGER(8), LEN :: d + end type + + type :: mytype (a,b) + integer, kind :: a = kind(0.0e0) + integer, LEN :: b = 4 + integer :: i + real(kind = a) :: d(b, b) + end type + + type, extends(mytype) :: thytype(h) + integer, kind :: h + integer(kind = h) :: j + end type + + type x (q, r, s) + integer, kind :: q + integer, kind :: r + integer, LEN :: s + integer(kind = q) :: idx_mat(2,2) + type (mytype (b=s)) :: mat1 + type (mytype (b=s*2)) :: mat2 + end type x + + real, allocatable :: matrix (:,:) + +! Bad KIND parameters + type(thytype(d_dim, 4, 4)) :: wbad ! { dg-error "does not reduce to a constant" } + type(thytype(*, 4, 4)) :: worse ! { dg-error "cannot either be ASSUMED or DEFERRED" } + type(thytype(:, 4, 4)) :: w_ugh ! { dg-error "cannot either be ASSUMED or DEFERRED" } + + type(thytype(ftype, b=4, h=4)) :: w + type(x(8,4,mat_dim)) :: q ! { dg-error "must not have the SAVE attribute" } + class(mytype(ftype, :)), allocatable :: cz + + w%a = 1 ! { dg-error "assignment to a KIND or LEN component" } + w%b = 2 ! { dg-error "assignment to a KIND or LEN component" } + w%h = 3 ! { dg-error "assignment to a KIND or LEN component" } + + w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim]) + + matrix = w%d + + allocate (cz, source = mytype(*, d_dim, 0, matrix)) ! { dg-error "Syntax error" } + allocate (cz, source = mytype(ftype, :, 0, matrix)) ! { dg-error "Syntax error" } + select type (cz) + type is (mytype(ftype, d_dim)) ! { dg-error "must be ASSUMED" } + if (int (sum (cz%d)) .ne. 136) STOP 1! { dg-error "Expected TYPE IS" } + type is (thytype(ftype, *, 8)) + STOP 2 + end select + deallocate (cz) + + allocate (thytype(ftype, d_dim*2, 8) :: cz) + cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b]) + select type (cz) + type is (mytype(4, *)) ! { dg-error "must be an extension" } + STOP 3 + type is (thytype(ftype, *, 8)) + if (int (sum (cz%d)) .ne. 20800) STOP 4 + end select + deallocate (cz) +contains + subroutine foo(arg) + type (mytype(4, *)) :: arg ! OK + end subroutine + subroutine bar(arg) ! { dg-error "is neither allocatable nor a pointer" } + type (thytype(8, :, 4)) :: arg + end subroutine + subroutine foobar(arg) ! OK + type (thytype(8, *, 4)) :: arg + end subroutine +end Index: Fortran/gfortran/regression/pdt_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_6.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Fixes of ICE on invalid & accepts invalid +! +! Contributed by Janus Weil +! +implicit none + +type :: param_matrix(c,r) + integer, len :: c,r + real :: m(c,r) +end type + +type real_array(k) + integer, kind :: k + real(kind=k), allocatable :: r(:) +end type + +type(param_matrix(1)) :: m1 ! { dg-error "does not contain enough parameter" } +type(param_matrix(1,2)) :: m2 ! ok +type(param_matrix(1,2,3)) :: m3 ! { dg-error "contains too many parameter" } +type(param_matrix(1,2.5)) :: m4 ! { dg-error "must be of INTEGER type" } + +type(real_array(4)) :: a1 ! ok +type(real_array(5)) :: a2 ! { dg-error "Kind 5 not supported for type REAL" } +end Index: Fortran/gfortran/regression/pdt_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_7.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Rejected valid +! +! ! Contributed by Janus Weil +! +implicit none + +type :: param_matrix(k,c,r) + integer, kind :: k + integer, len :: c,r + real(kind=k) :: m(c,r) +end type + +type(param_matrix(8,3,2)) :: mat +real(kind=mat%k) :: m ! Corrected error: Parameter ‘mat’ at (1) has not been declared or ... + +if (kind(m) .ne. 8) STOP 1 + +end Index: Fortran/gfortran/regression/pdt_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_8.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! Fixes of "accepts invalid". +! Note that the undeclared parameter 'y' in 't1' was originally in the +! type 't'. It turned out to be convenient to defer the error until the +! type is used in the declaration of 'z'. +! +! Contributed by Janus Weil +! +implicit none +type :: t(i,a,x) ! { dg-error "does not|has neither" } + integer, kind :: k ! { dg-error "does not not appear in the type parameter list" } + integer :: i ! { dg-error "has neither the KIND nor LEN attribute" } + integer, kind :: a(3) ! { dg-error "must be a scalar" } + real, kind :: x ! { dg-error "must be INTEGER" } +end type + +type :: t1(k,y) ! { dg-error "does not have a component" } + integer, kind :: k +end type + +! This is a knock-on from the previous error +type(t1(4,4)) :: z ! { dg-error "Invalid character in name" } +end Index: Fortran/gfortran/regression/pdt_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pdt_9.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Test the fix for PR82168 in which the declarations for 'a' +! and 'b' threw errors even though they are valid. +! +! Contributed by +! +module mod + implicit none + integer, parameter :: dp = kind (0.0d0) + type, public :: v(z, k) + integer, len :: z + integer, kind :: k = kind(0.0) + real(kind = k) :: e(z) + end type v +end module mod + +program bug + use mod + implicit none + type (v(2)) :: a ! Missing parameter replaced by initializer. + type (v(z=:, k=dp)), allocatable :: b ! Keyword was not working for '*' or ':' +end program bug Index: Fortran/gfortran/regression/pointer_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_1.f90 @@ -0,0 +1,14 @@ +! Testcase for PR34770 +! { dg-do run } + implicit none + integer, target :: x(0:12) + integer, pointer :: z(:) + integer i + do i = 0,12 + x(i) = i + enddo + z => x + do i = 0,12 + if (x(i) /= i .or. z(i) /= i) STOP 1 + enddo +end Index: Fortran/gfortran/regression/pointer_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Check that the compiler reports the errors, but does not segfault. +! Contributed by: Andre Vehreschild +! +program test + implicit none + class(*), pointer :: P + class(*), allocatable :: P2 + + allocate(P2, source=convertType(P)) + +contains + + function convertType(in) ! { dg-error "must be dummy, allocatable or pointer" } + class(*), intent(in) :: in + class(*) :: convertType + end function +end program test Index: Fortran/gfortran/regression/pointer_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Check the fix for PR34640 comments 1 and 3. +! +! This involves passing and returning pointer array components that +! point to components of arrays of derived types. +! +MODULE test + IMPLICIT NONE + TYPE :: my_type + INTEGER :: value + integer :: tag + END TYPE +CONTAINS + SUBROUTINE get_values(values, switch) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) print *, values(2) + else + values => d(:)%tag + if (any (values .ne. [101,102])) STOP 1 + end if + END SUBROUTINE + + function return_values(switch) result (values) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) STOP 2 + else + values => d(:)%tag + if (any (values([2,1]) .ne. [102,101])) STOP 3 + end if + END function +END MODULE + + use test + integer, pointer :: x(:) + type :: your_type + integer, pointer :: x(:) + end type + type(your_type) :: y + + call get_values (x, 1) + if (any (x .ne. [1,2])) STOP 4 + call get_values (y%x, 2) + if (any (y%x .ne. [101,102])) STOP 5 + + x => return_values (2) + if (any (x .ne. [101,102])) STOP 6 + y%x => return_values (1) + if (any (y%x .ne. [1,2])) STOP 7 +end Index: Fortran/gfortran/regression/pointer_array_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_10.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Test the fix for PR87336, in which the 'span' field of the array +! descriptor, passed to 'show', was not set. +! +! Contributed by Juergen Reuter following +! a posting to clf by 'Spectrum'. +! +program main + implicit none + integer, target :: a( 2:4 ) + + a = [2,3,4] +! print *, "a [before] = ", a + call show( a ) +! print *, "a [after] = ", a + if (any (a .ne. [200,300,400])) stop 1 + +contains + subroutine show( arr ) + integer, pointer, intent(in) :: arr(:) +! print *, "arr = ", arr +! print *, "bounds = ", lbound(arr), ubound(arr) + arr(:) = [200,300,400] +! print *, "arr2= ", arr + end subroutine show + end program Index: Fortran/gfortran/regression/pointer_array_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_11.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! Test the fix for PR91077 - both the original test and that in comment #4 of the PR. +! +! Contribute by Ygal Klein +! +program test + implicit none + call original + call comment_4 +contains + subroutine original + integer, parameter :: length = 9 + real(8), dimension(2) :: a, b + integer :: i + type point + real(8) :: x + end type point + + type stored + type(point), dimension(:), allocatable :: np + end type stored + type(stored), dimension(:), pointer :: std =>null() + allocate(std(1)) + allocate(std(1)%np(length)) + std(1)%np(1)%x = 0.3d0 + std(1)%np(2)%x = 0.3555d0 + std(1)%np(3)%x = 0.26782d0 + std(1)%np(4)%x = 0d0 + std(1)%np(5)%x = 1.555d0 + std(1)%np(6)%x = 7.3d0 + std(1)%np(7)%x = 7.8d0 + std(1)%np(8)%x = 6.3d0 + std(1)%np(9)%x = 5.5d0 +! do i = 1, 2 +! write(*, "('std(1)%np(',i1,')%x = ',1e22.14)") i, std(1)%np(i)%x +! end do +! do i = 1, 2 +! write(*, "('std(1)%np(1:',i1,') = ',9e22.14)") i, std(1)%np(1:i)%x +! end do + a = std(1)%np(1:2)%x + b = [std(1)%np(1)%x, std(1)%np(2)%x] +! print *,a +! print *,b + if (allocated (std(1)%np)) deallocate (std(1)%np) + if (associated (std)) deallocate (std) + if (norm2(a - b) .gt. 1d-3) stop 1 + end subroutine + + subroutine comment_4 + integer, parameter :: length = 2 + real(8), dimension(length) :: a, b + integer :: i + + type point + real(8) :: x + end type point + + type points + type(point), dimension(:), pointer :: np=>null() + end type points + + type stored + integer :: l + type(points), pointer :: nfpoint=>null() + end type stored + + type(stored), dimension(:), pointer :: std=>null() + + + allocate(std(1)) + allocate(std(1)%nfpoint) + allocate(std(1)%nfpoint%np(length)) + std(1)%nfpoint%np(1)%x = 0.3d0 + std(1)%nfpoint%np(2)%x = 0.3555d0 + +! do i = 1, length +! write(*, "('std(1)%nfpoint%np(',i1,')%x = ',1e22.14)") i, std(1)%nfpoint%np(i)%x +! end do +! do i = 1, length +! write(*, "('std(1)%nfpoint%np(1:',i1,')%x = ',2e22.14)") i, std(1)%nfpoint%np(1:i)%x +! end do + a = std(1)%nfpoint%np(1:2)%x + b = [std(1)%nfpoint%np(1)%x, std(1)%nfpoint%np(2)%x] + if (associated (std(1)%nfpoint%np)) deallocate (std(1)%nfpoint%np) + if (associated (std(1)%nfpoint)) deallocate (std(1)%nfpoint) + if (associated (std)) deallocate (std) + if (norm2(a - b) .gt. 1d-3) stop 2 + end subroutine +end program test Index: Fortran/gfortran/regression/pointer_array_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_2.f90 @@ -0,0 +1,143 @@ +! { dg-do compile } +! +! Test the fix for PR40737 as part of the overall fix for PR34640. +! +! Contributed by David Hough +! +module testmod + +integer, parameter :: standard_integer = 1 +integer, parameter :: int = KIND( standard_integer) + +integer, parameter :: i8 = selected_int_kind(12) +integer, parameter :: i4 = selected_int_kind(8) +integer, parameter :: i2 = selected_int_kind(4) + +integer, parameter :: standard_real = 1. +integer, parameter :: std_real = KIND( standard_real) + +integer, parameter :: r8 = selected_real_kind(12) +integer, parameter :: r4 = selected_real_kind(6) +integer, parameter :: double = selected_real_kind(20) + +integer, parameter :: name_string_length = 40 +integer, parameter :: file_name_length = 60 +integer, parameter :: text_string_length = 80 +integer, parameter :: max_kwd_lgth = file_name_length + +integer(int) :: bytes_per_int = 4 +integer(int) :: bytes_per_real = 8 +integer(int) :: workcomm, spincomm + + integer(int), parameter :: nb_directions = 3, & + direction_x = 1, & + direction_y = 2, & + direction_z = 3, & + nb_ghost_cells = 5 ! might be different for the lagrange step? + + integer(int), parameter :: ends = 4, & + lower_ghost = 1, & + lower_interior = 2, & + upper_interior = 3, & + upper_ghost = 4 + + ! Neighbors + integer(int), parameter :: side = 2, & + lower_end = 1, & + upper_end = 2 + + + integer(int), parameter :: nb_variables = 5, & + ro_var = 1, & + ets_var = 2, & + u_var = 3, & + up1_var = 4, & + up2_var = 5, & + eis_var = 6, & + ecs_var = 7, & + p_var = 8, & + c_var = 9, & + nb_var_sortie = 9 + + type :: VARIABLES_LIGNE + sequence + real, pointer, dimension( :, :) :: l + end type VARIABLES_LIGNE + + type VARIABLES_MAILLE + sequence + real(r8), dimension( nb_variables) :: cell_var + end type VARIABLES_MAILLE + + integer(int), dimension( nb_directions) :: & + first_real_cell, & ! without ghost cells + last_real_cell, & ! + nb_real_cells, & ! + first_work_cell, & ! including ghost cells + last_work_cell, & ! + nb_work_cells, & ! + global_nb_cells ! number of real cells, for the entire grid + + integer(int) :: dim_probleme ! dimension du probleme (1, 2 ou 3) + + integer(int) :: largest_local_size ! the largest of the 3 dimensions of the local grid + + ! Hydro variables of the actual domain + ! There are 3 copies of these, for use according to current work direction + type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) :: & + Hydro_vars_XYZ, & + Hydro_vars_YZX, & + Hydro_vars_ZXY + + ! Pointers to current and next Hydro var arrays + type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars, & + Hydro_vars_next + + ! Which of these 3 copies of the 3D arrays has been updated last + integer(int) :: last_updated_3D_array = 0 + + real(r8), pointer, dimension( :) :: & + ! Variables "permanentes" (entrant dans la projection) + Ro, & ! densite + Ets, & ! energie totale specifique + Um, & ! vitesse aux mailles, dans la direction de travail + Xn, & ! abscisse en fin de pas de temps + ! Variables en lecture seulement + Um_p1, & ! vitesse aux mailles, dans les directions + Um_p2, & ! orthogonales + Xa, & ! abscisses des noeuds en debut de pas de temps + Dxa, & ! longueur des mailles en debut de pas de temps + U_dxa ! inverses des longueurs des mailles + +end module testmod + + +subroutine TF_AD_SPLITTING_DRIVER_PLANE + +use testmod + +implicit none +save + + real(r8), allocatable, dimension( :) :: & + ! Variables maille recalculees a chaque pas de temps + Eis, & ! energie interne specifique (seulement pour calculer la pression) + Vit_son, & ! comme son nom l'indique + C_f_l, & ! nombre de Courant + Pm, & ! pression aux mailles + ! Variables aux noeuds + Un, & ! vitesse des noeuds + Pn ! pression aux noeuds + + +integer(int) :: i, j, k +integer(int) :: first_cell, last_cell + + Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var) + Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var) + Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var) + Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var) + Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var) + +end subroutine TF_AD_SPLITTING_DRIVER_PLANE + Index: Fortran/gfortran/regression/pointer_array_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test the fix for PR40737 comment 17 as part of the overall fix for PR34640. +! +! Contributed by Josh Hykes +! + module test_mod +! + type t1 + character(8) :: string + end type t1 +! + type t2 + integer :: tab + type(t1), pointer :: fp(:) + end type t2 +! + type t3 + integer :: tab + type(t2), pointer :: as + end type t3 +! + type(t3), pointer :: as_typ(:) => null() +! + character(8), pointer, public :: p(:) +! + contains +! + subroutine as_set_alias (i) +! + implicit none +! + integer, intent(in) :: i +! + allocate (as_typ(2)) + allocate (as_typ(1)%as) + allocate (as_typ(1)%as%fp(2), source = [t1("abcdefgh"),t1("ijklmnop")]) + p => as_typ(i)%as%fp(:)%string +! + end subroutine as_set_alias +! + end module test_mod + + program test_prog + use test_mod + call as_set_alias(1) + if (any (p .ne. ["abcdefgh","ijklmnop"])) STOP 1 + deallocate (as_typ(1)%as%fp) + deallocate (as_typ(1)%as) + deallocate (as_typ) + end program test_prog Index: Fortran/gfortran/regression/pointer_array_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_4.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! +! Test the fix for PR57116 as part of the overall fix for PR34640. +! +! Contributed by Reinhold Bader +! +module mod_rtti_ptr + implicit none + type :: foo + real :: v + integer :: i + end type foo +contains + subroutine extract(this, v, ic) + class(*), target :: this(:) + real, pointer :: v(:) + integer :: ic + select type (this) + type is (real) + v => this(ic:) + class is (foo) + v => this(ic:)%v + end select + end subroutine extract +end module + +program prog_rtti_ptr + use mod_rtti_ptr + class(*), allocatable, target :: o(:) + real, pointer :: v(:) + + allocate(o(3), source=[1.0, 2.0, 3.0]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [2.0, 3.0])) then + deallocate(o) + else + STOP 1 + end if + + allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [4.0, 5.0])) then + deallocate(o) + else + STOP 2 + end if + +! The rest tests the case in comment 2 + + call extract1 (v, 1) + if (any (v /= [1.0, 2.0])) STOP 3 + call extract1 (v, 2) ! Call to deallocate pointer. + +contains + subroutine extract1(v, flag) + type :: foo + real :: v + character(4) :: str + end type + class(foo), pointer, save :: this(:) + real, pointer :: v(:) + integer :: flag + + if (flag == 1) then + allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")]) + select type (this) + class is (foo) + v => this(1:2)%v + end select + else + deallocate (this) + end if + end subroutine + +end program prog_rtti_ptr Index: Fortran/gfortran/regression/pointer_array_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_5.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640. +! +! Contributed by Tobias Burnus +! + program change_field_type + use, intrinsic :: iso_c_binding + implicit none + REAL(kind=c_float), POINTER :: vector_comp(:) + TYPE, BIND(C) :: scalar_vector + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + END TYPE + TYPE, BIND(C) :: scalar_vector_matrix + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + REAL(kind=c_float) :: mat(3,3) + END TYPE + CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:) + real, pointer :: v1(:) + + allocate(one_d_field(3), & + source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), & + scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), & + scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) ) + + call extract_vec(one_d_field, 1, 2) + if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) STOP 1 + deallocate(one_d_field) ! v1 becomes undefined + + allocate(one_d_field(1), & + source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), & + reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), & + (/3, 3/) ) ) /) ) + + call extract_vec(one_d_field, 2, 1) + if (abs (vector_comp(1) + 1.0) > 1e-4) STOP 2 + call extract_vec(one_d_field, 2, 3) + if (abs (vector_comp(1) - 1.0) > 1e-4) STOP 3 + deallocate(one_d_field) ! v1 becomes undefined + contains + subroutine extract_vec(field, tag, ic) + use, intrinsic :: iso_c_binding + CLASS(*), TARGET :: field(:) + INTEGER(kind=c_int), value :: tag, ic + + type(scalar_vector), pointer :: sv(:) + type(scalar_vector_matrix), pointer :: svm(:) + + select type (field) + type is (real(c_float)) + vector_comp => field + class default + select case (tag) + case (1) + sv => field + vector_comp => sv(:)%vec(ic) + case (2) + svm => field + vector_comp => svm(:)%vec(ic) + end select + end select + end subroutine + end program Index: Fortran/gfortran/regression/pointer_array_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_6.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR57019 comment 4 as part of the overall fix for PR34640. +! +! Contributed by +! + type cParticle + real(4) :: v(3) + endtype cParticle + + type pCItem + type(cParticle) :: Ele + end type pCItem + + type(pCItem), target, dimension(1:1,1:1) :: pCellArray + type(cParticle), pointer, dimension(:,:) :: pArray + real(4), pointer, dimension(:) :: v_pointer + real(4), dimension(3) :: v_real = 99. + + pArray => pCellArray%Ele + v_pointer => pArray(1,1)%v; + v_pointer = v_real !OK %%%%%%%%%%%% + if (any (int (pArray(1,1)%v) .ne. 99)) STOP 1 + + v_real = 88 + pArray(1,1)%v = v_real !SEGFAULT %%%%%%%%%%%%%%%%%%%%%%%% + if (any (int (v_pointer) .ne. 88)) STOP 2 +end Index: Fortran/gfortran/regression/pointer_array_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_7.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! Test for the fix for PR34640. In this case, final testing of the +! patch revealed that in some cases the actual descriptor was not +! being passed to procedure dummy pointers. +! +! Contributed by Thomas Koenig +! +module x + use iso_c_binding + implicit none + type foo + complex :: c + integer :: i + end type foo +contains + subroutine printit(c, a) + complex, pointer, dimension(:) :: c + integer :: i + integer(kind=c_intptr_t) :: a + a = transfer(c_loc(c(2)),a) + end subroutine printit +end module x + +program main + use x + use iso_c_binding + implicit none + type(foo), dimension(5), target :: a + integer :: i + complex, dimension(:), pointer :: pc + integer(kind=c_intptr_t) :: s1, s2, s3 + a%i = 0 + do i=1,5 + a(i)%c = cmplx(i**2,i) + end do + pc => a%c + call printit(pc, s3) + + s1 = transfer(c_loc(a(2)%c),s1) + if (s1 /= s3) STOP 1 + + s2 = transfer(c_loc(pc(2)),s2) + if (s2 /= s3) STOP 2 + +end program main Index: Fortran/gfortran/regression/pointer_array_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_8.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! +! Make sure that the fix for pr34640 works with class pointers. +! + type :: mytype + real :: r + integer :: i + end type + + type :: thytype + real :: r + integer :: i + type(mytype) :: der + end type + + type(thytype), dimension(0:2), target :: tgt + class(*), dimension(:), pointer :: cptr + class(mytype), dimension(:), pointer :: cptr1 + integer :: i + integer(8) :: s1, s2 + + tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)] + + cptr => tgt%i + if (lbound (cptr, 1) .ne. 1) STOP 1! Not a whole array target! + + s1 = loc(cptr) + call foo (cptr, s2) ! Check bounds not changed... + if (s1 .ne. s2) STOP 2! ...and that the descriptor is passed. + + select type (cptr) + type is (integer) + if (any (cptr .ne. [1,2,3])) STOP 3! Check the scalarizer works. + if (cptr(2) .ne. 2) STOP 4! Check ordinary array indexing. + end select + + cptr(1:3) => tgt%der%r ! Something a tad more complicated! + + select type (cptr) + type is (real) + if (any (int(cptr) .ne. [2,4,6])) STOP 5 + if (any (int(cptr([2,3,1])) .ne. [4,6,2])) STOP 6 + if (int(cptr(3)) .ne. 6) STOP 7 + end select + + cptr1(1:3) => tgt%der + + s1 = loc(cptr1) + call bar(cptr1, s2) + if (s1 .ne. s2) STOP 8! Check that the descriptor is passed. + + select type (cptr1) + type is (mytype) + if (any (cptr1%i .ne. [2,4,6])) STOP 9 + if (cptr1(2)%i .ne. 4) STOP 10 + end select + +contains + + subroutine foo (arg, addr) + class(*), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (integer) + if (any (arg .ne. [1,2,3])) STOP 11! Check the scalarizer works. + if (arg(2) .ne. 2) STOP 12! Check ordinary array indexing. + end select + end subroutine + + subroutine bar (arg, addr) + class(mytype), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (mytype) + if (any (arg%i .ne. [2,4,6])) STOP 13 + if (arg(2)%i .ne. 4) STOP 14 + end select + end subroutine +end Index: Fortran/gfortran/regression/pointer_array_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_9.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Tests fix for PR82184 +! +! Contributed by Andrey Guskov x%r + if (any (abs (vtab_r%rvar - [11.0, 42.0]) > 1.0e-5)) STOP 1! Check skipping 'index; is OK. + + y = vtab_r%rvar + if (any (abs (y - [11.0, 42.0]) > 1.0e-5)) STOP 2! Check that the component is usable in assignment. + + call foobar (vtab_r, [11.0, 42.0]) + + vtab_r = barfoo () + + call foobar (vtab_r, [111.0, 142.0]) + +contains + subroutine foobar (vtab, array) + type(var_tables) :: vtab + real :: array (:) + if (any (abs (vtab%rvar - array) > 1.0e-5)) STOP 3! Check passing as a dummy. + if (abs (vtab%rvar(2) - array(2)) > 1.0e-5) STOP 4! Check component reference. + end subroutine + + function barfoo () result(res) + type(var_tables) :: res + allocate (res%rvar(2), source = [111.0, 142.0]) ! Check allocation + end function +end Index: Fortran/gfortran/regression/pointer_array_component_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_component_2.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Test the fix for PR34640. In the first version of the fix, the first +! testcase in PR51218 failed with a segfault. This test extracts the +! failing part and checks that all is well. +! + type t_info_block + integer :: n = 0 ! number of elements + end type t_info_block + ! + type t_dec_info + integer :: n = 0 ! number of elements + integer :: n_b = 0 ! number of blocks + type (t_info_block) ,pointer :: b (:) => NULL() ! info blocks + end type t_dec_info + ! + type t_vector_segm + integer :: n = 0 ! number of elements + real ,pointer :: x(:) => NULL() ! coefficients + end type t_vector_segm + ! + type t_vector + type (t_dec_info) ,pointer :: info => NULL() ! decomposition info + integer :: n = 0 ! number of elements + integer :: n_s = 0 ! number of segments + integer :: alloc_l = 0 ! allocation level + type (t_vector_segm) ,pointer :: s (:) => NULL() ! vector blocks + end type t_vector + + + type(t_vector) :: z + type(t_vector_segm), pointer :: ss + + allocate (z%s(2)) + do i = 1, 2 + ss => z%s(i) + allocate (ss%x(2), source = [1.0, 2.0]*real(i)) + end do + +! These lines would segfault. + if (int (sum (z%s(1)%x)) .ne. 3) STOP 1 + if (int (sum (z%s(1)%x * z%s(2)%x)) .ne. 10) STOP 2 +end Index: Fortran/gfortran/regression/pointer_array_component_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_array_component_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Test the fix for PR88685, in which the component array references in 'doit' +! were being ascribed to the class pointer 'Cls' itself so that the stride +! measure between elements was wrong. +! +! Contributed by Antony Lewis +! +program tester + implicit none + Type TArr + integer, allocatable :: CL(:) + end Type TArr + + type(TArr), allocatable, target :: arr(:,:) + class(TArr), pointer:: Cls(:,:) + integer i + + allocate(arr(1,1)) + allocate(arr(1,1)%CL(3)) + arr(1,1)%CL=-1 + cls => arr + call doit(cls) + if (any (arr(1,1)%cl .ne. [3,2,1])) stop 3 +contains + subroutine doit(cls) + class(TArr), pointer :: Cls(:,:) + + cls(1,1)%CL(1) = 3 + cls(1,1)%CL(2:3) = [2,1] + + if (any (Cls(1,1)%CL .ne. [3,2,1])) stop 1 + if (Cls(1,1)%CL(2) .ne. 2) stop 2 + + end subroutine doit +end program tester Index: Fortran/gfortran/regression/pointer_assign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests fix for PR20838 - would ICE with vector subscript in +! pointer assignment. +! +! Contributed by Paul Thomas +! + integer, parameter, dimension(3) :: i = (/2,1,3/) + integer, dimension(3), target :: tar + integer, dimension(2, 3), target :: tar2 + integer, dimension(:), pointer :: ptr + ptr => tar + ptr => tar(3:1:-1) + ptr => tar(i) ! { dg-error "with vector subscript" } + ptr => tar2(1, :) + ptr => tar2(2, i) ! { dg-error "with vector subscript" } + end + Index: Fortran/gfortran/regression/pointer_assign_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_10.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => TYPE pointer assignment for functions +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + function f1() + type(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + type(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + type(t), pointer :: p1, p2(:), p3(:,:) + p1 => f1() + if (p1%ii /= 123) STOP 1 + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) STOP 2 + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) STOP 3 +end program test Index: Fortran/gfortran/regression/pointer_assign_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_11.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! CLASS => CLASS pointer assignment for function results +! +module m + implicit none + type t + integer :: ii = 55 + end type t + type, extends(t) :: t2 + end type t2 +contains + function f1() + class(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + class(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + class(t), pointer :: p1, p2(:), p3(:,:) + type(t) :: my_t + type(t2) :: my_t2 + + allocate (t2 :: p1, p2(1), p3(1,1)) + if (.not. same_type_as (p1, my_t2)) STOP 1 + if (.not. same_type_as (p2, my_t2)) STOP 2 + if (.not. same_type_as (p3, my_t2)) STOP 3 + + p1 => f1() + if (p1%ii /= 123) STOP 4 + if (.not. same_type_as (p1, my_t)) STOP 5 + + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) STOP 6 + if (.not. same_type_as (p2, my_t)) STOP 7 + + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) STOP 8 + if (.not. same_type_as (p3, my_t)) STOP 9 +end program test Index: Fortran/gfortran/regression/pointer_assign_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_12.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR 70260 - this used to ICE +! Original test case by Gehard Steinmetz +module m + interface gkind + procedure g + end interface +contains + integer function g() + g => 1 ! { dg-error "Pointer assignment target cannot be a constant" } + end + subroutine f(x) + character(kind=kind(gkind())) :: x + end +end Index: Fortran/gfortran/regression/pointer_assign_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_14.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR fortran/94578 +! This used to give wrong results. +program main + implicit none + type foo + integer :: x, y,z + end type foo + integer :: i + integer, dimension(:), pointer :: array1d + type(foo), dimension(2), target :: solution + integer, dimension(2,2) :: a + data a /1,2,3,4/ + solution%x = -10 + solution%y = -20 + array1d => solution%x + array1d = maxval(a,dim=1) + if (any (array1d /= [2,4])) stop 1 +end program main Index: Fortran/gfortran/regression/pointer_assign_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_15.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR fortran/94578 +! This used to give wrong results. Original test case by Jan-Willem +! Blokland. +program main + implicit none + type foo + integer :: x, y + end type foo + integer :: i + integer, dimension (2,2) :: array2d + integer, dimension(:), pointer :: array1d + type(foo), dimension(2*2), target :: solution + data array2d /1,2,3,4/ + array1d => solution%x + array1d = reshape (source=array2d, shape=shape(array1d)) + if (any (array1d /= [1,2,3,4])) stop 1 +end program main Index: Fortran/gfortran/regression/pointer_assign_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR32361 Type declaration to initialize data in named common + BLOCK DATA + integer, pointer :: ptr1 => NULL() + common / T / ptr1 + END Index: Fortran/gfortran/regression/pointer_assign_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR32360 Won't compile 'data ptr1 /null ()/' when ptr1 has pointer attribute. + integer, pointer :: ptr1 + data ptr1 /NULL()/ + end + Index: Fortran/gfortran/regression/pointer_assign_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_4.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! +! Verify that the bounds are correctly set when assigning pointers. +! +! PR fortran/33139 +! +program prog + implicit none + real, target :: a(-10:10) + real, pointer :: p(:),p2(:) + integer :: i + do i = -10, 10 + a(i) = real(i) + end do + p => a + p2 => p + if((lbound(p, dim=1) /= -10) .or. (ubound(p, dim=1) /= 10)) & + STOP 1 + if((lbound(p2,dim=1) /= -10) .or. (ubound(p2,dim=1) /= 10)) & + STOP 2 + do i = -10, 10 + if(p(i) /= real(i)) STOP 3 + if(p2(i) /= real(i)) STOP 4 + end do + p => a(:) + p2 => p + if((lbound(p, dim=1) /= 1) .or. (ubound(p, dim=1) /= 21)) & + STOP 5 + if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) & + STOP 6 + p2 => p(:) + if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) & + STOP 7 + call multdim() +contains + subroutine multdim() + real, target, allocatable :: b(:,:,:) + real, pointer :: ptr(:,:,:) + integer :: i, j, k + allocate(b(-5:5,10:20,0:3)) + do i = 0, 3 + do j = 10, 20 + do k = -5, 5 + b(k,j,i) = real(i+10*j+100*k) + end do + end do + end do + ptr => b + if((lbound(ptr,dim=1) /= -5) .or. (ubound(ptr,dim=1) /= 5) .or. & + (lbound(ptr,dim=2) /= 10) .or. (ubound(ptr,dim=2) /= 20) .or. & + (lbound(ptr,dim=3) /= 0) .or. (ubound(ptr,dim=3) /= 3)) & + STOP 8 + do i = 0, 3 + do j = 10, 20 + do k = -5, 5 + if(ptr(k,j,i) /= real(i+10*j+100*k)) STOP 9 + end do + end do + end do + ptr => b(:,:,:) + if((lbound(ptr,dim=1) /= 1) .or. (ubound(ptr,dim=1) /= 11) .or. & + (lbound(ptr,dim=2) /= 1) .or. (ubound(ptr,dim=2) /= 11) .or. & + (lbound(ptr,dim=3) /= 1) .or. (ubound(ptr,dim=3) /= 4)) & + STOP 10 + end subroutine multdim +end program prog Index: Fortran/gfortran/regression/pointer_assign_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/37580 + +! See also the pointer_remapping_* tests. + +program test +implicit none +real, pointer :: ptr1(:), ptr2(:) +ptr1(1) => ptr2 ! { dg-error "Expected bounds specification" } +end program test Index: Fortran/gfortran/regression/pointer_assign_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_6.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/37580 +! +program test +implicit none +real, pointer :: ptr1(:), ptr2(:) +ptr1(1:) => ptr2 ! { dg-error "Fortran 2003: Bounds specification" } +end program test Index: Fortran/gfortran/regression/pointer_assign_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_7.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 39931: ICE on invalid Fortran 95 code (bad pointer assignment) +! +! Contributed by Thomas Orgis + +program point_of_no_return + +implicit none + +type face_t + integer :: bla +end type + +integer, pointer :: blu +type(face_t), pointer :: face + +allocate(face) +allocate(blu) + +face%bla => blu ! { dg-error "Non-POINTER in pointer association context" } + +end program + Index: Fortran/gfortran/regression/pointer_assign_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_8.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => CLASS pointer assignment for variables +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + subroutine sub (tgt, tgt2) + class(t), target :: tgt, tgt2(:) + type(t), pointer :: ptr, ptr2(:), ptr3(:,:) + + if (tgt%ii /= 43) STOP 1 + if (size (tgt2) /= 3) STOP 2 + if (any (tgt2(:)%ii /= [11,22,33])) STOP 3 + + ptr => tgt ! TYPE => CLASS + ptr2 => tgt2 ! TYPE => CLASS + ptr3(-3:-3,1:3) => tgt2 ! TYPE => CLASS + + if (.not. associated(ptr)) STOP 4 + if (.not. associated(ptr2)) STOP 5 + if (.not. associated(ptr3)) STOP 6 + if (.not. associated(ptr,tgt)) STOP 7 + if (.not. associated(ptr2,tgt2)) STOP 8 + if (ptr%ii /= 43) STOP 9 + if (size (ptr2) /= 3) STOP 10 + if (size (ptr3) /= 3) STOP 11 + if (any (ptr2(:)%ii /= [11,22,33])) STOP 12 + if (any (shape (ptr3) /= [1,3])) STOP 13 + if (any (ptr3(-3,:)%ii /= [11,22,33])) STOP 14 + end subroutine sub +end module m + +use m +type(t), target :: x +type(t), target :: y(3) +x%ii = 43 +y(:)%ii = [11,22,33] +call sub(x,y) +end Index: Fortran/gfortran/regression/pointer_assign_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_assign_9.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => CLASS pointer assignment for functions +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + function f1() + class(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + class(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + type(t), pointer :: p1, p2(:),p3(:,:) + p1 => f1() + if (p1%ii /= 123) STOP 1 + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) STOP 2 + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) STOP 3 +end program test Index: Fortran/gfortran/regression/pointer_check_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_1.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Unassociated/unallocated actual argument" } +! +! { dg-output ".*At line 53 .*Allocatable actual argument 'alloc2' is not allocated" } +! +! PR fortran/40580 +! +! Run-time check of passing deallocated/nonassociated actuals +! to nonallocatable/nonpointer dummies. +! +! Check for variable actuals +! + +subroutine test1(a) + integer :: a + a = 4444 +end subroutine test1 + +subroutine test2(a) + integer :: a(2) + a = 4444 +end subroutine test2 + +subroutine ppTest(f) + implicit none + external f + call f() +end subroutine ppTest + +Program RunTimeCheck + implicit none + external :: test1, test2, ppTest + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc2(:) + procedure(), pointer :: pptr + + allocate(ptr1,ptr2(2),alloc2(2)) + pptr => sub + ! OK + call test1(ptr1) + call test3(ptr1) + + call test2(ptr2) + call test2(alloc2) + call test4(ptr2) + call test4(alloc2) + call ppTest(pptr) + call ppTest2(pptr) + + ! Invalid 1: + deallocate(alloc2) + call test2(alloc2) +! call test4(alloc2) + + ! Invalid 2: + deallocate(ptr1,ptr2) + nullify(ptr1,ptr2) +! call test1(ptr1) +! call test3(ptr1) +! call test2(ptr2) +! call test4(ptr2) + + ! Invalid 3: + nullify(pptr) +! call ppTest(pptr) + call ppTest2(pptr) + +contains + subroutine test3(b) + integer :: b + b = 333 + end subroutine test3 + subroutine test4(b) + integer :: b(2) + b = 333 + end subroutine test4 + subroutine sub() + print *, 'Hello World' + end subroutine sub + subroutine ppTest2(f) + implicit none + procedure(sub) :: f + call f() + end subroutine ppTest2 +end Program RunTimeCheck Index: Fortran/gfortran/regression/pointer_check_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_10.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fcheck=all -std=f2003 " } +! { dg-shouldfail "Pointer actual argument 'ptr' is not associated" } +! +! PR fortran/49255 +! +! Valid F2008, invalid F95/F2003. +! +integer,pointer :: ptr => null() +call foo (ptr) +contains + subroutine foo (x) + integer, optional :: x + if (present (x)) STOP 1 + end subroutine foo +end Index: Fortran/gfortran/regression/pointer_check_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_11.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! { dg-shouldfail "Pointer check" } +! { dg-output "Fortran runtime error: Pointer actual argument 'y' is not associated" } +! +! +! PR fortran/50718 +! +! Was failing (ICE) with -fcheck=pointer if the dummy had the value attribute. + +type t + integer :: p +end type t + +type(t), pointer :: y => null() + +call sub(y) ! Invalid: Nonassociated pointer + +contains + subroutine sub (x) + type(t), value :: x + end subroutine +end Index: Fortran/gfortran/regression/pointer_check_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_12.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! { dg-shouldfail "Pointer check" } +! { dg-output "Fortran runtime error: Pointer actual argument 'p' is not associated" } +! +! PR fortran/50718 +! +! Was failing with -fcheck=pointer: Segfault at run time + +integer, pointer :: p => null() + +call sub2(%val(p)) ! Invalid: Nonassociated pointer +end + +! Not quite correct dummy, but if one uses VALUE, gfortran +! complains about a missing interface - which we cannot use +! if we want to use %VAL(). + +subroutine sub2(p) + integer :: p +end subroutine sub2 Index: Fortran/gfortran/regression/pointer_check_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_13.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Wall -Wno-uninitialized" } +! +! PR fortran/56477 +! The pointer target live range checking code used to trigger a NULL pointer +! dereference with the following case. +! +! Contributed by Andrew Benson +! +module s +contains + function so() + implicit none + integer, target :: so + integer, pointer :: sp + sp => so + return + end function So +end module s Index: Fortran/gfortran/regression/pointer_check_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_14.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! PR100602 - Erroneous "pointer argument is not associated" runtime error + +module m + type :: T + end type +contains + subroutine f(this) + class(T), intent(in) :: this(:) + class(T), allocatable :: ca(:) + class(T), pointer :: cp(:) + if (size (this) == 0) return + write(*,*) size (this) + stop 1 + write(*,*) size (ca) ! Check #1 + write(*,*) size (cp) ! Check #2 + end subroutine f +end module + +program main + use m + call f([T::]) +end program + +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 2 "original" } } +! { dg-final { scan-tree-dump-times "Allocatable argument .*ca" 1 "original" } } +! { dg-final { scan-tree-dump-times "Pointer argument .*cp" 1 "original" } } Index: Fortran/gfortran/regression/pointer_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_2.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Unassociated/unallocated actual argument" } +! +! { dg-output ".*At line 60.*Pointer actual argument 'ptr1' is not associated" } +! +! PR fortran/40580 +! +! Run-time check of passing deallocated/nonassociated actuals +! to nonallocatable/nonpointer dummies. +! +! Check for variable actuals +! + +subroutine test1(a) + integer :: a + a = 4444 +end subroutine test1 + +subroutine test2(a) + integer :: a(2) + a = 4444 +end subroutine test2 + +subroutine ppTest(f) + implicit none + external f + call f() +end subroutine ppTest + +Program RunTimeCheck + implicit none + external :: test1, test2, ppTest + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc2(:) + procedure(), pointer :: pptr + + allocate(ptr1,ptr2(2),alloc2(2)) + pptr => sub + ! OK + call test1(ptr1) + call test3(ptr1) + + call test2(ptr2) + call test2(alloc2) + call test4(ptr2) + call test4(alloc2) + call ppTest(pptr) + call ppTest2(pptr) + + ! Invalid 1: + deallocate(alloc2) +! call test2(alloc2) +! call test4(alloc2) + + ! Invalid 2: + deallocate(ptr1,ptr2) + nullify(ptr1,ptr2) +! call test1(ptr1) + call test3(ptr1) +! call test2(ptr2) +! call test4(ptr2) + + ! Invalid 3: + nullify(pptr) +! call ppTest(pptr) + call ppTest2(pptr) + +contains + subroutine test3(b) + integer :: b + b = 333 + end subroutine test3 + subroutine test4(b) + integer :: b(2) + b = 333 + end subroutine test4 + subroutine sub() + print *, 'Hello World' + end subroutine sub + subroutine ppTest2(f) + implicit none + procedure(sub) :: f + call f() + end subroutine ppTest2 +end Program RunTimeCheck Index: Fortran/gfortran/regression/pointer_check_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_3.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Unassociated/unallocated actual argument" } +! +! { dg-output ".*At line 61.*Pointer actual argument 'ptr2' is not associated" } +! +! PR fortran/40580 +! +! Run-time check of passing deallocated/nonassociated actuals +! to nonallocatable/nonpointer dummies. +! +! Check for variable actuals +! + +subroutine test1(a) + integer :: a + a = 4444 +end subroutine test1 + +subroutine test2(a) + integer :: a(2) + a = 4444 +end subroutine test2 + +subroutine ppTest(f) + implicit none + external f + call f() +end subroutine ppTest + +Program RunTimeCheck + implicit none + external :: test1, test2, ppTest + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc2(:) + procedure(), pointer :: pptr + + allocate(ptr1,ptr2(2),alloc2(2)) + pptr => sub + ! OK + call test1(ptr1) + call test3(ptr1) + + call test2(ptr2) + call test2(alloc2) + call test4(ptr2) + call test4(alloc2) + call ppTest(pptr) + call ppTest2(pptr) + + ! Invalid 1: + deallocate(alloc2) +! call test2(alloc2) +! call test4(alloc2) + + ! Invalid 2: + deallocate(ptr1,ptr2) + nullify(ptr1,ptr2) +! call test1(ptr1) +! call test3(ptr1) + call test2(ptr2) +! call test4(ptr2) + + ! Invalid 3: + nullify(pptr) +! call ppTest(pptr) + call ppTest2(pptr) + +contains + subroutine test3(b) + integer :: b + b = 333 + end subroutine test3 + subroutine test4(b) + integer :: b(2) + b = 333 + end subroutine test4 + subroutine sub() + print *, 'Hello World' + end subroutine sub + subroutine ppTest2(f) + implicit none + procedure(sub) :: f + call f() + end subroutine ppTest2 +end Program RunTimeCheck Index: Fortran/gfortran/regression/pointer_check_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_4.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Unassociated/unallocated actual argument" } +! +! { dg-output ".*At line 66.*Proc-pointer actual argument 'pptr' is not associated" } +! +! PR fortran/40580 +! +! Run-time check of passing deallocated/nonassociated actuals +! to nonallocatable/nonpointer dummies. +! +! Check for variable actuals +! + +subroutine test1(a) + integer :: a + a = 4444 +end subroutine test1 + +subroutine test2(a) + integer :: a(2) + a = 4444 +end subroutine test2 + +subroutine ppTest(f) + implicit none + external f + call f() +end subroutine ppTest + +Program RunTimeCheck + implicit none + external :: test1, test2, ppTest + integer, pointer :: ptr1, ptr2(:) + integer, allocatable :: alloc2(:) + procedure(), pointer :: pptr + + allocate(ptr1,ptr2(2),alloc2(2)) + pptr => sub + ! OK + call test1(ptr1) + call test3(ptr1) + + call test2(ptr2) + call test2(alloc2) + call test4(ptr2) + call test4(alloc2) + call ppTest(pptr) + call ppTest2(pptr) + + ! Invalid 1: + deallocate(alloc2) +! call test2(alloc2) +! call test4(alloc2) + + ! Invalid 2: + deallocate(ptr1,ptr2) + nullify(ptr1,ptr2) +! call test1(ptr1) +! call test3(ptr1) +! call test2(ptr2) +! call test4(ptr2) + + ! Invalid 3: + nullify(pptr) + call ppTest(pptr) +! call ppTest2(pptr) + +contains + subroutine test3(b) + integer :: b + b = 333 + end subroutine test3 + subroutine test4(b) + integer :: b(2) + b = 333 + end subroutine test4 + subroutine sub() + print *, 'Hello World' + end subroutine sub + subroutine ppTest2(f) + implicit none + procedure(sub) :: f + call f() + end subroutine ppTest2 +end Program RunTimeCheck Index: Fortran/gfortran/regression/pointer_check_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_5.f90 @@ -0,0 +1,100 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! { dg-shouldfail "Unassociated/unallocated actual argument" } +! +! { dg-output ".*At line 46 .*Pointer actual argument 'getptr' is not associated" } +! +! PR fortran/40580 +! +! Run-time check of passing deallocated/nonassociated actuals +! to nonallocatable/nonpointer dummies. +! +! Check for function actuals +! + +subroutine test1(a) + integer :: a + print *, a +end subroutine test1 + +subroutine test2(a) + integer :: a(2) + print *, a +end subroutine test2 + +subroutine ppTest(f) + implicit none + external f + call f() +end subroutine ppTest + +Program RunTimeCheck + implicit none + external :: test1, test2, ppTest + procedure(), pointer :: pptr + + ! OK + call test1(getPtr(.true.)) + call test2(getPtrArray(.true.)) + call test2(getAlloc(.true.)) + + ! OK but fails due to PR 40593 +! call ppTest(getProcPtr(.true.)) +! call ppTest2(getProcPtr(.true.)) + + ! Invalid: + call test1(getPtr(.false.)) +! call test2(getAlloc(.false.)) - fails because the check is inserted after +! _gfortran_internal_pack, which fails with out of memory +! call ppTest(getProcPtr(.false.)) - fails due to PR 40593 +! call ppTest2(getProcPtr(.false.)) - fails due to PR 40593 + +contains + function getPtr(alloc) + integer, pointer :: getPtr + logical, intent(in) :: alloc + if (alloc) then + allocate (getPtr) + getPtr = 1 + else + nullify (getPtr) + end if + end function getPtr + function getPtrArray(alloc) + integer, pointer :: getPtrArray(:) + logical, intent(in) :: alloc + if (alloc) then + allocate (getPtrArray(2)) + getPtrArray = 1 + else + nullify (getPtrArray) + end if + end function getPtrArray + function getAlloc(alloc) + integer, allocatable :: getAlloc(:) + logical, intent(in) :: alloc + if (alloc) then + allocate (getAlloc(2)) + getAlloc = 2 + else if (allocated(getAlloc)) then + deallocate(getAlloc) + end if + end function getAlloc + subroutine sub() + print *, 'Hello World' + end subroutine sub + function getProcPtr(alloc) + procedure(sub), pointer :: getProcPtr + logical, intent(in) :: alloc + if (alloc) then + getProcPtr => sub + else + nullify (getProcPtr) + end if + end function getProcPtr + subroutine ppTest2(f) + implicit none + procedure(sub) :: f + call f() + end subroutine ppTest2 +end Program RunTimeCheck Index: Fortran/gfortran/regression/pointer_check_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_6.f90 @@ -0,0 +1,115 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! +! { dg-shouldfail "pointer check" } +! { dg-output ".*At line 104 of file .*Fortran runtime error: Pointer actual argument 'a' is not associated.*" } +! +! PR fortran/40604 +! +! The following cases are all valid, but were failing +! for one or the other reason. +! +! Contributed by Janus Weil and Tobias Burnus. +! + +subroutine test1() + call test(uec=-1) +contains + subroutine test(str,uec) + implicit none + character*(*), intent(in), optional:: str + integer, intent(in), optional :: uec + end subroutine +end subroutine test1 + +module m + interface matrixMult + Module procedure matrixMult_C2 + End Interface +contains + subroutine test + implicit none + complex, dimension(0:3,0:3) :: m1,m2 + print *,Trace(MatrixMult(m1,m2)) + end subroutine + complex function trace(a) + implicit none + complex, intent(in), dimension(0:3,0:3) :: a + end function trace + function matrixMult_C2(a,b) result(matrix) + implicit none + complex, dimension(0:3,0:3) :: matrix,a,b + end function matrixMult_C2 +end module m + +SUBROUTINE plotdop(amat) + IMPLICIT NONE + REAL, INTENT (IN) :: amat(3,3) + integer :: i1 + real :: pt(3) + i1 = 1 + pt = MATMUL(amat,(/i1,i1,i1/)) +END SUBROUTINE plotdop + + FUNCTION evaluateFirst(s,n)result(number) + IMPLICIT NONE + CHARACTER(len =*), INTENT(inout) :: s + INTEGER,OPTIONAL :: n + REAL :: number + number = 1.1 + end function + +SUBROUTINE rw_inp(scpos) + IMPLICIT NONE + REAL scpos + + interface + FUNCTION evaluateFirst(s,n)result(number) + IMPLICIT NONE + CHARACTER(len =*), INTENT(inout) :: s + INTEGER,OPTIONAL :: n + REAL :: number + end function + end interface + + CHARACTER(len=100) :: line + scpos = evaluatefirst(line) +END SUBROUTINE rw_inp + +program test + integer, pointer :: a +! nullify(a) + allocate(a) + a = 1 + call sub1a(a) + call sub1b(a) + call sub1c() +contains + subroutine sub1a(a) + integer, pointer :: a + call sub2(a) + call sub3(a) + call sub4(a) + end subroutine sub1a + subroutine sub1b(a) + integer, pointer,optional :: a + call sub2(a) + call sub3(a) + call sub4(a) + end subroutine sub1b + subroutine sub1c(a) + integer, pointer,optional :: a + call sub4(a) +! call sub2(a) ! << Invalid - working correctly, but not allowed in F2003 + call sub3(a) ! << INVALID + end subroutine sub1c + subroutine sub4(b) + integer, optional,pointer :: b + end subroutine + subroutine sub2(b) + integer, optional :: b + end subroutine + subroutine sub3(b) + integer :: b + end subroutine +end Index: Fortran/gfortran/regression/pointer_check_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_7.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer" } +! +! PR 45438: [4.6 Regression] [OOP] ICE with -fcheck=pointer +! +! Contributed by Salvatore Filippone + +module base_mat_mod + + implicit none + + type :: base_sparse_mat + contains + procedure :: get_fmt + end type + +contains + + function get_fmt(a) result(res) + class(base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'NULL' + end function + + subroutine errlog(name) + character(len=*) :: name + end subroutine + + subroutine test (a) + class(base_sparse_mat), intent(in) :: a + call errlog(a%get_fmt()) + end subroutine + +end module Index: Fortran/gfortran/regression/pointer_check_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_8.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer" } +! +! PR 46809: [OOP] ICE with -fcheck=pointer for CLASS IS +! +! Contributed by Salvatore Filippone + + type t + end type t + +contains + + subroutine sub(a) + class(t) :: a + select type (a) + class is (t) + print *, 'Hi there' + end select + end subroutine + +end Index: Fortran/gfortran/regression/pointer_check_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_check_9.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcheck=all -std=f2008 " } +! +! PR fortran/49255 +! +! Valid F2008, invalid F95/F2003. +! +integer,pointer :: ptr => null() +call foo (ptr) +contains + subroutine foo (x) + integer, optional :: x + if (present (x)) STOP 1 + end subroutine foo +end Index: Fortran/gfortran/regression/pointer_comp_init_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_comp_init_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/50050 +! ICE whilst trying to access NULL shape. + +! Reduced from the FoX library http://www1.gly.bris.ac.uk/~walker/FoX/ +! Contributed by Andrew Benson + +module m_common_attrs + implicit none + + type dict_item + end type dict_item + + type dict_item_ptr + type(dict_item), pointer :: d => null() + end type dict_item_ptr + +contains + + subroutine add_item_to_dict() + type(dict_item_ptr), pointer :: tempList(:) + integer :: n + + allocate(tempList(0:n+1)) + end subroutine add_item_to_dict + +end module m_common_attrs Index: Fortran/gfortran/regression/pointer_component_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_component_type_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! This checks the fix for PR20889 in wrong pointer types in derived +! type constructors would either give no message or would segfault. +! +! Contributed by Joost VandVondele +!============== + TYPE TEST + REAL, POINTER :: A + END TYPE + + TYPE TEST1 + REAL :: A + END TYPE + + INTEGER, POINTER :: IP + real, POINTER :: RP + TYPE(TEST) :: DD + TYPE(TEST1) :: EE +! Next line is the original => gave no warning/error. + DD=TEST(NULL(IP)) ! { dg-error "INTEGER but should be REAL" } +! Would segfault here. + DD=TEST(IP) ! { dg-error "INTEGER but should be REAL" } +! Check right target type is OK. + DD=TEST(NULL(RP)) +! Check non-pointer is OK. + EE= TEST1(1) +! Test attempted conversion from character to real. + EE= TEST1("e") ! { dg-error "convert CHARACTER" } +END \ No newline at end of file Index: Fortran/gfortran/regression/pointer_function_actual_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_function_actual_1.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Tests the fix for PR31209, in which an ICE would result because +! the reference to the pointer function f would be indirected, as +! if it were the result that is being passed. +! +! COntributed by Joost VandeVondele +! +FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + ALLOCATE(RES) + RES=2 +END FUNCTION F + +SUBROUTINE S1(f,*,*) + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + RETURN F() +END SUBROUTINE + +PROGRAM TEST + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + + + INTERFACE + SUBROUTINE S1(f,*,*) + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + END SUBROUTINE + END INTERFACE + + CALL S1(F,*1,*2) + + 1 CONTINUE + STOP 1 + + GOTO 3 + 2 CONTINUE + + 3 CONTINUE +END + Index: Fortran/gfortran/regression/pointer_function_actual_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_function_actual_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Tests the fix for PR31200, in which the target x would +! not be associated with p +! +! COntributed by Joost VandeVondele +! + REAL,TARGET :: x + CALL s3(f(x)) +CONTAINS + FUNCTION f(a) + REAL,POINTER :: f + REAL,TARGET :: a + f => a + END FUNCTION + SUBROUTINE s3(targ) + REAL,TARGET :: targ + REAL,POINTER :: p + p => targ + IF (.NOT. ASSOCIATED(p,x)) STOP 1 + END SUBROUTINE +END + Index: Fortran/gfortran/regression/pointer_function_result_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_function_result_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Test the fix for PR47844, in which the stride in the function result +! was ignored. Previously, the result was [1,3] at lines 15 and 16. +! +! Contributed by KePu +! +PROGRAM test_pointer_value + IMPLICIT NONE + INTEGER, DIMENSION(10), TARGET :: array= [1,3,5,7,9,11,13,15,17,19] + INTEGER, dimension(2) :: array_fifth + INTEGER, POINTER, DIMENSION(:) :: ptr_array => NULL() + INTEGER, POINTER, DIMENSION(:) :: ptr_array_fifth => NULL() + ptr_array => array + array_fifth = every_fifth (ptr_array) + if (any (array_fifth .ne. [1,11])) STOP 1 + if (any (every_fifth(ptr_array) .ne. [1,11])) STOP 2 +CONTAINS + FUNCTION every_fifth (ptr_array) RESULT (ptr_fifth) + IMPLICIT NONE + INTEGER, POINTER, DIMENSION(:) :: ptr_fifth + INTEGER, POINTER, DIMENSION(:), INTENT(in) :: ptr_array + INTEGER :: low + INTEGER :: high + low = LBOUND (ptr_array, 1) + high = UBOUND (ptr_array, 1) + ptr_fifth => ptr_array (low: high: 5) + END FUNCTION every_fifth +END PROGRAM test_pointer_value Index: Fortran/gfortran/regression/pointer_init_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_1.f90 @@ -0,0 +1,15 @@ +! Check that null initialization of pointer variable works. +! { dg-do run } +program pointer_init_1 + type t + real x + end type + type(t), pointer :: a => NULL() + real, pointer :: b => NULL() + character, pointer :: c => NULL() + integer, pointer, dimension(:) :: d => NULL() + if (associated(a)) STOP 1 + if (associated(b)) STOP 2 + if (associated(c)) STOP 3 + if (associated(d)) STOP 4 +end Index: Fortran/gfortran/regression/pointer_init_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_10.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! PR 84504: [F08] procedure pointer variables cannot be initialized with functions returning pointers +! +! Contributed by Sriram Swaminarayan + +module test_mod + implicit none + private + integer, target :: i = 333 + procedure(the_proc), pointer, public :: ptr => the_proc +contains + function the_proc() + integer, pointer :: the_proc + the_proc => i + end function +end module + +program test_prog + use test_mod + integer, pointer :: ip + ip => ptr() + if (ip /= 333) stop 1 +end Index: Fortran/gfortran/regression/pointer_init_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_11.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR 85537: [F08] Invalid memory reference at runtime when calling subroutine through procedure pointer +! +! Contributed by Tiziano Müller + +module m1 + implicit none +contains + subroutine foo() + integer :: a + + abstract interface + subroutine ibar() + end subroutine + end interface + + procedure(ibar), pointer :: bar_ptr => bar_impl ! { dg-error "invalid in procedure pointer initialization" } + + contains + subroutine bar_impl() + write (*,*) "foo" + a = a + 1 + end subroutine + + end subroutine +end module + + +module m2 + implicit none +contains + subroutine foo(dbar) + interface + subroutine dbar() + end subroutine + end interface + + procedure(dbar), pointer :: bar_ptr => dbar ! { dg-error "invalid in procedure pointer initialization" } + + call bar_ptr() + + end subroutine +end module Index: Fortran/gfortran/regression/pointer_init_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_12.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 94347 - this used to cause an ICE. +! Original test case by "Serghei". +program main + character(10), target :: a + character(:), pointer :: p => null() + p => a +end program main Index: Fortran/gfortran/regression/pointer_init_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_2.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +subroutine sub + implicit none + + real, target, save :: r + integer, target, save, dimension(1:3) :: v + + integer, save :: i + integer, target :: j + integer, target, save, allocatable :: a + + + integer, pointer :: dp0 => 13 ! { dg-error "Error in pointer initialization" } + integer, pointer :: dp1 => r ! { dg-error "Different types in pointer assignment" } + integer, pointer :: dp2 => v ! { dg-error "Different ranks in pointer assignment" } + integer, pointer :: dp3 => i ! { dg-error "Pointer assignment target in initialization expression does not have the TARGET attribute" } + integer, pointer :: dp4 => j ! { dg-error "must have the SAVE attribute" } + integer, pointer :: dp5 => a ! { dg-error "must not be ALLOCATABLE" } + + type :: t + integer, pointer :: dpc0 => 13 ! { dg-error "Error in pointer initialization" } + end type t + + type t2 + integer, pointer :: dpc1 => r ! { dg-error "attempted assignment of REAL.4. to INTEGER.4." } + end type t2 + + type t3 + integer, pointer :: dpc2 => v ! { dg-error "Different ranks in pointer assignment" } + end type t3 + + type t4 + integer, pointer :: dpc3 => i ! { dg-error "Pointer assignment target in initialization expression does not have the TARGET attribute" } + end type t4 + + type t5 + integer, pointer :: dpc4 => j ! { dg-error "must have the SAVE attribute" } + end type t5 + + type t6 + integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" } + end type t6 + +end subroutine Index: Fortran/gfortran/regression/pointer_init_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_3.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m + integer, target :: t1 ! SAVE is implicit + integer, pointer :: p1 => t1 +end module m + + +use m +implicit none + +integer,target :: i0 = 2 +integer,target,dimension(1:3) :: vec = 1 + +type :: t + integer, pointer :: dpc => i0 + integer :: i = 0 +end type + +type (t), save, target :: u + +integer, pointer :: dp => i0 +integer, pointer :: dp2 => vec(2) +integer, pointer :: dp3 => u%i + +dp = 5 +if (i0/=5) STOP 1 + +u%dpc = 6 +if (i0/=6) STOP 2 + +dp2 = 3 +if (vec(2)/=3) STOP 3 + +dp3 = 4 +if (u%i/=4) STOP 4 + +end Index: Fortran/gfortran/regression/pointer_init_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_4.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m + +implicit none + +contains + + integer function f1() + f1 = 42 + end function + + integer function f2() + f2 = 43 + end function + +end module + + +program test_ptr_init + +use m +implicit none + +procedure(f1), pointer :: pp => f1 + +type :: t + procedure(f2), pointer, nopass :: ppc => f2 +end type + +type (t) :: u + +if (pp()/=42) STOP 1 +if (u%ppc()/=43) STOP 2 + +end Index: Fortran/gfortran/regression/pointer_init_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_5.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m + +implicit none + +procedure(f1), pointer :: pp => f1 + +type :: t + procedure(f2), pointer, nopass :: ppc => f2 +end type + +contains + + integer function f1() + f1 = 42 + end function + + integer function f2() + f2 = 43 + end function + +end module + + +program test_ptr_init + +use m +implicit none + +type (t) :: u + +if (pp()/=42) STOP 1 +if (u%ppc()/=43) STOP 2 + +end Index: Fortran/gfortran/regression/pointer_init_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_6.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 45290: [F08] pointer initialization +! +! Contributed by Janus Weil + +module m1 + implicit none + type :: t + integer, pointer :: p + integer :: i + end type + integer, target :: i + type(t), target :: x + integer, pointer :: p1 => i + integer, pointer :: p2 => p1 ! { dg-error "Pointer assignment target in initialization expression does not have the TARGET attribute at" } + integer, pointer :: p3 => x%p ! { dg-error "must have the TARGET attribute" } + integer, pointer :: p4 => x%i + integer, pointer :: p5 => u ! { dg-error "has no IMPLICIT type" } +end module m1 + + +module m2 + + type :: t + procedure(s), pointer, nopass :: ppc + end type + type(t) :: x + procedure(s), pointer :: pp1 => s + procedure(s), pointer :: pp2 => pp1 ! { dg-error "may not be a procedure pointer" } + procedure(s), pointer :: pp3 => t%ppc ! { dg-error "Symbol 't' at .1. has no IMPLICIT type" } + +contains + + subroutine s + end subroutine + +end module m2 Index: Fortran/gfortran/regression/pointer_init_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_7.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR fortran/55763 +! + +subroutine sub() + type t + integer :: i + end type t + + type(t), target :: tgt + type(t), target, save :: tgt2(2) + + type t2a + type(t), pointer :: cmp1 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2a + + type t2b + class(t), pointer :: cmp2 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2b + + type t2c + class(t), pointer :: cmp3 => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2c + + type t2d + integer, pointer :: cmp4 => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + end type t2d + + type(t), pointer :: w => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + class(t), pointer :: x => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + class(*), pointer :: y => tgt ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } + integer, pointer :: z => tgt%i ! { dg-error "Pointer initialization target at .1. must have the SAVE attribute" } +end subroutine + +program main + type t3 + integer :: j + end type t3 + + type(t3), target :: tgt + + type t4 + type(t3), pointer :: cmp1 => tgt ! OK + class(t3), pointer :: cmp2 => tgt ! OK + class(t3), pointer :: cmp3 => tgt ! OK + integer, pointer :: cmp4 => tgt%j ! OK + end type t4 + + type(t3), target :: mytarget + + type(t3), pointer :: a => mytarget ! OK + class(t3), pointer :: b => mytarget ! OK + class(*), pointer :: c => mytarget ! OK + integer, pointer :: d => mytarget%j ! OK +end program main Index: Fortran/gfortran/regression/pointer_init_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_8.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR 57306: [OOP] ICE on valid with class pointer initialization +! +! Contributed by Andrew Benson + +module m + type :: c + end type c + type, extends(c) :: d + end type d + type(c), target :: x + type(d), target :: y +end module m + + use m + class(c), pointer :: px => x + class(c), pointer :: py => y + + if (.not. associated(px, x)) STOP 1 + if (.not. same_type_as(px, x)) STOP 2 + if (.not. associated(py, y)) STOP 3 + if (.not. same_type_as(py, y)) STOP 4 +end Index: Fortran/gfortran/regression/pointer_init_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_init_9.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 71237 - this used to ICE. +module data_mod + implicit none + + type data_t + integer :: i + end type + + type(data_t), pointer :: data + integer, pointer :: idata => data%i ! { dg-error "Pointer assignment target in initialization expression does not have the TARGET attribute" } + +end module Index: Fortran/gfortran/regression/pointer_intent_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_1.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } +! Pointer intent test +! PR fortran/29624 +! +! Valid program +program test + implicit none + type myT + integer :: x + integer, pointer :: point + end type myT + integer, pointer :: p + type(myT), pointer :: t + type(myT) :: t2 + allocate(p,t) + allocate(t%point) + t%point = 55 + p = 33 + call a(p,t) + deallocate(p) + nullify(p) + call a(p,t) + t2%x = 5 + allocate(t2%point) + t2%point = 42 + call nonpointer(t2) + if(t2%point /= 7) STOP 1 +contains + subroutine a(p,t) + integer, pointer,intent(in) :: p + type(myT), pointer, intent(in) :: t + integer, pointer :: tmp + if(.not.associated(p)) return + if(p /= 33) STOP 2 + p = 7 + if (associated(t)) then + ! allocating is valid as we don't change the status + ! of the pointer "t", only of it's target + t%x = -15 + if(.not.associated(t%point)) STOP 3 + if(t%point /= 55) STOP 4 + nullify(t%point) + allocate(tmp) + t%point => tmp + deallocate(t%point) + t%point => null(t%point) + tmp => null(tmp) + allocate(t%point) + t%point = 27 + if(t%point /= 27) STOP 5 + if(t%x /= -15) STOP 6 + call foo(t) + if(t%x /= 32) STOP 7 + if(t%point /= -98) STOP 8 + end if + call b(p) + if(p /= 5) STOP 9 + end subroutine + subroutine b(v) + integer, intent(out) :: v + v = 5 + end subroutine b + subroutine foo(comp) + type(myT), intent(inout) :: comp + if(comp%x /= -15) STOP 10 + if(comp%point /= 27) STOP 11 + comp%x = 32 + comp%point = -98 + end subroutine foo + subroutine nonpointer(t) + type(myT), intent(in) :: t + if(t%x /= 5 ) STOP 12 + if(t%point /= 42) STOP 13 + t%point = 7 + end subroutine nonpointer +end program Index: Fortran/gfortran/regression/pointer_intent_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! { dg-shouldfail "Fortran 2003 feature with -std=f95" } +! +! Pointer intent test +! PR fortran/29624 +! +! Fortran 2003 features in Fortran 95 +program test + implicit none + integer, pointer :: p + allocate(p) + p = 33 + call a(p) ! { dg-error "Type mismatch in argument" } +contains + subroutine a(p)! { dg-error "has no IMPLICIT type" } + integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute conflicts with INTENT attribute" } + end subroutine +end program Index: Fortran/gfortran/regression/pointer_intent_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_3.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! { dg-shouldfail "Invalid code" } +! +! Pointer intent test +! PR fortran/29624 +! +! Valid program +program test + implicit none + type myT + integer :: j = 5 + integer, pointer :: jp => null() + end type myT + integer, pointer :: p + type(myT) :: t + call a(p) + call b(t) +contains + subroutine a(p) + integer, pointer,intent(in) :: p + p => null(p)! { dg-error "pointer association context" } + nullify(p) ! { dg-error "pointer association context" } + allocate(p) ! { dg-error "pointer association context" } + call c(p) ! { dg-error "pointer association context" } + deallocate(p) ! { dg-error "pointer association context" } + end subroutine + subroutine c(p) + integer, pointer, intent(inout) :: p + nullify(p) + end subroutine c + subroutine b(t) + type(myT),intent(in) :: t + t%jp = 5 + t%jp => null(t%jp) ! { dg-error "pointer association context" } + nullify(t%jp) ! { dg-error "pointer association context" } + t%j = 7 ! { dg-error "variable definition context" } + allocate(t%jp) ! { dg-error "pointer association context" } + deallocate(t%jp) ! { dg-error "pointer association context" } + end subroutine b +end program Index: Fortran/gfortran/regression/pointer_intent_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fno-inline" } +! +! PR fortran/46937 +! +! Check that a non-pointer INTENT(IN) dummy +! with pointer component is properly treated +! +program test + type myT + integer, pointer :: point + end type myT + type(myT) :: t2 + allocate(t2%point) + t2%point = 42 + call nonpointer(t2) + if(t2%point /= 7) STOP 1 + t2%point = 42 + call nonpointer2(t2) + if(t2%point /= 66) STOP 2 +contains + subroutine nonpointer(t) + type(myT), intent(in) :: t + t%point = 7 + end subroutine nonpointer + subroutine nonpointer2(t) + class(myT), intent(in) :: t + t%point = 66 + end subroutine nonpointer2 +end program Index: Fortran/gfortran/regression/pointer_intent_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR 50570: [4.6/4.7 Regression] Incorrect error for assignment to intent(in) pointer +! +! Contributed by Bill Long + +program bots_sparselu_pointer_intent_in + + implicit none + integer, pointer :: array(:) + + allocate(array(4)) + array = 0 + call sub(array) + if (sum(array)/=1) STOP 1 + +contains + + subroutine sub(dummy) + integer, pointer, intent(in) :: dummy(:) + dummy(1) = 1 + end subroutine sub + +end program Index: Fortran/gfortran/regression/pointer_intent_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_6.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/52864 +! +! Assigning to an intent(in) pointer (which is valid). +! + program test + type PoisFFT_Solver3D + complex, dimension(:,:,:), & + pointer :: work => null() + end type PoisFFT_Solver3D + contains + subroutine PoisFFT_Solver3D_FullPeriodic(D, p) + type(PoisFFT_Solver3D), intent(in) :: D + real, intent(in), pointer :: p(:) + D%work(i,j,k) = 0.0 + p = 0.0 + end subroutine + end Index: Fortran/gfortran/regression/pointer_intent_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_7.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! PR fortran/ +! +! Contributed by Neil Carlson +! +! Check whether passing an intent(in) pointer +! to an intent(inout) nonpointer is allowed +! +module modA + type :: typeA + integer, pointer :: ptr + end type +contains + subroutine foo (a,b,c) + type(typeA), intent(in) :: a + type(typeA), intent(in) , pointer :: b + class(typeA), intent(in) , pointer :: c + + call bar (a%ptr) + call bar2 (b) + call bar3 (b) + call bar2 (c) + call bar3 (c) + call bar2p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + call bar3p (b) ! { dg-error "Actual argument to .n. at \\(1\\) must be polymorphic" } + call bar2p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + call bar3p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" } + end subroutine + subroutine bar (n) + integer, intent(inout) :: n + end subroutine + subroutine bar2 (n) + type(typeA), intent(inout) :: n + end subroutine + subroutine bar3 (n) + class(typeA), intent(inout) :: n + end subroutine + subroutine bar2p (n) + type(typeA), intent(inout), pointer :: n + end subroutine + subroutine bar3p (n) + class(typeA), intent(inout), pointer :: n + end subroutine +end module Index: Fortran/gfortran/regression/pointer_intent_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_8.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR 85797 - this used to get wrong results. + + +PROGRAM testfortran2 + IMPLICIT NONE + + INTEGER, DIMENSION(10), TARGET :: i4array + + i4array = (/ 1,2,3,4,5,6,7,8,9,10 /) + + call InRef(i4array) + +CONTAINS + + subroutine InRef(v) + INTEGER, DIMENSION(:), POINTER, INTENT(in) :: v + INTEGER :: i + if (any (v /= [(i,i=1,10)])) stop 1 + END subroutine + +END Index: Fortran/gfortran/regression/pointer_intent_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_intent_9.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/103418 +! Validate checks for dummy arguments with INTENT(IN), pointer attribute + +module m + type t + real, pointer :: a, b(:) + end type t +contains + subroutine s1 (a, b, c, d, e) + real, pointer, intent(in) :: a, b(:) + type(t), intent(in) :: c + class(t), intent(in) :: d + type(t), pointer, intent(in) :: e + real, pointer :: pa, pb(:) + call random_number (a) ! legal + call random_number (b) + call cpu_time (a) + call system_clock (count_rate=a) + call random_number (c% a) + call random_number (c% b) + call random_number (d% a) + call random_number (d% b) + call random_number (e% a) + call random_number (e% b) + call move_alloc (a, pa) ! { dg-error "must be ALLOCATABLE" } + call move_alloc (b, pb) ! { dg-error "must be ALLOCATABLE" } + allocate (a) ! { dg-error "pointer association context" } + allocate (b(10)) ! { dg-error "pointer association context" } + allocate (c% a) ! { dg-error "pointer association context" } + allocate (c% b(10)) ! { dg-error "pointer association context" } + end subroutine s1 +end module Index: Fortran/gfortran/regression/pointer_remapping_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/29785 +! PR fortran/45016 +! Check for F2003 rejection of pointer remappings. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: arr(12) + INTEGER, POINTER :: vec(:), mat(:, :) + + vec => arr ! This is ok. + + vec(2:) => arr ! { dg-error "Fortran 2003" } + mat(1:2, 1:6) => arr ! { dg-error "Fortran 2003" } +END PROGRAM main Index: Fortran/gfortran/regression/pointer_remapping_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_10.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! PR fortran/71194 +! +! Contributed by T Kondic +! +program ice +implicit none +integer, parameter :: pa=10, pb=20 +complex, target :: a(pa*pb) +real, pointer:: ptr(:,:) =>null() +integer :: i, j, cnt +logical :: negative + + do i = 1, size(a) + a(i) = cmplx(i,-i) + end do + + ! Was ICEing before with bounds checks + ptr(1:pa*2,1:pb) => conv2real(a) + + negative = .false. + cnt = 1 + do i = 1, ubound(ptr,dim=2) + do j = 1, ubound(ptr,dim=1) + if (negative) then + if (-cnt /= ptr(j, i)) STOP 1 + cnt = cnt + 1 + negative = .false. + else + if (cnt /= ptr(j, i)) STOP 2 + negative = .true. + end if + end do + end do + +contains + function conv2real(carr) + use, intrinsic :: iso_c_binding + ! returns real pointer to a complex array + complex, contiguous, intent(inout), target :: carr(:) + real,contiguous,pointer :: conv2real(:) + call c_f_pointer(c_loc(carr),conv2real,[size(carr)*2]) + end function conv2real +end program Index: Fortran/gfortran/regression/pointer_remapping_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_2.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/29785 +! Check for F2008 rejection of rank remapping to rank-two base array. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: arr(12), basem(3, 4) + INTEGER, POINTER :: vec(:), mat(:, :) + + ! These are ok. + vec => arr + vec(2:) => arr + mat(1:2, 1:6) => arr + + vec(1:12) => basem ! { dg-error "Fortran 2008" } +END PROGRAM main Index: Fortran/gfortran/regression/pointer_remapping_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_3.f08 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! PR fortran/29785 +! PR fortran/45016 +! PR fortran/60091 +! Check for pointer remapping compile-time errors. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: arr(12), basem(3, 4) + INTEGER, POINTER :: vec(:), mat(:, :) + + ! Existence of reference elements. + vec(:) => arr ! { dg-error "or list of 'lower-bound : upper-bound'" } + vec(5:7:1) => arr ! { dg-error "Stride must not be present" } + mat(1:,2:5) => arr ! { dg-error "Rank remapping requires a list of " } + mat(1:3,4:) => arr ! { dg-error "Rank remapping requires a list of " } + mat(2, 6) => arr ! { dg-error "Expected bounds specification" } + + mat(1:,3:) => arr ! { dg-error "Rank remapping requires a list of " } + + ! Invalid remapping target; for non-rank one we already check the F2008 + ! error elsewhere. Here, test that not-contiguous target is disallowed + ! with rank > 1. + mat(1:2, 1:3) => arr(1:12:2) ! This is ok, rank one target. + vec(1:8) => basem(1:3:2, :) ! { dg-error "rank 1 or simply contiguous" } + + ! Target is smaller than pointer. + vec(1:20) => arr ! { dg-error "smaller than size of the pointer" } + vec(1:10) => arr(1:12:2) ! { dg-error "smaller than size of the pointer" } + vec(1:20) => basem(:, :) ! { dg-error "smaller than size of the pointer" } + mat(1:5, 1:5) => arr ! { dg-error "smaller than size of the pointer" } +END PROGRAM main Index: Fortran/gfortran/regression/pointer_remapping_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_4.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-std=f2003 -fcheck=bounds" } + +! PR fortran/45016 +! Check pointer bounds remapping at runtime. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: arr(2_2:5), basem(-2:-1, 3:4_1) + INTEGER, POINTER :: vec(:), vec2(:), mat(:, :) + + arr = (/ 1, 2, 3, 4 /) + basem = RESHAPE (arr, SHAPE (basem)) + + vec(0:) => arr + IF (LBOUND (vec, 1) /= 0 .OR. UBOUND (vec, 1) /= 3) STOP 1 + IF (ANY (vec /= arr)) STOP 2 + IF (vec(0) /= 1 .OR. vec(2) /= 3) STOP 3 + + ! Test with bound different of index type, so conversion is necessary. + vec2(-5_1:) => vec + IF (LBOUND (vec2, 1) /= -5 .OR. UBOUND (vec2, 1) /= -2) STOP 4 + IF (ANY (vec2 /= arr)) STOP 5 + IF (vec2(-5) /= 1 .OR. vec2(-3) /= 3) STOP 6 + + mat(1:, 2:) => basem + IF (ANY (LBOUND (mat) /= (/ 1, 2 /) .OR. UBOUND (mat) /= (/ 2, 3 /))) & + STOP 7 + IF (ANY (mat /= basem)) STOP 8 + IF (mat(1, 2) /= 1 .OR. mat(1, 3) /= 3 .OR. mat(2, 3) /= 4) STOP 9 +END PROGRAM main Index: Fortran/gfortran/regression/pointer_remapping_5.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_5.f08 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-options "-std=f2008 -fcheck=bounds" } + +! PR fortran/29785 +! Check pointer rank remapping at runtime. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: arr(12), basem(3, 4) + INTEGER, POINTER :: vec(:), mat(:, :) + INTEGER :: i + + arr = (/ (i, i = 1, 12) /) + basem = RESHAPE (arr, SHAPE (basem)) + + ! We need not necessarily change the rank... + vec(2_1:5) => arr(1_1:12_1:2_1) + IF (LBOUND (vec, 1) /= 2 .OR. UBOUND (vec, 1) /= 5) STOP 1 + IF (ANY (vec /= (/ 1, 3, 5, 7 /))) STOP 2 + IF (vec(2) /= 1 .OR. vec(5) /= 7) STOP 3 + + ! ...but it is of course the more interesting. Also try remapping a pointer. + vec => arr(1:12:2) + mat(1:3, 1:2) => vec + IF (ANY (LBOUND (mat) /= (/ 1, 1 /) .OR. UBOUND (mat) /= (/ 3, 2 /))) & + STOP 4 + IF (ANY (mat /= RESHAPE (arr(1:12:2), SHAPE (mat)))) STOP 5 + IF (mat(1, 1) /= 1 .OR. mat(1, 2) /= 7) STOP 6 + + ! Remap with target of rank > 1. + vec(1:12_1) => basem + IF (LBOUND (vec, 1) /= 1 .OR. UBOUND (vec, 1) /= 12) STOP 7 + IF (ANY (vec /= arr)) STOP 8 + IF (vec(1) /= 1 .OR. vec(5) /= 5 .OR. vec(12) /= 12) STOP 9 +END PROGRAM main Index: Fortran/gfortran/regression/pointer_remapping_6.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_6.f08 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-std=f2008 -fcheck=bounds" } +! { dg-shouldfail "Bounds check" } + +! PR fortran/29785 +! Check that -fcheck=bounds catches too small target at runtime for +! pointer rank remapping. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, POINTER :: ptr(:, :) + INTEGER :: n + + n = 10 + BLOCK + INTEGER, TARGET :: arr(2*n) + + ! These are ok. + ptr(1:5, 1:2) => arr + ptr(1:5, 1:2) => arr(::2) + ptr(-5:-1, 11:14) => arr + + ! This is not. + ptr(1:3, 1:5) => arr(::2) + END BLOCK +END PROGRAM main +! { dg-output "At line 26 of .*\nFortran runtime error: Target of rank remapping is too small \\(10 < 15\\)" } Index: Fortran/gfortran/regression/pointer_remapping_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/49624 +! + integer, target :: A(100) + integer,pointer :: P(:,:) + p(10,1:) => A ! { dg-error "or list of 'lower-bound : upper-bound'" } + end Index: Fortran/gfortran/regression/pointer_remapping_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_8.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 54788 ICE on pointer-array element assignment +! +program bug + integer, pointer :: a(:) + integer :: b + allocate(a(0:0)) + a(0:0) => b ! { dg-error "Rank remapping target must be rank 1 or simply contiguous" } +end Index: Fortran/gfortran/regression/pointer_remapping_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_remapping_9.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/61138 +! Wrong code with pointer-bounds remapping +! +! Contributed by Tobias Burnus + +implicit none +integer, target :: tgt(10) +integer, target, allocatable :: tgt2(:) +integer, pointer :: ptr(:) + +tgt = [1,2,3,4,5,6,7,8,9,10] +tgt2 = [1,2,3,4,5,6,7,8,9,10] + + +ptr(-5:) => tgt(5:) ! Okay + +if (size(ptr) /= 6 .or. lbound(ptr,1) /= -5) STOP 1 +if (any (ptr /= [5,6,7,8,9,10])) STOP 2 + + +ptr(-5:) => tgt2(5:) ! wrongly associates the whole array + +print '(*(i4))', size(ptr), lbound(ptr) +print '(*(i4))', ptr + +if (size(ptr) /= 6 .or. lbound(ptr,1) /= -5) STOP 3 +if (any (ptr /= [5,6,7,8,9,10])) STOP 4 +end + Index: Fortran/gfortran/regression/pointer_target_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_target_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! TARGET actual to POINTER dummy with INTENT(IN) +! +program test + implicit none + integer, target :: a + a = 66 + call foo(a) + if (a /= 647) STOP 1 +contains + subroutine foo(p) + integer, pointer, intent(in) :: p + if (a /= 66) STOP 2 + if (p /= 66) STOP 3 + p = 647 + if (p /= 647) STOP 4 + if (a /= 647) STOP 5 + end subroutine foo +end program test Index: Fortran/gfortran/regression/pointer_target_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_target_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! TARGET actual to POINTER dummy with INTENT(IN) +! +program test + implicit none + integer, target :: a + a = 66 + call foo(a) ! { dg-error "Fortran 2008: Non-pointer actual argument" } + if (a /= 647) STOP 1 +contains + subroutine foo(p) + integer, pointer, intent(in) :: p + if (a /= 66) STOP 2 + if (p /= 66) STOP 3 + p = 647 + if (p /= 647) STOP 4 + if (a /= 647) STOP 5 + end subroutine foo +end program test Index: Fortran/gfortran/regression/pointer_target_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_target_3.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! TARGET actual to POINTER dummy with INTENT(IN) +! +program test + implicit none + integer, target :: a + integer :: b + call foo(a) ! OK + call foo(b) ! { dg-error "must be a pointer" } + call bar(a) ! { dg-error "must be a pointer" } + call bar(b) ! { dg-error "must be a pointer" } +contains + subroutine foo(p) + integer, pointer, intent(in) :: p + end subroutine foo + subroutine bar(p) + integer, pointer :: p + end subroutine bar +end program test Index: Fortran/gfortran/regression/pointer_target_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_target_4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/47377 +! +! Contributed by +! +program testgferr + real, pointer :: y + y => f() ! { dg-error "must deliver a pointer result" } +contains + function f() + real :: f + f = 5 + end function f +end program testgferr Index: Fortran/gfortran/regression/pointer_to_substring.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pointer_to_substring.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR36724 - ICE on pointer to substring +! testcase contributed by Loukas Peristeras. + + character(LEN=132), target :: line + character(LEN=1), pointer :: t + + read(*,'(A)') line + t=>line(1:1) +end Index: Fortran/gfortran/regression/popcnt_poppar_1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/popcnt_poppar_1.F90 @@ -0,0 +1,121 @@ +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + +interface runtime_popcnt + procedure runtime_popcnt_i1 + procedure runtime_popcnt_i2 + procedure runtime_popcnt_i4 + procedure runtime_popcnt_i8 +end interface + +interface runtime_poppar + procedure runtime_poppar_i1 + procedure runtime_poppar_i2 + procedure runtime_poppar_i4 + procedure runtime_poppar_i8 +end interface + +#define CHECK(val,res) \ + if (popcnt(val) /= res) STOP 1; \ + if (runtime_popcnt(val) /= res) STOP 2 + +#define CHECK2(val) \ + if (poppar(val) /= modulo(popcnt(val),2)) STOP 3; \ + if (runtime_poppar(val) /= poppar(val)) STOP 4 + + CHECK(0_1, 0) + CHECK(0_2, 0) + CHECK(0_4, 0) + CHECK(0_8, 0) + + CHECK(1_1, 1) + CHECK(1_2, 1) + CHECK(1_4, 1) + CHECK(1_8, 1) + + CHECK(-1_1,8) + CHECK(-1_2,16) + CHECK(-1_4,32) + CHECK(-1_8,64) + + CHECK(-8_1,8-3) + CHECK(-8_2,16-3) + CHECK(-8_4,32-3) + CHECK(-8_8,64-3) + + CHECK(huge(0_1), 8-1) + CHECK(huge(0_2), 16-1) + CHECK(huge(0_4), 32-1) + CHECK(huge(0_8), 64-1) + + CHECK(-huge(0_1), 2) + CHECK(-huge(0_2), 2) + CHECK(-huge(0_4), 2) + CHECK(-huge(0_8), 2) + + CHECK2(0_1) + CHECK2(0_2) + CHECK2(0_4) + CHECK2(0_8) + + CHECK2(17_1) + CHECK2(17_2) + CHECK2(17_4) + CHECK2(17_8) + + CHECK2(-17_1) + CHECK2(-17_2) + CHECK2(-17_4) + CHECK2(-17_8) + + CHECK2(huge(0_1)) + CHECK2(huge(0_2)) + CHECK2(huge(0_4)) + CHECK2(huge(0_8)) + + CHECK2(-huge(0_1)) + CHECK2(-huge(0_2)) + CHECK2(-huge(0_4)) + CHECK2(-huge(0_8)) + +contains + integer function runtime_popcnt_i1 (i) result(res) + integer(kind=1), intent(in) :: i + res = popcnt(i) + end function + + integer function runtime_popcnt_i2 (i) result(res) + integer(kind=2), intent(in) :: i + res = popcnt(i) + end function + + integer function runtime_popcnt_i4 (i) result(res) + integer(kind=4), intent(in) :: i + res = popcnt(i) + end function + + integer function runtime_popcnt_i8 (i) result(res) + integer(kind=8), intent(in) :: i + res = popcnt(i) + end function + + integer function runtime_poppar_i1 (i) result(res) + integer(kind=1), intent(in) :: i + res = poppar(i) + end function + + integer function runtime_poppar_i2 (i) result(res) + integer(kind=2), intent(in) :: i + res = poppar(i) + end function + + integer function runtime_poppar_i4 (i) result(res) + integer(kind=4), intent(in) :: i + res = poppar(i) + end function + + integer function runtime_poppar_i8 (i) result(res) + integer(kind=8), intent(in) :: i + res = poppar(i) + end function +end Index: Fortran/gfortran/regression/popcnt_poppar_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/popcnt_poppar_2.F90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + +#define CHECK(val,res) \ + if (popcnt(val) /= res) STOP 1; \ + if (runtime_popcnt(val) /= res) STOP 2 + +#define CHECK2(val) \ + if (poppar(val) /= modulo(popcnt(val),2)) STOP 3; \ + if (runtime_poppar(val) /= poppar(val)) STOP 4 + + CHECK(0_16, 0) + CHECK(1_16, 1) + + CHECK(-1_16,128) + CHECK(-8_16,128-3) + + CHECK(huge(0_16), 128-1) + + CHECK(-huge(0_16), 2) + + CHECK2(0_16) + CHECK2(17_16) + CHECK2(-17_16) + CHECK2(huge(0_16)) + CHECK2(-huge(0_16)) + +contains + integer function runtime_popcnt (i) result(res) + integer(kind=16), intent(in) :: i + res = popcnt(i) + end function + + integer function runtime_poppar (i) result(res) + integer(kind=16), intent(in) :: i + res = poppar(i) + end function +end Index: Fortran/gfortran/regression/power.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +integer i +i = 0 +if ( a (i) ** 5 .ne. 1) STOP 1 +contains +function a (i) +integer a, i +i = i + 1 +a = i +end function +end Index: Fortran/gfortran/regression/power1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/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) STOP 1 + if (abs(rid - 4) > eps_d) STOP 2 + if (abs(rie - 4) > eps_e) STOP 3 + if (abs(real(cis, s) - 3) > eps_s .or. abs(aimag(cis) - 4) > eps_s) STOP 4 + if (abs(real(cid, d) - 3) > eps_d .or. abs(aimag(cid) - 4) > eps_d) STOP 5 + if (abs(real(cie, e) - 3) > eps_e .or. abs(aimag(cie) - 4) > eps_e) STOP 6 + + if (abs(rrs - 4) > eps_s) STOP 7 + if (abs(rrd - 4) > eps_d) STOP 8 + if (abs(rre - 4) > eps_e) STOP 9 + if (abs(real(crs, s) - 3) > eps_s .or. abs(aimag(crs) - 4) > eps_s) STOP 10 + if (abs(real(crd, d) - 3) > eps_d .or. abs(aimag(crd) - 4) > eps_d) STOP 11 + if (abs(real(cre, e) - 3) > eps_e .or. abs(aimag(cre) - 4) > eps_e) STOP 12 + + if (abs(rds - 4) > eps_s) STOP 13 + if (abs(rdd - 4) > eps_d) STOP 14 + if (abs(rde - 4) > eps_e) STOP 15 + if (abs(real(cds, s) - 3) > eps_s .or. abs(aimag(cds) - 4) > eps_s) STOP 16 + if (abs(real(cdd, d) - 3) > eps_d .or. abs(aimag(cdd) - 4) > eps_d) STOP 17 + if (abs(real(cde, e) - 3) > eps_e .or. abs(aimag(cde) - 4) > eps_e) STOP 18 + +end program power Index: Fortran/gfortran/regression/power2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/46794 + +! Check that results of powers of integers with kinds 1 and 2 are +! correctly converted back; this used to ICE because a conversion +! from kind 4 to the correct one was missing. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + INTEGER(KIND=1) :: k1 + INTEGER(KIND=2) :: k2 + + k1 = 1_1 + k2 = 1_2 + + k1 = 1_1 + 1_1**k1 + k2 = 1_2 + 1_2**k2 + + k2 = 1_1 + 1_1**k2 + k2 = 1_1 + 1_2**k1 + k2 = 1_1 + 1_2**k2 +END PROGRAM main Index: Fortran/gfortran/regression/power_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_3.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 57071 - Check that (-1)**k is transformed into 1-2*iand(k,1). +program main + implicit none + integer, parameter :: n = 3 + integer(kind=8), dimension(-n:n) :: a, b + integer, dimension(-n:n) :: c, d, e + integer :: m + integer :: i, v + integer (kind=2) :: i2 + + m = n + v = -1 + ! Test in scalar expressions + do i=-n,n + if (v**i /= (-1)**i) STOP 1 + end do + + ! Test in array constructors + a(-m:m) = [ ((-1)**i, i= -m, m) ] + b(-m:m) = [ ( v**i, i= -m, m) ] + if (any(a .ne. b)) STOP 2 + + ! Test in array expressions + c = [ ( i, i = -n , n ) ] + d = (-1)**c + e = v**c + if (any(d .ne. e)) STOP 3 + + ! Test in different kind expressions + do i2=-n,n + if (v**i2 /= (-1)**i2) STOP 4 + end do + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 4 "original" } } Index: Fortran/gfortran/regression/power_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_4.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 57071 - Check that 2**k is transformed into ishift(1,k). +program main + implicit none + integer :: i,m,v + integer, parameter :: n=30 + integer, dimension(-n:n) :: a,b,c,d,e + m = n + + v = 2 + ! Test scalar expressions. + do i=-n,n + if (2**i /= v**i) STOP 1 + end do + + ! Test array constructors + b = [(2**i,i=-m,m)] + c = [(v**i,i=-m,m)] + if (any(b /= c)) STOP 2 + + ! Test array expressions + a = [(i,i=-m,m)] + d = 2**a + e = v**a + if (any(d /= e)) STOP 3 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 3 "original" } } Index: Fortran/gfortran/regression/power_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_5.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 57071 - Check that 1**k is transformed into 1 +program main + implicit none + integer, parameter :: n = 3 + integer(kind=8), dimension(-n:n) :: a + integer, dimension(-n:n) :: c, d + integer :: m + integer :: i, v + integer (kind=2) :: i2 + + v = 1 + m = n + ! Test in scalar expressions + do i=-n,n + if (v /= 1**i) STOP 1 + end do + + ! Test in array constructors + a(-m:m) = [ (1**i, i= -m, m) ] + if (any(a .ne. v)) STOP 2 + + ! Test in array expressions + c = [ ( i, i = -n , n ) ] + d = 1**c + if (any(d .ne. v)) STOP 3 + + ! Test in different kind expressions + do i2=-n,n + if (v /= 1**i2) STOP 4 + end do + +end program main +! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 0 "original" } } Index: Fortran/gfortran/regression/power_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O1 -fdump-tree-optimized" } +! +! PR middle-end/57073 +! See also PR 57073 +! +real function f(k) + integer, value :: k + f = (-1.0)**k +end + +! { dg-final { scan-tree-dump-not "__builtin_powif" "optimized" } } +! { dg-final { scan-tree-dump "powi_cond_\[0-9\] = k_\[0-9\]\\(D\\) & 1;" "optimized" } } +! { dg-final { scan-tree-dump "powi_\[0-9\] = powi_cond_\[0-9\] \\? -1.0e\\+0 : 1.0e\\+0;" "optimized" } } Index: Fortran/gfortran/regression/power_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_7.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 85544 - this used to ICE. +program p + integer, parameter :: na = -3, ne = 10 + integer :: i, a(na:ne), b(na:ne) + integer :: v + a = [(i, i=na, ne)] + b = [2**a] + if (any (b /= [0,0,0,1,2,4,8,16,32,64,128,256,512,1024])) stop 1 + b = [1**a] + if (any (b /= 1)) stop 2 + b = [(-1)**a] + if (any (b /= [-1,1,-1,1,-1,1,-1,1,-1,1,-1,1,-1,1]) )stop 3 + b = [8**a] + if (any (b /= [0,0,0,1,8,64,512,4096,32768,262144,2097152,16777216,& + 134217728,1073741824])) stop 4 + b = [4**a] + if (any (b /= [0,0,0,1,4,16,64,256,1024,4096,16384,65536,262144,1048576])) stop 5 + + v = 1 + do i=1,6 + v = v * 16 + if (v /= 16**i) stop 6 + end do + end program p +! { dg-final { scan-tree-dump-not "_gfortran_pow" "original" } } Index: Fortran/gfortran/regression/power_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/power_8.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR88579 - Test optimizations for bases that are powers of 2 or -2. +program p + implicit none + integer(4) :: i, u + integer(1) :: j, v + integer(2) :: k, w + integer(8) :: z + ! Test selected positive bases + u = 1 + do i=1,5 + u = u * 64_4 + if (u /= 64_4 ** i) stop 1 + end do + z = 1 + do i=1,7 + z = z * 256_8 + if (z /= 256_8 ** i) stop 2 + end do + z = 1 + do i=1,3 + z = z * 65536_8 + if (z /= 65536_8 ** i) stop 3 + end do + ! Test selected negative bases and integer kind combinations + u = 1 + do i=1,7 + u = u * (-2_1) + if (u /= (-2_1) ** i) stop 4 + end do + v = 1 + do j=1,7 + v = v * (-2_1) + if (v /= (-2_1) ** j) stop 5 + end do + v = 1 + do k=1,7 + v = v * (-2_1) + if (v /= (-2_1) ** k) stop 6 + end do + w = 1 + do k=1,7 + w = w * (-4_2) + if (w /= (-4_2) ** k) stop 7 + end do + w = 1 + do i=1,5 + w = w * (-8_2) + if (w /= (-8_2) ** i) stop 8 + end do + u = 1 + do i=1,1 + u = u * (-HUGE(1_4)/2-1) + if (u /= (-HUGE(1_4)/2-1) ** i) stop 9 + end do + z = 1 + do i=1,7 + z = z * (-512_8) + if (z /= (-512_8) ** i) stop 10 + end do +end program p +! { dg-final { scan-tree-dump-not "_gfortran_pow" "original" } } Index: Fortran/gfortran/regression/pr100154.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr100154.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR100154 - ICE in gfc_conv_procedure_call, at fortran/trans-expr.c:6131 + +program p + implicit none + integer :: n + character, target :: c + character(len=0) :: c0 + character(len=:), allocatable :: cc + n = fget(cc) + n = fget('a') ! { dg-error "must be a variable" } + n = fget(c0) ! { dg-error "must have length at least 1" } + call fget('x') ! { dg-error "must be a variable" } + n = fgetc(5,'a') ! { dg-error "must be a variable" } + call fgetc(5,c0) ! { dg-error "must have length at least 1" } + call fgetc(5,c,1) ! { dg-error "must be a variable" } + call fputc(5,'x',1) ! { dg-error "must be a variable" } + n = fget (ptr_returning_func()) + print *, c +contains + function ptr_returning_func () result (res) + character, pointer :: res + res => c + end +end Index: Fortran/gfortran/regression/pr100551.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr100551.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR fortran/100551 - Passing return value to class(*) dummy argument + +program p + implicit none + integer :: result + result = 1 + result = test ( (result)) ! works + if (result /= 1) stop 1 + result = test (int (result)) ! issue 1 +! write(*,*) result + if (result /= 1) stop 2 + result = test (f (result)) ! issue 2 +! write(*,*) result + if (result /= 2) stop 3 +contains + integer function test(x) + class(*), intent(in) :: x + select type (x) + type is (integer) + test = x + class default + test = -1 + end select + end function test + integer function f(x) + integer, intent(in) :: x + f = 2*x + end function f +end program Index: Fortran/gfortran/regression/pr100949.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr100949.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/100949 - ICE in gfc_conv_expr_present, at fortran/trans-expr.c:1975 + +subroutine s +entry f + type t + end type + class(t), allocatable :: y, z + allocate (z, mold=y) +end Index: Fortran/gfortran/regression/pr100950.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr100950.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/100950 - ICE in output_constructor_regular_field, at varasm.c:5514 + +program p + character(8), parameter :: u = "123" + character(8) :: x = "", s + character(2) :: w(2) = [character(len(x(3:4))) :: 'a','b' ] + character(*), parameter :: y(*) = [character(len(u(3:4))) :: 'a','b' ] + character(*), parameter :: z(*) = [character(len(x(3:4))) :: 'a','b' ] + character(*), parameter :: t(*) = [character(len(x( :2))) :: 'a','b' ] + character(*), parameter :: v(*) = [character(len(x(7: ))) :: 'a','b' ] + type t_ + character(len=5) :: s + character(len=8) :: t(4) + character(len=8), pointer :: u(:) + character(len=:), allocatable :: str + character(len=:), allocatable :: str2(:) + end type t_ + type(t_) :: q, r(1) + integer, parameter :: lq = len (q%s(3:4)), lr = len (r%s(3:4)) + integer, parameter :: l1 = len (q %t(1)(3:4)) + integer, parameter :: l2 = len (q %t(:)(3:4)) + integer, parameter :: l3 = len (q %str (3:4)) + integer, parameter :: l4 = len (r(:)%t(1)(3:4)) + integer, parameter :: l5 = len (r(1)%t(:)(3:4)) + integer, parameter :: l6 = len (r(1)%str (3:4)) + integer, parameter :: l7 = len (r(1)%str2(1)(3:4)) + integer, parameter :: l8 = len (r(1)%str2(:)(3:4)) + + if (len (y) /= 2) stop 1 + if (len (z) /= 2) stop 2 + if (any (w /= y)) stop 3 + if (len ([character(len(u(3:4))) :: 'a','b' ]) /= 2) stop 4 + if (len ([character(len(x(3:4))) :: 'a','b' ]) /= 2) stop 5 + if (any ([character(len(x(3:4))) :: 'a','b' ] /= y)) stop 6 + write(s,*) [character(len(x(3:4))) :: 'a','b' ] + if (s /= " a b ") stop 7 + if (len (t) /= 2) stop 8 + if (len (v) /= 2) stop 9 + if (lq /= 2 .or. lr /= 2) stop 10 + if (l1 /= 2 .or. l2 /= 2 .or. l4 /= 2 .or. l5 /= 2) stop 11 + if (l3 /= 2 .or. l6 /= 2 .or. l7 /= 2 .or. l8 /= 2) stop 12 + + block + integer, parameter :: l9 = len (r(1)%u(:)(3:4)) + if (l9 /= 2) stop 13 + end block + + call sub (42, "abcde") +contains + subroutine sub (m, c) + integer, intent(in) :: m + character(len=*), intent(in) :: c + character(len=m) :: p, o(3) + integer, parameter :: l10 = len (p(6:7)) + integer, parameter :: l11 = len (o(:)(6:7)) + integer, parameter :: l12 = len (c(2:3)) + if (l10 /= 2 .or. l11 /= 2 .or. l12 /= 2) stop 14 + end subroutine sub +end + +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 2 "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(3, 0\\);" "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(7, 0\\);" "original" } } Index: Fortran/gfortran/regression/pr101026.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101026.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Ofast -frounding-math" } + SUBROUTINE PASSB4 (CC,CH) + DIMENSION CC(IDO,4,L1), CH(IDO,L1,*) + DO 103 I=2,IDO,2 + TI4 = CC0-CC(I,4,K) + CI4 = TI1-TI4 + CH(I-1,K,4) = CI4 + CH(I,K,4) = CI4 + 103 CONTINUE + END Index: Fortran/gfortran/regression/pr101121.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101121.f @@ -0,0 +1,203 @@ +! { dg-do compile } +! { dg-options "-Ofast -std=legacy" } +! { dg-additional-options "-march=haswell" { target x86_64-*-* i?86-*-* } } + COMMON /JMSG80/ PI4,PIF,P120,R12,P340,R34,FCS(4,3),E34MAX, + 7 IJSAME,KLSAME,IKSMJL + DIMENSION P1(3),FQ(0:5),F1(0:4),F2(0:4),WS(8),WP(8) + DIMENSION VEA(12),VES(9),WES(6) + DIMENSION T(0:20),U(0:20) + DIMENSION T3R(6,3,3,3),T9B(0:20,3,3,3) + DIMENSION F5X(0:12,3,3,3),F6X(0: 6,3,3,3,3) + DIMENSION A31(0:3,0:3),C31(2,0:3),A32(0:3,0:3),C32(2,0:3) + DIMENSION A41(0:3,0:3),C41(2,0:3),A42(0:3,0:3),C42(2,0:3) + DIMENSION A33(16),FIJ00(2),A43(16),FI0K0(2) + DIMENSION SEJJK0( 3),A54(16, 3),C54(2, 3) + DIMENSION A56(0:22,3,0:3),C56(2,0:3) + DIMENSION A60(0:3,0:3),C60(2,0:3),A61(0:3,0:3),C61(2,0:3) + DIMENSION A62(16),FI00L(2),A63(16),F0J0L(2) + DIMENSION A64(0:3,0:3),C64(2, 3),A65(0:3,0:3),C65(2, 3) + DIMENSION A69(0:3, 3),C69(2,0:3),A70(0:3, 3),C70(2,0:3) + DIMENSION A71(18, 3),C71(2, 3) + DIMENSION A72(18, 3),C72(2, 3) + DIMENSION A73(18,0:3),C73(2,0:3) + DIMENSION SE0LKL( 3),A75(16,3),C75(2,0:3) + DIMENSION SE0JLL( 3),A76(16,3),C76(2,0:3) + DIMENSION A77(0:25,3,0:3),C77(2,0:3),A78(0:31,3,0:3),C78(2,0:3) + DIMENSION A79(0:31,3,0:3),C79(2,0:3) + DIMENSION A80(0: 2,2),A81(0:24,3),A82(0:31,2),A83(0:22,2) + DIMENSION A84(0:13,2),A85(0:13,2),A86(0: 6) + DIMENSION S4(0:14),Q4(0:4),FIJKL(2) + IF(XVA.LT.CUG) THEN + ENDIF + F1(M)= FQ0*TMP + F2(M)= FQ0*TMP + XX1=-X12*X43 + IF(JI.EQ.1) THEN + DO 255 J=1,3 + 255 CONTINUE + DO 268 K=1,3 + SEJJK00= E0+E(2,2,K,0)+E(3,3,K,0) + A54( 5,K)= A540 + 268 CONTINUE + 297 F5X(3+M,I,I,I)=-R3(M,I,I,I) + DO 299 J=1,3 + F5X(3+M,I,I,J)=-R3(M,J,I,I) + 299 CONTINUE + DO 300 L=0,M56 + DO 300 M=1,3 + 300 A56(N,M,L)= ZER + A60(2,L)= A600+P34(I,3)*E(I,0,0,L) + A61(0,L)= A610+D1I *E(L,0,0,I) + A61(1,L)= A610+P12(I,3)*E(L,0,0,I) + SEL00L= E(1,0,0,1)+E(2,0,0,2)+E(3,0,0,3) + IF(I.NE.J) THEN + K=6-I-J + F6X(0,J,I,I,I)= ZER + F6X(0,I,J,I,I)= ZER + F6X(0,I,I,J,I)= ZER + F6X(0,I,I,I,J)= ZER + F6X(M,I,I,K,J)= R2(M,K,J) + ENDIF + 391 A82( M,N)= ZER + 392 A83( M,N)= ZER + A84(M,N)= ZER + A85(M,N)= ZER + 397 A86( M)= ZER + DO 399 K=1,3 + DO 399 J=1,3 + DO 398 M=1,6 + T9B(M+ 2,I,J,K)= T3R0 + T9B(M+ 8,I,J,K)= T1R(M,I,J,K) + T9B(M+14,I,J,K)= T3R0 + 398 CONTINUE + 399 CONTINUE + 417 A77( M,3,K)= A770+F5X0*GEIJKL + 445 A81( M,3) = A81( M,3)+T( M)*TMP + IF(K.EQ.L)A81( 5,3)=A81( 5,3)+TMP + IF(I.EQ.J) THEN + DO 447 M=6,11 + 447 A81( M,3) = A81( M,3)+T( M)*GEIJKL + ENDIF + ENDIF + IF(LK.EQ.1) THEN + IF(JTYPE.NE.4) THEN + DO 510 J=0,3 + A31(3,J)= A310+ A310*Y02 + A32(3,J)= A320+ A320*Y02 + 510 CONTINUE + A33( 6)=-AEIJ00*Y1Y+T01 + A33( 7)= A330-0*Y01+T01 + A33( 8)= A330- A330*Y01 + A33(15)= A330+0*Y02 + A33(16)= A330+ A330*Y02 + ENDIF + A84(12,N)= A84( 7,N)+ A84( 8,N)*Y02 + A84(13,N)= A84( 9,N) + A85(10,2)= A85(10,2)- A85(10,1)+ A850 + A85(11,2)= A85(11,2)- A85(11,1)+ A850 + A85(12,2)= A85(12,2)- A85(12,1)+ A850 + A85(13,2)= A85(13,2)- A85(13,1) + Q4(0)= S4( 0)+(S4( 1)+(S4( 2)+(S4( 3)+S4( 4)*Y02)*Y02)*Y02)*Y02 + Q4(1)= S4( 5)+(S4( 6)+(S4( 7)+ S4( 8)*Y02)*Y02)*Y02 + Q4(2)= S4( 9)+(S4(10)+ S4(11)*Y02)*Y02 + Q4(3)= S4(12)+ S4(13)*Y02 + Q4(4)= S4(14) + ENDIF + IF(JTYPE.NE.4) THEN + ENDIF + C42(1,M)= T0*F10-T0*F10 + C42(2,M)= T0*F20-T0*F20 + T(1)= T01+(A43( 4)- A43( 5)*Y04)*Y04 + F0J0L(2)= T(0)*F20-T0*F20+T(2)*F20 + DO 660 N=1,3 + T(0)= A64(3,N)- A64(0,N)- A64(1,N) + T(1)= A640- A640*Y04 + C64(1,N)= T0*F10-T0*F10 + C64(2,N)= T0*F20-T0*F2(1) + C65(1,N)= T0*F10-T0*F10 + C65(2,N)= T0*F20-T0*F2(1) + C70(2,N)= T0*F20-T0*F20 + T(2)=(A71(17,N)-(A71(18,N)- A71(16,N)*Y04)*Y04)*XX1 + C71(1,N)= T0*F10-T0*F10+T0*F10 + C71(2,N)= T0*F20-T0*F20+T0*F20 + T(1)=(A720+ A720- A720-T0)*XX1 + C72(1,N)= T0*F10-T0*F10+T0*F10 + C75(1,N)= T(0)*F10-T0*F1(1)+T(2)*F1(2) + C75(2,N)= T(0)*F20-T0*F2(1)+T(2)*F2(2) + T01 = A76( 6,N)*XX1 + T(1)=(T01- A760-(A760- A76( 7,N)- A76( 8,N) + 2 -(A760+ A76( 3,N))*Y04)*Y04)*XX1 + 660 CONTINUE + C73(2,M)= T0*F20+T0*F20+T(2)*F20 + 2 +(A77(23,1,M)+ A77(24,1,M)*Y04)*Y03 + T(2)=(A77(21,2,M)+(A77(22,2,M)+ A77(23,2,M)*Y04)*Y04)*XX1 + 2 -(A77(24,2,M)-(A77(25,2,M)+ A77(20,2,M)*Y04)*Y04)*Y03 + T(3)=(A77(21,3,M)+(A77(22,3,M)+(A77(23,3,M) + 2 + A77(24,3,M)*Y04)*Y04)*Y04)*XX1 + C77(1,M)= T0*F10-T0*F10-T0*F10+T0*F10 + C77(2,M)= T(0)*F20-T(1)*F20-T(2)*F20+T(3)*F20 + T(0)=(A780+ A78(24,1,M))*Y3Y+ A780*XX1 + T(1)=(A78(23,1,M)+(A78(21,1,M)+A78(22,1,M)*Y04)*Y04)*XX1 + 2 +(A78(25,1,M)+ A78(26,1,M)*Y04)*Y3Y- A78(27,1,M)*XX2 + T(2)=(A78(21,2,M)+(A78(22,2,M)+ A78(28,2,M)*Y04)*Y04)*XX2 + 2 +(A78(23,2,M)-(A78(24,2,M)+ A78(25,2,M)*Y04)*Y04)*XX1 + 3 -(A78(29,2,M)-(A78(30,2,M)+ A78(31,2,M)*Y04)*Y04)*Y41 + T(3)=(A78(21,3,M)+(A78(22,3,M)+(A78(23,3,M) + 2 + A78(24,3,M)*Y04)*Y04)*Y04)*XX2 + C78(1,M)= T0*F10-T0*F1(1)-T(2)*F1(2)+T(3)*F1(3) + C78(2,M)= T(0)*F2(0)-T(1)*F2(1)-T(2)*F2(2)+T(3)*F2(3) + T(0)=-A79(24,1,M)*Y3Y+ A79(30,1,M)*H43 + T(1)=(A79(21,1,M)-(A79(23,1,M)+ A79(22,1,M)*Y04)*Y04)*XX1 + 2 +(A79(25,1,M)+ A79(26,1,M)*Y04)*Y3Y- A79(29,1,M)*XX2 + T(2)=(A79(21,2,M)+(A79(22,2,M)- A79(28,2,M)*Y04)*Y04)*XX2 + 2 +(A79(23,2,M)-(A79(24,2,M)+ A79(25,2,M)*Y04)*Y04)*XX1 + 3 -(A79(29,2,M)-(A79(30,2,M)+ A79(31,2,M)*Y04)*Y04)*Y41 + T(3)=(A79(21,3,M)+(A79(22,3,M)+(A79(23,3,M) + 2 + A79(24,3,M)*Y04)*Y04)*Y04)*XX2 + C79(1,M)= T(0)*F1(0)-T(1)*F1(1)-T(2)*F1(2)+T(3)*F1(3) + C79(2,M)= T(0)*F2(0)-T(1)*F2(1)-T(2)*F2(2)+T(3)*F2(3) + T(0)= A80( 2,1)*Y3Y+ A80( 2,2)*H43 + T(1)=(A81(16,1)+(A81(14,1)+A81(15,1)*Y04)*Y04)*XX1 + 2 +(A81(18,1)+ A81(19,1)*Y04)*Y3Y- A81(20,1)*XX2 + T(2)=(A82(21,1)+(A82(22,1)+ A82(28,1)*Y04)*Y04)*XX2 + 2 +(A82(23,1)-(A82(24,1)+ A82(25,1)*Y04)*Y04)*XX1 + 3 +(A83(15,2)+(A83(16,2)+ A82(31,1)*Y04)*Y04)*Y41 + 4 -(A83(17,2)-(A83(18,2)- A83(19,2)*Y04)*Y04)*Y3Y + T(3)=(A84(10,1)+(A84(11,1)+(A84(12,1)+A84(13,1)*Y04)*Y04)*Y04)*XX2 + 2 +(A85(10,1)+(A85(10,2)+(A85(11,2)+(A85(12,2) + 3 + A85(13,2)*Y04)*Y04)*Y04)*Y04)*XX1 + T(4)=(Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*Y04)*Y04)*Y04)*Y04)*XX2 + FIJKL(1)= T(0)*F1(0)-T(1)*F1(1)-T(2)*F1(2)+T(3)*F1(3)+T(4)*F1(4) + FIJKL(2)= T(0)*F2(0)-T(1)*F2(1)-T(2)*F2(2)+T(3)*F2(3)+T(4)*F2(4) + DO 800 ICP=1,2 + VE0= VE0+C61(ICP,0)*WP(1)+FI00L(ICP)*WP(2) + 2 +F0J0L(ICP)*WP(3)+C77(ICP,0)*WP(4) + 3 +C73(ICP,0)*WP(5)+C78(ICP,0)*WP(6) + 4 +C79(ICP,0)*WP(7)+FIJKL(ICP)*WP(8) + IF(ICP.EQ.1) THEN + DO 720 M=1,3 + VES( M)= VES( M)+VEA( M) + VES(3+M)= VES(3+M)+VEA(3+M) + T01 = VEA(6+M) + T02 = VEA(9+M) + WES( M)=-T01+(T01+T02)*Y03 + 720 CONTINUE + FE1= X24*VE0 + DO 730 M=1,3 + T01 = VEA( M)+VEA(3+M) + T02 = VEA(6+M)+VEA(9+M) + WES(3+M)=-T01+(T01+T02)*Z02 + 730 CONTINUE + ENDIF + 800 CONTINUE + WES( M)= WES( M)+P34(M,3)*FE0 + WES(3+M)= WES(3+M)-P1(M)*FE1 + VES(6+M)= VES(6+M)+WES(3+M) + FCS(3,M)= FCS(3,M)-WES(3+M)*Y03+WES( M) + DO 925 M=1,3 + T01= VES( M) + T02= VES(3+M)+VES(6+M) + T01=-T01+(T01+T02)*Y01+P12(M,3)*TMP + FCS(2,M)= FCS(2,M)-T01+VES(6+M) + 925 CONTINUE + END Index: Fortran/gfortran/regression/pr101158.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101158.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-O1 -ftree-slp-vectorize -fwrapv" } +! { dg-additional-options "-march=armv8-a+sve" { target aarch64-*-* } } + +subroutine sprpl5 (left) + implicit none + + integer :: left + integer :: avail1, avail2, delx1, delx2, i2, ic + + ic = left + delx1 = ic / 2 + delx2 = delx1 + 1 + i2 = ic + delx2 + avail1 = i2 + avail2 = 1 + + do delx1 = 1, 2 + ic = left + nint (real (left) / 2) + if (ic .ge. avail1) avail1 = ic + 1 + + i2 = ic + delx2 + if (i2 .le. avail2) avail2 = i2 + 1 + end do +end subroutine sprpl5 Index: Fortran/gfortran/regression/pr101264.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101264.f90 @@ -0,0 +1,94 @@ +! { dg-do compile } +! { dg-options "-Ofast" } + SUBROUTINE foo (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,la) + IMPLICIT NONE (type, external) + INTEGER, PARAMETER :: wp = 8 + INTEGER, PARAMETER :: iwp = 4 + INTEGER(iwp) :: inc1 + INTEGER(iwp) :: inc2 + INTEGER(iwp) :: inc3 + INTEGER(iwp) :: inc4 + INTEGER(iwp) :: la + INTEGER(iwp) :: lot + INTEGER(iwp) :: n + + REAL(wp) :: a(*) + REAL(wp) :: b(*) + REAL(wp) :: c(*) + REAL(wp) :: d(*) + REAL(wp) :: trigs(*) + + REAL(wp) :: c1 + REAL(wp) :: c2 + REAL(wp) :: s1 + REAL(wp) :: s2 + REAL(wp) :: sin60 + + INTEGER(iwp) :: i + INTEGER(iwp) :: ia + INTEGER(iwp) :: ib + INTEGER(iwp) :: ibase + INTEGER(iwp) :: ic + INTEGER(iwp) :: iink + INTEGER(iwp) :: ijk + INTEGER(iwp) :: j + INTEGER(iwp) :: ja + INTEGER(iwp) :: jb + INTEGER(iwp) :: jbase + INTEGER(iwp) :: jc + INTEGER(iwp) :: jink + INTEGER(iwp) :: jump + INTEGER(iwp) :: k + INTEGER(iwp) :: kb + INTEGER(iwp) :: kc + INTEGER(iwp) :: kstop + INTEGER(iwp) :: l + INTEGER(iwp) :: m + + sin60=0.866025403784437_wp + + ia = 1 + ib = ia + (2*m-la)*inc1 + ic = ib + ja = 1 + jb = ja + jink + jc = jb + jink + + DO k = la, kstop, la + kb = k + k + kc = kb + kb + c1 = trigs(kb+1) + s1 = trigs(kb+2) + c2 = trigs(kc+1) + s2 = trigs(kc+2) + ibase = 0 + DO l = 1, la + i = ibase + j = jbase + DO ijk = 1, lot + c(ja+j) = a(ia+i) + (a(ib+i)+a(ic+i)) + d(ja+j) = b(ia+i) + (b(ib+i)-b(ic+i)) + c(jb+j) = c1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ & + & b(ic+i)))) & + & - s1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- & + & a(ic+i)))) + d(jb+j) = s1*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)+ & + & b(ic+i)))) & + & + c1*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))+(sin60*(a(ib+i)- & + & a(ic+i)))) + c(jc+j) = c2*((a(ia+i)-0.5_wp*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)+ & + & b(ic+i)))) & + & - s2*((b(ia+i)-0.5_wp*(b(ib+i)-b(ic+i)))-(sin60*(a(ib+i)- & + & a(ic+i)))) + i = i + inc3 + j = j + inc4 + END DO + ibase = ibase + inc1 + jbase = jbase + inc2 + END DO + ia = ia + iink + ib = ib + iink + ic = ic - iink + jbase = jbase + jump + END DO + END Index: Fortran/gfortran/regression/pr101267.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101267.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +! { dg-additional-options "-march=znver2" { target x86_64-*-* i?86-*-* } } + SUBROUTINE sfddagd( regime, znt,ite ,jte ) + REAL, DIMENSION( ime, IN) :: regime, znt + REAL, DIMENSION( ite, jte) :: wndcor_u + LOGICAL wrf_dm_on_monitor + IF( int4 == 1 ) THEN + DO j=jts,jtf + DO i=itsu,itf + reg = regime(i, j) + IF( reg > 10.0 ) THEN + znt0 = znt(i-1, j) + znt(i, j) + IF( znt0 <= 0.2) THEN + wndcor_u(i,j) = 0.2 + ENDIF + ENDIF + ENDDO + ENDDO + IF ( wrf_dm_on_monitor()) THEN + ENDIF + ENDIF + END Index: Fortran/gfortran/regression/pr101327.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101327.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/101327 - ICE in find_array_element, at fortran/expr.c:1355 + +subroutine s + integer, parameter :: n([2]) = [1, 2] ! { dg-error "must be scalar" } + type t + integer :: a(n(1):n(2)) + end type +end + +! { dg-error "cannot be automatic or of deferred shape" " " { target *-*-* } 5 } Index: Fortran/gfortran/regression/pr101329.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101329.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/101329 - ICE: Invalid expression in gfc_element_size + +program p + use iso_c_binding + implicit none + integer(c_int), pointer :: ip4 + integer(c_int64_t), pointer :: ip8 + print *, c_sizeof (c_null_ptr) ! valid + print *, c_sizeof (null ()) ! { dg-error "is not interoperable" } + print *, c_sizeof (null (ip4)) ! { dg-error "is not interoperable" } + print *, c_sizeof (null (ip8)) ! { dg-error "is not interoperable" } +end Index: Fortran/gfortran/regression/pr101514.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101514.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR fortran/101514 - ICE: out of memory allocating ... bytes + +subroutine s + type t1 + integer :: a(..) ! { dg-error "must have an explicit shape" } + end type + type t2 + integer :: a(*) ! { dg-error "must have an explicit shape" } + end type + type t3 + integer :: a(:) ! { dg-error "must have an explicit shape" } + end type + type t4 + integer :: a(0:) ! { dg-error "must have an explicit shape" } + end type + type t5 + integer, allocatable :: a(:) + end type + type t6 + integer, pointer :: a(:) + end type + type(t1) :: a1 + type(t2) :: a2 + type(t3) :: a3 + type(t4) :: a4 + type(t5) :: a5 + type(t6) :: a6 + a1 = transfer(1, a1) + a2 = transfer(1, a2) + a3 = transfer(1, a3) + a4 = transfer(1, a4) + a5 = transfer(1, a5) + a6 = transfer(1, a6) +end Index: Fortran/gfortran/regression/pr101536.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101536.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/101536 - ICE in gfc_conv_expr_descriptor + +program p + type s + class(*), allocatable :: c + end type + type t + class(*), allocatable :: c(:) + end type t + type u + integer :: c(2) + end type + type(t) :: x + x%c = [1,2,3,4] +! print *, size (x) + print *, size (x%c) + print *, size (x%c(1)) ! { dg-error "must be an array" } +contains + integer function f(x, y, z) + class(t), allocatable :: x(:) + class(u) :: y(:) + class(s) :: z + f = size (x) + f = size (x(1)) ! { dg-error "must be an array" } + f = size (y) + f = size (y%c(1)) + f = size (y(2)%c) + f = size (y(2)%c(1)) ! { dg-error "must be an array" } + f = size (z) ! { dg-error "must be an array" } + f = size (z% c) ! { dg-error "must be an array" } + end +end Index: Fortran/gfortran/regression/pr101762.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr101762.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/101762 - ICE on non-constant pointer initialization targets +! Contributed by G.Steinmetz + +program p + integer, target :: a(3) = [7, 8, 9] + integer, pointer :: x => a(3) + integer, pointer :: y => a(n()) ! { dg-error "constant expression" } + integer, pointer :: z(:) => a(:n()) ! { dg-error "constant expression" } + character(7), target :: c = "abcdefg" + character(3), pointer :: c0 => c(2:4) + character(3), pointer :: c1 => c(m():) ! { dg-error "constant expression" } + character(3), pointer :: c2 => c(:m()) ! { dg-error "constant expression" } + print *, x, y +contains + pure integer function k () + k = 2 + end function k + subroutine s () + integer, pointer :: yy => a(k()) ! { dg-error "constant expression" } + print *, yy + end subroutine s +end Index: Fortran/gfortran/regression/pr102180.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102180.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/102180 - Improve checking of assumed size array spec + +subroutine s(x,y) + real :: x(0:*) ! legal + real :: y[0:*] ! legal +end + +subroutine t(x,y) + real :: x(:*) ! { dg-error "A lower bound must precede colon" } + real :: y[:*] ! { dg-error "A lower bound must precede colon" } +end + +subroutine u(x,y,z) + real :: x(2,*) + real :: y(2,2:*) + real :: z(2,:*) ! { dg-error "A lower bound must precede colon" } +end Index: Fortran/gfortran/regression/pr102332.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102332.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! PR fortran/102332 - ICE in select_type_set_tmp +! Contributed by G.Steinmetz + +program p + type t + real :: a, b + end type + class(t), allocatable :: x ! Valid + select type (y => x) + type is (t) + y%a = 0 + end select +end + +subroutine s0 (x) + type t + real :: a, b + end type + class(t) :: x ! Valid + select type (y => x) + type is (t) + y%a = 0 + end select +end + +subroutine s1 + type t + real :: a, b + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + type is (t) + y%a = 0 + end select +end + +subroutine s3 + type t + real :: a, b + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + class is (t) + y%a = 0 + end select +end + +subroutine s2 + type t + real :: a, b + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + type default ! { dg-error "Expected" } + y%a = 0 + end select +end + +subroutine s4 + type t + real :: a, b + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + class default + y%a = 0 + end select +end Index: Fortran/gfortran/regression/pr102366.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102366.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -Wall" } +! { dg-final { scan-tree-dump-times "static real" 1 "original" } } +! PR fortran/102366 - large arrays no longer become static + +program p + real(kind=4) :: a(16776325) + a=1.0 +end Index: Fortran/gfortran/regression/pr102458.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102458.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/102458 - standard intrinsics excluded in constant expressions + +subroutine s1 + integer :: a(command_argument_count()) = 1 ! { dg-error "Automatic array" } + print *, a +end + +program p + block + integer :: a(get_team()) = 1 ! { dg-error "Automatic array" } + print *, a + end block +end + +subroutine s2 + integer :: a(num_images()) = 1 ! { dg-error "Automatic array" } + print *, a +end + +function f() + block + integer :: a(team_number()) = 0 ! { dg-error "Automatic array" } + a = 1 + end block +end + +subroutine s3 + integer :: a(this_image()) = 1 ! { dg-error "Automatic array" } + print *, a +end + +subroutine s4 + integer, parameter :: n = 4 + integer, parameter :: x(transfer(n, n)) = 1 ! legal + integer :: y(transfer(n, n)) = 2 ! legal + integer, parameter :: k = size (x) ! ok +! integer, parameter :: m = size (y) ! fails, tracked separately + print *, k, x, y + if (k /= size (y)) stop 1 +end Index: Fortran/gfortran/regression/pr102458b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102458b.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 0 "original" } } +! PR fortran/102458 + +subroutine s4 + integer, parameter :: n = 4 + integer :: w(transfer(n, n)) = 1 + integer :: x(transfer(n, n)) + integer :: y(2*int(n) - n) + type t + integer :: z(int(n)) + end type t + type(t) :: tt, uu(3) + integer, parameter :: i = size (w) + integer, parameter :: k = size (x) + integer, parameter :: m = size (y) + integer, parameter :: j = size (tt% z) + integer, parameter :: l = size (uu(2)% z) + if (i /= n .or. k /= n .or. m /= n .or. j /= n .or. l /= n) stop 1 +end Index: Fortran/gfortran/regression/pr102520.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102520.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/102520 - ICE in expand_constructor, at fortran/array.c:1802 + +program p + type t + end type + type(t), parameter :: a(4) = shape(1) ! { dg-error "Incompatible" } + type(t), parameter :: b(2,2) = reshape(a,[2,2]) ! { dg-error "must be an array" } + type(t), parameter :: c(2,2) = transpose(b) ! { dg-error "must be of rank 2" } +end Index: Fortran/gfortran/regression/pr102685.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102685.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/102685 + +program p + type t + integer :: a(2) + end type + type(t), parameter :: x0 = t([2]) ! { dg-error "shape of component" } + type(t), parameter :: x1(2) = t([2]) ! { dg-error "shape of component" } + type(t), parameter :: x(2) = t([integer::]) ! { dg-error "shape of component" } + + type u + integer :: a + integer :: b(0) + end type + type(u), parameter :: z0(2) = u(1, [integer::]) ! valid + type(u), parameter :: z1 = u(1, 2 ) ! valid + type(u), parameter :: z2(2) = u(1, 2 ) ! valid + type(u), parameter :: z3 = u(1, [2]) ! { dg-error "shape of component" } + type(u), parameter :: z4(2) = u(1, [2]) ! { dg-error "shape of component" } + + type v + integer :: a(2,1) + end type + type(v), parameter :: y0 = v(reshape([1,2],[2,1])) ! valid + type(v), parameter :: y1 = v(reshape([1,2],[1,2])) ! { dg-error "shape of component" } + type(v), parameter :: y(1) = v(reshape([1,2],[1,2])) ! { dg-error "shape of component" } + + print *, x0,x,x1,y0,y1,y,z0,z1,z2,z3,z4 +end Index: Fortran/gfortran/regression/pr102715.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102715.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/102715 - ICE in gfc_simplify_transpose + +program p + type t + end type + type(t), parameter :: a(4) = t() + type(t), parameter :: b(2,2) = reshape(a, [2]) ! { dg-error "Rank mismatch" } + type(t), parameter :: c(2,2) = transpose(b) ! { dg-error "must be of rank 2" } + type(t), parameter :: s2(*) = b(2,:) ! { dg-error "Syntax error" } + type(t), parameter :: x(*,*) = reshape(a, [2]) ! { dg-error "Rank mismatch" } + type(t), parameter :: s3(*) = x(2,:) ! { dg-error "Syntax error" } +end Index: Fortran/gfortran/regression/pr102816.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102816.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/102816 + +program p + type t + integer :: a([2]) ! { dg-error "must be scalar" } + end type + type(t) :: x = t([3, 4]) ! { dg-error "Bad array spec of component" } +end Index: Fortran/gfortran/regression/pr102817.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102817.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/102817 - ICE in gfc_clear_shape + +program test + type t + integer :: a(1,2) = 3 + end type t + type(t), parameter :: u = t(4) + type(t), parameter :: x(1) = t(4) + integer, parameter :: p(1,2) = (x(1)%a) + integer :: z(1,2) = (x(1)%a) + integer :: y(1,2), v(1,2), w(1,2) + v = (u %a) + w = x(1)%a + y = (x(1)%a) + print *, v, w, y, z, p +end Index: Fortran/gfortran/regression/pr102860.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr102860.f90 @@ -0,0 +1,9 @@ +! PR middle-end/102860 +! { dg-do compile { target { powerpc*-*-* } } } +! { dg-require-effective-target powerpc_vsx_ok } +! { dg-options "-O2 -mdejagnu-cpu=power10" } + +function foo(a) + integer(kind=4) :: a(1024) + a(:) = modulo (a(:), 39) +end function Index: Fortran/gfortran/regression/pr103258.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103258.f90 @@ -0,0 +1,14 @@ +! { dg-do compile} +! { dg-additional-options "-Wno-pedantic" } +! +! Test from PR103258. This used to ICE due to incorrectly marking the +! no-implicit-type error for n and m in the character length expression +! as already diagnosed during early resolution, when in fact errors are +! ignored in that parsing context. We now expect the errors to be diagnosed +! at the point of the first use of each symbol. + +subroutine s(n) ! { dg-error "Symbol 'n' .*has no IMPLICIT type" } +implicit none +character(n+m) :: c ! { dg-error "Symbol 'm' .*has no IMPLICIT type" } +entry e(m) +end Index: Fortran/gfortran/regression/pr103259.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103259.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/103259 - ICE in resolve_common_vars +! Contributed by G.Steinmetz + +module m + integer :: p + common /c/ p +end +program p ! { dg-error "cannot appear in a COMMON block" } + use m ! { dg-error "is also the name of the current program unit" } +end Index: Fortran/gfortran/regression/pr103286.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103286.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "std=gnu" } +! PR fortran/103286 - ICE in resolve_select + +program p + select case (.true.) ! { dg-warning "Extension: Conversion" } + case (1_8) + case (:0) ! { dg-error "Logical range in CASE statement" } + case (2:) ! { dg-error "Logical range in CASE statement" } + end select +end Index: Fortran/gfortran/regression/pr103366.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103366.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! Test the fix for PR103366. +! +! Contributed by Gerhardt Steinmetz +! +program p + call u([1]) +contains + subroutine s(x) bind(c) + type(*) :: x(..) + end + subroutine u(x) + class(*) :: x(..) + call s(x) ! Used to ICE here + end +end Index: Fortran/gfortran/regression/pr103475.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103475.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -Wall" } +! PR fortran/103475 - ICE in gfc_expr_attr +! Contributed by G.Steinmetz + +program p + type t + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + y = x() ! { dg-error "Cannot convert invalid class" } +end Index: Fortran/gfortran/regression/pr103504.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103504.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! PR fortran/103504 - ICE in get_sym_storage_size, at fortran/interface.c:2800 +! Contributed by G.Steinmetz + +program p + implicit none + real :: y(1) + character :: b + call s(y) + call t(y) + call u(y) + call c(b) +contains + subroutine s(x) + real :: x(abs(1.):1) ! { dg-error "must be of INTEGER type" } + end + subroutine t(x) + real :: x(abs(1.):1) ! { dg-error "must be of INTEGER type" } + end + subroutine u(x) + real :: x(1:abs(1.)) ! { dg-error "must be of INTEGER type" } + end + subroutine c(z) + character(len=abs(1.)) :: z ! { dg-error "must be of INTEGER type" } + end subroutine c +end + +! { dg-prune-output "must be of INTEGER type" } Index: Fortran/gfortran/regression/pr103505.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103505.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/103505 - this used to ICE in compare_bound_mpz_t +! Testcase by G.Steinmetz + +program p + integer, parameter :: a((2.)) = [4,8] ! { dg-error "INTEGER type" } + integer, parameter :: z(1:(2.)) = [4,8] ! { dg-error "INTEGER type" } + print *, a(1:1) +end + +! { dg-prune-output "Parameter array" } Index: Fortran/gfortran/regression/pr103506_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103506_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR103506 ICE in gfc_free_namespace. ice-on-invalid +! Test case from the PR. +module m ! { dg-error "is already being used as a MODULE" } +stop ! { dg-error "Unexpected STOP statement in MODULE" } +end +program p +call m ! { dg-error "is already being used as a MODULE" } +end Index: Fortran/gfortran/regression/pr103588.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103588.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/103588 - ICE: Simplification error in gfc_ref_dimen_size +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = [1,2] ! { dg-error "cannot be automatic or of deferred shape" } + integer :: b(2) = a(::a(1)) ! { dg-error "Invalid" } +end Index: Fortran/gfortran/regression/pr103606.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103606.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/103606 - ICE in resolve_fl_procedure +! Contributed by G.Steinmetz + +program p + type t + end type +contains + elemental function f() result(z) ! { dg-error "CLASS variable" } + class(t) :: z + end +end Index: Fortran/gfortran/regression/pr103607.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103607.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/103607 - ICE in do_subscript, at fortran/frontend-passes.c:2927 +! Contributed by G.Steinmetz + +program p + integer :: i, x(abs(2.)) ! { dg-error "must be of INTEGER type" } + do i = 1, 2 + x(i) = 0 + end do +end + +! { dg-prune-output "must have constant shape" } Index: Fortran/gfortran/regression/pr103608.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103608.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-w" } +! PR fortran/103608 - ICE in do_intent +! Contributed by G.Steinmetz + +program p + implicit none + integer :: i + integer :: x ! { dg-error "Alternate return specifier" } + x(*) = 0 + do i = 1, 2 + print *, x(i) ! { dg-error "Missing alternate return specifier" } + end do +end Index: Fortran/gfortran/regression/pr103609.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103609.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/103609 - ICE in gfc_sym_get_dummy_args +! Contributed by G.Steinmetz + +program p + implicit none + integer :: i + do i = 1, 2 + call s + end do +contains + subroutine s + call sub(x) ! { dg-error "has no IMPLICIT type" } + end +end Index: Fortran/gfortran/regression/pr103691.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103691.f90 @@ -0,0 +1,9 @@ +! PR fortran/103691 +! { dg-do compile } +! { dg-options "-O2 -g" } + +program pr103691 + real, parameter :: a(0) = 2.0 + real, allocatable :: b(:) + allocate (b, mold=a) +end Index: Fortran/gfortran/regression/pr103692.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103692.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/103692 - ICE in expand_constructor +! Contributed by G.Steinmetz + +program p + character(3), parameter :: a(4) = 'abc' + character(*), parameter :: b(*) = (a(2:1)) + character(*), parameter :: y(*) = [(a(2:1))] + character(*), parameter :: u(*) = a(2:1) + character(*), parameter :: v(*) = [a(2:1)] + character(*), parameter :: w(-1) = (a(2:1)) + character(*), parameter :: x(-1) = a(2:1) + character(5), parameter :: c(3,3) = 'def' + character(*), parameter :: d(*) = [(c(2:1,2:))] + character(*), parameter :: e(*,*) = (c(2:1,2:)) + if (len(b) /= 3 .or. size (b) /= 0) stop 1 + if (len(y) /= 3 .or. size (y) /= 0) stop 2 + if (len(d) /= 5 .or. size (d) /= 0) stop 3 + if (len(e) /= 5 .or. any (shape (e) /= [0,2])) stop 4 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/pr103694.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103694.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/103694 - ICE in gfc_conv_expr_op +! Contributed by G.Steinmetz + +subroutine s + type t + integer :: a(2) + end type + type(t) :: x((0.)/0) + integer :: n = size(x(1)%a) ! { dg-error "does not reduce to a constant expression" } +end Index: Fortran/gfortran/regression/pr103779.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103779.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/69636 +! PR fortran/103779 +! Contributed by G.Steinmetz + +character(1,) function f() ! { dg-error "Expected initialization expression" } + f = 'a' +end + +character(1,kind=) function g() ! { dg-error "Expected initialization expression" } + g = 'a' +end + +character(1,n) function h() ! { dg-error "has not been declared" } + h = 'a' +end + +! { dg-prune-output "Bad kind expression" } Index: Fortran/gfortran/regression/pr103898.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr103898.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +! This test used to ICE during gimplification (PR103898). + +Module g +contains + function mysize(array, dim) + integer :: mysize + integer, dimension(:), intent(in) :: array + integer, optional, intent(in) :: dim + if (present(dim)) then + mysize = size(array, dim=dim) + endif + end function mysize +end module Index: Fortran/gfortran/regression/pr104210.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104210.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR fortran/104210 +! Contributed by G.Steinmetz + +function f() ! { dg-error "shall not be a coarray" } + integer :: f[*] +end +program p + interface + function f() ! { dg-error "shall not be a coarray" } + integer :: f[*] + end + end interface +end Index: Fortran/gfortran/regression/pr104211.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104211.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/104211 - ICE in find_array_section +! Contributed by G.Steinmetz + +program p + type t + real :: n + end type + type(t), parameter :: a(3) = [t(2)] ! { dg-error "Different shape" } + type(t), parameter :: b(2) = a(2:3) ! { dg-error "Error in array constructor" } +end Index: Fortran/gfortran/regression/pr104313.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104313.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-ff2c -fdump-tree-original" } +! +! PR fortran/104313 - ICE verify_gimple failed with -ff2c +! Contributed by G.Steinmetz + + function f(a) + return + end + +! { dg-final { scan-tree-dump-times "return" 1 "original" } } Index: Fortran/gfortran/regression/pr104314.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104314.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/104314 - ICE in deferred_op_assign +! Contributed by G.Steinmetz + +program p + character(:), allocatable :: c(:) + c = ['123'] + c = c == c ! { dg-error "Cannot convert" } +end Index: Fortran/gfortran/regression/pr104330.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104330.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! PR fortran/104330 - ICE in gfc_simplify_image_index +! Contributed by G.Steinmetz + +program p + implicit none + type t + end type t + class(*), allocatable :: x[:] + class(t), allocatable :: y[:] + type(t), allocatable :: z[:] + allocate (real :: x[*]) + print *, image_index(x, [1]) + allocate (t :: y[*]) + print *, image_index(y, [1]) + allocate (t :: z[*]) + print *, image_index(z, [1]) +end Index: Fortran/gfortran/regression/pr104466.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104466.f90 @@ -0,0 +1,116 @@ +! { dg-do compile } +! { dg-options "-std=legacy -O2 --param max-inline-insns-auto=0 --param max-inline-insns-single=0 -fdump-tree-lim2-details" } + + MODULE mod_param + integer, parameter :: Ngrids = 1 + integer, dimension(Ngrids) :: N + END + MODULE mod_forces + TYPE T_FORCES + real, pointer :: sustr(:,:) + real, pointer :: svstr(:,:) + real, pointer :: bustr(:,:) + real, pointer :: bvstr(:,:) + real, pointer :: srflx(:,:) + real, pointer :: stflx(:,:,:) + END TYPE + TYPE (T_FORCES), allocatable :: FORCES(:) + END + MODULE mod_grid + TYPE T_GRID + real, pointer :: f(:,:) + real, pointer :: Hz(:,:,:) + real, pointer :: z_r(:,:,:) + real, pointer :: z_w(:,:,:) + END TYPE + TYPE (T_GRID), allocatable :: GRID(:) + END + MODULE mod_scalars + USE mod_param + END + MODULE mod_mixing + TYPE T_MIXING + integer, pointer :: ksbl(:,:) + real, pointer :: Akv(:,:,:) + real, pointer :: Akt(:,:,:,:) + real, pointer :: alpha(:,:) + real, pointer :: beta(:,:) + real, pointer :: bvf(:,:,:) + real, pointer :: hsbl(:,:) + real, pointer :: ghats(:,:,:,:) + END TYPE + TYPE (T_MIXING), allocatable :: MIXING(:) + END + MODULE mod_ocean + TYPE T_OCEAN + real, pointer :: pden(:,:,:) + real, pointer :: u(:,:,:,:) + real, pointer :: v(:,:,:,:) + END TYPE + TYPE (T_OCEAN), allocatable :: OCEAN(:) + END + MODULE lmd_skpp_mod + PRIVATE + PUBLIC lmd_skpp + CONTAINS + SUBROUTINE lmd_skpp + USE mod_forces + USE mod_grid + USE mod_mixing + USE mod_ocean + integer tile + integer UBi, UBj + CALL lmd_skpp_tile (ng, tile, LBi, UBi, LBj, UBj, & + IminS, ImaxS, JminS, JmaxS, nstp0, & + GRID(ng) % f, GRID(ng) % Hz, & + GRID(ng) % z_r, GRID(ng) % z_w, & + OCEAN(ng) % u, OCEAN(ng) % v, & + OCEAN(ng) % pden, FORCES(ng) % srflx, & + FORCES(ng) % stflx, FORCES(ng) % bustr, & + FORCES(ng) % bvstr, FORCES(ng) % sustr, & + FORCES(ng) % svstr, MIXING(ng) % alpha, & + MIXING(ng) % beta, MIXING(ng) % bvf, & + MIXING(ng) % ghats, MIXING(ng) % Akt, & + MIXING(ng) % Akv, MIXING(ng) % hsbl, MIXING(ng) % ksbl) + END + SUBROUTINE lmd_skpp_tile (ng, tile, LBi, UBi, LBj, UBj, & + IminS, ImaxS, JminS, JmaxS, nstp, f, Hz, z_r, z_w, & + u, v, pden, srflx, stflx, bustr, bvstr, sustr, svstr, & + alpha, beta, bvf, & + ghats, Akt, Akv, hsbl, ksbl) + USE mod_scalars + integer tile + integer UBi, UBj + real f(:,:) + real Hz(:,:,:) + real z_r(:,:,:) + real z_w(:,:,:) + real u(:,:,:,:) + real v(:,:,:,:) + real pden(:,:,:) + real srflx(:,:) + real stflx(:,:,:) + real alpha(:,:) + real beta(:,:) + real bustr(:,:) + real bvstr(:,:) + real sustr(:,:) + real svstr(:,:) + real bvf(:,:,:) + real Akt(:,:,:,:) + real Akv(:,:,:) + real hsbl(:,:) + integer ksbl(:,:) + real ghats(:,:,:,:) + DO j=Jstr,Jend + DO iik=IstrIstr,z_w(i,j,N(ng)) + IF (hsbl0.gt.z_w0) THEN + ksbl=zbl + END IF + END DO + END DO + END + END + +! { dg-final { scan-tree-dump-not ": dependent" "lim2" } } +! { dg-final { scan-tree-dump "Moving statement\[\n\r\]_\[0-9\]+ = n" "lim2" } } Index: Fortran/gfortran/regression/pr104528.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104528.f @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-O2 -fpeel-loops -ftree-loop-vectorize -fno-tree-scev-cprop --param iv-max-considered-uses=2" } + REAL FUNCTION FOO(M, N, A, W) + + INTEGER M, N + + REAL W(*) + COMPLEX A(*) + + INTEGER II, JI, JJ, KK, LL, MP + + EXTERNAL BAR + + INTEGER QUX + EXTERNAL QUX + + CALL BAR(II) + + IF (M .EQ. 0) THEN + IF (N .EQ. 0) THEN + DO 140 KK = II, II + MP + W(KK) = 0 + 140 CONTINUE + ELSE + KK = II + MP + END IF + + DO 130 JI = KK, KK + MP + DO 120 LL = JJ, JJ + MP + DO 110 KK = II, II + MP + W(KK) = (A(KK)) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + + IF (W(KK) .EQ. 0) THEN + FOO = W(QUX(MP, W, 1)) + END IF + + END IF + + RETURN + + END Index: Fortran/gfortran/regression/pr104554.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104554.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/104554 - ICE in check_assumed_size_reference +! Contributed by G.Steinmetz + +program p + type t + integer :: a + end type + class(t) :: x(*) ! { dg-error "Assumed size array" } + x%a = 3 +end Index: Fortran/gfortran/regression/pr104571.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104571.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/104571 - ICE in resolve_elemental_actual +! Contributed by G.Steinmetz + +program p + real :: x(3) + call g(x) ! { dg-error "Missing alternate return" } +contains + elemental subroutine g(*) ! { dg-error "Alternate return specifier" } + end +end Index: Fortran/gfortran/regression/pr104716.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104716.f @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=legacy -O2 -ftree-loop-distribution -fno-move-loop-stores -fno-tree-dominator-opts" } + + SUBROUTINE FOO() + + COMMON /WORK/ C2(2, 2) + + DIMENSION D11(2) + + EQUIVALENCE (D11(1), C2(1, 1)) + + DO 40 I = 1, 2 + DO 30 J = 1, 2 + ASSIGN 10 TO ILBL + IF (C2(J, I) .NE. 0.0) THEN + ASSIGN 20 TO ILBL + ENDIF + GO TO ILBL + 10 CONTINUE + 20 CONTINUE + C2(J, I) = C2(J, I) + 1 + 30 CONTINUE + 40 CONTINUE + + DO 50 I = 1, 2 + PRINT 90, I + 50 CONTINUE + + RETURN + 90 FORMAT(I5) + END Index: Fortran/gfortran/regression/pr104849.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr104849.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/104849 - ICE in find_array_section +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = [1, 2] ! { dg-error "deferred shape" } + integer :: x(2) + data x /a(:)/ ! { dg-error "Invalid" } +end Index: Fortran/gfortran/regression/pr105230.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr105230.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/105230 - ICE in find_array_section +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = [1, 2] ! { dg-error "deferred shape" } + print *, reshape([3, 4], a(1:2)) +end Index: Fortran/gfortran/regression/pr105501.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr105501.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/105501 - check for non-optional spaces between adjacent keywords + +MODULE M + TYPE T + INTEGER I + END TYPE +CONTAINS + SUBROUTINE S(X) + CLASS(T), POINTER :: X + SELECTTYPE (X) ! blank between SELECT and TYPE is optional + TYPEIS (T) ! { dg-error "Mangled derived type definition" } + END SELECT + END SUBROUTINE +END MODULE Index: Fortran/gfortran/regression/pr105633.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr105633.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/105633 - ICE in find_array_section +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = [1,2] ! { dg-error "deferred shape" } + print *, [a([1,2])] +end Index: Fortran/gfortran/regression/pr105954.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr105954.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/105954 - ICE in gfc_element_size, at fortran/target-memory.cc:132 +! Contributed by G.Steinmetz + +program p + use iso_c_binding, only: c_float, c_sizeof + implicit none + integer, parameter :: n = -99 + type t + real :: b(3,7:n) + end type + type, bind(c) :: u + real(c_float) :: b(3,7:n) + end type + type(t) :: d + type(u) :: e + integer, parameter :: k = storage_size(d) + integer, parameter :: m = sizeof(d) + integer, parameter :: l = c_sizeof(e) + if (k /= 0) stop 1 + if (m /= 0) stop 2 + if (l /= 0) stop 3 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/pr106209.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106209.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/106209 - ICE in add_init_expr_to_sym +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = 0 ! { dg-error "of deferred shape" } + integer, parameter :: b(*) = a ! { dg-error "Bad shape of initializer" } + integer, parameter :: c(*) = [a] ! { dg-error "Cannot determine shape" } +end Index: Fortran/gfortran/regression/pr106226.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106226.f @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-O3 -std=legacy" } + + SUBROUTINE EFTORD(DM,CHDINT,L4) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MXPT=100, MXFRG=50, MXFGPT=MXPT*MXFRG) + DIMENSION DM(*),CHDINT(L4) + COMMON /FGRAD / DEF0,DEFT0,TORQ0 + * ,ATORQ(3,MXFRG) + COMMON /CSSTV / CX,CY,CZ + * EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT), + * EFDIP(3,MXFGPT),EFQAD(6,MXFGPT), + * EFOCT(10,MXFGPT),FRGNME(MXFGPT) + IF(NROOTS.EQ.5) CALL ROOT5 + IF(NROOTS.EQ.6) CALL ROOT6 + IF(NROOTS.GE.7) THEN + CALL ABRT + END IF + DO 403 I = 1,IJ + CHDINT(ICC)=CHDINT(ICC)-DUM*DUMY + ICC=ICC+1 + 403 CONTINUE + CHDINT(ICC)=CHDINT(ICC)-DUM*DUMY + DO 550 J=MINJ,MAX + LJ=LOCJ+J + IF (LI-LJ) 920,940,940 + 920 ID = LJ + GO TO 960 + 940 ID = LI + 960 NN = (ID*(ID-1))/2+JD + DUM = DM(NN) + ATORQ(1,INF)=ATORQ(1,INF)-DUM*(CHDINT(ICC+1)*EFDIP(3,IC) + $ -CHDINT(ICC+2)*EFDIP(2,IC)) + ICC=ICC+1 + ICC=ICC+1 + 550 CONTINUE + END Index: Fortran/gfortran/regression/pr106331.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106331.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! { dg-options "-Og" } + +PROGRAM main + CHARACTER(LEN=24) :: a(2) + a = '' +END PROGRAM Index: Fortran/gfortran/regression/pr106556.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106556.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O1 -fnon-call-exceptions -ftree-loop-if-convert" } + + +program p + real :: a(2) + + a(:) = 1.0 + if (minloc (a, dim = 1).ne.1) STOP 1 +end Index: Fortran/gfortran/regression/pr106557.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106557.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/106557 - nesting intrinsics ibset and transfer gives wrong result + +program p + implicit none + character(1) :: s + + write(s,'(i1)') ibset (transfer (0, 0), 0) + if (s /= '1') stop 1 + write(s,'(i1)') ibclr (transfer (1, 0), 0) + if (s /= '0') stop 2 + + ! These shall be fully resolved at compile time: + if (transfer (ibset (transfer (0, 0), 0), 0) /= 1) stop 3 + if (transfer (ibclr (transfer (1, 0), 0), 0) /= 0) stop 4 +end + +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 2 "original" } } Index: Fortran/gfortran/regression/pr106731.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106731.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! PR106731 ICE on automatic array of derived type +module causes_ice + implicit none + + type :: t + real(8) :: x + contains + procedure, private :: write_formatted + generic :: write(formatted) => write_formatted + end type t + + contains + + subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: this + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + write(unit, '(a,3x,f10.5)', iostat=iostat, iomsg=iomsg) 'dummy', this%x + end subroutine write_formatted + +end module causes_ice + +module use_t + use causes_ice + implicit none + + public :: automatic_alloc + + contains + + subroutine automatic_alloc(n) + integer, intent(in) :: n + + ! Automatic array: ICE! + type(t) :: automatic(n) + + ! Allocatable: works + type(t), allocatable :: alloc(:) + allocate(alloc(n)) + + automatic%x = 42.34675_8 + + ! Do anything + print *, 'n=',n,automatic%x + print *, 'n=',n,automatic + + end subroutine automatic_alloc + +end module use_t + +program test + use use_t + call automatic_alloc(1) +end program test Index: Fortran/gfortran/regression/pr106857.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106857.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/106857 - ICE in gfc_simplify_pack +! Contributed by G.Steinmetz + +program p + type t + integer :: n + end type + type(t), parameter :: a(2,2) = t(1) + type(t), parameter :: b(4) = reshape(a, [2]) ! { dg-error "Different shape" } + type(t), parameter :: c(2) = pack(b, [.false.,.true.,.false.,.true.]) ! { dg-error "Different shape" } +end Index: Fortran/gfortran/regression/pr106911.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106911.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/106911 - ICE in gfc_convert_mpz_to_signed +! Contributed by G.Steinmetz + +program p + implicit none + integer, parameter :: a = 10 + integer, parameter :: b = 20 + integer, parameter :: c = ishftc(1_1, a, b) ! { dg-error "must be less than or equal" } + integer, parameter :: d = ishftc(1_1, a, 0) ! { dg-error "must be positive" } + interface + subroutine s + import :: a, b + integer, parameter :: e = ishftc(1_1, a, b) ! { dg-error "must be less than or equal" } + integer, parameter :: f = ishftc(1_1, a, 0) ! { dg-error "must be positive" } + end + end interface +end Index: Fortran/gfortran/regression/pr106934.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106934.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-O" } +subroutine s + logical(1) :: a = .true. + logical(2) :: b + a = transfer(b, a) +end Index: Fortran/gfortran/regression/pr106985.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106985.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/106985 - ICE in gfc_simplify_expr +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(2) = 1 + integer, parameter :: b = a(2) + b ! { dg-error "before its definition is complete" } +end Index: Fortran/gfortran/regression/pr106986.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr106986.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/106986 - ICE in simplify_findloc_nodim +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(:) = [1] ! { dg-error "deferred shape" } + print *, findloc (a, 1) +end Index: Fortran/gfortran/regression/pr107000.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107000.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! PR fortran/107000 - ICE in gfc_real2complex, reduce_unary, reduce_binary_* +! Contributed by G.Steinmetz + +program p + real :: y(1) + complex :: x(1) + x = (1.0, 2.0) * [real :: -'1'] ! { dg-error "Operand of unary numeric operator" } + x = (1.0, 2.0) * [complex :: +'1'] ! { dg-error "Operand of unary numeric operator" } + x = [complex :: -'1'] * (1.0, 2.0) ! { dg-error "Operand of unary numeric operator" } + y = [complex :: -'1'] * 2 ! { dg-error "Operand of unary numeric operator" } + y = 2 * [complex :: -'1'] ! { dg-error "Operand of unary numeric operator" } + y = 2 * [complex :: -(.true.)] ! { dg-error "Operand of unary numeric operator" } + y = [complex :: -(.true.)] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, - [real :: -'1' ] ! { dg-error "Operand of unary numeric operator" } + print *, - [real :: [-'1']] ! { dg-error "Operand of unary numeric operator" } + print *, - [real :: +(.true.) ] ! { dg-error "Operand of unary numeric operator" } + print *, - [real :: [+(.true.)]] ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: -'1' ] ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: (-'1')] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: -'1' ] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, [real :: (-'1')] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [integer :: -('1')] ! { dg-error "Operand of unary numeric operator" } + print *, [integer :: -('1')] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: 0, (-'1')] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 0, (-'1')] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: 0, -'1'] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 0, -'1'] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: 0, 1+'1'] ! { dg-error "Operands of binary numeric operator" } + print *, [real :: 0, 1+'1'] * 2 ! { dg-error "Operands of binary numeric operator" } + print *, [real :: 1, +(.true.)] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, -(.true.)] ! { dg-error "Operand of unary numeric operator" } + print *, 2 * [real :: 1, +(.true.)] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, +(.true.)] * 2 ! { dg-error "Operand of unary numeric operator" } + print *, [1, 2] * [real :: 1, +(.true.)] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, +(.true.)] * [1, 2] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, 2] * [real :: 1, +(.true.)] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, +(.true.)] * [real :: 1, 2] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 0, -'1'] * [real :: 1, +(+(.true.))] ! { dg-error "Operand of unary numeric operator" } + print *, [real :: 1, [(+(.true.))]] * [real :: 0, [(-'1')]] ! { dg-error "Operand of unary numeric operator" } + + ! Legal: + print *, 2 * [real :: 1, [2], 3] + print *, [real :: 1, [2], 3] * 2 + print *, [real :: 1, [2], 3] * [real :: 1, [2], 3] + print *, [real :: 1, [2], 3] * [integer :: 1, [2], 3] + print *, [real :: 1, [2], 3] * [1, [2], 3] + print *, [real :: 1, huge(2.0)] * [real :: 1, real(1.0)] + print *, [real :: 1, -(huge(2.0))] * [real :: 1, +(real(1))] +end Index: Fortran/gfortran/regression/pr107054.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107054.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/107054 - ICE in gfc_simplify_unpack +! Contributed by G.Steinmetz + +program p + type t + integer :: n = 0 + end type + type(t), parameter :: a(4) = t(2) + type(t), parameter :: b(4) = reshape(a,[2]) ! { dg-error "Different shape" } + type(t), parameter :: c(2) = pack(b,[.false.,.true.,.false.,.true.]) ! { dg-error "Different shape" } + type(t), parameter :: d(4) = unpack(c,[.false.,.true.,.false.,.true.],a) +end Index: Fortran/gfortran/regression/pr107215.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107215.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/107215 - ICE in gfc_real2real and gfc_complex2complex +! Contributed by G.Steinmetz + +program p + double precision, parameter :: z = 1.0d0 + complex :: x(1) + real :: y(1) + x = [real :: -'1'] * z ! { dg-error "Operand of unary numeric operator" } + y = z * [real :: -'1'] ! { dg-error "Operand of unary numeric operator" } + x = [real :: -(.true.)] * z ! { dg-error "Operand of unary numeric operator" } + y = z * [real :: -(.true.)] ! { dg-error "Operand of unary numeric operator" } + x = [complex :: -'1'] * z ! { dg-error "Operand of unary numeric operator" } + y = z * [complex :: -'1'] ! { dg-error "Operand of unary numeric operator" } + x = [complex :: -(.true.)] * z ! { dg-error "Operand of unary numeric operator" } + y = z * [complex :: -(.true.)] ! { dg-error "Operand of unary numeric operator" } +end Index: Fortran/gfortran/regression/pr107217.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107217.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/107217 - ICE in gfc_arith_times +! Contributed by G.Steinmetz + +program p + print *, [real :: (['1'])] * 2 ! { dg-error "Cannot convert" } + print *, 2 * [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] + 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] - 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] / 2 ! { dg-error "Cannot convert" } + print *, 1 / [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] ** 2 ! { dg-error "Cannot convert" } + print *, 2 ** [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2.0 ** [real :: (.true.)] ! { dg-error "Cannot convert" } + print *, [real :: (.true.)] ** 2.0 ! { dg-error "Cannot convert" } + print *, [complex :: (['1'])] ** (1.0,2.0) ! { dg-error "Cannot convert" } + print *, (1.0,2.0) ** [complex :: (['1'])] ! { dg-error "Cannot convert" } +end Index: Fortran/gfortran/regression/pr107272.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107272.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/107272 - followup of PR/107217 for non-numeric types + +program p + print *, 2 <= [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2 < [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2 == [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2 /= [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2 >= [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, 2 > [real :: (['1'])] ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] >= 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] > 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] == 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] /= 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] <= 2 ! { dg-error "Cannot convert" } + print *, [real :: (['1'])] < 2 ! { dg-error "Cannot convert" } + print *, [logical :: (['1'])] .and. .true. ! { dg-error "Cannot convert" } + print *, [logical :: (['1'])] .or. .true. ! { dg-error "Cannot convert" } + print *, [logical :: (['1'])] .eqv. .true. ! { dg-error "Cannot convert" } + print *, [logical :: (['1'])] .neqv. .true. ! { dg-error "Cannot convert" } +end Index: Fortran/gfortran/regression/pr107397.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107397.f90 @@ -0,0 +1,9 @@ +!{ dg-do compile } +! +program p + type t + real :: a = 1.0 + end type + type(t), parameter :: x = z'1' ! { dg-error "incompatible with a BOZ" } + x%a = x%a + 2 ! { dg-error "has no IMPLICIT type" } +end Index: Fortran/gfortran/regression/pr107423.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107423.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/107423 - ICE in parse_spec +! Contributed by G.Steinmetz + +program p + type t(k) + integer, kind :: k ! { dg-error "Fortran 2003" } + integer :: a + end type +contains + function f() + type(t(4)), allocatable :: x ! { dg-error "Invalid character" } + allocate (t(4) :: x) ! { dg-error "cannot be used" } + end ! { dg-error "END" } +end ! { dg-error "END" } + +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/pr107559.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107559.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/107559 - ICE in resolve_equivalence +! Contributed by G.Steinmetz + +module m + implicit none + integer, protected :: a ! { dg-error "Fortran 2003: PROTECTED attribute" } + integer :: b + equivalence (a, b) ! { dg-error "has no IMPLICIT type" } +end Index: Fortran/gfortran/regression/pr107577.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107577.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/107577 - ICE in find_array_spec +! Contributed by G.Steinmetz + +program p + implicit none + associate (y => f(4)) ! { dg-error "has no IMPLICIT type" } + if (lbound (y, 1) /= 1) stop 1 ! { dg-error "Invalid array reference" } + if (y(1) /= 1) stop 2 ! { dg-error "Invalid array reference" } + end associate +end + +! { dg-error "has no type" " " { target *-*-* } 7 } Index: Fortran/gfortran/regression/pr107679.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107679.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine s1(x) + integer, intent(out) :: x +end +subroutine s2(z) + integer, value :: z + call s1(z) +end Index: Fortran/gfortran/regression/pr107680.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107680.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/107680 - ICE in arith_power +! Contributed by G.Steinmetz + +program p + real, parameter :: x(*) = [real :: ([1])] ** 2.0 + complex, parameter :: y(*) = [real :: ([1])] ** (2.0,1.0) + complex, parameter :: z(*) = [complex :: ([1])] ** (2.0,1.0) + complex, parameter :: u(*) = [complex :: ([1.0])] ** (2.0,1.0) + complex, parameter :: v(*) = [real :: ([(1.0,2.0)])] ** (3.0,1.0) + complex, parameter :: w(*) = [integer :: ([(1.0,2.0)])] ** (3.0,1.0) + print *, [real :: ([3])] ** 2 + print *, [real :: ([3])] ** 2.0 + print *, [real :: ([1])] ** (1.0,2.0) + print *, [real :: ([1.0])] ** (1.0,2.0) + print *, [complex :: ([3])] ** 2 + print *, [complex :: ([3])] ** 2.0 + print *, [complex :: ([1])] ** (1.0,2.0) + print *, [complex :: ([1.0])] ** (1.0,2.0) + print *, [integer :: ([3.0])] ** 2 + print *, [integer :: ([3.0])] ** 2.0 + print *, [integer :: ([1.0])] ** (1.0,2.0) + print *, [integer :: ([(1.0,2.0)])] ** (3.0,1.0) + print *, v(1) + if (u(1) /= 1) stop 1 + if (v(1) /= 1) stop 2 + if (w(1) /= 1) stop 3 + if (x(1) /= 1) stop 4 + if (y(1) /= 1) stop 5 + if (z(1) /= 1) stop 6 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/pr107681.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107681.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/107681 - ICE in gfc_type_is_extensible +! Contributed by G.Steinmetz + +program p + type t + integer, allocatable :: a + end type + class(t) :: x[*] ! { dg-error "must be dummy, allocatable or pointer" } + associate (y => x) ! { dg-error "Invalid array reference" } + end associate +end Index: Fortran/gfortran/regression/pr107707.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107707.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/107707 - ICE in gfc_compare_actual_formal +! Contributed by G.Steinmetz + +program p + character(3), allocatable :: c + c = 'abc' + call s(c) +contains + subroutine s(x) + character(real(3)), allocatable :: x ! { dg-error "must be of INTEGER type" } + end +end Index: Fortran/gfortran/regression/pr107872.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107872.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Test the fix for PR107872, where an ICE occurred in +! resolve.cc(derived_inaccessible) because derived types with +! recursive allocatable components were not catered for. +! +module mod1 + type t + integer :: data + type(t), allocatable :: next + contains + procedure, private :: write_t + generic :: write(formatted) => write_t + end type +contains + recursive subroutine write_t(this, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: this + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (ALLOCATED(this%next)) & + write (unit, '(dt)') this%next + write (unit, '(i2)') this%data + end subroutine +end module + + use mod1 + type(t) :: a + character (8) :: buffer + a%data = 1 + allocate (a%next) + a%next%data = 2 + allocate (a%next%next) + a%next%next%data = 3 + write (buffer, '(dt)')a + deallocate (a%next) + if (trim (buffer) .ne. ' 3 2 1') stop 1 +end Index: Fortran/gfortran/regression/pr107899.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107899.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR fortran/107899 - ICE in resolve_deallocate_expr +! Contributed by G.Steinmetz + +program p + type t + end type + class(t), target :: x[:] ! { dg-error "deferred shape" } + if (allocated (x)) then ! { dg-error "must be ALLOCATABLE" } + deallocate (x) ! { dg-error "must be ALLOCATABLE or a POINTER" } + end if +end Index: Fortran/gfortran/regression/pr107995.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr107995.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/107995 +! Contributed by G.Steinmetz + +program p + implicit none + integer :: n ! { dg-error "Self-referential argument" } + n(n) = 1 ! { dg-warning "Statement function" } + print *, n(n) ! { dg-error "Statement function" } +end Index: Fortran/gfortran/regression/pr108010.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108010.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! PR fortran/108010 - ICE in reduce_unary, reduce_binary_aa +! Contributed by G.Steinmetz + +program p + implicit none + print *, + [integer :: [real ::]] + print *, - [integer :: [real ::]] + print *, 1 + [integer :: [real ::]] + print *, 1 - [integer :: [real ::]] + print *, 2 * [integer :: [real ::]] + print *, - [real :: [real ::], 2] + print *, + [integer :: [real ::], 2] + print *, - [integer :: [real ::], 2] + print *, 1 + [integer :: [real ::], 2] + print *, 1 - [integer :: [real ::], 2] + print *, 2 * [integer :: [real ::], 2] + print *, [integer :: [real ::]] + [integer :: [real ::]] + print *, [integer :: [real ::]] - [integer :: [real ::]] + print *, [integer :: [real ::]] * [integer :: [real ::]] + print *, [integer :: [real ::], 2] + [real :: [real ::], 3] + print *, [integer :: [real ::], 2] - [real :: [real ::], 3] + print *, [integer :: [real ::], 2] * [real :: [real ::], 3] + + ! Validate type of resulting arrays + if (.not. is_int ([integer :: [real ::]] )) stop 1 + if (.not. is_int ([integer :: [real ::]] + [integer :: [real ::]])) stop 2 + if (.not. is_real([real :: [integer ::]] )) stop 3 + if (.not. is_real([real :: [integer ::]] + [real :: [integer ::]])) stop 4 + if (.not. is_real([real :: [integer ::]] + [integer :: [real ::]])) stop 5 + if (.not. is_real([integer :: [real ::]] + [real :: [integer ::]])) stop 6 + +contains + + logical function is_int (x) + class(*) :: x(:) + select type (x) + type is (integer) + is_int = .true. + class default + is_int = .false. + end select + end function is_int + + logical function is_real (x) + class(*) :: x(:) + select type (x) + type is (real) + is_real = .true. + class default + is_real = .false. + end select + end function is_real +end Index: Fortran/gfortran/regression/pr108131.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108131.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/108131 +! +! Incorrect array bounds when bound intrinsic used in declaration + +program test + implicit none + integer, parameter :: mg(7:10) = 0 + integer, parameter :: u = ubound(mg, dim=1) + integer, parameter :: cx(-1:ubound(mg, dim=1)) = 1 + integer, parameter :: dx(lbound(mg, dim=1):ubound(cx, dim=1)) = 2 + + write(*,*) ubound(mg, dim=1) + write(*,*) ubound(cx, dim=1) + if (u /= 10) stop 1 + if (ubound(mg, dim=1) /= 10) stop 2 + if (ubound(cx, dim=1) /= 10) stop 3 + if (ubound(dx, dim=1) /= 10) stop 4 + if (lbound(mg, dim=1) /= 7) stop 5 + if (lbound(cx, dim=1) /= -1) stop 6 + if (lbound(dx, dim=1) /= 7) stop 7 +end program test + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/pr108193.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108193.f90 @@ -0,0 +1,24 @@ +! PR rtl-optimization/108193 +! { dg-do compile { target pthread } } +! { dg-options "-O2 -fsplit-loops -ftree-parallelize-loops=2 -fno-tree-dominator-opts" } + +subroutine foo (n, r) + implicit none + integer :: i, j, n + real :: s, r(*) + + s = 0.0 + + do j = 1, 2 + do i = j, n + s = r(i) + end do + end do + + do i = 1, n + do j = i, n + s = s + 1 + end do + r(i) = s + end do +end subroutine foo Index: Fortran/gfortran/regression/pr108420.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108420.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/108420 +! Contributed by G.Steinmetz + +program p + character :: c = 'c' + logical :: m = .true. + print *, merge(transfer('a', 'b', 0), c, .true.) + print *, merge(transfer('a', 'b', 0), c, m) +end Index: Fortran/gfortran/regression/pr108421.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108421.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/108421 +! Contributed by G.Steinmetz + +program p + character(real(3)) :: c ! { dg-error "must be of INTEGER type" } + call s(c) +end +subroutine s(x) + character(*) :: x +end Index: Fortran/gfortran/regression/pr108434.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108434.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/108434 - ICE in class_allocatable +! Contributed by G.Steinmetz + +program p + type t + class(c), pointer :: a(2) ! { dg-error "must have a deferred shape" } + end type t + class(t), allocatable :: x + class(t), pointer :: y +end Index: Fortran/gfortran/regression/pr108501.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108501.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/108501 - ICE in get_expr_storage_size +! Contributed by G.Steinmetz + +program p + real, parameter :: n = 2 + real :: a(1,(n),2) ! { dg-error "must be of INTEGER type" } + call s(a(:,:,1)) +end +subroutine s(x) + real :: x(2) +end + +! { dg-prune-output "must have constant shape" } Index: Fortran/gfortran/regression/pr108502.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108502.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -ffrontend-optimize" } +! PR fortran/108502 - ICE in gfc_check_dependency +! Contributed by G.Steinmetz + +integer function n() + integer :: a(1) + a = [1] / 0 +end +program p + integer :: b = n() ! { dg-error "must be an intrinsic function" } +end Index: Fortran/gfortran/regression/pr108527.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108527.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/108527 - ICE in compare_bound_int +! Contributed by G.Steinmetz + +program p + integer, parameter :: a((2.)) = [4,8] ! { dg-error "must be of INTEGER type" } + integer(a(1:1)) :: b ! { dg-error "Unclassifiable statement" } +end + +! { dg-prune-output "Parameter array" } Index: Fortran/gfortran/regression/pr108528.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108528.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/108528 - +! Contributed by G.Steinmetz + +function f() ! { dg-error "mismatched array specifications" } + integer :: f((2.)) ! { dg-error "must be of INTEGER type" } + integer :: g((2)) +entry g() +end Index: Fortran/gfortran/regression/pr108529.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108529.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/108529 - ICE in transformational_result +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(*,*) = reshape([1, 2, 3, 4], [2, 2]) + logical, parameter :: b(2,*) = a > 2 ! { dg-error "Assumed size" } + logical, parameter :: c(*) = all(b, 1) ! { dg-error "Bad shape" } +end Index: Fortran/gfortran/regression/pr108544.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108544.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/108544 - ICE in check_host_association +! Contributed by G.Steinmetz + +module m +contains + subroutine s + select type (s => 1) ! { dg-error "Selector shall be polymorphic" } + end select + end +end Index: Fortran/gfortran/regression/pr108592.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr108592.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Winteger-division" } +! PR fortran/108592 - warn only once for truncation of integer division + +program foo + if (8 < (20/9)) stop 1 ! { dg-bogus "Integer division.*Integer division" } +! { dg-message "Integer division truncated" "" { target *-*-* } .-1 } +end program Index: Fortran/gfortran/regression/pr12884.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr12884.f @@ -0,0 +1,25 @@ +c { dg-do run } +c pr 12884 +c test namelist with input file containg / before namelist. Also checks +c non-standard use of $ instead of & +c Based on example provided by jean-pierre.flament@univ-lille1.fr + + program pr12884 + integer ispher,nosym,runflg,noprop + namelist /cntrl/ ispher,nosym,runflg,noprop + ispher = 0 + nosym = 0 + runflg = 0 + noprop = 0 + open (10, status = "scratch") + write (10, '(A)') " $FILE" + write (10, '(A)') " pseu dir/file" + write (10, '(A)') " $END" + write (10, '(A)') " $cntrl ispher=1,nosym=2," + write (10, '(A)') " runflg=3,noprop=4,$END" + write (10, '(A)')"/" + rewind (10) + read (10, cntrl) + if ((ispher.ne.1).or.(nosym.ne.2).or.(runflg.ne.3).or. + & (noprop.ne.4)) STOP 1 + end Index: Fortran/gfortran/regression/pr15129.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15129.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 15129: we used to share the character length between A and B in the +! subroutine. +CHARACTER*10 A +CHARACTER*8 B +A = 'gfortran' +B = 'rocks!' +CALL T(A,B) +contains +SUBROUTINE T(A,B) +CHARACTER*(*) A,B +if(len(a)/=10) STOP 1 +if(len(b)/=8) STOP 2 +END SUBROUTINE +end Index: Fortran/gfortran/regression/pr15140.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15140.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 15140: we used to fail an assertion, because we don't use the +! argument of the subroutine directly, but instead use a copy of it. +function M(NAMES) + CHARACTER*(*) NAMES(*) + if (any(names(1:2).ne."asdfg")) STOP 1 + m = LEN(NAMES(1)) +END function M + +character(5) :: c(2) +c = "asdfg" +if(m(c).ne.5) STOP 1 +end Index: Fortran/gfortran/regression/pr15164.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15164.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! I couldn't reproduce the failure with a compiler built from the +! 2004-09-26 sources + module specfiles + contains + subroutine split(instring,outstrings,lenout,n,i) + integer(kind=4),intent(in) :: lenout,n + character(len=*),intent(in) :: instring + character(len=lenout),dimension(n),intent(out) :: outstrings + integer(kind=4) :: i,j,k + j=1; k=1 + outstrings(j)(k:k)=instring(i:i) + return + end subroutine split + end module specfiles Index: Fortran/gfortran/regression/pr15324.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15324.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR 15234 +! tests for passing arrays of assumed length characters +program strarray_6 +character(5), dimension(:), allocatable :: c +n = 3 +allocate(c(-1:n-2)) +c = "BLUBB" +call foo(c) +call bar(c,n) +deallocate(c) +contains +subroutine foo(x) + character (len = *), dimension(:) :: x + if (any (x .ne. "BLUBB")) STOP 1 +end subroutine foo +end + +subroutine bar(x,n) + character (len = *), dimension(n) :: x + if (any (x .ne. "BLUBB")) STOP 2 +end subroutine bar Index: Fortran/gfortran/regression/pr15332.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15332.f @@ -0,0 +1,14 @@ +! PR libfortran/15332 +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*12 c + + write (c,100) 0, 1 + if (c .ne. 'i = 0, j = 1') STOP 1 + + write (c,100) 0 + if (c .ne. 'i = 0 ') STOP 2 + + 100 format ('i = ',i1,:,', j = ',i1) + end Index: Fortran/gfortran/regression/pr15754.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15754.f90 @@ -0,0 +1,7 @@ +! we didn't give a warning if the RHS of an assignment was NULL +! { dg-do compile } +INTEGER, POINTER :: P +I = NULL() ! { dg-error "NULL appears" "Assignment non-pointer = NULL" } +P = NULL() ! { dg-error "NULL appears" "Assignment pointer = NULL" } +P => NULL() +END Index: Fortran/gfortran/regression/pr15957.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15957.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR 15957 +! we used to return the wrong shape when the order parameter was used +! in reshape. +! +INTEGER, parameter :: i(2,3) = reshape ((/1,2,3,4,5,6/), (/2,3/)), & + j(2,4) = reshape ((/1,2,3,4,5,6/), (/2,4/), (/0,0/), (/2,1/)) + +integer :: k(2,3), m(2,4), n(2,3), o(2,4) + +k(1,:) = (/ 1, 3, 5 /) +k(2,:) = (/ 2, 4, 6 /) + +m(1,:) = (/ 1, 2, 3, 4 /) +m(2,:) = (/ 5, 6, 0, 0 /) + +! check that reshape does the right thing while constant folding +if (any(i /= k)) STOP 1 +if (any(j /= m)) STOP 2 + +! check that reshape does the right thing at runtime +n = reshape ((/1,2,3,4,5,6/), (/2,3/)) +if (any(n /= k)) STOP 3 +o = reshape ((/1,2,3,4,5,6/), (/2,4/), (/0,0/), (/2,1/)) +if (any(o /= m)) STOP 4 +end + Index: Fortran/gfortran/regression/pr15959.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr15959.f90 @@ -0,0 +1,5 @@ +! { dg-do run } +! Test initializer of character array. PR15959 +character (*), parameter :: a (1:2) = (/'ab ', 'abc'/) +if (a(2) .ne. 'abc') STOP 1 +end Index: Fortran/gfortran/regression/pr16433.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr16433.f @@ -0,0 +1,6 @@ +! { dg-do compile } + real x + double precision dx + data x/x'2ffde'/ ! { dg-error "Hexadecimal constant" } + dx = x + end Index: Fortran/gfortran/regression/pr16597.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr16597.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! pr 16597 +! libgfortran +! reading a direct access record after it was written did +! not always return the correct data. + + program gfbug4 + implicit none + + integer strlen + parameter (strlen = 4) + + integer iunit + character string *4 + + iunit = 99 + open (UNIT=iunit,FORM='unformatted',ACCESS='direct',RECL=strlen) + write (iunit, rec=1) 'ABCD' + read (iunit, rec=1) string + close (iunit, status = 'delete') + if (string.ne.'ABCD') STOP 1 + + open (UNIT=iunit,FORM='unformatted',ACCESS='direct',STATUS='scratch',RECL=strlen) + write (iunit, rec=1) 'ABCD' + read (iunit, rec=1) string + close (iunit) + if (string.ne.'ABCD') STOP 2 + end Index: Fortran/gfortran/regression/pr16861.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr16861.f90 @@ -0,0 +1,32 @@ +! PR fortran/16861 +! { dg-do run } +module foo + integer :: i +end module foo + +module bar +contains + subroutine baz(j) + use foo + integer, dimension(i) :: j + integer :: n + + do n = 1, i + if (j(n) /= n**2) STOP 1 + end do + end subroutine baz +end module bar + +subroutine quus() + use foo + use bar + + i = 2 + call baz ((/1,4/)) + i = 7 + call baz ((/1,4,9,16,25,36,49/)) +end subroutine quus + +program test + call quus +end program test Index: Fortran/gfortran/regression/pr16935.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr16935.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! pr16935 +! segfault at run time on open statement + program bug2 + implicit none + open( 1 , file = "str_500.txt", position = "REWIND" ) + close( 1 , status = "DELETE" ) + end Index: Fortran/gfortran/regression/pr16938.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr16938.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! We used to get an internal error in the backend when trying to compile this +! Added some code which verifies that we're actually doing the right thing. + program Array_List + implicit none + + type :: Compound + integer :: Count + character (len = 4) :: Name + end type Compound + + type :: Table + type (Compound) :: Data (2) + integer :: L_Size + end type Table + + type (Table) :: ElementTable + ElementTable%Data(1) = Compound(1,"one") + ElementTable%Data(2) = Compound(2,"two") + ElementTable%L_size = 2 + + if (elementtable%data(1)%count /= 1) STOP 1 + if (elementtable%data(2)%count /= 2) STOP 2 + if (elementtable%data(1)%name /= "one ") STOP 3 + if (elementtable%data(2)%name /= "two ") STOP 4 + if (elementtable%l_size /= 2) STOP 5 + end program Array_List Index: Fortran/gfortran/regression/pr17090.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17090.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! pr 17090 Runtime I/O error +! bdavis9659@comcast.net +! 9/12/2004 +! list directed read with spaces between the last data item and the +! eoln cause missed data items. +! this is a libgfortran test case + implicit none + integer i,sum + real a(14) + data sum / 0 / + open(unit=9,status='SCRATCH') + write(9,*)1.0,2.0,3.0,4.0,' ' + write(9,*)5.0,6.0,7.0,8.0,' ' + write(9,*)9.0,10.0,11.0,12.0,13.0,14.0,' ' + rewind(9) + read(9,*)a + do i = 1,14 + sum = sum + a(i) + end do + if (sum.ne.105) STOP 1 + end Index: Fortran/gfortran/regression/pr17143.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17143.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! pr17143 +! does not print 2*63 correctly + character*25 l + integer(kind=8) i + data i /1/ + do j = 1,63 + i = i * 2 + end do + write(l,*)i + if (l.ne.' -9223372036854775808') then +! ^ +! the space is required before a number + STOP 1 + endif + end + Index: Fortran/gfortran/regression/pr17164.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17164.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! pr17164 +! index aborts when substring is longer than string + implicit none + character*5 x + integer i + x='12345' + i=index(x,'blablabl') + if (i.ne.0) STOP 1 + end + Index: Fortran/gfortran/regression/pr17229.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17229.f @@ -0,0 +1,25 @@ +! PR fortran/17229 +! { dg-do run } +! { dg-options "-std=legacy" } + + integer i + logical l + + l = .false. + i = -1 + if (l) if (i) 999,999,999 + + l = .true. + if (l) if (i) 10,999,999 + go to 999 + + 10 i = 0 + if (l) if (i) 999,20,999 + go to 999 + + 20 i = 1 + if (l) if (i) 999,999,30 + go to 999 + + 999 STOP 1 + 30 end Index: Fortran/gfortran/regression/pr17285.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17285.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! pr 17285 +! Test that namelist can read its own output. +! At the same time, check arrays and different terminations +! Based on example provided by paulthomas2@wanadoo.fr + +program pr17285 + implicit none + integer, dimension(10) :: number = 42 + integer :: ctr, ierr + namelist /mynml/ number + open (10, status = "scratch") + write (10,'(A)') & + "&mynml number(:)=42,42,42,42,42,42,42,42,42,42,/ " + write (10,mynml) + write (10,'(A)') "&mynml number(1:10)=10*42 &end" + rewind (10) + do ctr = 1,3 + number = 0 + read (10, nml = mynml, iostat = ierr) + if ((ierr /= 0) .or. (any (number /= 42))) & + STOP 1 + end do + close(10) +end program pr17285 Index: Fortran/gfortran/regression/pr17286.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17286.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! PR17286 +! Namelist read failed when spaces exist between the '=' and the numbers +! This is a libgfortran bug +! Derived from testcase provided by Paul Thomas + program bug3 + integer num1 , num2 , num3 , num4 + data num3 / 42 / + data num4 / 56 / + namelist /mynml1/ num1,num2 + namelist /mynml2/ num3,num4 + logical dbg + data dbg / .FALSE. / + open(unit=10,status='SCRATCH') + write(10,'(A)') "&mynml1,num1= 16,num2=32,&end" +! +! write mynml2 +! + write(10,mynml2) + rewind(10) +! +! now read back +! + num1 = -1 + num2 = -1 + read(10,mynml1) + if (num1.eq.16.and.num2.eq.32) then + if (dbg) write(*,mynml1) + else + if (dbg) print *, 'expected 16 32 got ',num1,num2 + STOP 1 + endif + num3 = -1 + num4 = -1 + read(10,mynml2) + if (num3.eq.42.and.num4.eq.56) then + if (dbg) write(*,mynml2) + else + if (dbg) print *, 'expected 42 56 got ',num3,num4 + STOP 2 + endif + + close(10) + end Index: Fortran/gfortran/regression/pr17472.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17472.f @@ -0,0 +1,12 @@ +c { dg-do run } +c pr 17472 +c test namelist handles arrays +c Based on example provided by thomas.koenig@online.de + + integer a(10), ctr + data a / 1,2,3,4,5,6,7,8,9,10 / + namelist /ints/ a + do ctr = 1,10 + if (a(ctr).ne.ctr) STOP 1 + end do + end Index: Fortran/gfortran/regression/pr17612.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17612.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! PR 17612 +! We used to not determine the length of character-valued expressions +! correctly, leading to a segfault. +program prog + character(len=2), target :: c(4) + type pseudo_upf + character(len=2), pointer :: els(:) + end type pseudo_upf + type (pseudo_upf) :: p + type t + character(5) :: s(2) + end type + type (t) v + ! A full arrays. + c = (/"ab","cd","ef","gh"/) + call n(p) + if (any (c /= p%els)) STOP 1 + ! An array section that needs a new array descriptor. + v%s(1) = "hello" + v%s(2) = "world" + call test (v%s) +contains + + subroutine n (upf) + type (pseudo_upf), intent(inout) :: upf + upf%els => c + return + end subroutine n + + subroutine test(s) + character(len=*) :: s(:) + if ((len (s) .ne. 5) .or. (any (s .ne. (/"hello", "world"/)))) STOP 2 + end subroutine +end program + + Index: Fortran/gfortran/regression/pr17615.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17615.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! we didn't look at the right symbol when genrating code. This broke +! when array valued functions came into play. +module module_vec3d + INTERFACE cross_product + MODULE PROCEDURE cross_product3_R4_R8 + END INTERFACE +CONTAINS + FUNCTION cross_product3_R4_R8 () + real(8) :: cross_product3_r4_r8(3) + cross_product3_r4_r8 = 0 + END FUNCTION cross_product3_R4_R8 +END MODULE module_vec3d + +PROGRAM TEST + use module_vec3d, only: cross_product + real(8) :: c(3) + c = cross_product() +END PROGRAM TEST Index: Fortran/gfortran/regression/pr17706.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr17706.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fno-sign-zero" } +! PR17706 +! this is a libgfortran test +! output value -0.00 is not standard compliant +! derived from NIST F77 test FM406, with extra bits added. +program pr17706 + implicit none + character(len=10) :: s + character(len=10), parameter :: x = "xxxxxxxxxx" + real, parameter :: small = -0.0001 + + s = x + write (s, '(F4.1)') small + ! The plus is optional. We choose not to display it. + if (s .ne. " 0.0") STOP 1 + + s = x + write (s, '(SS,F4.1)') small + if (s .ne. " 0.0") STOP 2 + + s = x + write (s, '(SP,F4.1)') small + if (s .ne. "+0.0") STOP 3 +end program Index: Fortran/gfortran/regression/pr18025.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr18025.f90 @@ -0,0 +1,8 @@ +! PR libfortran/18025 +! { dg-do run } + character(len=80) :: c + write(c, "('#',F0.2,'#')") 1.23 + if (c /= '#1.23#') STOP 1 + write(c, "('#',F0.2,'#')") -1.23 + if (c /= '#-1.23#') STOP 2 + end Index: Fortran/gfortran/regression/pr18122.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr18122.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! test namelist with scalars and arrays. +! Based on example provided by thomas.koenig@online.de + +program sechs_w + implicit none + + integer, parameter :: dr=selected_real_kind(15) + + integer, parameter :: nkmax=6 + real (kind=dr) :: rb(nkmax) + integer :: z + + real (kind=dr) :: dg + real (kind=dr) :: a + real (kind=dr) :: da + real (kind=dr) :: delta + real (kind=dr) :: s,t + integer :: nk + real (kind=dr) alpha0 + + real (kind=dr) :: phi, phi0, rad, rex, zk, z0, drdphi, dzdphi + + namelist /schnecke/ z, dg, a, t, delta, s, nk, rb, alpha0 + + open (10,status="scratch") + write (10, *) "&SCHNECKE" + write (10, *) " z=1," + write (10, *) " dg=58.4," + write (10, *) " a=48.," + write (10, *) " delta=0.4," + write (10, *) " s=0.4," + write (10, *) " nk=6," + write (10, *) " rb=60, 0, 40," + write (10, *) " alpha0=20.," + write (10, *) "/" + + rewind (10) + read (10,schnecke) + close (10) + if ((z /= 1) .or. (dg /= 58.4_dr) .or. (a /= 48.0_dr) .or. & + (delta /= 0.4_dr).or. (s /= 0.4_dr) .or. (nk /= 6) .or. & + (rb(1) /= 60._dr).or. (rb(2) /= 0.0_dr).or. (rb(3) /=40.0_dr).or. & + (alpha0 /= 20.0_dr)) STOP 1 +end program sechs_w Index: Fortran/gfortran/regression/pr18210.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr18210.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Names in upper case and object names starting column 2 +! Based on example provided by thomas.koenig@online.de + +program pr18210 + + real :: a + character*80 :: buffer + namelist /foo/ a + + a = 1.4 + open (10, status = "scratch") + write (10,foo) + rewind (10) + read (10, '(a)') buffer + if (buffer(2:4) /= "FOO") STOP 1 + read (10, '(a)') buffer + if (buffer(1:2) /= " A") STOP 2 + close (10) + +end program pr18210 Index: Fortran/gfortran/regression/pr18392.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr18392.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! pr 18392 +! test namelist with derived types +! Based on example provided by thomas.koenig@online.de + +program pr18392 + implicit none + type foo + integer a + real b + end type foo + type(foo) :: a + namelist /nl/ a + open (10, status="scratch") + write (10,*) " &NL" + write (10,*) " A%A = 10," + write (10,*) "/" + rewind (10) + read (10,nl) + close (10) + IF (a%a /= 10.0) STOP 1 +end program pr18392 Index: Fortran/gfortran/regression/pr19155.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19155.f @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR libfortran/19155 +! We accept 'E+00' as a valid real number. The standard says it is not, +! but doesn't require us to issue an error. Since g77 accepts this as zero, +! we do the same. + real a + character*10 c + a = 42 + open (19,status='scratch') + write (19,'(A15)') 'E+00' + rewind (19) + read (19,'(E15.8)') a + if (a .ne. 0) STOP 1 + close (19) + + c = "+ " + read (c,"(F10.4)") a + if (a /= 0) STOP 2 + end Index: Fortran/gfortran/regression/pr19216.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19216.f @@ -0,0 +1,18 @@ +! PR libfortran/19216 +! { dg-do run } + integer dat(3), i, j + data dat / 3,2,1 / + + open (20, status='scratch') + write (20,'(A)') '/ 10 20 30' + write (20,'(A)') '1 2 3 4' + write (20,'(A)') '5 6 7 8' + rewind (20) + read (20,*) (dat(i), i=1,3) + if (dat(1).ne.3 .or. dat(2).ne.2 .or. dat(3).ne.1) STOP 1 + read (20,*) I,J + if (i .ne. 1 .or. j .ne. 2) STOP 2 + read (20,*) I,J + if (i .ne. 5 .or. j .ne. 6) STOP 3 + close(20) + end Index: Fortran/gfortran/regression/pr19467.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19467.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! pr 19467 +! test namelist with character arrays +! Based on example provided by paulthomas2@wanadoo.fr + +program pr19467 + implicit none + integer :: ier + character(len=2) :: ch(2) + character(len=2) :: dh(2)=(/"aa","bb"/) + namelist /a/ ch + open (10, status = "scratch") + write (10, *) "&A ch = 'aa' , 'bb' /" + rewind (10) + READ (10,nml=a, iostat = ier) + close (10) + if ((ier /= 0) .or. (any (ch /= dh))) STOP 1 +end program pr19467 Index: Fortran/gfortran/regression/pr19657.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19657.f @@ -0,0 +1,21 @@ +c { dg-do run } +c pr 19657 +c test namelist not skipped if ending with logical. +c Based on example provided by fuyuki@ccsr.u-tokyo.ac.jp + + program pr19657 + implicit none + logical l + integer i, ctr + namelist /nm/ i, l + open (10, status = "scratch") + write (10,*) "&nm i=1,l=t &end" + write (10,*) "&nm i=2 &end" + write (10,*) "&nm i=3 &end" + rewind (10) + do ctr = 1,3 + read (10,nm,end=190) + if (i.ne.ctr) STOP 1 + enddo + 190 continue + end Index: Fortran/gfortran/regression/pr19926.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19926.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +module b + type cat + integer :: i = 0 + end type cat +end module b + +program a + use b + type(cat) z + integer :: i = 0, j(4,3,2) = 0 + call string_comp(i) + if (i /= 3) STOP 1 + call string_comp(z%i) + if (z%i /= 3) STOP 2 + call string_comp(j(1,2,1)) + if (j(1,2,1) /= 3) STOP 3 +end program a + +subroutine string_comp(i) + integer, parameter :: map(0:50) = 3 + integer :: i + i = map(42) +end subroutine string_comp Index: Fortran/gfortran/regression/pr19928-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19928-1.f90 @@ -0,0 +1,11 @@ +! PR 19928. Check the use of constant substring indexes in a +! scalarization loop. +! { dg-do run } +program main + implicit none + character (len = 5), dimension (2) :: a + character (len = 3), dimension (2) :: b + a = (/ 'abcde', 'ghijk' /) + b = a(:)(2:4) + if (b(1) .ne. 'bcd' .or. b(2) .ne. 'hij') STOP 1 +end program main Index: Fortran/gfortran/regression/pr19928-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19928-2.f90 @@ -0,0 +1,23 @@ +! Related to PR 19928. Check that foo() is only called once per statement. +! { dg-do run } +program main + implicit none + type t + integer, dimension (5) :: field + end type t + type (t), dimension (2) :: a + integer :: calls, i, j + + forall (i = 1:2, j = 1:5) a(i)%field(j) = i * 100 + j + calls = 0 + if (sum (a%field(foo(calls))) .ne. 304) STOP 1 + if (calls .ne. 1) STOP 2 + if (sum (a(foo(calls))%field) .ne. 1015) STOP 3 + if (calls .ne. 2) STOP 4 +contains + function foo (calls) + integer :: calls, foo + calls = calls + 1 + foo = 2 + end function foo +end program main Index: Fortran/gfortran/regression/pr19936_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19936_1.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program pr19936_1 + integer, parameter :: i=4 + print *,(/(i,i=1,4)/) ! { dg-error "variable definition context" } +end program pr19936_1 Index: Fortran/gfortran/regression/pr19936_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19936_2.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program pr19936_2 + integer i + print *,(/(i,i=1a,4)/) ! { dg-error "Syntax error in iterator" } +end program pr19936_2 Index: Fortran/gfortran/regression/pr19936_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr19936_3.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program pr19936_3 + integer, parameter :: i = 4 + print *,(/(i,i,4)/) ! { dg-error "Syntax error in COMPLEX" } +end program pr19936_3 Index: Fortran/gfortran/regression/pr20086.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20086.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 20086 - Missing characters in output with hollerith strings + implicit none + character*80 line + write(line,2070) + if (line.ne.' stiffness reformed for this high step')STOP 1 + write(line,2090) + if (line.ne.' stiffness reformed for hello hello')STOP 2 + stop + + 2070 format (2x,37hstiffness reformed for this high step) + 2090 format (2x,34hstiffness reformed for hello hello) + + end Index: Fortran/gfortran/regression/pr20124.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20124.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! pr 20124 + character*80 line + x = -.01 + y = .01 + write(line,'(2f10.2)') x, y + if (line.ne.' -0.01 0.01') STOP 1 + end Index: Fortran/gfortran/regression/pr20163-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20163-2.f @@ -0,0 +1,6 @@ +! { dg-do run } + open(10,status="foo",err=100) ! { dg-warning "STATUS specifier in OPEN statement .* has invalid value" } + STOP 1 + 100 continue + open(10,status="scratch") + end Index: Fortran/gfortran/regression/pr20257.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20257.f90 @@ -0,0 +1,9 @@ +! { dg-do run } + integer,parameter :: n = 10000 + real(8) array(10000) + + array(:) = 0 + open (10, status='scratch') + write (10,*) array + close (10) +end Index: Fortran/gfortran/regression/pr20480.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20480.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR libfortran/20480 +! fxcoudert@gcc.gnu.org + character(len=80) c + write (c,'(ES12.3)') 0.0 + if (trim(adjustl(c)) .ne. '0.000E+00') STOP 1 + write (c,'(EN12.3)') 0.0 + if (trim(adjustl(c)) .ne. '0.000E+00') STOP 2 + end Index: Fortran/gfortran/regression/pr20755.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20755.f @@ -0,0 +1,12 @@ +! PR libfortran/20755 +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*30 s + + write (s,2000) 0.0, 0.02 + if (s .ne. " 0.00 2.000E-02") STOP 1 + write (s,2000) 0.01, 0.02 + if (s .ne. " 1.000E-02 2.000E-02") STOP 2 + 2000 format (1PG12.3,G12.3) + end Index: Fortran/gfortran/regression/pr20865.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20865.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR fortran/20865 + subroutine tt(j) + integer :: j + end subroutine + + integer :: i, st + st(i) = (i*i+2) + call tt(st) ! { dg-error "Statement function .* is not allowed as an actual argument|Invalid procedure argument" } + end Index: Fortran/gfortran/regression/pr20950.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20950.f @@ -0,0 +1,9 @@ +! PR libfortran/20950 +! Original bug-report by Walt Brainerd, The Fortran Company +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*20 c + inquire (33, sequential = c) + if (c .ne. "UNKNOWN") STOP 1 + end Index: Fortran/gfortran/regression/pr20954.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr20954.f @@ -0,0 +1,12 @@ + ! { dg-do run } + ! { dg-options "-fdefault-integer-8" } + ! Program to test character length type + Program pr20954 + character*16 string (5) + character*5 filename + character*80 line + filename = 'input' + open (2,file=filename) + write (line, '(5a16)') (string(i),i=1,5) + close (2, status='delete') + end Index: Fortran/gfortran/regression/pr21177.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr21177.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! PR fortran/21177 +module mymod + interface tt + module procedure tt_i, tt_r, tt_l, tt_c4, tt_c8 + end interface tt +contains + function tt_l(x) result(y) + integer :: y + logical, pointer :: x + y = 0 + end function + function tt_i(x) result(y) + integer :: y + integer, pointer :: x + y = 1 + end function + function tt_r(x) result(y) + integer :: y + real, pointer :: x + y = 2 + end function + function tt_c4(x) result(y) + integer :: y + complex(4), pointer :: x + y = 3 + end function + function tt_c8(x) result(y) + integer :: y + complex(8), pointer :: x + y = 4 + end function +end module mymod + +program test + use mymod + logical, pointer :: l + integer, pointer :: i + real, pointer :: r + complex(4), pointer :: c4 + complex(8), pointer :: c8 + + if (tt(l) /= 0) STOP 1 + if (tt(i) /= 1) STOP 2 + if (tt(r) /= 2) STOP 3 + if (tt(c4) /= 3) STOP 4 + if (tt(c8) /= 4) STOP 5 + if (tt(null(l)) /= 0) STOP 6 + if (tt(null(i)) /= 1) STOP 7 + if (tt(null(r)) /= 2) STOP 8 + if (tt(null(c4)) /= 3) STOP 9 + if (tt(null(c8)) /= 4) STOP 10 +end program test Index: Fortran/gfortran/regression/pr21730.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr21730.f @@ -0,0 +1,13 @@ +! PR fortran/21730 +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*2 a + character*4 b + character*6 c + parameter (a="12") + parameter (b = a) + write (c,'("#",A,"#")') b + if (c .ne. '#12 #') STOP 1 + end + Index: Fortran/gfortran/regression/pr22491.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr22491.f @@ -0,0 +1,13 @@ +! PR fortran/21730 +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*2 a (1) + character*4 b (1) + character*6 c + parameter (a="12") + parameter (b = a) + write (c,'("#",A,"#")') b + if (c .ne. '#12 #') STOP 1 + end + Index: Fortran/gfortran/regression/pr23095.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr23095.f @@ -0,0 +1,22 @@ + ! { dg-do compile { target { { i?86-*-* x86_64-*-* } && ilp32 } } } + ! { dg-options "-w -O2 -ffloat-store -fgcse-after-reload" } + ! + ! GCSE after reload made a stack register live across an abnormal + ! edges for one of the computed jumps. This bombed in reg-stack. + function foo(n) + real(kind=8) foo + integer ix, n, next + real(kind=8) xmax, absx + foo = 0.0d0 + assign 20 to next + do ix = 1,n + go to next,(10, 30) + 10 assign 40 to next + go to 40 + 20 if (absx .gt. 8.232d-11) go to 40 + 30 if (absx .le. xmax) go to 40 + xmax = absx + 40 go to next,(10, 30) + end do + return + end Index: Fortran/gfortran/regression/pr24823.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr24823.f @@ -0,0 +1,78 @@ +! { dg-do compile } +! { dg-options "-O2 -std=legacy" } +! PR24823 Flow didn't handle a PARALLEL as destination of a SET properly. + SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, + $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, + $ PACK, A, LDA, IWORK, INFO ) + COMPLEX*16 A( LDA, * ), D( * ), DL( * ), DR( * ) + LOGICAL BADPVT, DZERO, FULBND + COMPLEX*16 ZLATM2, ZLATM3 + IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN + END IF + IF( IPVTNG.GT.0 ) THEN + END IF + IF( M.LT.0 ) THEN + ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. + $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. + $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. + $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. + $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN + INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + RETURN + END IF + IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) + $ FULBND = .TRUE. + IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN + TEMP = ABS( D( 1 ) ) + IF( TEMP.EQ.ZERO .AND. DMAX.NE.CZERO ) THEN + INFO = 2 + END IF + END IF + IF( ISYM.EQ.0 ) THEN + END IF + IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. + $ 5 .OR. IGRADE.EQ.6 ) THEN + IF( INFO.NE.0 ) THEN + END IF + END IF + IF( FULBND ) THEN + IF( IPACK.EQ.0 ) THEN + IF( ISYM.EQ.0 ) THEN + CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, + $ IWORK, SPARSE ) + DO 120 I = 1, M + CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, + $ IWORK, SPARSE ) + 120 CONTINUE + END IF + IF( I.LT.1 ) THEN + IF( ISYM.EQ.0 ) THEN + A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL, + $ DR, IPVTNG, IWORK, SPARSE ) ) ! { dg-warning "Type mismatch" } + ELSE + A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } + $ IPVTNG, IWORK, SPARSE ) + END IF + END IF + IF( ISYM.NE.1 ) THEN + IF( I.GE.1 .AND. I.NE.J ) THEN + IF( ISYM.EQ.0 ) THEN + END IF + END IF + A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "More actual than formal" } + $ DR, IPVTNG, IWORK, SPARSE ) ! { dg-warning "Type mismatch" } + END IF + END IF + END IF + IF( IPACK.EQ.0 ) THEN + ONORM = ZLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) + END IF + IF( ANORM.GE.ZERO ) THEN + IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN + IF( IPACK.LE.2 ) THEN + END IF + END IF + END IF + END Index: Fortran/gfortran/regression/pr25603.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr25603.f @@ -0,0 +1,102 @@ +C { dg-do run } +C +C PR rtl-optimization/25603 +C Check if reload handles REG_INC notes correctly. + PROGRAM BAR + IMPLICIT REAL (A-H, O-Z) + DIMENSION WORK(250) + + XSTART = 201.0 + + CALL BAR1(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT, + *XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL, + *DX,DY,DZ,WORK,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP) + STOP + END + + SUBROUTINE BAR2(NX,NY,NZ,NT,NTIME,NWINDX,ISH,NSMT,NFILT, + * XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL, + * DX,DY,DZ,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP,LFINAL, + * C,STEPC,POTT,STEPT,UX,STEPU,VY,STEPV,WZ,PRES,STEPP,Q,DKZM,DKZH, + * ELEV,ELEVX,ELEVY,Z0,HMIX,STEPH,TAVR,OBUK,USTR,TSTR,VDEP,DEP, + * ZET,HVAR,UM,VM,UG,VG,TM,DKM,DCDX,DCDY,AN,BN,CN,HELP,HELPA) + IMPLICIT REAL (A-H, O-Z) + + DIMENSION C(*),STEPC(*),POTT(*),STEPT(*),UX(*),STEPU(*), + * VY(*),STEPV(*),WZ(*),PRES(*),STEPP(*),Q(*),DKZM(*),DKZH(*), + * ELEV(*),ELEVX(*),ELEVY(*),Z0(*),HMIX(*),STEPH(*),TAVR(*), + * OBUK(*),USTR(*),TSTR(*),VDEP(*), DEP(*),ZET(*),HVAR(*), + * UM(*),VM(*),UG(*),VG(*),TM(*),DKM(*), DCDX(*),DCDY(*), + * AN(*),BN(*),CN(*),HELP(*),HELPA(*) +C + + RETURN + END + + SUBROUTINE BAR1(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT, + *XSTART,YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL, + *DX,DY,DZ,WORK,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP) + + IMPLICIT REAL (A-H, O-Z) + DIMENSION WORK(*) + + if (XSTART .NE. 201.0) then + STOP 1 + endif + + LHELPA = 1 + LHELP = 1 + LCN = 1 + LBN = 1 + LAN = 1 + LDCDY = 1 + LDCDX = 1 + LKM = 1 + LTM = 1 + LVG = 1 + LUG = 1 + LVM = 1 + LUM = 1 + LHVAR = 1 + LZET = 1 + LDEP = 1 + LVDEP = 1 + LTSTR = 1 + LUSTR = 1 + LOBUK = 1 + LTAVR = 1 + LSTEPH = 1 + LHMIX = 1 + LZ0 = 1 + LELEVY = 1 + LELEVX = 1 + LELEV = 1 + LDKZH = 1 + LDKZM = 1 + LQ = 1 + LPSTEP = 1 + LPI = 1 + LWZ = 1 + LVSTEP = 1 + LVY = 1 + LUSTEP = 1 + LUX = 1 + LTSTEP = 1 + LPOT = 1 + LCSTEP = 1 + LC = 1 + + CALL BAR2(NX,NY,NZ,NT,NTIME,NWINDX,NWINDY,NSINKS,NFILT,XSTART, + * YSTART,ZSTART,TSTART,DELTAX,DELTAY,DELTAZ,DELTAT,PHI,DL, + * DX,DY,DZ,IB,IK,ITY,NCOUNT,NPRINT,NGRAPH,NPSTEP,NGSTEP,LAST, + * WORK(LC),WORK(LCSTEP),WORK(LPOT),WORK(LTSTEP),WORK(LUX), + * WORK(LUSTEP),WORK(LVY),WORK(LVSTEP),WORK(LWZ),WORK(LPI), + * WORK(LPSTEP),WORK(LQ),WORK(LDKZM),WORK(LDKZH),WORK(LELEV), + * WORK(LELEVX),WORK(LELEVY),WORK(LZ0),WORK(LHMIX),WORK(LSTEPH), + * WORK(LTAVR),WORK(LOBUK),WORK(LUSTR),WORK(LTSTR),WORK(LVDEP), + * WORK(LDEP),WORK(LZET),WORK(LHVAR),WORK(LUM),WORK(LVM),WORK(LUG), + * WORK(LVG),WORK(LTM),WORK(LKM),WORK(LDCDX),WORK(LDCDY),WORK(LAN), + * WORK(LBN),WORK(LCN),WORK(LHELP),WORK(LHELPA)) + + RETURN + END Index: Fortran/gfortran/regression/pr25923.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr25923.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-O -Wuninitialized" } + +module foo +implicit none + + type bar + integer :: yr + end type + +contains + + function baz(arg) result(res) ! { dg-bogus "res.yr' may be" } + type(bar), intent(in) :: arg + type(bar) :: res + logical, external:: some_func + if (.not. some_func(arg)) then + call fatal('arg not valid') + else + res = arg + end if + end function baz ! { dg-warning "res.yr' may be" } + +end module foo Index: Fortran/gfortran/regression/pr26246_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr26246_1.f90 @@ -0,0 +1,17 @@ +! PR fortran/26246 +! { dg-options "-fdump-tree-original" } +! { dg-do compile } + +module pr26246_1 + implicit none + contains + function foo(string) + character(*), intent(in) :: string + character(len=len(string)+2) :: foo + if (index(trim(string), '"').ne.0) then + foo = "'" // trim(string) // "'" + end if + end function foo +end module pr26246_1 + +! { dg-final { scan-tree-dump-times "static int" 0 "original" } } Index: Fortran/gfortran/regression/pr26246_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr26246_2.f90 @@ -0,0 +1,12 @@ +! PR fortran/26246 +! { dg-options "-fdump-tree-original -fno-automatic" } +! { dg-do compile } + +subroutine foo(string, n) + implicit none + integer :: n + character(len=n + 6), intent(in) :: string + if (string .eq. 'abc') STOP 1 +end subroutine foo + +! { dg-final { scan-tree-dump-times "static int" 0 "original" } } Index: Fortran/gfortran/regression/pr26524.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr26524.f @@ -0,0 +1,16 @@ +C PR tree-optimization/26524 +C { dg-do compile } +C { dg-options "-O2 -ffast-math" } + SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, + $ E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, + $ QBLCKB ) + COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ L( LDL, * ), R( LDR, * ) + COMPLEX IMEPS, REEPS + DO 240 I = 1, M + IF( MOD( I, 2 ).NE.0 .AND. I.LT.M ) THEN + A( I, I-1 ) = -IMEPS*2 + END IF + 240 CONTINUE + END + Index: Fortran/gfortran/regression/pr28158.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr28158.f90 @@ -0,0 +1,7 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-require-effective-target ilp32 } +! { dg-options "-O -msse -mfpmath=sse" } + subroutine yhalf(z) + complex cdexpj,z + z=cdexpj((0.d0,1.d0)*z) + end Index: Fortran/gfortran/regression/pr28971.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr28971.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! This caused an ICE for gfortrans of July 2006 vintage. It was a regression +! that "fixed" itself. The cause and the fix are mysteries. This test is intended +! to signal any further regression, should it occur. +! +! Contributed by Oskar Enoksson + +SUBROUTINE BUG(A,B) + IMPLICIT NONE + + INTEGER :: A + INTEGER :: B(2) + + INTEGER, PARAMETER :: C(2) = (/ 1,2 /) + + WHERE (C(:).EQ.A) + B = -1 + END WHERE +END SUBROUTINE BUG + Index: Fortran/gfortran/regression/pr29067.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr29067.f @@ -0,0 +1,18 @@ + ! { dg-do compile } + ! PR fortran/29067 + implicit none + integer :: n, i + character(len=16),parameter :: s = "", s2 = "1234567890123456" + + i = 0 ; n = 9 + print *, s(9:16) + print *, s2(9:16) + if (s(9:16) == "90123456") then + endif + if (i > 0) then + write (i,*) n + call foo(0) + endif + do i = 1, n + end do + end Index: Fortran/gfortran/regression/pr29713.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr29713.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! + character*2 a + character*4 b + parameter (a="12") + parameter (b = a(1:2)) + end Index: Fortran/gfortran/regression/pr30391-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr30391-1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O1" } +SUBROUTINE check_for_overlap (cell_length) + REAL, DIMENSION(1:3), INTENT(IN), OPTIONAL :: cell_length + REAL, DIMENSION(1:3) :: abc, box_length + + IF (PRESENT(cell_length)) THEN + box_length(1:3)=abc(1:3) + ENDIF +END SUBROUTINE check_for_overlap Index: Fortran/gfortran/regression/pr30667.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr30667.f @@ -0,0 +1,10 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-require-effective-target ilp32 } +! { dg-options "-O2 -msse -ftree-vectorize -std=legacy" } + subroutine cblank_cvb(a,ndim) + character*(*) a + character*1 blank + data blank/' '/ + do 100 i=1,ndim +100 a(i:i)=blank + end Index: Fortran/gfortran/regression/pr31025.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr31025.f90 @@ -0,0 +1,9 @@ +! { dg-options "-O2" } +real*8 function f(x) +t1 = g(0) +if(x .eq. 0) then + f = 0 +else if(x .eq. 1) then + f = t1 *log( t1 ) +end if +end Index: Fortran/gfortran/regression/pr32136.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32136.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Tests PR32136, which went away! +! +! Contributed by Tobias Burnus +! +real(kind(0d0)), parameter :: r(1) = & + transfer(transfer(sqrt(2d0), (/ .true. /) ), (/ 0d0 /), 1) + if (r(1) .ne. sqrt(2d0)) STOP 1 +end + Index: Fortran/gfortran/regression/pr32222.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32222.f90 @@ -0,0 +1,17 @@ +!PR fortran/32222 +! { dg-do compile } + +module splinemod +implicit none +integer, parameter :: dl = KIND(1.d0) +Type lSamples + integer l(10) +end Type lSamples +end module splinemod + +subroutine InterpolateClArr(lSet) +use splinemod +type (lSamples), intent(in) :: lSet +real(dl) xl(10) +xl = real(lSet%l,dl) +end subroutine InterpolateClArr Index: Fortran/gfortran/regression/pr32238.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32238.f90 @@ -0,0 +1,21 @@ +!PR fortran/32238 +! { dg-do compile } + +module bug_test + +contains + subroutine bug(c) + + implicit none + + integer, parameter :: fp = selected_real_kind(13) + complex(kind=fp) :: c(:,:) + where( abs( aimag( c ) ) < 1.e-10_fp ) & + & c = cmplx( real( c , fp ) , 0._fp , fp ) + where( abs( real( c , fp ) ) < 1.e-10_fp ) & + & c = cmplx( 0._fp , aimag( c ) , fp ) + + return + end subroutine bug + +end module bug_test Index: Fortran/gfortran/regression/pr32242.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32242.f90 @@ -0,0 +1,39 @@ +!PR fortran/32242 +! { dg-do compile } +! { dg-options "-Wreturn-type" } + +MODULE kahan_sum + INTEGER, PARAMETER :: dp=KIND(0.0D0) + INTERFACE accurate_sum + MODULE PROCEDURE kahan_sum_d1, kahan_sum_z1 + END INTERFACE accurate_sum + TYPE pw_grid_type + REAL (KIND=dp), DIMENSION ( : ), POINTER :: gsq + END TYPE pw_grid_type + TYPE pw_type + REAL (KIND=dp), DIMENSION ( : ), POINTER :: cr + COMPLEX (KIND=dp), DIMENSION ( : ), POINTER :: cc + TYPE ( pw_grid_type ), POINTER :: pw_grid + END TYPE pw_type +CONTAINS + FUNCTION kahan_sum_d1(array,mask) RESULT(ks) ! { dg-warning "not set" } + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array + LOGICAL, DIMENSION(:), INTENT(IN), & + OPTIONAL :: mask + REAL(KIND=dp) :: ks + END FUNCTION kahan_sum_d1 + FUNCTION kahan_sum_z1(array,mask) RESULT(ks) ! { dg-warning "not set" } + COMPLEX(KIND=dp), DIMENSION(:), & + INTENT(IN) :: array + LOGICAL, DIMENSION(:), INTENT(IN), & + OPTIONAL :: mask + COMPLEX(KIND=dp) :: ks + END FUNCTION kahan_sum_z1 + +FUNCTION pw_integral_a2b ( pw1, pw2 ) RESULT ( integral_value ) + TYPE(pw_type), INTENT(IN) :: pw1, pw2 + REAL(KIND=dp) :: integral_value + integral_value = accurate_sum ( REAL ( CONJG ( pw1 % cc ( : ) ) & + * pw2 % cc ( : ) ,KIND=dp) * pw1 % pw_grid % gsq ( : ) ) +END FUNCTION pw_integral_a2b +END MODULE Index: Fortran/gfortran/regression/pr32533.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32533.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-O2 -ftree-vectorize -ffast-math" } +! +! Contributed by Joost VandeVondele +! +SUBROUTINE T(nsubcell,sab_max,subcells) + INTEGER, PARAMETER :: dp=KIND(0.0D0) + REAL(dp) :: sab_max(3), subcells,nsubcell(3) + nsubcell(:) = MIN(MAX(1,NINT(0.5_dp*subcells/sab_max(:))),20) +END SUBROUTINE T + +INTEGER, PARAMETER :: dp=KIND(0.0D0) +REAL(dp) :: sab_max(3), subcells,nsubcell(3) +subcells=2.0_dp +sab_max=0.590060749244805_dp +CALL T(nsubcell,sab_max,subcells) +IF (ANY(nsubcell.NE.2.0_dp)) STOP 1 +END Index: Fortran/gfortran/regression/pr32535.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32535.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! PR32535: namelist with private items contained in sub-sub-procedure of a module rejected +! +! Contributed by Janus Weil + +module mo +implicit none +real, private:: a,b,c + +contains + + subroutine sub + implicit none + namelist /nl1/ a,b,c + + contains + + subroutine subsub + implicit none + namelist /nl2/ a,b,c + end subroutine subsub + end subroutine sub +end module mo Index: Fortran/gfortran/regression/pr32599.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32599.f03 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/32599 +! Verifies that character string arguments to a bind(c) procedure have length +! 1, or no len is specified. Note that the C interop extensions in F2008 allow +! string arguments of length greater than one to be passed to a C descriptor. +! +module pr32599 + interface + subroutine destroy(path) BIND(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'path' at .1. of procedure .destroy. with BIND\\(C\\) attribute" } + use iso_c_binding + implicit none + character(len=*,kind=c_char), intent(IN) :: path + end subroutine destroy + + subroutine create(path) BIND(C) ! { dg-error "Character dummy argument 'path' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'create' has the BIND\\(C\\) attribute" } + use iso_c_binding + implicit none + character(len=5,kind=c_char), intent(IN) :: path + end subroutine create + + ! This should be valid. + subroutine create1(path) BIND(C) + use iso_c_binding + implicit none + character(len=1,kind=c_char), intent(IN) :: path + end subroutine create1 + + ! This should be valid. + subroutine create2(path) BIND(C) + use iso_c_binding + implicit none + character(kind=c_char), intent(IN) :: path + end subroutine create2 + + ! This should be valid. + subroutine create3(path) BIND(C) + use iso_c_binding + implicit none + character(kind=c_char), dimension(*), intent(IN) :: path + end subroutine create3 + end interface +end module pr32599 Index: Fortran/gfortran/regression/pr32601.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32601.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/32601 +module pr32601 +use, intrinsic :: iso_c_binding, only: c_int +contains + function get_ptr() + integer(c_int), pointer :: get_ptr + integer(c_int), target :: x + get_ptr = x + end function get_ptr +end module pr32601 + +USE ISO_C_BINDING, only: c_null_ptr, c_ptr, c_loc +use pr32601 +implicit none + +type(c_ptr) :: t +t = c_null_ptr + +! Next two lines should be errors if -pedantic or -std=f2003 +print *, c_null_ptr, t ! { dg-error "cannot have PRIVATE components" } +print *, t ! { dg-error "cannot have PRIVATE components" } + +print *, c_loc(get_ptr()) ! { dg-error "cannot have PRIVATE components" } + +end Index: Fortran/gfortran/regression/pr32601_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32601_1.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/32601 +use, intrinsic :: iso_c_binding, only: c_loc, c_ptr +implicit none + +! This was causing an ICE, but is an error because the argument to C_LOC +! needs to be a variable. +print *, c_loc(4) ! { dg-error "shall have either the POINTER or the TARGET attribute" } + +end Index: Fortran/gfortran/regression/pr32627.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32627.f03 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-additional-sources pr32627_driver.c } +! Verify that c_f_pointer exists for string arguments. +program main + use iso_c_binding + implicit none + interface + function get_c_string() bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr + type(c_ptr) :: get_c_string + end function get_c_string + end interface + + type, bind( c ) :: A + integer( c_int ) :: xc, yc + type( c_ptr ) :: str + end type + type( c_ptr ) :: x + type( A ), pointer :: fptr + type( A ), target :: my_a_type + character( len=8 ), pointer :: strptr + + fptr => my_a_type + + fptr%str = get_c_string() + + call c_f_pointer( fptr%str, strptr ) + + print *, 'strptr is: ', strptr +end program main + + Index: Fortran/gfortran/regression/pr32627_driver.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32627_driver.c @@ -0,0 +1,4 @@ +char *get_c_string() +{ + return "c_string"; +} Index: Fortran/gfortran/regression/pr32635.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32635.f @@ -0,0 +1,51 @@ +C { dg-do run } +C PR 32635 - this used to call an ICE in verify_ssa at -O2. +C An empty main program ensures that we cycle through all +C the options. + + program main + end + + subroutine aled7(ix,ib,itable,ip,ip2,imat,nummat, + 1 mx0,k,numnp,numel,iadj) + + implicit double precision (a-h,o-z) dp + + common/cale6/fst(16,4),ist(256,14) +c + dimension ib(*),itable(*),ip(3,*),ip2(*),ix(6,*),imat(nummat+1,*) +c +c + ipnt=1 + do 20 i=1,numel + if (imat(ix(5,i),mx0).ne.1) go to 20 + 20 continue +c + k=0 + kflg=0 + 25 do 30 i=1,ipnt + if (ip(1,i).eq.0) go to 30 + ii=i + go to 40 + 30 continue +c + 40 k=k+1 + iel=ip(3,ii) + ib(k+iadj)=i1 + if (kflg.eq.1) ip(1,ii)=0 + kflg=1 +c + isum=0 + do 50 i=1,ipnt + if (ip(1,i).eq.0) isum=isum+1 + if (ip(1,i).eq.0.or.ip(1,i).ne.i2) go to 50 + ii=i + if (ip(3,i).eq.iel) go to 40 + 50 continue +c + if (ip(1,ii).eq.i2) go to 40 + kflg=0 + if (isum.ne.ipnt) go to 25 +c + return + end Index: Fortran/gfortran/regression/pr32738.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32738.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! PR fortran/32738 +! +! A regression that mysteriously appeared and disappeared again. +! Added to the testsuite "just in case". +! +! Contributed by Michael Richmond +! + +module cluster_definition + implicit none + integer, parameter, public:: cluster_size = 1000 +end module cluster_definition +module cluster_tree + use cluster_definition, only: ct_cluster_size => cluster_size + implicit none + private + private:: ct_initialize, ct_dealloc, ct_tree_size + public:: initialize, dealloc, tree_size + interface initialize + module procedure ct_initialize + end interface + interface dealloc + module procedure ct_dealloc + end interface + interface tree_size + module procedure ct_tree_size + end interface +contains + subroutine ct_initialize() + end subroutine ct_initialize + subroutine ct_dealloc() + end subroutine ct_dealloc + function ct_tree_size(t) result(s) + integer :: t + integer :: s + s = 0 + end function ct_tree_size +end module cluster_tree +program example + use cluster_tree + implicit none + print *, tree_size(1) +end program example Index: Fortran/gfortran/regression/pr32801.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32801.f03 @@ -0,0 +1,6 @@ +! { dg-do compile } +! Verify that C_PTR is auto generated because it's needed by C_LOC. +! This tests that PR 32801 is fixed. +PROGRAM c_loc_prob + USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LOC +END PROGRAM c_loc_prob Index: Fortran/gfortran/regression/pr32921.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr32921.f @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-lim2" } +! gfortran -c -m32 -O2 -S junk.f +! + MODULE LES3D_DATA + + IMPLICIT REAL*8 (A-H,O-Z) + + PARAMETER ( NSPECI = 1, ND = 7 + NSPECI ) + + INTEGER IMAX + + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:) :: + > UAV,QAV + + + END MODULE LES3D_DATA +!--------------------------------------------------------------------- +!------------------------------------------------------------------------ + SUBROUTINE FLUXI() + + USE LES3D_DATA + IMPLICIT REAL*8(A-H,O-Z) + + ALLOCATABLE QS(:) + + ALLOCATE( QS(0:IMAX)) + QS=0D0 + + RETURN + END +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + SUBROUTINE EXTRAPI() + + USE LES3D_DATA + IMPLICIT REAL*8(A-H,O-Z) + + I1 = 0 + I2 = IMAX - 1 + + DO I = I1, I2 + UAV(I,1,2) = QAV(I,1,2) + END DO + + RETURN + END +! { dg-final { scan-tree-dump-times "stride" 4 "lim2" } } Index: Fortran/gfortran/regression/pr33074.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr33074.f90 @@ -0,0 +1,8 @@ +! PR middle-end/33074 +! { dg-do compile } +! { dg-options "-O" } + +subroutine pr33074(a, w) + real a(1), w(1) + a(1) = 2.0**int(w(1)) +end Index: Fortran/gfortran/regression/pr33449.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr33449.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-vectorize" } +! +! Testcase for vectorization (see PR33449). +! +subroutine dlarre (w, iblock, work) + integer m, i, iblock(*) + double precision w(*), work(*) + + m = 0 + do jblk = 1, 10 + do i = 1, 10 + m = m + 1 + w(m) = -work(i) + iblock(m) = 0 + end do + end do +end Index: Fortran/gfortran/regression/pr33646.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr33646.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! PR fortran/33646 +! +! + +module BAR_MODULE + implicit none + private + public create_ + interface create_ + module procedure create + end interface + type system_type + integer(kind=kind(1)) :: max_memory_used + end type + +contains + + subroutine create(self) + type(system_type) :: self + pointer :: self + allocate(self) + end subroutine + +end + +module FOO_MODULE + use BAR_MODULE + implicit none + private + public create_ + interface create_ + module procedure create + end interface + + public create_copy_ + interface create_copy_ + module procedure create_copy + end interface +contains + + subroutine create(self) + character(*) :: self + pointer :: self + nullify(self) + allocate(self) + + self = " " + end subroutine + + subroutine create_copy(self,s) + character(*) :: self + pointer :: self + character(*) :: s + call create_(self) + end subroutine +end Index: Fortran/gfortran/regression/pr33794.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr33794.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-O2 -ffast-math -mfpmath=387" { target { { i?86-*-* x86_64-*-* } && { ! { ia32 } } } } } +! { dg-options "-O2 -ffast-math" } + +module scc_m + implicit none + integer, parameter :: dp = selected_real_kind(15,90) +contains + subroutine self_ind_cir_coil (r, l, turns, mu, self_l) + implicit none + real (kind = dp), intent(in) :: r, l, turns, mu + real (kind = dp), intent(out) :: self_l + real (kind = dp) :: alpha, modulus, pk, ak, bk, ae, be, elliptice, elliptick + real (kind = dp) :: expected + alpha = atan(2.0_dp*r/l) + modulus = sin(alpha) + pk = 1.0_dp - modulus**2 + ak = (((0.01451196212_dp*pk+0.03742563713_dp)*pk+ & + 0.03590092383_dp)*pk+0.09666344259_dp)*pk+1.38629436112_dp + bk = (((0.00441787012_dp*pk+0.03328355346_dp)*pk+ & + 0.06880248576_dp)*pk+0.12498593597_dp)*pk+0.5_dp + elliptick = ak - bk * log(pk) + ae = (((0.01736506451_dp*pk+0.04757383546_dp)*pk+ & + 0.0626060122_dp)*pk+0.44325141463_dp)*pk+1.0_dp + be = (((0.00526449639_dp*pk+0.04069697526_dp)*pk+ & + 0.09200180037_dp)*pk+0.2499836831_dp)*pk + elliptice = ae - be * log(pk) + self_l = (mu * turns**2 * l**2 * 2.0_dp * r)/3.0_dp * & + (((tan(alpha)**2-1.0_dp)*elliptice+elliptick)/sin(alpha) - & + tan(alpha)**2) + expected = 3.66008420600434162E-002_dp + if (abs(self_l - expected) / expected > 1e-3) & + STOP 1 + end subroutine self_ind_cir_coil +end module scc_m + +program test + use scc_m + implicit none + + real (kind = dp) :: mu, turns, r, l, self_l + mu = 1.25663706143591729E-006_dp + turns = 166666.66666666666_dp + l = 3.00000000000000006E-003_dp + r = 2.99999999999999989E-002_dp + + call self_ind_cir_coil (r, l, turns, mu, self_l) +end program test Index: Fortran/gfortran/regression/pr34163.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr34163.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fno-tree-pre -fpredictive-commoning -fdump-tree-pcom-details" } +subroutine trisolve2(x,i1,i2,nxyz) +integer :: nxyz +real,dimension(nxyz):: au1 +real,allocatable,dimension(:) :: gi +integer :: i1 , i2 +real,dimension(i2)::x +integer :: i +allocate(gi(nxyz)) +do i = i1+1 , i2 + x(i) = gi(i)*(x(i)-au1(i-1)*x(i-1)) +enddo +end subroutine trisolve2 +! { dg-final { scan-tree-dump "Executing predictive commoning" "pcom" } } Index: Fortran/gfortran/regression/pr35031.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35031.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +elemental subroutine sub2(x) + integer, intent(in) :: x + entry sub2_c(x) bind(c) ! { dg-error "prohibited in an elemental" } +end subroutine sub2 + +elemental function func2(x) + integer, intent(in) :: x + entry func2_c(x) bind(c) ! { dg-error "prohibited in an elemental" } +end function func2 Index: Fortran/gfortran/regression/pr35662.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35662.f90 @@ -0,0 +1,20 @@ +! PR target/35662 +! { dg-do run } +! { dg-options "-O1" } + +subroutine f(x, y, z) + real, intent (in) :: x + real, intent (out) :: y, z + y = sin (x) + z = cos (x) +end subroutine f + +program pr35662 + real :: x, y, z + x = 3.1415926535897932384626433832795029 + call f (x, y, z) + if (abs (y) > 1.0e-5 .or. abs (z + 1.0) > 1.0e-5) STOP 1 + x = x / 2.0 + call f (x, y, z) + if (abs (y - 1.0) > 1.0e-5 .or. abs (z) > 1.0e-5) STOP 2 +end program pr35662 Index: Fortran/gfortran/regression/pr35849.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35849.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR35849 +INTEGER, PARAMETER :: j = 15 +INTEGER, PARAMETER, DIMENSION(10) :: A = [(i, i = 1,10)] +INTEGER, PARAMETER, DIMENSION(10) :: B = ISHFTC(j, A, -20) ! { dg-error "must be positive" } +INTEGER, PARAMETER, DIMENSION(10) :: C = ISHFTC(1_1, A, j) ! { dg-error "less than or equal to BIT_SIZE" } +INTEGER, PARAMETER, DIMENSION(10) :: D = ISHFTC(3, A, 5) ! { dg-error "Absolute value of SHIFT shall be less than or equal" } +INTEGER, PARAMETER, DIMENSION(10) :: E = ISHFTC(3_1, A) ! { dg-error "second argument of ISHFTC exceeds BIT_SIZE of first argument" } +end Index: Fortran/gfortran/regression/pr35944-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35944-1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } + + implicit none + integer i + real rda1(10), rda(10), rval + double precision dda1(10), dda(10), dval + + rda = (/ 1,2,3,4,5,6,7,8,9,10 /) + rDA1 = MOD (1.1*(rDA(1)-5.0), P=(rDA-2.5)) + DO i = 1, 10 + rVAL = MOD (1.1*(rDA(1)-5.0), P=(rDA(i)-2.5)) + if (rval /= rda1(i)) STOP 1 + enddo + + dda = (/ 1,2,3,4,5,6,7,8,9,10 /) + dDA1 = MOD (1.1d0*(dDA(1)-5.0d0), P=(dDA-2.5d0)) + DO i = 1, 10 + dVAL = MOD (1.1d0*(dDA(1)-5.0d0), P=(dDA(i)-2.5d0)) + if (dval /= dda1(i)) STOP 2 + enddo + +end Index: Fortran/gfortran/regression/pr35944-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35944-2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } + + implicit none + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + integer :: i + real(k) :: qda1(10), qda(10), qval + + qda = (/ 1,2,3,4,5,6,7,8,9,10 /) + QDA1 = MOD (1.1_k*(QDA(1)-5.0_k), P=(QDA-2.5_k)) + DO i = 1, 10 + QVAL = MOD (1.1_k*(QDA(1)-5.0_k), P=(QDA(i)-2.5_k)) + if (qval /= qda1(i)) STOP 1 + enddo +end Index: Fortran/gfortran/regression/pr35983.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr35983.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR fortran/35983 +! C_LOC expanded to a NULL_PTR expr if called from a structure constructor +! +! Contributed by François-Xavier Coudert + +program main + use ISO_C_BINDING + implicit none + type, bind(C) :: descr + type(C_PTR) :: address + end type descr + type(descr) :: DD + double precision, target :: buf(1) + integer (C_INTPTR_T) :: i, j + + buf = (/ 0 /) + DD = descr(c_loc(buf)) + i = transfer (DD%address, 0_c_intptr_t) + j = transfer (c_loc(buf), 0_c_intptr_t) + if (any((/ i,j /) == 0_c_intptr_t)) STOP 1 + if (i /= j) STOP 2 +end program main Index: Fortran/gfortran/regression/pr36006-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36006-1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +subroutine test4 + integer, parameter :: wp = 4 + complex(wp), parameter :: i = (0._wp, 1._wp) + complex(wp) :: c(12) + integer :: m, N + + N = 12 + c = (/(exp(i*m),m=1,N)/) + print *, c(1) +end + +subroutine test8 + integer, parameter :: wp = 8 + complex(wp), parameter :: i = (0._wp, 1._wp) + complex(wp) :: c(12) + integer :: m, N + + N = 12 + c = (/(exp(i*m),m=1,N)/) + print *, c(1) +end Index: Fortran/gfortran/regression/pr36006-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36006-2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-require-effective-target fortran_large_real } +! +subroutine test_large + integer, parameter :: wp = selected_real_kind (precision (0.0_8) + 1) + complex(wp), parameter :: i = (0._wp, 1._wp) + complex(wp) :: c(12) + integer :: m, N + + N = 12 + c = (/(exp(i*m),m=1,N)/) + print *, c(1) +end Index: Fortran/gfortran/regression/pr36192.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36192.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/36192.f90 +! +program three_body + real, parameter :: n = 2, d = 2 + real, dimension(n,d) :: x ! { dg-error "Expecting a scalar INTEGER" } + x(1,:) = (/ 1.0, 0.0 /) +end program three_body Index: Fortran/gfortran/regression/pr36192_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36192_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/36192 +program three_body + real, parameter :: n = 2, d = 2 + real, dimension(n,d) :: x_hq ! { dg-error "Expecting a scalar INTEGER" } + call step(x_hq) + contains + subroutine step(x) + real, dimension(:,:), intent(in) :: x + end subroutine step +end program three_body +! { dg-prune-output "Rank mismatch in argument" } Index: Fortran/gfortran/regression/pr36206.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36206.f @@ -0,0 +1,95 @@ +! { dg-do compile } +! { dg-options "-O3" } +! PR fortran/36206 + + SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) + REAL ALPHA + INTEGER INCX,N + CHARACTER UPLO + REAL AP(*),X(*) + REAL ZERO + PARAMETER (ZERO=0.0E+0) + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL LSAME + EXTERNAL LSAME + EXTERNAL XERBLA + + INFO = 0 + IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN + INFO = 1 + ELSE IF (N.LT.0) THEN + INFO = 2 + ELSE IF (INCX.EQ.0) THEN + INFO = 5 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SSPR ',INFO) + RETURN + END IF + IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN + IF (INCX.LE.0) THEN + KX = 1 - (N-1)*INCX + ELSE IF (INCX.NE.1) THEN + KX = 1 + END IF + KK = 1 + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 60 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF + RETURN + END Index: Fortran/gfortran/regression/pr36680.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36680.f90 @@ -0,0 +1,43 @@ +! PR target/36680 +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-options "-O1 -fschedule-insns" } + +MODULE class_dummy_atom_kdtree_types + TYPE dummy_atom_kdtree_data + INTEGER :: dummy + END TYPE + + TYPE :: dummy_atom_kdtree_node + TYPE(dummy_atom_kdtree_node_private), POINTER :: p + END TYPE + + TYPE :: dummy_atom_kdtree_node_private + TYPE(dummy_atom_kdtree_data) :: data + END TYPE + + TYPE :: dummy_atom_kdtree + TYPE(dummy_atom_kdtree_node) :: root + END TYPE +END MODULE + +FUNCTION dummy_atom_kdtree_insert(this, item) + USE class_dummy_atom_kdtree_types + + TYPE(dummy_atom_kdtree), INTENT(inout) :: this + TYPE(dummy_atom_kdtree_data), INTENT(in) :: item + + TYPE(dummy_atom_kdtree_node) :: parent, current + INTEGER :: cmp, level, discriminator + + parent = dummy_atom_kdtree_node(null()) + current = this%root + level = 1 + discriminator = 1 + + DO WHILE (ASSOCIATED( current%p )) + discriminator = MODULO(level-1, 3) + 1 + cmp = dummy_atom_kdtree_data_compare(item, current%p%data, discriminator) + level = level + 1 + END DO + +END FUNCTION Index: Fortran/gfortran/regression/pr36967.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr36967.f @@ -0,0 +1,25 @@ +! { dg-options "-O2 -fpredictive-commoning" } + subroutine foo(x,y,n) + integer n + real*8 y(n,n,n),x(n,n,n) + integer k, j, i + do k = 2, n-1 + do j = 2, n-1 + do I = 2, n-1 + y(i,j,k) = y(i,j,k) + + + (x(i-1,j-1,k) + + + x(i,j-1,k-1) + + + x(i,j+1,k-1) + + + x(i,j+1,k+1) + + + x(i+1,j,k+1)) + + + (x(i-1,j-1,k-1) + + + x(i+1,j-1,k-1) + + + x(i-1,j+1,k-1) + + + x(i+1,j+1,k-1) + + + x(i-1,j+1,k+1) + + + x(i+1,j+1,k+1)) + enddo + enddo + enddo + return + end Index: Fortran/gfortran/regression/pr37243.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr37243.f @@ -0,0 +1,66 @@ +! PR rtl-optimization/37243 +! { dg-do run } +! { dg-options "-std=legacy" } +! { dg-add-options ieee } +! Check if register allocator handles IR flattening correctly. + SUBROUTINE SCHMD(V,M,N,LDV) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + LOGICAL GOPARR,DSKWRK,MASWRK + DIMENSION V(LDV,N) + COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400) + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK + PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TOL=1.0D-10) + IF (M .EQ. 0) GO TO 180 + DO 160 I = 1,M + DUMI = ZERO + DO 100 K = 1,N + 100 DUMI = DUMI+V(K,I)*V(K,I) + DUMI = ONE/ SQRT(DUMI) + DO 120 K = 1,N + 120 V(K,I) = V(K,I)*DUMI + IF (I .EQ. M) GO TO 160 + I1 = I+1 + DO 140 J = I1,M + DUM = -DDOT(N,V(1,J),1,V(1,I),1) + CALL DAXPY(N,DUM,V(1,I),1,V(1,J),1) + 140 CONTINUE + 160 CONTINUE + IF (M .EQ. N) RETURN + 180 CONTINUE + I = M + J = 0 + 200 I0 = I + I = I+1 + IF (I .GT. N) RETURN + 220 J = J+1 + IF (J .GT. N) GO TO 320 + DO 240 K = 1,N + 240 V(K,I) = ZERO + CALL DAXPY(N,DUM,V(1,I),1,V(1,I),1) + 260 CONTINUE + DUMI = ZERO + DO 280 K = 1,N + 280 DUMI = DUMI+V(K,I)*V(K,I) + IF ( ABS(DUMI) .LT. TOL) GO TO 220 + DO 300 K = 1,N + 300 V(K,I) = V(K,I)*DUMI + GO TO 200 + 320 END + program main + DOUBLE PRECISION V + DIMENSION V(18, 18) + common // v + + call schmd(V, 1, 18, 18) + end + + subroutine DAXPY(N,D,V,M,W,L) + INTEGER :: N, M, L + DOUBLE PRECISION D, V(1,1), W(1,1) + end + + FUNCTION DDOT (N,V,M,W,L) + INTEGER :: N, M, L + DOUBLE PRECISION DDOT, V(1,1), W(1,1) + DDOT = 1 + end Index: Fortran/gfortran/regression/pr37286.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr37286.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-require-visibility "" } + +module general_rand + implicit none + private + + integer, public, parameter :: GNDP = kind(1.0d0) + + real(kind = GNDP), save :: & + gnc = 362436.0 / 16777216.0, & + gncd = 7654321.0 / 16777216.0, & + gncm = 16777213.0 / 16777216.0 + integer, save :: & + gni97 = 97, & + gnj97 = 33 + + real(kind = GNDP), save :: gnu(97) + +contains + subroutine gn_fatal(message) + character(len = *), intent(in) :: message + + stop 1 + end subroutine gn_fatal + + function gn_monte_rand(min, max) result(monte) + real(kind = GNDP), intent(in) :: min + real(kind = GNDP), intent(in) :: max + real(kind = GNDP) :: monte + + real :: monte_temp + + if (min > max) then + call gn_fatal('gn_monte_rand: min > max') + else if (min == max) then + call gn_fatal('gn_monte_rand: min = max: returning min') + monte_temp = min + else + + monte_temp = gnu(gni97) - gnu(gnj97) + if (monte_temp < 0.0) then + monte_temp = monte_temp + 1.0 + end if + + gnu(gni97) = monte_temp + gni97 = gni97 - 1 + if (gni97 == 0) then + gni97 = 97 + end if + end if + + monte = min + monte_temp * (max - min) + + end function gn_monte_rand + +end module general_rand Index: Fortran/gfortran/regression/pr37287-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr37287-1.f90 @@ -0,0 +1,15 @@ +! PR debug/37287 +! { dg-do link } +! { dg-options "-g -DPR37287_1" } +! { dg-additional-sources pr37287-2.F90 } +module pr37287_1 + use iso_c_binding, only : c_ptr, c_associated, c_null_ptr + implicit none +contains + subroutine set_null(ptr) + type(c_ptr), intent(out) :: ptr + ptr = c_null_ptr + end subroutine set_null +end module pr37287_1 +end +! { dg-final { cleanup-modules "pr37287_2" } } Index: Fortran/gfortran/regression/pr37287-2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr37287-2.F90 @@ -0,0 +1,9 @@ +! PR debug/37287 +! { dg-do compile } +! { dg-options "-g" } +module pr37287_2 +#ifdef PR37287_1 + use pr37287_1 +#endif + implicit none +end module pr37287_2 Index: Fortran/gfortran/regression/pr38351.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr38351.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +module m1 + type t1 + integer :: i + end type t1 + interface operator(+) + module procedure add + end interface + contains + type(t1) function add(a,b) + type(t1), intent(in) :: a,b + end function +end module m1 + +program foo + use m1 + type(t1), dimension(2,2) :: a = t1(1), b = t1(2) + type(t1) :: c=t1(1), d=t1(2) + c = c + d + a = a + b ! { dg-error "Unexpected derived-type entities" } +end program foo Index: Fortran/gfortran/regression/pr38722.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr38722.f90 @@ -0,0 +1,38 @@ +! PR rtl-optimization/38722 +! { dg-do compile } +! { dg-options "-O1" } +SUBROUTINE foo(x, n, ga, gc, vr) + TYPE pt + DOUBLE PRECISION, DIMENSION (:, :, :), POINTER :: cr + END TYPE pt + TYPE pu + TYPE(pt), POINTER :: pw + END TYPE pu + LOGICAL, INTENT(in) :: x, ga, gc + INTEGER :: i, n + LOGICAL :: dd, ep, fe + TYPE(pu) :: vr + TYPE(pu), DIMENSION(:), POINTER :: v + IF (.NOT. fe) THEN + IF (ga) THEN + CALL bar (dd, ep, gc) + END IF + IF (x .AND. .NOT. ga) THEN + IF (gc) THEN + DO i=1,n + CALL baz (v(i), x, gc) + v(i)%pw%cr = 1.0 + END DO + DO i=1,n + IF (ep) THEN + IF (dd) THEN + IF (i==1) THEN + v(i)%pw%cr=v(i)%pw%cr + vr%pw%cr + ENDIF + END IF + END IF + END DO + END IF + ENDIF + END IF +END SUBROUTINE foo Index: Fortran/gfortran/regression/pr38868.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr38868.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-rtl-expand" } + PROGRAM testcase + IMPLICIT NONE + + CHARACTER*4 ANER(18) + CHARACTER*80 LINE + aner = '' + ANER(1)='A ' + ANER(2)=' ' + LINE=' ' + LINE(78:80)='xyz' + WRITE(*,'(A82)') "'"//LINE//"'" + END + +! { dg-final { scan-rtl-dump-times "line\\\+80" 0 "expand" } } Index: Fortran/gfortran/regression/pr39152.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39152.f @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-O2" } + SUBROUTINE CASHES(E,HESS,FC,FA,NORB,NPR) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MXAO=2047) + DIMENSION HESS(NPR),E(NORB,*),FC(*),FA(*) + COMMON /IJPAIR/ IA(MXAO) + COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM + K=0 + DO 200 IU = 1,NORB - NCORBS + I = IU + NCORBS + II=IA(I)+I + DO 100 J = 1,NCORBS + IF (I.GT.NORBS) THEN + HESS(K)=FC(II) + FA(II) - E(J,J) + ELSE + HESS(K)=FA(II) - E(I,I) - E(J,J) + FC(JJ) + FA(JJ) + END IF + 100 CONTINUE + 200 CONTINUE + RETURN + END Index: Fortran/gfortran/regression/pr39666-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39666-1.f90 @@ -0,0 +1,14 @@ +! PR middle-end/39666 +! { dg-do compile } +! { dg-options "-O2 -Wuninitialized" } + +FUNCTION f(n) + INTEGER, INTENT(in) :: n + REAL :: f + + SELECT CASE (n) + CASE (:-1); f = -1.0 + CASE (0); f = 0.0 + CASE (1:); f = 1.0 + END SELECT +END FUNCTION Index: Fortran/gfortran/regression/pr39666-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39666-2.f90 @@ -0,0 +1,14 @@ +! PR middle-end/39666 +! { dg-do compile } +! { dg-options "-O2 -Wuninitialized" } + +FUNCTION f(n) + INTEGER, INTENT(in) :: n + REAL :: f + + SELECT CASE (n) + CASE (:-1); f = -1.0 + CASE (0); f = 0.0 + CASE (2:); f = 1.0 + END SELECT +END FUNCTION ! { dg-warning "may be used uninitialized" } Index: Fortran/gfortran/regression/pr39695_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39695_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! + +function f() + intrinsic :: sin + procedure(sin), pointer :: f ! { dg-error "Procedure pointer 'f'" } + f => sin +end function f Index: Fortran/gfortran/regression/pr39695_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39695_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! + +function g() + interface + subroutine g() + end subroutine g + end interface + pointer g + real g ! { dg-error "Symbol 'g' at .1. cannot have a type" } +end function + Index: Fortran/gfortran/regression/pr39695_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39695_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! + +function g() + interface + subroutine g() ! { dg-error "RESULT attribute in 'g'" } + end subroutine g + end interface + real g ! { dg-error "Symbol 'g' at .1. cannot have a type" } +end function + Index: Fortran/gfortran/regression/pr39695_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39695_4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! + +function g() + implicit none + interface + function g() + integer g + end function g + end interface + pointer g + real g ! { dg-error "Symbol 'g' at .1. already has basic type of INTEGER" } +end function + Index: Fortran/gfortran/regression/pr39865.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39865.f90 @@ -0,0 +1,84 @@ +! PR fortran/39865 +! { dg-do run } + +subroutine f1 (a) + character(len=1) :: a(7:) + character(len=12) :: b + character(len=1) :: c(2:10) + write (b, a) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') STOP 1 + write (b, a(:)) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') STOP 2 + write (b, a(8:)) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') STOP 3 + c(2) = ' ' + c(3) = '(' + c(4) = '3' + c(5) = 'A' + c(6) = '4' + c(7) = ')' + write (b, c) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') STOP 4 + write (b, c(:)) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') STOP 5 + write (b, c(3:)) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') STOP 6 +end subroutine f1 + +subroutine f2 (a) + character(len=1) :: a(10:,20:) + character(len=12) :: b + write (b, a) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') STOP 7 + write (b, a) 'hell', 'o Wo', 'rld!' + if (b .ne. 'hello World!') STOP 8 +end subroutine f2 + +function f3 () + character(len=1) :: f3(5) + f3(1) = '(' + f3(2) = '3' + f3(3) = 'A' + f3(4) = '4' + f3(5) = ')' +end function f3 + + interface + subroutine f1 (a) + character(len=1) :: a(:) + end + end interface + interface + subroutine f2 (a) + character(len=1) :: a(:,:) + end + end interface + interface + function f3 () + character(len=1) :: f3(5) + end + end interface + integer :: i, j + character(len=1) :: e (6, 7:9), f (3,2), g (10) + character(len=12) :: b + e = 'X' + e(2,8) = ' ' + e(3,8) = '(' + e(4,8) = '3' + e(2,9) = 'A' + e(3,9) = '4' + e(4,9) = ')' + f = e(2:4,8:9) + g = 'X' + g(2) = ' ' + g(3) = '(' + g(4) = '3' + g(5) = 'A' + g(6) = '4' + g(7) = ')' + call f1 (g(2:7)) + call f2 (f) + call f2 (e(2:4,8:9)) + write (b, f3 ()) 'Hell', 'o wo', 'rld!' + if (b .ne. 'Hello world!') STOP 9 +end Index: Fortran/gfortran/regression/pr39937.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr39937.f @@ -0,0 +1,30 @@ +C { dg-do compile } +C { dg-options "-std=legacy" } + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) + DOUBLE PRECISION X( 2, 2 ) + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ ZERO, X, 2, SCALE, XNORM, IERR ) ! { dg-warning "Type mismatch" } + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + END IF + END IF + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, ! { dg-warning "Type mismatch" } + $ XNORM, IERR ) ! { dg-warning "Type mismatch" } + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE + END Index: Fortran/gfortran/regression/pr40587.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr40587.f @@ -0,0 +1,17 @@ +C PR traget/40587 +C { dg-do compile } +C { dg-options "-O2" } + subroutine TEST(i, r, result) + implicit none + integer i + REAL*8 r + REAL*8 result + REAL*8 r2 + if(i.eq.0) then + r2 = r + else + call ERROR() + endif + result = r2 + return + end Index: Fortran/gfortran/regression/pr40839.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr40839.f90 @@ -0,0 +1,5 @@ +! PR fortran/40839 +! { dg-do compile } +write(fmt='(a)'), 'abc' ! { dg-error "UNIT not specified" } +write(fmt='()') ! { dg-error "UNIT not specified" } +end Index: Fortran/gfortran/regression/pr40999.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr40999.f @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O3" } + + SUBROUTINE ZLARFG( ALPHA ) + COMPLEX*16 ZLADIV + ALPHA = ZLADIV( DCMPLX( 1.0D+0 ) ) + END + COMPLEX*16 FUNCTION ZLADIV( X ) + COMPLEX*16 X + CALL DLADIV( DBLE( X ), DIMAG( X ) ) + END + Index: Fortran/gfortran/regression/pr41011.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41011.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O3 -std=legacy" } + CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" } + *ITY,ISH,NSMT,F) + CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA, + * HELP,HELPA,FY,FYC,SAVEY) + END + SUBROUTINE PADEC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT) + COMPLEX*16 WM(*),WG(*),FN(*),AN(*),BN(*),CN(*) + BN(J)=F4+AS+GAMMA*F2 + CN(J)=F4-AS+GAMMA*F2 + FN(J)=(AS+F4-GAMMA*F2)*H2+(F4-AS-GAMMA*F2)*H0+ + * H1*(F3-GAMMA/3.D0)+GAMMA*WG(J)-CONST + END + SUBROUTINE UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM, + *WORK,ITY,IH,NSMT,F) + DIMENSION HVAR(*),ZET(*),TM(*),DKM(*),UM(*),VM(*),UG(*),VG(*), + *WORK(*) + IF(IH.EQ.0) THEN + CALL PADEC(DKM,VM,HVAR,WORK(LWM),WORK(LWG), ! { dg-warning "Rank mismatch" } + * WORK(LF),NZ,WORK(LA),WORK(LB),WORK(LC),ITY) ! { dg-warning "Type mismatch" } + ENDIF + END Index: Fortran/gfortran/regression/pr41043.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41043.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2" } + subroutine foo + implicit none + + integer :: i + + call gee_i(int(i**huge(0_8),kind=kind(i))) + + end subroutine foo + Index: Fortran/gfortran/regression/pr41126.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41126.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +SUBROUTINE write_cputime( checkpoint ) + CHARACTER(LEN=*), INTENT(IN) :: checkpoint + CHARACTER(LEN=LEN_TRIM(checkpoint)+7) :: string1 + string1 = ADJUSTL(string1) +END SUBROUTINE write_cputime Index: Fortran/gfortran/regression/pr41162.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41162.f @@ -0,0 +1,5 @@ +! { dg-do compile } +! PRs 41154/41162 + write (*,'(1PD24.15,F4.2,0P)') 1.0d0 + write (*,'(1PD24.15,F4.2,0P/)') 1.0d0 + end Index: Fortran/gfortran/regression/pr41212.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41212.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-O2" } +program m + double precision :: y,z + call b(1.0d0,y,z) + if (ABS (z - 1.213) > 0.1) STOP 1 +contains + subroutine b( x, y, z) + implicit none + double precision :: x,y,z + integer :: i, k + double precision :: h, r + + y = 1.0d0 + z = 0.0d0 + + h = 0 + DO k = 1,10 + h = h + 1.0d0/k + + r = 1 + DO i = 1,k + r = (x/(2*i) ) * r + END DO + + y = y + (-1)**k * r + z = z + (-1)**(k+1) * h * r + + IF ( ABS(2*k/x*r) < 1d-6 ) EXIT + END DO + + z = 2*y + end subroutine b +end program m Index: Fortran/gfortran/regression/pr41225.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41225.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O2 -ffast-math -funroll-loops -ftree-vectorize -g" } + SUBROUTINE block_15_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + INTEGER, PARAMETER :: dp=8 + REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(15*1), kac(15*1), pbd(1*1), & + pbc(1*1), pad(15*1), pac(15*1), prim(15*1*1*1), scale + INTEGER :: ma, mb, mc, md, p_index + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,15 + p_index=p_index+1 + tmp = scale*prim(p_index) + ks_bd = ks_bd + tmp* pac((mc-1)*15+ma) + END DO + kbd((md-1)*1+mb) = kbd((md-1)*1+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_15_1_1_1 Index: Fortran/gfortran/regression/pr41229.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41229.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O2 -g" } +SUBROUTINE cp_fm_triangular_multiply() + INTEGER, PARAMETER :: dp=KIND(0.0D0) + REAL(dp), ALLOCATABLE, DIMENSION(:) :: tau, work + REAL(KIND=dp), DIMENSION(:, :), POINTER :: a + ndim = SIZE(a,2) + ALLOCATE(tau(ndim),STAT=istat) + ALLOCATE(work(2*ndim),STAT=istat) +END SUBROUTINE Index: Fortran/gfortran/regression/pr41347.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41347.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-O3" } +module hsl_ma41_m + + implicit none + + contains + + subroutine solve_ma41 + integer, dimension(20) :: info + call prininfo(15, info) + end subroutine solve_ma41 + + subroutine prininfo (ni, info) + integer, intent(in) :: ni + integer, intent(in), dimension(:) :: info + + integer i + + call prinfo + + contains + + subroutine prinfo + do i = 1, ni + write(*,'(i5,1x,i0)') i, info(i) + end do + end subroutine prinfo + + end subroutine prininfo + +end module hsl_ma41_m Index: Fortran/gfortran/regression/pr41922.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41922.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options -std=gnu } + Subroutine RestoreR8Run() + Implicit NONE + Integer ISTORE + Real XSTORE + character CSTORE(8) + data cstore/8*' '/ + data istore/0/ + EQUIVALENCE (CSTORE(1),XSTORE,ISTORE) ! { dg-error "Overlapping unequal" } + end Index: Fortran/gfortran/regression/pr41928.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr41928.f90 @@ -0,0 +1,263 @@ +! { dg-do compile } +! { dg-options "-O -fbounds-check -w" } +MODULE kinds + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 ) + INTEGER, DIMENSION(:), ALLOCATABLE :: nco,ncoset,nso,nsoset + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: co,coset +END MODULE kinds +MODULE ai_moments + USE kinds +CONTAINS + SUBROUTINE cossin(la_max,npgfa,zeta,rpgfa,la_min,& + lb_max,npgfb,zetb,rpgfb,lb_min,& + rac,rbc,kvec,cosab,sinab) + REAL(KIND=dp), DIMENSION(ncoset(la_max),& + ncoset(lb_max)) :: sc, ss + DO ipgf=1,npgfa + DO jpgf=1,npgfb + IF (la_max > 0) THEN + DO la=2,la_max + DO ax=2,la + DO ay=0,la-ax + sc(coset(ax,ay,az),1) = rap(1)*sc(coset(ax-1,ay,az),1) +& + f2 * kvec(1)*ss(coset(ax-1,ay,az),1) + ss(coset(ax,ay,az),1) = rap(1)*ss(coset(ax-1,ay,az),1) +& + f2 * kvec(1)*sc(coset(ax-1,ay,az),1) + END DO + END DO + END DO + IF (lb_max > 0) THEN + DO lb=2,lb_max + ss(1,coset(0,0,lb)) = rbp(3)*ss(1,coset(0,0,lb-1)) +& + f2 * kvec(3)*sc(1,coset(0,0,lb-1)) + DO bx=2,lb + DO by=0,lb-bx + ss(1,coset(bx,by,bz)) = rbp(1)*ss(1,coset(bx-1,by,bz)) +& + f2 * kvec(1)*sc(1,coset(bx-1,by,bz)) + END DO + END DO + END DO + END IF + END IF + DO j=ncoset(lb_min-1)+1,ncoset(lb_max) + END DO + END DO + END DO + END SUBROUTINE cossin + SUBROUTINE moment(la_max,npgfa,zeta,rpgfa,la_min,& + lb_max,npgfb,zetb,rpgfb,& + lc_max,rac,rbc,mab) + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta, rpgfa + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb, rpgfb + REAL(KIND=dp), DIMENSION(:, :, :), & + INTENT(INOUT) :: mab + REAL(KIND=dp), DIMENSION(3) :: rab, rap, rbp, rpc + REAL(KIND=dp), DIMENSION(ncoset(la_max),& + ncoset(lb_max), ncoset(lc_max)) :: s + DO ipgf=1,npgfa + DO jpgf=1,npgfb + IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) THEN + DO k=1, ncoset(lc_max)-1 + DO j=nb+1,nb+ncoset(lb_max) + DO i=na+1,na+ncoset(la_max) + mab(i,j,k) = 0.0_dp + END DO + END DO + END DO + END IF + rpc = zetp*(zeta(ipgf)*rac+zetb(jpgf)*rbc) + DO l=2, ncoset(lc_max) + lx = indco(1,l) + l2 = 0 + IF ( lz > 0 ) THEN + IF ( lz > 1 ) l2 = coset(lx,ly,lz-2) + ELSE IF ( ly > 0 ) THEN + IF ( ly > 1 ) l2 = coset(lx,ly-2,lz) + IF ( lx > 1 ) l2 = coset(lx-2,ly,lz) + END IF + s(1,1,l) = rpc(i)*s(1,1,l1) + IF ( l2 > 0 ) s(1,1,l) = s(1,1,l) + f2*REAL(ni,dp)*s(1,1,l2) + END DO + DO l = 1, ncoset(lc_max) + IF ( lx > 0 ) THEN + lx1 = coset(lx-1,ly,lz) + END IF + IF ( ly > 0 ) THEN + ly1 = coset(lx,ly-1,lz) + END IF + IF (la_max > 0) THEN + DO la=2,la_max + IF ( lz1 > 0 ) s(coset(0,0,la),1,l) = s(coset(0,0,la),1,l) + & + f2z*s(coset(0,0,la-1),1,lz1) + IF ( ly1 > 0 ) s(coset(0,1,az),1,l) = s(coset(0,1,az),1,l) + & + f2y*s(coset(0,0,az),1,ly1) + DO ay=2,la + s(coset(0,ay,az),1,l) = rap(2)*s(coset(0,ay-1,az),1,l) +& + f2*REAL(ay-1,dp)*s(coset(0,ay-2,az),1,l) + IF ( ly1 > 0 ) s(coset(0,ay,az),1,l) = s(coset(0,ay,az),1,l) + & + f2y*s(coset(0,ay-1,az),1,ly1) + END DO + DO ay=0,la-1 + IF ( lx1 > 0 ) s(coset(1,ay,az),1,l) = s(coset(1,ay,az),1,l) + & + f2x*s(coset(0,ay,az),1,lx1) + END DO + DO ax=2,la + DO ay=0,la-ax + s(coset(ax,ay,az),1,l) = rap(1)*s(coset(ax-1,ay,az),1,l) +& + f3*s(coset(ax-2,ay,az),1,l) + IF ( lx1 > 0 ) s(coset(ax,ay,az),1,l) = s(coset(ax,ay,az),1,l) + & + f2x*s(coset(ax-1,ay,az),1,lx1) + END DO + END DO + END DO + IF (lb_max > 0) THEN + DO j=2,ncoset(lb_max) + DO i=1,ncoset(la_max) + s(i,j,l) = 0.0_dp + END DO + END DO + DO la=la_start,la_max-1 + DO ax=0,la + DO ay=0,la-ax + s(coset(ax,ay,az),2,l) = s(coset(ax+1,ay,az),1,l) -& + rab(1)*s(coset(ax,ay,az),1,l) + s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az+1),1,l) -& + rab(3)*s(coset(ax,ay,az),1,l) + END DO + END DO + END DO + DO ax=0,la_max + DO ay=0,la_max-ax + IF (ax == 0) THEN + s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l) + ELSE + s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l) +& + fx*s(coset(ax-1,ay,az),1,l) + END IF + IF (lx1 > 0) s(coset(ax,ay,az),2,l) = s(coset(ax,ay,az),2,l) +& + f2x*s(coset(ax,ay,az),1,lx1) + IF (ay == 0) THEN + s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l) + ELSE + s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l) +& + fy*s(coset(ax,ay-1,az),1,l) + END IF + IF (ly1 > 0) s(coset(ax,ay,az),3,l) = s(coset(ax,ay,az),3,l) +& + f2y*s(coset(ax,ay,az),1,ly1) + IF (az == 0) THEN + s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l) + ELSE + s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l) +& + fz*s(coset(ax,ay,az-1),1,l) + END IF + IF (lz1 > 0) s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az),4,l) +& + f2z*s(coset(ax,ay,az),1,lz1) + END DO + END DO + DO lb=2,lb_max + DO la=la_start,la_max-1 + DO ax=0,la + DO ay=0,la-ax + s(coset(ax,ay,az),coset(0,0,lb),l) =& + rab(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l) + DO bx=1,lb + DO by=0,lb-bx + s(coset(ax,ay,az),coset(bx,by,bz),l) =& + rab(1)*s(coset(ax,ay,az),coset(bx-1,by,bz),l) + END DO + END DO + END DO + END DO + END DO + DO ax=0,la_max + DO ay=0,la_max-ax + IF (az == 0) THEN + s(coset(ax,ay,az),coset(0,0,lb),l) =& + rbp(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l) +& + f3*s(coset(ax,ay,az),coset(0,0,lb-2),l) + END IF + IF (lz1 > 0) s(coset(ax,ay,az),coset(0,0,lb),l) =& + f2z*s(coset(ax,ay,az),coset(0,0,lb-1),lz1) + IF (ay == 0) THEN + IF (ly1 > 0) s(coset(ax,ay,az),coset(0,1,bz),l) =& + f2y*s(coset(ax,ay,az),coset(0,0,bz),ly1) + DO by=2,lb + s(coset(ax,ay,az),coset(0,by,bz),l) =& + f3*s(coset(ax,ay,az),coset(0,by-2,bz),l) + IF (ly1 > 0) s(coset(ax,ay,az),coset(0,by,bz),l) =& + f2y*s(coset(ax,ay,az),coset(0,by-1,bz),ly1) + END DO + s(coset(ax,ay,az),coset(0,1,bz),l) =& + fy*s(coset(ax,ay-1,az),coset(0,0,bz),l) + END IF + IF (ax == 0) THEN + DO by=0,lb-1 + IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =& + f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1) + END DO + DO bx=2,lb + DO by=0,lb-bx + s(coset(ax,ay,az),coset(bx,by,bz),l) =& + f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l) + IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =& + f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1) + END DO + END DO + DO by=0,lb-1 + IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =& + f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1) + END DO + DO bx=2,lb + DO by=0,lb-bx + s(coset(ax,ay,az),coset(bx,by,bz),l) =& + f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l) + IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =& + f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1) + END DO + END DO + END IF + END DO + END DO + END DO + END IF + IF (lb_max > 0) THEN + DO lb=2,lb_max + IF (lz1 > 0) s(1,coset(0,0,lb),l) = s(1,coset(0,0,lb),l) +& + f2z*s(1,coset(0,0,lb-1),lz1) + IF (ly1 > 0) s(1,coset(0,1,bz),l) = s(1,coset(0,1,bz),l) +& + f2y*s(1,coset(0,0,bz),ly1) + DO by=2,lb + s(1,coset(0,by,bz),l) = rbp(2)*s(1,coset(0,by-1,bz),l) +& + f2*REAL(by-1,dp)*s(1,coset(0,by-2,bz),l) + IF (lx1 > 0) s(1,coset(1,by,bz),l) = s(1,coset(1,by,bz),l) +& + f2x*s(1,coset(0,by,bz),lx1) + END DO + DO bx=2,lb + DO by=0,lb-bx + IF (lx1 > 0) s(1,coset(bx,by,bz),l) = s(1,coset(bx,by,bz),l) +& + f2x*s(1,coset(bx-1,by,bz),lx1) + END DO + END DO + END DO + END IF + END IF + END DO + DO k=2,ncoset(lc_max) + DO j=1,ncoset(lb_max) + END DO + END DO + END DO + END DO + END SUBROUTINE moment + SUBROUTINE diff_momop(la_max,npgfa,zeta,rpgfa,la_min,& + order,rac,rbc,difmab,mab_ext) + REAL(KIND=dp), DIMENSION(:, :, :), & + OPTIONAL, POINTER :: mab_ext + REAL(KIND=dp), ALLOCATABLE, & + DIMENSION(:, :, :) :: difmab_tmp + DO imom = 1,ncoset(order)-1 + CALL adbdr(la_max,npgfa,rpgfa,la_min,& + difmab_tmp(:,:,2), difmab_tmp(:,:,3)) + END DO + END SUBROUTINE diff_momop +END MODULE ai_moments Index: Fortran/gfortran/regression/pr42051.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42051.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/42051 +! PR fortran/44064 +! Access to freed symbols +! +! Testcase provided by Damian Rouson , +! reduced by Janus Weil . + +module grid_module + implicit none + type grid + end type + type field + type(grid) :: mesh + end type +contains + real function return_x(this) + class(grid) :: this + end function +end module + +module field_module + use grid_module, only: field,return_x + implicit none +contains + subroutine output(this) + class(field) :: this + print *,return_x(this%mesh) + end subroutine +end module + +end Index: Fortran/gfortran/regression/pr42108.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42108.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-fre1 -fdump-tree-pre-details -fno-tree-loop-im" } + +subroutine eval(foo1,foo2,foo3,foo4,x,n,nnd) + implicit real*8 (a-h,o-z) + dimension foo3(n),foo4(n),x(nnd) + nw=0 + foo3(1)=foo2*foo4(1) + do i=2,n + foo3(i)=foo2*foo4(i) + do j=1,i-1 + temp=0.0d0 + jmini=j-i + do k=i,nnd,n + temp=temp+(x(k)-x(k+jmini))**2 + end do + temp = sqrt(temp+foo1) + foo3(i)=foo3(i)+temp*foo4(j) + foo3(j)=foo3(j)+temp*foo4(i) + end do + end do +end subroutine eval + +! There should be only one load from n left +! { dg-final { scan-tree-dump-times "\\*n_" 1 "fre1" } } Index: Fortran/gfortran/regression/pr42119.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42119.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } + +module Test +use ISO_C_BINDING + +contains + +subroutine Callback(arg) bind(C) + integer(C_INT) :: arg +end subroutine Callback + +subroutine Check(proc) + type(C_FUNPTR) :: proc +end subroutine Check + +end module Test + + +program Main + use Test + type(C_FUNPTR) :: proc + + call Check(C_FUNLOC(Callback)) +end program Main Index: Fortran/gfortran/regression/pr42166.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42166.f90 @@ -0,0 +1,19 @@ +! { dg-options "-O2 -g" } + +MODULE powell + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE newuob (n, bmat, ndim, d, vlag, w, npt) + REAL(dp), DIMENSION(ndim, *), INTENT(inout) :: bmat + REAL(dp), DIMENSION(*), INTENT(inout) :: d, vlag, w + REAL(dp) :: sum + INTEGER, INTENT(in) :: npt + DO j=1,n + jp=npt+j + DO k=1,n + sum=sum+bmat(jp,k)*d(k) + END DO + vlag(jp)=sum + END DO + END SUBROUTINE newuob +END MODULE powell Index: Fortran/gfortran/regression/pr42246-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42246-2.f @@ -0,0 +1,21 @@ +C PR rtl-optimization/42246 +C { dg-do compile { target powerpc*-*-* ia64-*-* i?86-*-* x86_64-*-* } } +C { dg-options "-O2 -fselective-scheduling -fsel-sched-pipelining -fsel-sched-pipelining-outer-loops" } + + subroutine distance(x,clo) + implicit real*8 (a-h,o-z) + dimension x(2,6),x1(2,6),clo(6) + do 60 i=1,2 + do 20 j=1,6 + x(i,j)=clo(j) + 20 continue + do 40 iq=1,6 + x1(i,iq)=0.0d0 + 40 continue + do 50 j=1,6 + x(i,j)=x1(i,j) + 50 continue + 60 continue + return + end + Index: Fortran/gfortran/regression/pr42294.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42294.f @@ -0,0 +1,41 @@ +C PR rtl-optimization/42294 +C { dg-do compile { target powerpc*-*-* ia64-*-* i?86-*-* x86_64-*-* } } +C { dg-options "-O2 -fselective-scheduling2 -fsel-sched-pipelining -funroll-all-loops" } + + SUBROUTINE ORIEN(IW,NATOT,NTOTORB,NATORB,P,T) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION NATORB(NATOT),P(NTOTORB*(NTOTORB+1)/2) + DIMENSION T(NTOTORB,NTOTORB) + DO 9000 IATOM=1,NATOT + ILAST = NTOTORB + IF (IATOM.NE.NATOT) ILAST=NATORB(IATOM+1)-1 + DO 8000 IAOI=NATORB(IATOM),ILAST + DO 7000 IAOJ = IAOI+1,ILAST + R2 = 0.0D+00 + R3 = 0.0D+00 + DO 6000 INOTA=1,NATOT + DO 5000 IK=NATORB(INOTA),NTOTORB + IMAI=MAX(IK,IAOI) + IMII=MIN(IK,IAOI) + IMAJ=MAX(IK,IAOJ) + IMIJ=MIN(IK,IAOJ) + IKI=(IMAI*(IMAI-1))/2 + IMII + IKJ=(IMAJ*(IMAJ-1))/2 + IMIJ + PIKI=P(IKI) + PIKJ=P(IKJ) + R2 = R2 + (PIKI**4)-6*(PIKI*PIKI*PIKJ*PIKJ)+(PIKJ) + 5000 CONTINUE + 6000 CONTINUE + R2 = (R2/4.0D+00) + Q = SQRT(R2*R2 + R3*R3) + IF (Q.LT.1.0D-08) GO TO 7000 + A = COS(THETA) + B = -SIN(THETA) + CALL ROT1INT(NTOTORB,IAOI,IAOJ,A,B,P) + 7000 CONTINUE + 8000 CONTINUE + 9000 CONTINUE + RETURN + END + + Index: Fortran/gfortran/regression/pr42651.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr42651.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR fortran/42651 +integer function func() + asynchronous :: func + integer, asynchronous:: b + allocatable :: c + volatile :: func + type t + sequence + integer :: i = 5 + end type t +end function func + +function func2() result(res) ! { dg-error " RESULT variable" } + volatile res + asynchronous res + target func2 ! { dg-error " RESULT variable" } + volatile func2 ! { dg-error " RESULT variable" } + asynchronous func2 ! { dg-error " RESULT variable" } + allocatable func2 ! { dg-error " RESULT variable" } + dimension func2(2) ! { dg-error " RESULT variable" } + codimension func2[*] ! { dg-error " RESULT variable" } + contiguous func2 ! { dg-error " RESULT variable" } +end function func2 Index: Fortran/gfortran/regression/pr43229.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43229.f90 @@ -0,0 +1,10 @@ +! PR debug/43229 +! { dg-do compile } +! { dg-options "-g -O3 -ffast-math" } +! { dg-options "-g -O3 -ffast-math -msse3" { target { i?86-*-* x86_64-*-* } } } + +function foo (c, d) + real(8) :: c(6), d(6), foo + x = sum (c * d) + foo = exp (-x) +end function foo Index: Fortran/gfortran/regression/pr43475.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43475.f90 @@ -0,0 +1,14 @@ +! PR middle-end/43475 +! { dg-do compile } +! { dg-options "-O2" } +subroutine ss(w) + implicit none + integer :: w(:) + integer :: b,c,d + b = w(8) + c = 5 + d = 3 + call s1(c) + call s2(b+c) + call s3(w(b)) +end subroutine ss Index: Fortran/gfortran/regression/pr43505.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43505.f90 @@ -0,0 +1,41 @@ + MODULE MAIN1 + INTEGER , PARAMETER :: MXGLVL = 87 + CHARACTER(8) :: SRCTYP + REAL :: GRIDWS(MXGLVL) + REAL :: ZI, HS + END MODULE MAIN1 + + PROGRAM TEST + USE MAIN1 + IF (HS >= ZI) THEN + ELSEIF ( SRCTYP == 'AREA' & + .OR. SRCTYP == 'AREAPOLY' & + .OR. SRCTYP == 'AREACIRC' & + .OR. SRCTYP == 'OPENPIT' ) THEN + CALL ANYAVG (MXGLVL, GRIDWS) + CALL ANYAVG (MXGLVL, GRIDWS) + ELSE + IF ( HS > 0.0 ) THEN + CALL ANYAVG (MXGLVL, GRIDWS) + CALL ANYAVG (MXGLVL, GRIDWS) + CALL ANYAVG (MXGLVL, GRIDWS) + ENDIF + ENDIF + IF (HS.LT.ZI) THEN + ZI = HS + ENDIF + contains + SUBROUTINE ANYAVG(NLVLS,HTS) + INTEGER NLVLS + REAL HTS(NLVLS) + IF (5.LT.NLVLS) THEN + CALL GINTRP (HTS(5),HTS(5+1)) + ENDIF + CALL GINTRP (HTS(5-1), HTS(5)) + END SUBROUTINE ANYAVG + + subroutine gintrp (x1, x2) + print *, x1, x2 + end subroutine + + END PROGRAM TEST Index: Fortran/gfortran/regression/pr43688.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43688.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O0 -fipa-reference" } + + subroutine sub + type :: a + integer :: i = 42 + end type a + type(a), target :: dt(2) + integer, pointer :: ip(:) + ip => dt%i + end subroutine Index: Fortran/gfortran/regression/pr43793.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43793.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/30073 +! PR fortran/43793 +! +! Original code by Joost VandeVondele +! Reduced and corrected code by Steven G. Kargl +! +module fft_tools + implicit none + integer, parameter :: lp = 8 +contains + subroutine sparse_alltoall (rs, rq, rcount) + complex(kind=lp), dimension(:, :), pointer :: rs, rq + integer, dimension(:) :: rcount + integer :: pos + pos = 1 + if (rcount(pos) /= 0) then + rq(1:rcount(pos),pos) = rs(1:rcount(pos),pos) + end if + end subroutine sparse_alltoall +end module fft_tools Index: Fortran/gfortran/regression/pr43796.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43796.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-O2 -fcheck=bounds" } + + FUNCTION F06FKFN(N,W,INCW,X,INCX) + IMPLICIT NONE + INTEGER, PARAMETER :: WP = KIND(0.0D0) + REAL (KIND=WP) :: F06FKFN + REAL (KIND=WP), PARAMETER :: ONE = 1.0E+0_WP + REAL (KIND=WP), PARAMETER :: ZERO = 0.0E+0_WP + INTEGER, INTENT (IN) :: INCW, INCX, N + REAL (KIND=WP), INTENT (IN) :: W(*), X(*) + REAL (KIND=WP) :: ABSYI, NORM, SCALE, SSQ + INTEGER :: I, IW, IX + REAL (KIND=WP), EXTERNAL :: F06BMFN + INTRINSIC ABS, SQRT + IF (N<1) THEN + NORM = ZERO + ELSE IF (N==1) THEN + NORM = SQRT(W(1))*ABS(X(1)) + ELSE + IF (INCW>0) THEN + IW = 1 + ELSE + IW = 1 - (N-1)*INCW + END IF + IF (INCX>0) THEN + IX = 1 + ELSE + IX = 1 - (N-1)*INCX + END IF + SCALE = ZERO + SSQ = ONE + DO I = 1, N + IF ((W(IW)/=ZERO) .AND. (X(IX)/=ZERO)) THEN + ABSYI = SQRT(W(IW))*ABS(X(IX)) + IF (SCALE M%B + P => M%A + DO C=1,X + DO D=C+1,Y + IF (T) THEN + P(D,C)=P(C,D) + ELSE + Q(D,C)=Q(C,D) + ENDIF + ENDDO + ENDDO + END SUBROUTINE FOO +END MODULE PR43866 + + USE PR43866 + TYPE(TT), POINTER :: Q + INTEGER, PARAMETER :: N=17 + ALLOCATE (Q) + NULLIFY (Q%A) + ALLOCATE (Q%B(N,N)) + Q%B=0 + CALL FOO (Q,N,N,.FALSE.) +END Index: Fortran/gfortran/regression/pr43984.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43984.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! { dg-options "-O2 -fno-tree-dominator-opts -fdump-tree-pre" } +module test + + type shell1quartet_type + + integer(kind=kind(1)) :: ab_l_sum + integer(kind=kind(1)), dimension(:), pointer :: ab_form_3dints_x_indices => NULL() + integer(kind=kind(1)), dimension(:), pointer :: ab_form_3dints_yz_rms_indices => NULL() + + end type + +contains +subroutine make_esss(self,esss) + type(shell1quartet_type) :: self + intent(in) :: self + real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(:), pointer :: Izz + real(kind=kind(1.0d0)), dimension(:,:), pointer :: Ix,Iy,Iz,Iyz + integer(kind=kind(1)), dimension(:), pointer :: e_x,ii_ivec + integer(kind=kind(1)) :: dim, dim1, nroots, ii,z,y + + dim = self%ab_l_sum+1 + dim1 = self%ab_l_sum+2 + nroots = (dim1) / 2 + call create_(Ix,nroots,dim) + call create_(Iy,nroots,dim) + call create_(Iz,nroots,dim) + call create_(Iyz,nroots,dim*dim1/2) + + e_x => self%ab_form_3dints_x_indices + ii_ivec => self%ab_form_3dints_yz_rms_indices + + call foo(Ix) + call foo(Iy) + call foo(Iz) + + esss = ZERO + ii = 0 + do z=1,dim + Izz => Iz(:,z) + do y=1,dim1-z + ii = ii + 1 + Iyz(:,ii) = Izz * Iy(:,y) + end do + end do + esss = esss + sum(Ix(:,e_x) * Iyz(:,ii_ivec),1) + +end subroutine + +end + +! There should be two loads from iyz.data, not four. + +! { dg-final { scan-tree-dump-times "= iyz.data" 2 "pre" } } Index: Fortran/gfortran/regression/pr43996.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr43996.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/43996 +! +real, parameter :: a(720,360) = spread((/(j, j=1,720) /), dim=2, ncopies=360) ! { dg-error "number of elements" } +real x +x = a(720,360) +end Index: Fortran/gfortran/regression/pr44491.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr44491.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/44491 + character*2 escape /z'1B'/ ! { dg-error "cannot appear in" } + end Index: Fortran/gfortran/regression/pr44592.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr44592.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-O3" } +! From forall_12.f90 +! Fails with loop reversal at -O3 +! + character(len=1) :: b(4) = (/"1","2","3","4"/), c(4) + c = b + i = 1 + ! This statement must be here for the abort below + b(1:3)(i:i) = b(2:4)(i:i) + + b = c + b(4:2:-1)(i:i) = b(3:1:-1)(i:i) + + ! This fails. If the condition is printed, the result is F F F F + if (any (b .ne. (/"1","1","2","3"/))) i = 2 + print *, b + print *, b .ne. (/"1","1","2","3"/) + if (i == 2) STOP 1 +end Index: Fortran/gfortran/regression/pr44691.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr44691.f @@ -0,0 +1,41 @@ +C PR rtl-optimization/44691 +C { dg-do compile { target powerpc*-*-* ia64-*-* i?86-*-* x86_64-*-* } } +C { dg-options "-O2 -fselective-scheduling2" } + + SUBROUTINE ORIEN(IW,NATOT,NTOTORB,NATORB,P,T) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION NATORB(NATOT),P(NTOTORB*(NTOTORB+1)/2) + DIMENSION T(NTOTORB,NTOTORB) + DO 9000 IATOM=1,NATOT + ILAST = NTOTORB + IF (IATOM.NE.NATOT) ILAST=NATORB(IATOM+1)-1 + DO 8000 IAOI=NATORB(IATOM),ILAST + DO 7000 IAOJ = IAOI+1,ILAST + R2 = 0.0D+00 + R3 = 0.0D+00 + DO 6000 INOTA=1,NATOT + DO 5000 IK=NATORB(INOTA),NTOTORB + IMAI=MAX(IK,IAOI) + IMII=MIN(IK,IAOI) + IMAJ=MAX(IK,IAOJ) + IMIJ=MIN(IK,IAOJ) + IKI=(IMAI*(IMAI-1))/2 + IMII + IKJ=(IMAJ*(IMAJ-1))/2 + IMIJ + PIKI=P(IKI) + PIKJ=P(IKJ) + R2 = R2 + (PIKI**4)-6*(PIKI*PIKI*PIKJ*PIKJ)+(PIKJ) + 5000 CONTINUE + 6000 CONTINUE + R2 = (R2/4.0D+00) + Q = SQRT(R2*R2 + R3*R3) + IF (Q.LT.1.0D-08) GO TO 7000 + A = COS(THETA) + B = -SIN(THETA) + CALL ROT1INT(NTOTORB,IAOI,IAOJ,A,B,P) + 7000 CONTINUE + 8000 CONTINUE + 9000 CONTINUE + RETURN + END + + Index: Fortran/gfortran/regression/pr44735.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr44735.f90 @@ -0,0 +1,16 @@ +! { dg-do run } + +program main + if (bug() /= "abcdefghij") STOP 1 +contains + function bug() + character(len=10) :: bug + character(len=1), dimension(:), pointer :: p_chars + allocate(p_chars(10)) + p_chars = ['a','b','c','d','e','f','g','h','i','j'] + forall (i=1:len(bug)) + bug(i:i) = p_chars(i) + end forall + deallocate(p_chars) + end function bug +end program main Index: Fortran/gfortran/regression/pr44882.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr44882.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -funroll-loops -w" } + + SUBROUTINE TRUDGE(KDIR) +! There is a type mismatch here for TRUPAR which caused an ICE + COMMON /TRUPAR/ DR(10),V(10,10) + DO 110 I=1,NDIR + 110 DR(I)=V(I,JDIR) + END + SUBROUTINE TRUSRC(LEAVE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /TRUPAR/ DX(10),V(10,10) + END + Index: Fortran/gfortran/regression/pr45308.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr45308.f03 @@ -0,0 +1,9 @@ +! PR fortran/45308 +! { dg-do run } + character(len=36) :: date, time + date = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' + time = 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' + call date_and_time (date, time) + if (index (date, 'a') /= 0 .or. index (time, 'a') /= 0) & + STOP 1 +end Index: Fortran/gfortran/regression/pr45337_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr45337_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + +module ptrmod +contains +subroutine lengthX(x, i) ! { dg-error "Dummy 'x' at .1. cannot have an initializer" } + implicit none + real, pointer, intent(out) :: x(:)=>null() + integer :: i + x=>null() + allocate(x(i)) + x=i +end subroutine +end module + Index: Fortran/gfortran/regression/pr45337_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr45337_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +type t +end type t +type t2 + integer :: j = 7 +end type t2 +contains + subroutine x(a, b, c) + intent(out) :: a, b, c + type(t) :: a = t() + type(t2) :: b = t2() + type(t2) :: c + end subroutine x +end + +! { dg-error "Dummy .a. at .1. cannot have an initializer" " " { target *-*-* } 9 } +! { dg-error "Dummy .b. at .1. cannot have an initializer" " " { target *-*-* } 9 } Index: Fortran/gfortran/regression/pr45578.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr45578.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +!*==CENTCM.spg processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005 + SUBROUTINE CENTCM + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + PARAMETER (NM=16384) + PARAMETER (NG=100) + PARAMETER (NH=100) + PARAMETER (MU=20) + PARAMETER (NL=1) + PARAMETER (LL=10*NM) + PARAMETER (KP=2001,KR=2001,KG=2001) + COMMON /LCS / X0(3,-2:NM) , X(3,-2:NM,5) , XIN(3,-2:NM) + COMMON /MOLEC / LPBc(3) , MOLsp , MOLsa , NBX , NBY , NBZ , NPLa ,& + & LPBcsm + cm1 = 0.D0 + cm2 = 0.D0 + cm3 = 0.D0 + DO i = 1 , MOLsa + cm1 = cm1 + X0(1,i) + cm2 = cm2 + X0(2,i) + cm3 = cm3 + X0(3,i) + ENDDO + cm1 = cm1/MOLsa + cm2 = cm2/MOLsa + cm3 = cm3/MOLsa + IF ( (cm1.EQ.0.D0) .AND. (cm2.EQ.0.D0) .AND. (cm3.EQ.0.D0) ) & + & RETURN + DO i = 1 , MOLsa + X0(1,i) = X0(1,i) - cm1 + X0(2,i) = X0(2,i) - cm2 + X0(3,i) = X0(3,i) - cm3 + XIN(1,i) = XIN(1,i) - cm1 + XIN(2,i) = XIN(2,i) - cm2 + XIN(3,i) = XIN(3,i) - cm3 + ENDDO + CONTINUE + END + PROGRAM test + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + PARAMETER (NM=16384) + PARAMETER (NG=100) + PARAMETER (NH=100) + PARAMETER (MU=20) + PARAMETER (NL=1) + PARAMETER (LL=10*NM) + PARAMETER (KP=2001,KR=2001,KG=2001) + COMMON /LCS / X0(3,-2:NM) , X(3,-2:NM,5) , XIN(3,-2:NM) + COMMON /MOLEC / LPBc(3) , MOLsp , MOLsa , NBX , NBY , NBZ , NPLa ,& + & LPBcsm + MOLsa = 10 + X0 = 1. + CALL CENTCM + END Index: Fortran/gfortran/regression/pr45636.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr45636.f90 @@ -0,0 +1,15 @@ +! PR fortran/45636 +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-forwprop2" } +! PR 45636 - make sure no memset is needed for a short right-hand side. +program main + character(len=2), parameter :: x='a ' + character(len=1), parameter :: y='b' + character(len=4) :: a, b + a = x + b = y + call sub(a, b) +end program main +! This test will fail on targets which prefer memcpy/memset over +! move_by_pieces/store_by_pieces. +! { dg-final { scan-tree-dump-times "memset" 0 "forwprop2" { xfail { { hppa*-*-* && { ! lp64 } } || { mips*-*-* && { ! nomips16 } } } } } } Index: Fortran/gfortran/regression/pr46190.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46190.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-vectorize" } + + TYPE :: spot_weld_type + CHARACTER(8) PLACE ! Keyword "NODE" or "POSITION" + END TYPE + TYPE (spot_weld_type), DIMENSION(:), ALLOCATABLE :: SPOT_WELD + INTEGER, PARAMETER :: LSRT = 12 ! Length of sorted-element-distance array + INTEGER & + & IETYP(LSRT) ! -/- Sort array for closest el's, 0/1=tri/qu + REAL(KIND(0D0)) & + & DSQRD(LSRT) ! -/- Sort array for closest el's, d**2 + LOGICAL & + & COINCIDENT, & + & INSIDE_ELEMENT + IF (SPOT_WELD(NSW)%PLACE .EQ. 'POSITION') THEN + DO n = 1,LSRT + ENDDO + DO i = 1,NUMP3 + DO WHILE (Distance_Squared .GT. DSQRD(n) .AND. n .LE. LSRT) + ENDDO + IF (n .LT. LSRT) THEN + DO k = LSRT-1,n,-1 + DSQRD(k+1) = DSQRD(k) + IETYP(k+1) = IETYP(k) + ENDDO + ENDIF + DO n = 1,LSRT + IF (IETYP(n) .EQ. 0) THEN + INSIDE_ELEMENT = & + & Xi1EL(n) .GE. 0.0 .AND. Xi2EL(n) .GE. 0.0 + IF (DSQRD(n) .LT. Dmin) THEN + ENDIF + ENDIF + ENDDO + ENDDO + IF (Icount .GT. 0) THEN + DO i = 1,Icount + CALL USER_MESSAGE & + & ( & + & ) + ENDDO + CALL USER_MESSAGE & + & ( & + & ) + ENDIF + IF & + & ( & + & .NOT.COINCIDENT & + & ) & + & THEN + IF (NP1 .GT. 0) THEN + IF (NP1 .GT. 0) THEN + ENDIF + ENDIF + ENDIF + IF (.NOT.COINCIDENT) THEN + DO i = 1,3 + IF (NP(i) .GT. 0) THEN + ENDIF + ENDDO + ENDIF + ENDIF + END Index: Fortran/gfortran/regression/pr46259.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46259.f @@ -0,0 +1,19 @@ +! PR tree-optimization/46259 +! { dg-do compile } +! { dg-options "-O3" } + SUBROUTINE RDSTFR(FRGMNT,IFRAG,PROVEC,FOCKMA, + * MXBF,MXMO,MXMO2,NTMOF) + PARAMETER (MXPT=100, MXFRG=50, MXFGPT=MXPT*MXFRG) + CHARACTER*8 WORD,MNAME,PNAME,RNAME + COMMON /FRGSTD/ CORD(3,MXPT),PCORD(3,MXPT),POLT(9,MXPT), + * INLPR(4*MXPT),IKFR(MXPT),IKLR(MXPT), + * MNAME(MXPT),PNAME(MXPT),RNAME(MXPT) + DO 10 I=1,MXPT + INLPR(4*(I-1)+1)=0 + INLPR(4*(I-1)+2)=0 + INLPR(4*(I-1)+3)=0 + INLPR(4*(I-1)+4)=0 + IKLR(I)=0 + RNAME(I)=' ' + 10 CONTINUE + END Index: Fortran/gfortran/regression/pr46297.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46297.f @@ -0,0 +1,25 @@ +! { dg-options "-Os -fno-asynchronous-unwind-tables" } +! { dg-do run } + + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + equivalence (r3, s3(2)) + equivalence (d3, r3(2)) + s1(1) = 1. + s3(1) = 3. + r3(1) = 3. + d3 = 30. + i3 = 3 + call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + end + subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + if (s1(1) .ne. 1.) STOP 1 + if (s3(1) .ne. 3.) STOP 2 + if (r3(1) .ne. 3.) STOP 3 + if (d3 .ne. 30.) STOP 4 + if (i3 .ne. 3) STOP 5 + end Index: Fortran/gfortran/regression/pr46519-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46519-1.f @@ -0,0 +1,46 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-options "-O3 -mavx -mvzeroupper -fno-tree-slp-vectorize -mtune=generic -dp" } + + PROGRAM MG3XDEMO + INTEGER LM, NM, NV, NR, NIT + + + PARAMETER( LM=7 ) +C PARAMETER( NIT=40 ) + PARAMETER( NM=2+2**LM, NV=NM**3 ) + PARAMETER( NR = (8*(NM**3+NM**2+5*NM-23+7*LM))/7 ) +C +C +C If commented line is used than there is no penalty +C COMMON /X/ U, V, R, A, C, IR, MM + COMMON /X/ A, C, IR, MM + REAL*8 A(0:3),C(0:3) + + INTEGER IT, N + INTEGER LMI, MTIME, NTIMES +C + READ *,LMI + READ *,NIT + READ *,NTIMES + READ *,U0 + + READ 9004, A + READ 9004, C +9004 FORMAT (4D8.0) + + DO I = 0, 3 + A(I) = A(I)/3.0D0 + C(I) = C(I)/64.0D0 + ENDDO +C + N = 2 + 2**LMI + + WRITE(6,7)N-2,N-2,N-2,NIT + 6 FORMAT( I4, 2E19.12) + 7 FORMAT(/,' KERNEL B: SOLVING A POISSON PROBLEM ON A ',I6,' BY ', + > I6,' BY ',I6,' GRID,',/,' USING ',I6,' MULTIGRID ITERATIONS.',/) +C + STOP + END + +! { dg-final { scan-assembler-times "avx_vzeroupper" 1 } } Index: Fortran/gfortran/regression/pr46519-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46519-2.f90 @@ -0,0 +1,31 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-options "-O3 -mavx -mvzeroupper -mtune=generic -dp" } + + SUBROUTINE func(kts, kte, qrz, qiz, rho) + IMPLICIT NONE + INTEGER, INTENT(IN) :: kts, kte + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qrz, qiz, rho + INTEGER :: k + REAL, DIMENSION(kts:kte) :: praci, vtiold + REAL :: fluxout + INTEGER :: min_q, max_q, var + do k=kts,kte + praci(k)=1.0 + enddo + min_q=kte + max_q=kts-1 + DO var=1,20 + do k=max_q,min_q,-1 + fluxout=rho(k)*qrz(k) + enddo + qrz(min_q-1)=qrz(min_q-1)+fluxout + ENDDO + DO var=1,20 + do k=kts,kte-1 + vtiold(k)= (rho(k))**0.16 + enddo + ENDDO + STOP + END SUBROUTINE func + +! { dg-final { scan-assembler "avx_vzeroupper" } } Index: Fortran/gfortran/regression/pr46588.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46588.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR fortran/46588 +! Original code contributed by Oleh Steblev +! +! Issue appears to be fixed by PR 67805/68108 +function aufun(pm) + character(len = *) pm + character(len = *) aufun + character(len = len(aufun)) temp + temp = pm + aufun = 'Oh' // trim(temp) +end function aufun + +program ds + implicit none + character(len = 4) :: ins = ' no!' + character(len = 20) st, aufun + st = aufun(ins) + if (trim(st) /= 'Oh no!') STOP 1 +end Index: Fortran/gfortran/regression/pr46665.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46665.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-fipa-pta -fno-tree-ccp -fno-tree-forwprop -g" } + +program main + implicit none + call test ((/ 3, 4, 5 /), f ((/ 3, 4, 5 /))) +contains + subroutine test (expected, x) + integer, dimension (:,:,:) :: x + integer, dimension (3) :: expected + integer :: i, i1, i2, i3 + do i = 1, 3 + if (size (x, i) .ne. expected (i)) STOP 1 + end do + do i1 = 1, expected (1) + do i2 = 1, expected (2) + do i3 = 1, expected (3) + if (x (i1, i2, i3) .ne. i1 + i2 * 10 + i3 * 100) STOP 2 + end do + end do + end do + end subroutine test + + function f (x) + integer, dimension (3) :: x + integer, dimension (x(1), x(2), x(3)) :: f + integer :: i1, i2, i3 + do i1 = 1, x(1) + do i2 = 1, x(2) + do i3 = 1, x(3) + f (i1, i2, i3) = i1 + i2 * 10 + i3 * 100 + end do + end do + end do + end function f +end program main Index: Fortran/gfortran/regression/pr46755.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46755.f @@ -0,0 +1,24 @@ +C { dg-do compile } +C { dg-options "-O" } + IMPLICIT NONE + INTEGER I640,I760,I800 + INTEGER I,ITER,ITMX,LENCM + LOGICAL QDISK,QDW + ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + + GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + 801 CONTINUE + ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 761 CONTINUE + DO I=1,LENCM + ENDDO + DO WHILE(ITER.LT.ITMX) + IF(QDW) THEN + ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + 641 CONTINUE + ENDIF + ENDDO + RETURN + END + Index: Fortran/gfortran/regression/pr46804.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46804.f90 @@ -0,0 +1,36 @@ +! PR rtl-optimization/46804 +! { dg-do run } +! { dg-options "-O -fPIC -fexpensive-optimizations -fgcse -fpeel-loops -fno-tree-loop-optimize" } + +program main + integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + integer (kind = 1), dimension (2, 4) :: shift1 + integer (kind = 2), dimension (2, 4) :: shift2 + integer (kind = 4), dimension (2, 4) :: shift3 + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3) + end do + end do + end do + shift1 (1, :) = (/ 4, 11, 19, 20 /) + shift1 (2, :) = (/ 55, 5, 1, 2 /) + shift2 = shift1 + shift3 = shift1 + call test (cshift (a, shift2, 2)) + call test (cshift (a, shift3, 2)) +contains + subroutine test (b) + character (len = slen), dimension (n1, n2, n3) :: b + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + i2p = mod (shift1 (i1, i3) + i2 - 1, n2) + 1 + if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) STOP 1 + end do + end do + end do + end subroutine test +end program main Index: Fortran/gfortran/regression/pr46884.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46884.f @@ -0,0 +1,8 @@ +C PR fortran/46884 +C { dg-do compile } +C { dg-options "" } + SUBROUTINE F + IMPLICIT CHARACTER*12 (C) + CALL G(C1) + CALL H(C1(1:4)) + END Index: Fortran/gfortran/regression/pr46945.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46945.f90 @@ -0,0 +1,10 @@ +! PR fortran/46945 +! { dg-do run } +! { dg-options "-O -ftree-vrp -fno-tree-ccp -fno-tree-fre" } + +program pr46945 + real, allocatable :: a(:,:,:) + integer :: n + n = 0 + allocate (a(n,n,n)) +end program pr46945 Index: Fortran/gfortran/regression/pr46985.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr46985.f90 @@ -0,0 +1,17 @@ +! PR tree-optimization/46985 +! { dg-do compile } +! { dg-options "-O -ftree-pre -ftree-vrp -fno-tree-ccp -fno-tree-dominator-opts -fno-tree-fre" } + + type :: t + integer :: i + end type t + type(t), target :: tar(2) = (/t(2), t(4)/) + integer, pointer :: ptr(:) + ptr => tar%i + call foo (ptr) +contains + subroutine foo (arg) + integer :: arg(:) + arg = arg - 1 + end subroutine +end Index: Fortran/gfortran/regression/pr47008.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47008.f03 @@ -0,0 +1,24 @@ +! PR rtl-optimization/47008 +! { dg-do run } +! { dg-options "-Os -fno-asynchronous-unwind-tables -fschedule-insns -fsched-pressure -fno-inline" { target i?86-*-* x86_64-*-* } } + +program main + type :: t + integer :: i + character(24) :: c + type (t), pointer :: p + end type t + type(t), pointer :: r, p + allocate (p) + p = t (123455, "", p) + r => entry ("", 123456, 1, "", 99, "", p) + if (p%i /= 123455) STOP 1 +contains + function entry (x, i, j, c, k, d, p) result (q) + integer :: i, j, k + character (*) :: x, c, d + type (t), pointer :: p, q + allocate (q) + q = t (i, c, p) + end function +end program main Index: Fortran/gfortran/regression/pr47054_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47054_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! PR fortran/47054 +subroutine host_sub + implicit none + real xg + pointer (paxg, xg) + call internal_sub + contains + subroutine internal_sub + implicit none + real xg + pointer (paxg, xg) + end subroutine internal_sub +end subroutine host_sub Index: Fortran/gfortran/regression/pr47054_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47054_2.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! PR fortran/47054 +! Code contributed by Deji Akingunola +subroutine host_sub(F_su,F_nk) + implicit none + + integer :: F_nk + real,dimension(F_nk) :: F_su + integer G_ni, G_nj + real*8 G_xg_8, G_yg_8 + pointer (paxg_8, G_xg_8(G_ni)) + pointer (payg_8, G_yg_8(G_nj)) + common / G_p / paxg_8,payg_8 + common / G / G_ni, G_nj + + call internal_sub(F_su,F_nk) + return +contains + + subroutine internal_sub(F_su,F_nk) + implicit none + integer G_ni, G_nj + real*8 G_xg_8, G_yg_8 + pointer (paxg_8, G_xg_8(G_ni)) + pointer (payg_8, G_yg_8(G_nj)) + common / G_p / paxg_8,payg_8 + common / G / G_ni, G_nj + + integer :: F_nk + real,dimension(F_nk) :: F_su + integer k,k2 + + k2 = 0 + do k = 1, F_nk, 2 + k2 = k2+1 + F_su(k) = F_su(k) + 1.0 + enddo + return + end subroutine internal_sub +end subroutine host_sub Index: Fortran/gfortran/regression/pr47574.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47574.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR 47574 - this used to ICE. + SUBROUTINE EXCH2_UV_AGRID_3D_RL( uPhi, vPhi, myNz ) + + IMPLICIT NONE + + INTEGER, parameter :: sNx=32, sNy=32, OLx=4, OLy=4 + + INTEGER myNz + Real(8) uPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,3,1) + REAL(8) vPhi(1-OLx:sNx+OLx,1-OLy:sNy+OLy,myNz,3,1) + + INTEGER i,j,k,bi,bj + REAL(8) uLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy) + REAL(8) vLoc(1-OLx:sNx+OLx,1-OLy:sNy+OLy) + REAL(8) negOne + + negOne = 1. + DO k = 1,myNz + DO j = 1-OLy,sNy+OLy + DO i = 1-OLx,sNx+OLx + uLoc(i,j) = uPhi(i,j,k,bi,bj) + vLoc(i,j) = vPhi(i,j,k,bi,bj) + ENDDO + ENDDO + DO j = 1-OLy,sNy+OLy + DO i = 1,OLx + uPhi(1-i,j,k,bi,bj) = vLoc(1-i,j) + vPhi(1-i,j,k,bi,bj) = uLoc(1-i,j)*negOne + ENDDO + ENDDO + + ENDDO + + END + Index: Fortran/gfortran/regression/pr47614.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47614.f @@ -0,0 +1,38 @@ +! { dg-do run { target { powerpc*-*-* } } } +! { dg-skip-if "" { powerpc*-*-darwin* } } +! { dg-options "-O3 -funroll-loops -ffast-math -mdejagnu-cpu=power4" } +! { dg-options "-O3 -funroll-loops -ffast-math" { target powerpc64le*-*-linux* } } + + + SUBROUTINE SFCPAR(ZET,NZ,ZMH,TSL,TMES) + IMPLICIT REAL*8 (A-H, O-Z) + REAL*8 ZET(*) + + ZS=MAX(TSL*ZMH,ZET(2)) + + DO 10 K=2,NZ + KLEV=K-1 + IF(ZS.LE.ZET(K)) GO TO 20 + 10 CONTINUE + + 20 CONTINUE + TMES=ZET(KLEV+1) + + RETURN + END + + program pr47614 + real*8 ar1(10),d1,d2,d3 + integer i + + d1 = 2.0 + d2 = 3.0 + d3 = 3.0 + do 50 i=1,10 + ar1(i) = d1 + d1 = d1 + 2.0 + 50 continue + + call sfcpar(ar1,10,d2,d3,d1) + if (d1.ne.10.0) STOP 1 + end Index: Fortran/gfortran/regression/pr47757-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47757-1.f90 @@ -0,0 +1,40 @@ +! PR libfortran/47757 +! { dg-do run } + + integer(1) :: a1(2,2) + integer(2) :: a2(2,2) + integer(4) :: a4(2,2) + integer(8) :: a8(2,2) + logical :: mask(2,2) + logical :: mask2 + a1 = 0 + a2 = 0 + a3 = 0 + a4 = 0 + mask2 = .true. + mask = reshape([.true.,.true.,.false.,.true.],[2,2]) + print *, iany(a1, dim=1, mask=mask) + print *, iany(a2, dim=1, mask=mask) + print *, iany(a4, dim=1, mask=mask) + print *, iany(a8, dim=1, mask=mask) + print *, iall(a1, dim=1, mask=mask) + print *, iall(a2, dim=1, mask=mask) + print *, iall(a4, dim=1, mask=mask) + print *, iall(a8, dim=1, mask=mask) + print *, iparity(a1, dim=1, mask=mask) + print *, iparity(a2, dim=1, mask=mask) + print *, iparity(a4, dim=1, mask=mask) + print *, iparity(a8, dim=1, mask=mask) + print *, iany(a1, dim=1, mask=mask2) + print *, iany(a2, dim=1, mask=mask2) + print *, iany(a4, dim=1, mask=mask2) + print *, iany(a8, dim=1, mask=mask2) + print *, iall(a1, dim=1, mask=mask2) + print *, iall(a2, dim=1, mask=mask2) + print *, iall(a4, dim=1, mask=mask2) + print *, iall(a8, dim=1, mask=mask2) + print *, iparity(a1, dim=1, mask=mask2) + print *, iparity(a2, dim=1, mask=mask2) + print *, iparity(a4, dim=1, mask=mask2) + print *, iparity(a8, dim=1, mask=mask2) +end Index: Fortran/gfortran/regression/pr47757-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47757-2.f90 @@ -0,0 +1,16 @@ +! PR libfortran/47757 +! { dg-do run { target fortran_large_int } } + + integer(16) :: a16(2,2) + logical :: mask(2,2) + logical :: mask2 + a16 = 0 + mask2 = .true. + mask = reshape([.true.,.true.,.false.,.true.],[2,2]) + print *, iany(a16, dim=1, mask=mask) + print *, iall(a16, dim=1, mask=mask) + print *, iparity(a16, dim=1, mask=mask) + print *, iany(a16, dim=1, mask=mask2) + print *, iall(a16, dim=1, mask=mask2) + print *, iparity(a16, dim=1, mask=mask2) +end Index: Fortran/gfortran/regression/pr47757-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47757-3.f90 @@ -0,0 +1,12 @@ +! PR libfortran/47757 +! { dg-do run { target fortran_large_int } } + + character(kind=4):: str(3,3), s(3) + str(1,:) = [4_'A', 4_'b', 4_'C'] + str(2,:) = [4_'A', 4_'b', 4_'C'] + str(3,:) = [4_'A', 4_'b', 4_'C'] + s = 4_'A' + print *, cshift(str, shift=2_16, dim=1_16) + print *, eoshift(str, shift=2_16, dim=1_16) + print *, eoshift(str, shift=2_16, boundary=s, dim=1_16) +end Index: Fortran/gfortran/regression/pr47878.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr47878.f90 @@ -0,0 +1,10 @@ +! PR fortran/47878 +! { dg-do run { target fd_truncate } } + integer :: a(5) + open (99, recl = 40) + write (99, '(5i3)') 1, 2, 3 + rewind (99) + read (99, '(5i3)') a + if (any (a.ne.(/1, 2, 3, 0, 0/))) STOP 1 + close (99, status = 'delete') +end Index: Fortran/gfortran/regression/pr48636-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr48636-2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-ipa-cp-details -fno-inline -fno-ipa-sra" } + +module foo + implicit none +contains + subroutine bar(a,x) + real, dimension(:,:), intent(in) :: a + real, intent(out) :: x + integer :: i,j + + x = 0 + do j=1,ubound(a,2) + do i=1,ubound(a,1) + x = x + a(i,j)**2 + end do + end do + end subroutine bar +end module foo + +program main + use foo + implicit none + real, dimension(2,3) :: a + real :: x + integer :: i + + data a /1.0, 2.0, 3.0, -1.0, -2.0, -3.0/ + + do i=1,2000000 + call bar(a,x) + end do + print *,x +end program main + +! { dg-final { scan-ipa-dump "Creating a specialized node of \[^\n\r\]*bar/\[0-9\]*\\." "cp" } } +! { dg-final { scan-ipa-dump-times "Aggregate replacements\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=\[^=\]*=" 2 "cp" } } Index: Fortran/gfortran/regression/pr48636.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr48636.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-ipa-inline-details -fdump-ipa-fnsummary-details -fno-ipa-cp" } + +module foo + implicit none +contains + subroutine bar(a,x) + real, dimension(:,:), intent(in) :: a + real, intent(out) :: x + integer :: i,j + + x = 0 + do j=1,ubound(a,2) + do i=1,ubound(a,1) + x = x + a(i,j)**2 + end do + end do + end subroutine bar +end module foo + +program main + use foo + implicit none + real, dimension(2,3) :: a + real :: x + integer :: i + + data a /1.0, 2.0, 3.0, -1.0, -2.0, -3.0/ + + do i=1,2000000 + call bar(a,x) + end do + print *,x +end program main + +! { dg-final { scan-ipa-dump "bar\[^\\n\]*inline copy in MAIN" "inline" } } +! { dg-final { scan-ipa-dump-times "phi predicate:" 3 "fnsummary" } } +! { dg-final { scan-ipa-dump "IPA hints: loop_iterations" "inline" } } Index: Fortran/gfortran/regression/pr48757.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr48757.f @@ -0,0 +1,54 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-options "-O2 -w" } +C fconc64.F, from CERNLIB (simplified) + + FUNCTION DFCONC(X,TAU,M) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMPLEX*16 WGAMMA,WLOGAM + COMPLEX*16 CGM,CLG,CRG,I,A,B,C,TI,R,RR,U(0:3),V(0:3),W(19) + LOGICAL LM0,LM1,LTA + CHARACTER NAME*(*) + CHARACTER*80 ERRTXT + PARAMETER (NAME = 'RFCONC/DFCONC') + DIMENSION T(7),H(9),S(5),P(11),D(-1:6) + PARAMETER (PI = 3.14159 26535 89793 24D+0) + PARAMETER (RPI = 1.77245 38509 05516 03D+0) + PARAMETER (I = (0,1)) + PARAMETER (Z1 = 1, HF = Z1/2, TH = 1+HF, C1 = Z1/10, C2 = Z1/5) + PARAMETER (RPH = 2/PI, RPW = 2/RPI, TW = 20, NMAX = 200) + DATA EPS /1D-14/ + ASSIGN 1 TO JP + GO TO 20 + 1 ASSIGN 2 TO JP + GO TO 20 + 2 IF(LM1) FC=2*FC/SQRT(1-X1) + GO TO 99 + 12 ASSIGN 3 TO JP + GO TO 20 + 3 IF(LM1) FC=SIGN(HF,1-X)*(TAU**2+HF**2)*SQRT(ABS(X**2-1))*FC + GO TO 99 + 13 ASSIGN 4 TO JP + GO TO 20 + 4 R1=EXP((TI-HF)*LOG(X+X)+CLG(1+TI)-CLG((TH-FM)+TI))* + 1 R*((HF-FM)+TI)/TI + FC=RPW*R1 + IF(LM1) FC=FC/SQRT(1-X1) + GO TO 99 + 20 IF(LTA) THEN + IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4) + ELSE + W(1)=X1*A*B/C + R=1+W(1) + DO 23 N = 1,NMAX + RR=R + W(1)=W(1)*X1*(A+FN)*(B+FN)/((C+FN)*(FN+1)) + IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4) + 23 CONTINUE + END IF + 99 DFCONC=FC + RETURN + 101 FORMAT('ILLEGAL ARGUMENT(S) X = ',D15.8,' TAU = ',D15.8, + 1 ' M = ',I3) + 102 FORMAT('CONVERGENCE PROBLEM FOR HYPERGEOMETRIC FUNCTION, X = ', + 1 D15.8) + END Index: Fortran/gfortran/regression/pr48958.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr48958.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! { dg-shouldfail "Fortran runtime error: Allocatable argument 'a' is not allocated" } +! { dg-output "At line 13 .*" } +! PR48958 - Add runtime diagnostics for SIZE intrinsic function + +program p + integer :: n + integer, allocatable :: a(:) + integer, pointer :: b(:) + class(*), allocatable :: c(:) + integer :: d(10) + print *, size (a) + print *, size (b) + print *, size (c) + print *, size (d) + print *, size (f(n)) +contains + function f (n) + integer, intent(in) :: n + real, allocatable :: f(:) + end function f +end + +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 4 "original" } } Index: Fortran/gfortran/regression/pr49103.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49103.f90 @@ -0,0 +1,19 @@ +! PR fortran/49103 +! { dg-do run } + integer :: a(2), b(2), i, j + open (10, status='scratch') + do j = 1, 2 + a = (/ 0, 0 /) + b = (/ 1, 1 /) + do i = 1, 2 + write (10, *) a + write (10, *) b + end do + end do + rewind (10) + do i = 0, 7 + read (10, *) a + if (any (a .ne. mod (i, 2))) STOP 1 + end do + close (10) +end Index: Fortran/gfortran/regression/pr49179.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49179.f90 @@ -0,0 +1,11 @@ +! { dg-options " -O -findirect-inlining" } +function more_OK (fcn) + character(*) more_OK + character (*), external :: fcn + more_OK = fcn () +end function more_OK + character(4) :: answer + character(4), external :: is_OK, more_OK + answer = more_OK (is_OK) +contains +END Index: Fortran/gfortran/regression/pr49308.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49308.f90 @@ -0,0 +1,28 @@ +! PR middle-end/49308 +! { dg-do compile } +! { dg-options "-O2 -funroll-loops -g" } + +subroutine foo(n, b, d, e) + type t + integer :: f + end type t + type s + type(t), pointer :: g + end type s + type u + type(s), dimension(:), pointer :: h + end type + integer :: i, k, n + type(u), pointer :: a, e + character(len=250) :: b, c, d + logical :: l + do i = 1, n + j = i - 1 + if (j/=0) c = trim(b) // adjustl(d(j)) + end do + a => e + do k = 1, size(a%h) + l = (a%h(k)%g%f == a%h(1)%g%f) + if (.not.(l)) call bar() + enddo +end subroutine foo Index: Fortran/gfortran/regression/pr49472.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49472.f90 @@ -0,0 +1,15 @@ +! PR rtl-optimization/49472 +! { dg-do compile } +! { dg-options "-O -fcompare-debug -ffast-math" } +subroutine pr49472 + integer, parameter :: n = 3 + real(8) :: a, b, c, d, e (n+1) + integer :: i + do i=2, (n+1) + b = 1. / ((i - 1.5d0) * 1.) + c = b * a + d = -b * c / (1. + b * b) ** 1.5d0 + e(i) = d + end do + call dummy (e) +end subroutine Index: Fortran/gfortran/regression/pr49494.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49494.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O -findirect-inlining -fno-guess-branch-probability -finline-functions -finline-small-functions" } +function more_OK (fcn) + character(*) more_OK + character (*), external :: fcn + more_OK = fcn () +end function more_OK + character(4) :: answer + character(4), external :: is_OK, more_OK + answer = more_OK (is_OK) +contains +END Index: Fortran/gfortran/regression/pr49540-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49540-1.f90 @@ -0,0 +1,6 @@ +! PR fortran/49540 +! { dg-do compile } +block data + common /a/ b(100000,100) + data b /10000000 * 0.0/ +end block data Index: Fortran/gfortran/regression/pr49540-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49540-2.f90 @@ -0,0 +1,17 @@ +! PR fortran/49540 +! { dg-do compile } +! { dg-options "" } +block data + common /a/ i(5,5) + data i /4, 23 * 5, 6/ + data i(:,2) /1, 3 * 2, 3/ + common /b/ j(5,5) + data j(2,:) /1, 3 * 2, 3/ + data j /4, 23 * 5, 6/ + common /c/ k(5,5) + data k(:,2) /1, 3 * 2, 3/ + data k /4, 23 * 5, 6/ + common /d/ l(5,5) + data l /4, 23 * 5, 6/ + data l(2,:) /1, 3 * 2, 3/ +end block data Index: Fortran/gfortran/regression/pr49675.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49675.f90 @@ -0,0 +1,6 @@ +! PR middle-end/49675 +! { dg-do compile } +! { dg-options "-finstrument-functions" } +end +! { dg-final { scan-assembler "__cyg_profile_func_enter" } } +! { dg-final { scan-assembler "__cyg_profile_func_exit" } } Index: Fortran/gfortran/regression/pr49698.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49698.f90 @@ -0,0 +1,15 @@ +! PR fortran/49698 +! { dg-do compile } +subroutine foo (x, y, z) + type S + integer, pointer :: e => null() + end type S + type T + type(S), dimension(:), allocatable :: a + end type T + type(T) :: x, y + integer :: z, i + forall (i = 1 : z) + y%a(i)%e => x%a(i)%e + end forall +end subroutine foo Index: Fortran/gfortran/regression/pr49721-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr49721-1.f @@ -0,0 +1,35 @@ +! PR middle-end/49721 +! { dg-do compile } +! { dg-options "-O3 -funroll-loops -std=legacy" } + + subroutine midbloc6(c,a2,a2i,q) + parameter (ndim2=6) + parameter (ndim=3) + dimension ri(ndim2),cr(ndim2,ndim2),xj(ndim2,ndim2),q(*) + @,sai(ndim2,ndim2),cm(ndim2,ndim2),w(ndim2,ndim2) + dimension vr(ndim2,ndim2),vi(ndim2,ndim2),s1(ndim2,ndim2),p(ndim) + dimension xq(6),qb(2),qc(2),ifl(6),iplane(3) + save + call eig66(cr,rr,ri,vr,vi) + xq(i)=asin(ri(i))/x2pi + i9=6 + qb(1)=q(1)/x2pi + do 180 i=1,2 + do 170 j=1,6 + 120 if(xq(j)) 130,190,140 + 130 if(qb(i)-0.5d0) 160,150,150 + 140 if(qb(i)-0.5d0) 150,150,160 + 150 continue + tst=abs(abs(qb(i))-abs(xq(j))) + 160 continue + 170 continue + iplane(i)=k + 180 continue + 190 continue + n1=iplane(3) + if(i9.eq.6) then + z=vr(1,n1)*vi(2,n1)-vr(2,n1)*vi(1,n1)+vr(3,n1)*vi(4,n1)-vr(4,n1) + endif + sai(6,i)=vi(i,n1)/z + call dacond6(a2,zero) + end Index: Fortran/gfortran/regression/pr50069_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr50069_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } + + implicit none + integer i + character(LEN=6) :: a(1) = "123456" + forall (i = 3:4) a(1)(i:i+2) = a(1)(i-2:i) + !print *,a ! displays '12@' must be '121234' + IF (a(1) .ne. "121234") STOP 1 +end Index: Fortran/gfortran/regression/pr50069_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr50069_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + +function reverse(string) +implicit none +character(len=*), intent(in) :: string +character(len=:),allocatable :: reverse +integer i +reverse = string +forall (i=1:len(reverse)) reverse(i:i) = & + reverse(len(reverse)-i+1:len(reverse)-i+1) +end function reverse Index: Fortran/gfortran/regression/pr50392.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr50392.f @@ -0,0 +1,12 @@ +! { dg-do compile } +! + function kf() + integer kf + assign 1 to kf ! { dg-warning "Deleted feature: ASSIGN statement at" } + kf = 2 + goto kf ! { dg-warning "Deleted feature: Assigned GOTO statement at" } + kf = 1 + 1 continue + kf = 0 + end + Index: Fortran/gfortran/regression/pr50769.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr50769.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-tail-merge -fno-delete-null-pointer-checks -fno-guess-branch-probability" } +! +! based on testsuite/gfortran.dg/alloc_comp_optional_1.f90, +! which was contributed by David Kinniburgh +! +program test_iso + type ivs + character(LEN=1), dimension(:), allocatable :: chars + end type ivs + type(ivs) :: v_str + integer :: i + call foo(v_str, i) + if (v_str%chars(1) .ne. "a") STOP 1 + if (i .ne. 0) STOP 2 + call foo(flag = i) + if (i .ne. 1) STOP 3 +contains + subroutine foo (arg, flag) + type(ivs), optional, intent(out) :: arg + integer :: flag + if (present(arg)) then + arg = ivs([(char(i+96), i = 1,10)]) + flag = 0 + else + flag = 1 + end if + end subroutine +end + Index: Fortran/gfortran/regression/pr50875.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr50875.f90 @@ -0,0 +1,37 @@ +! { dg-do compile { target { i?86-*-* x86_64-*-* } } } +! { dg-options "-O3 -mavx" } +! +! PR fortran/50875.f90 + +module test + + implicit none + + integer, parameter :: dp=kind(1.d0) + + integer :: P = 2 + + real(kind=dp), allocatable :: real_array_A(:),real_array_B(:,:) + complex(kind=dp), allocatable :: cmplx_array_A(:) + +contains + + subroutine routine_A + + integer :: i + + allocate(cmplx_array_A(P),real_array_B(P,P),real_array_A(P)) + + real_array_A = 1 + real_array_B = 1 + + do i = 1, p + cmplx_array_A = cmplx(real_array_B(:,i),0.0_dp,dp) + cmplx_array_A = cmplx_array_A * exp(cmplx(0.0_dp,real_array_A+1)) + end do + + deallocate(cmplx_array_A,real_array_B,real_array_A) + + end subroutine routine_A + +end module test Index: Fortran/gfortran/regression/pr51434.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr51434.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR fortran/51434 +module foo + implicit none + integer, parameter :: n = 5 + character(len=1), parameter :: s(n) = 'a' + type :: a + integer :: m = n + character(len=1):: t(n) = transfer('abcde', s) + end type a +end module foo + +program bar + use foo + implicit none + type(a) c + if (c%m /= n) stop 1 + if (any(c%t /= ['a', 'b', 'c', 'd', 'e'])) stop 2 +end program bar Index: Fortran/gfortran/regression/pr51991.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr51991.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/51991 +! Orginal code contributed by Sebastien Bardeau +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: i,j + i = a%i + ! + ! Prior to patching gfortran, the following lined generated a syntax + ! error with the SAVE statement. Now, gfortran generates an error + ! that indicates 'j' is not a component of 'mytyp'. + ! + j = a%j ! { dg-error "is not a member of the" } + end subroutine mysub +end module mymod Index: Fortran/gfortran/regression/pr51993.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr51993.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/51993 +! Code contributed by Sebastien Bardeau +module mymod + type :: mytyp + character(len=3) :: a = .true. ! { dg-error "convert LOGICAL" } + end type mytyp +end module mymod Index: Fortran/gfortran/regression/pr52370.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52370.f90 @@ -0,0 +1,21 @@ +! PR fortran/52370 +! { dg-do compile } +! { dg-options "-O1 -Wall" } + +module pr52370 +contains + subroutine foo(a,b) + real, intent(out) :: a + real, dimension(:), optional, intent(out) :: b + a=0.5 + if (present(b)) then + b=1.0 + end if + end subroutine foo +end module pr52370 + +program prg52370 + use pr52370 + real :: a + call foo(a) +end program prg52370 Index: Fortran/gfortran/regression/pr52608.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52608.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR 52608 +! Testcase reduced from NIST testsuite FM110 +program fm110_snippet + implicit none + real :: aavs + character(len=100) :: s(2), s2(2) + AAVS = .087654 +35043 FORMAT (" ",16X,"COMPUTED: ",22X,1P/26X,F5.4,3X,2P,F5.3,+3P," ",& + (23X,F6.2),3X) +5043 FORMAT (17X,"CORRECT: ",/24X,& + " .8765 8.765 87.65") + WRITE (s,35043) AAVS,AAVS,AAVS + WRITE (s2,5043) + if (s(2) /= s2(2)) STOP 1 +end program fm110_snippet + Index: Fortran/gfortran/regression/pr52621.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52621.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O2 -fprefetch-loop-arrays -w" } + + SUBROUTINE GHDSYM(IZ,IS,LMMAX,S,LMS,Y,L2M,DRL,NLAY2,K0,DCUT)!, +! + COMPLEX Y(L2M,L2M),H(33),S(LMS) + COMPLEX RU,CI,CZ,K0,FF,Z,Z1,Z2,Z3,ST +! + DO 140 KK=1,4 + DO 130 L=1,L2M + L1=L*L-L + DO 120 M=1,L + IPM=L1+M + IMM=L1-M+2 + S(IPM)=S(IPM)+Z3*Y(L,M) + IF (M.NE.1) S(IMM)=S(IMM)+Z3*Y(M-1,L)*CSGN +120 CONTINUE +130 CONTINUE +140 CONTINUE + END Index: Fortran/gfortran/regression/pr52678.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52678.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O -ftree-vectorize" } + SUBROUTINE OpenAD_set_ref_state(DRF, RHOFACF, RHOFACC) + real(8) DRF(1 : 15) + real(8) RHOFACF(1 : 16) + real(8) RHOFACC(1 : 15) + integer, dimension(:), allocatable :: oad_it + integer :: oad_it_ptr + INTEGER(8) OpenAD_Symbol_188 + INTEGER(4) K + OpenAD_Symbol_188 = 0 + DO K = 2, 15, 1 + RHOFACF(INT(K)) = ((RHOFACC(K) * DRF(K + (-1)) + RHOFACC(K + + + (-1)) * DRF(K)) /(DRF(K) + DRF(K + (-1)))) + OpenAD_Symbol_188 = (INT(OpenAD_Symbol_188) + INT(1)) + END DO + oad_it(oad_it_ptr) = OpenAD_Symbol_188 + end subroutine OpenAD_set_ref_state Index: Fortran/gfortran/regression/pr52701.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52701.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O3" } +function pr52701 (x, z, e, f, g, l) + integer a, b, c, d, e, f, g, i, j, l, pr52701 + double precision x(e), z(e*e) + do i = l, f + do j = l, i + d = 0 + do a = 1, g + c = a - g + do b = 1, g + d = d + 1 + c = c + g + z(d) = z(d) / (x(i) + x(j) - x(f + a) - x(f + b)) + end do + end do + end do + end do + pr52701 = c +end Index: Fortran/gfortran/regression/pr52835.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr52835.f90 @@ -0,0 +1,15 @@ +! PR tree-optimization/52835 +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } + +subroutine foo (x, y, z, n) + integer :: n, i + real :: x(n), y(n), z(n) + do i = 1, n + z(i) = 0.0 + y(i) = 0.0 + call bar (y(i), z(i), x(i)) + end do +end subroutine + +! { dg-final { scan-tree-dump "bar\[ _\]" "optimized" } } Index: Fortran/gfortran/regression/pr53217.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr53217.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } + +! This tests only for compile-time failure, which formerly occurred +! when statements were emitted out of order, failing verify_ssa. + +MODULE xc_cs1 + INTEGER, PARAMETER :: dp=KIND(0.0D0) + REAL(KIND=dp), PARAMETER :: a = 0.04918_dp, & + c = 0.2533_dp, & + d = 0.349_dp +CONTAINS + SUBROUTINE cs1_u_2 ( rho, grho, r13, e_rho_rho, e_rho_ndrho, e_ndrho_ndrho,& + npoints, error) + REAL(KIND=dp), DIMENSION(*), & + INTENT(INOUT) :: e_rho_rho, e_rho_ndrho, & + e_ndrho_ndrho + DO ip = 1, npoints + IF ( rho(ip) > eps_rho ) THEN + oc = 1.0_dp/(r*r*r3*r3 + c*g*g) + d2rF4 = c4p*f13*f23*g**4*r3/r * (193*d*r**5*r3*r3+90*d*d*r**5*r3 & + -88*g*g*c*r**3*r3-100*d*d*c*g*g*r*r*r3*r3 & + +104*r**6)*od**3*oc**4 + e_rho_rho(ip) = e_rho_rho(ip) + d2F1 + d2rF2 + d2F3 + d2rF4 + END IF + END DO + END SUBROUTINE cs1_u_2 +END MODULE xc_cs1 Index: Fortran/gfortran/regression/pr53298.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr53298.f90 @@ -0,0 +1,14 @@ +! { dg-do run } + +program test + character(len=5) :: str(3) + str = ["abcde", "12345", "ABCDE" ] + call f(str(:)) +contains + subroutine f(x) + character(len=*) :: x(:) + write(*,*) x(:)(1:) + end subroutine f +end program test + +! { dg-output "abcde12345ABCDE" } Index: Fortran/gfortran/regression/pr53787.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr53787.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-ipa-cp-details -fno-ipa-sra -fno-inline -fwhole-program" } + + real x(10) + n = 10 + call init(x,n) + print *, x +end program + +subroutine init(x, n) + real x(10) + do i=1,n + x(i) = i*i + 1 + enddo + + return +end subroutine init + +! { dg-final { scan-ipa-dump "Creating a specialized node of init" "cp" } } +! { dg-final { scan-ipa-dump-times "Aggregate replacements" 2 "cp" } } Index: Fortran/gfortran/regression/pr54131.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr54131.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O2 -funroll-loops" } + + SUBROUTINE EFPGRD(IFCM,NAT,NVIB,NPUN,FCM, + * DEN,GRD,ENG,DIP,NVST,NFTODO,LIST) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION DEN(*),GRD(*),ENG(*),DIP(*),LIST(*) + PARAMETER (MXPT=100, MXFRG=50, MXFGPT=MXPT*MXFRG) + COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG), + * ATORQ(3,MXFRG) + IF(NVST.EQ.0) THEN + CALL PUVIB(IFCM,IW,.FALSE.,NCOORD,IVIB,IATOM,ICOORD, + * ENG(IENG),GRD(IGRD),DIP(IDIP)) + END IF + DO 290 IVIB=1,NVIB + DO 220 IFRG=1,NFRG + DO 215 J=1,3 + DEFT(J,IFRG)=GRD(INDX+J-1) + 215 CONTINUE + INDX=INDX+6 + 220 CONTINUE + 290 CONTINUE + END Index: Fortran/gfortran/regression/pr54889.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr54889.f90 @@ -0,0 +1,10 @@ +! PR tree-optimization/54889 +! { dg-do compile } +! { dg-options "-O3" } +! { dg-additional-options "-mavx" { target { i?86-*-* x86_64-*-* } } } + +subroutine foo(x,y,z) + logical, pointer :: x(:,:) + integer :: y, z + x=x(1:y,1:z) +end subroutine Index: Fortran/gfortran/regression/pr54967.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr54967.f90 @@ -0,0 +1,18 @@ + SUBROUTINE calc_S_derivs() + INTEGER, DIMENSION(6, 2) :: c_map_mat + INTEGER, DIMENSION(:), POINTER:: C_mat + DO j=1,3 + DO m=j,3 + n=n+1 + c_map_mat(n,1)=j + IF(m==j)CYCLE + c_map_mat(n,2)=m + END DO + END DO + DO m=1,6 + DO j=1,2 + IF(c_map_mat(m,j)==0)CYCLE + CALL foo(C_mat(c_map_mat(m,j))) + END DO + END DO + END SUBROUTINE calc_S_derivs Index: Fortran/gfortran/regression/pr55086_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55086_1.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! + implicit none + character(len=5), pointer :: a(:), b(:) + character(len=5), pointer :: c, d + allocate (a(2), b(2), c, d) + a = [ "abcde", "ABCDE" ] + call aloct_pointer_copy_4 (b, a) + !print *, b(1) + !print *, b(2) + if (any (a /= b)) stop 'WRONG' + + call aloct_copy_4 (b, a) + !print *, b(1) + !print *, b(2) + if (any (a /= b)) stop 'WRONG' + + d = '12345' + c = "abcde" + call test2 (d, c) + !print *, d + if (d /= '1cb15') stop 'WRONG' + + call test2p (d, c) + !print *, d + if (d /= '1cb15') stop 'WRONG' + +contains + subroutine aloct_pointer_copy_4(o, i) + character(len=*), pointer :: o(:), i(:) + integer :: nl1, nu1 + integer :: i1 + nl1 = lbound(i,dim=1) + nu1 = ubound(i,dim=1) + forall (i1 = nl1:nu1) o(i1) = i(i1) + end subroutine aloct_pointer_copy_4 + subroutine aloct_copy_4(o, i) + character(len=*), pointer :: o(:), i(:) + integer :: nl1, nu1 + integer :: i1 + nl1 = lbound(i,dim=1) + nu1 = ubound(i,dim=1) + forall (i1 = nl1:nu1) o(i1) = i(i1) + end subroutine aloct_copy_4 + subroutine test2(o, i) + character(len=*) :: o, i + integer :: nl1, nu1 + integer :: i1 + nl1 = 2 + nu1 = 4 + forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) + forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1) + end subroutine test2 + subroutine test2p(o, i) + character(len=*), pointer :: o, i + integer :: nl1, nu1 + integer :: i1 + nl1 = 2 + nu1 = 4 + forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE + forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1) + end subroutine test2p +end Index: Fortran/gfortran/regression/pr55086_1_tfat.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55086_1_tfat.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-ftest-forall-temp" } +! + implicit none + character(len=5), pointer :: a(:), b(:) + character(len=5), pointer :: c, d + allocate (a(2), b(2), c, d) + a = [ "abcde", "ABCDE" ] + call aloct_pointer_copy_4 (b, a) + !print *, b(1) + !print *, b(2) + if (any (a /= b)) stop 'WRONG' + + call aloct_copy_4 (b, a) + !print *, b(1) + !print *, b(2) + if (any (a /= b)) stop 'WRONG' + + d = '12345' + c = "abcde" + call test2 (d, c) + !print *, d + if (d /= '1cb15') stop 'WRONG' + + call test2p (d, c) + !print *, d + if (d /= '1cb15') stop 'WRONG' + +contains + subroutine aloct_pointer_copy_4(o, i) + character(len=*), pointer :: o(:), i(:) + integer :: nl1, nu1 + integer :: i1 + nl1 = lbound(i,dim=1) + nu1 = ubound(i,dim=1) + forall (i1 = nl1:nu1) o(i1) = i(i1) + end subroutine aloct_pointer_copy_4 + subroutine aloct_copy_4(o, i) + character(len=*), pointer :: o(:), i(:) + integer :: nl1, nu1 + integer :: i1 + nl1 = lbound(i,dim=1) + nu1 = ubound(i,dim=1) + forall (i1 = nl1:nu1) o(i1) = i(i1) + end subroutine aloct_copy_4 + subroutine test2(o, i) + character(len=*) :: o, i + integer :: nl1, nu1 + integer :: i1 + nl1 = 2 + nu1 = 4 + forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) + forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1) + end subroutine test2 + subroutine test2p(o, i) + character(len=*), pointer :: o, i + integer :: nl1, nu1 + integer :: i1 + nl1 = 2 + nu1 = 4 + forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE + forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1) + end subroutine test2p +end Index: Fortran/gfortran/regression/pr55086_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55086_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! + implicit none + + character(len=7), pointer :: u + character(len=7), pointer :: v + + character(len=7), target :: a + character(len=7), target :: b + + integer :: j + + b = "1234567" + a = "abcdefg" + + u => a + v => b + + forall (j = 1:2) a(j:j) = b(j:j) + + if (a /= "12cdefg") STOP 1 + + forall (j = 2:3) a(j:j) = v(j:j) + if (a /= "123defg") STOP 2 + + forall (j = 3:4) u(j:j) = b(j:j) + if (a /= "1234efg") STOP 3 + + forall (j = 4:5) u(j:j) = v(j:j) + if (a /= "12345fg") STOP 4 + +end Index: Fortran/gfortran/regression/pr55086_2_tfat.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55086_2_tfat.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-ftest-forall-temp" } +! + implicit none + + character(len=7), pointer :: u + character(len=7), pointer :: v + + character(len=7), target :: a + character(len=7), target :: b + + integer :: j + + b = "1234567" + a = "abcdefg" + + u => a + v => b + + forall (j = 1:2) a(j:j) = b(j:j) + + if (a /= "12cdefg") STOP 1 + + forall (j = 2:3) a(j:j) = v(j:j) + if (a /= "123defg") STOP 2 + + forall (j = 3:4) u(j:j) = b(j:j) + if (a /= "1234efg") STOP 3 + + forall (j = 4:5) u(j:j) = v(j:j) + if (a /= "12345fg") STOP 4 + +end Index: Fortran/gfortran/regression/pr55086_aliasing_dummy_4_tfat.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55086_aliasing_dummy_4_tfat.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-ftest-forall-temp" } +! This is a copy of aliasing_dummy_4.f90, with an option set to improve +! test coverage by forcing forall code to use a temporary. +! +program test_f90 + + integer, parameter :: N = 2 + + type test_type + integer a(N, N) + end type + + type (test_type) s(N, N) + + forall (l = 1:N, m = 1:N) & + s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N]) + + call test_sub(s%a(1, 1), 1000) ! Test the original problem. + + if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) STOP 1 + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 2 + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 3 + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 4 + + call test_sub(s(1, 1)%a(:, :), 1000) ! Check "normal" references. + + if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) STOP 5 + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 6 + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 7 + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 8 +contains + subroutine test_sub(array, offset) + integer array(:, :), offset + + forall (i = 1:N, j = 1:N) & + array(i, j) = array(i, j) + offset + end subroutine +end program + Index: Fortran/gfortran/regression/pr55330.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr55330.f90 @@ -0,0 +1,73 @@ +! PR rtl-optimization/55330 +! { dg-do compile } +! { dg-options "-O -fPIC -fno-dse -fno-guess-branch-probability" } + +module global + public p, line + interface p + module procedure p + end interface + character(128) :: line = 'abcdefghijklmnopqrstuvwxyz' +contains + subroutine p() + character(128) :: word + word = line + call redirect_((/word/)) + end subroutine + subroutine redirect_ (ch) + character(*) :: ch(:) + if (ch(1) /= line) STOP 1 + end subroutine redirect_ +end module global + +module my_module + implicit none + type point + real :: x + end type point + type(point), pointer, public :: stdin => NULL() +contains + subroutine my_p(w) + character(128) :: w + call r(stdin,(/w/)) + end subroutine my_p + subroutine r(ptr, io) + use global + type(point), pointer :: ptr + character(128) :: io(:) + if (associated (ptr)) STOP 2 + if (io(1) .ne. line) STOP 3 + end subroutine r +end module my_module + +program main + use global + use my_module + + integer :: i(6) = (/1,6,3,4,5,2/) + character (6) :: a = 'hello ', t + character(len=1) :: s(6) = (/'g','g','d','d','a','o'/) + equivalence (s, t) + + call option_stopwatch_s (a) + call p () + call my_p (line) + + s = s(i) + call option_stopwatch_a ((/a,'hola! ', t/)) + +contains + + subroutine option_stopwatch_s(a) + character (*), intent(in) :: a + character (len=len(a)) :: b + + b = 'hola! ' + call option_stopwatch_a((/a, b, 'goddag'/)) + end subroutine option_stopwatch_s + subroutine option_stopwatch_a (a) + character (*) :: a(:) + if (any (a .ne. (/'hello ','hola! ','goddag'/))) STOP 4 + end subroutine option_stopwatch_a + +end program main Index: Fortran/gfortran/regression/pr56007.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56007.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/56007 +! Based on testcase by Tobias Schlüter + + integer iw1(90), doiw1(90) + do iw1(1)=1 + do iw1=1 + do iw1=1,2 ! { dg-error "cannot be an array" } + end do ! { dg-error "Expecting END PROGRAM statement" } + END Index: Fortran/gfortran/regression/pr56007.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56007.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/56007 +! Based on testcase by Tobias Schlüter + + integer iw1(90), doiw1(90) + do iw1=1,2 ! { dg-error "cannot be an array" } + end do ! { dg-error "Expecting END PROGRAM statement" } + do iw1(1)=1 + do iw1=1 ! { dg-error "cannot be an array" } + end do ! { dg-error "Expecting END PROGRAM statement" } +END program Index: Fortran/gfortran/regression/pr56015.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56015.f90 @@ -0,0 +1,16 @@ +! PR middle-end/56015 +! { dg-do run } +! { dg-options "-Ofast -fno-inline" } + +program pr56015 + implicit none + complex*16 p(10) + p(:) = (0.1d0, 0.2d0) + p(:) = (0.0d0, 1.0d0) * p(:) + call foo (p) +contains + subroutine foo (p) + complex*16 p(10) + if (any (p .ne. (-0.2d0, 0.1d0))) STOP 1 + end subroutine +end program pr56015 Index: Fortran/gfortran/regression/pr56049.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56049.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } + +program inline + + integer i + integer a(8,8), b(8,8) + + a = 0 + do i = 1, 10000000 + call add(b, a, 1) + a = b + end do + + print *, a + +contains + + subroutine add(b, a, o) + integer, intent(inout) :: b(8,8) + integer, intent(in) :: a(8,8), o + b = a + o + end subroutine add + +end program inline + +! Check there's no loop left, just two bb 2 in two functions. +! { dg-final { scan-tree-dump-times "" 2 "optimized" } } +! { dg-final { scan-tree-dump-times "" 2 "optimized" } } Index: Fortran/gfortran/regression/pr56520.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56520.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/56520 +! +program misleading + implicit none + real a, c + a = 1.0 + c = exp(+a) ) ! { dg-error "Unclassifiable statement" } + c = exp(-a) ) + c = exp((a)) ) + c = exp(a) ) + c = exp(a) +end program misleading Index: Fortran/gfortran/regression/pr56852.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr56852.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Test the fix for pr56852, where an ICE would occur after the error. +! +! Contributed by Lorenz Huedepohl +! +program test + implicit none + real :: a(4) + ! integer :: i + read(0) (a(i),i=1,4) ! { dg-error "has no IMPLICIT type" } +end program Index: Fortran/gfortran/regression/pr57393-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57393-1.f90 @@ -0,0 +1,38 @@ +! PR middle-end/57393 +! { dg-do compile } +! { dg-options "-g -O2 -ffast-math" } + +SUBROUTINE pr57393(nn,e,g,t0,t1,t2,t3,t4,t5,t6,t7,& + t8,t9,t10,t11,t12,t13,t14,t15,& + t16,t17,t18,t19,t20,t21,t22,t23,& + t24,t25,t26,t27,t28,t29,t30,& + t31,t32,t33,t34,t35,t36,t37,t38,& + t39,t40,t41,t42,t43,t44,t45,t46,t47) + IMPLICIT REAL*8 (t) + INTEGER, PARAMETER :: dp=8 + REAL(kind=dp) :: e(nn) + DO ii=1,nn + t48 = 0.1955555555e2_dp * t1 * t2 + & + 0.6000000000e1_dp * t3 * t4 * t5 + t49 = 0.1620000000e3_dp * t6 * t7 * t8 + & + 0.1080000000e3_dp * t6 * t9 * t5 - & + 0.6000000000e1_dp * t10 * t20 * t21 * t55 - & + 0.2400000000e2_dp * t10 * t11 * t12 - & + 0.1200000000e2_dp * t13 * t14 * t15 + t50 = t49 + t16 + t51 = (3 * t17 * t18 * t19) + & + (t22 * t23 * t19) + (t50 * t19) - & + 0.3333333336e0_dp * t24 * t25 + t52 = 0.1555555556e1_dp * t26 * t27 * t12 + & + (t51 + t28 + t29 + t30) * & + 0.3125000000e0_dp * t31 * t32 * t33 * t34 + t53 = -0.1000000001e1_dp * t35 * t36 * t5 - & + (t37 + t38 + t39 + t52) - & + 0.8333333340e-1_dp * t40 * t41 * t42 + t54 = -0.1000000001e1_dp * t43 * t44 * t45 - & + t47 * (t46 + t53) + IF (g >= 3 .OR. g == -3) THEN + e(ii) = e(ii) + t54 * t0 + END IF + END DO +END SUBROUTINE pr57393 Index: Fortran/gfortran/regression/pr57393-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57393-2.f90 @@ -0,0 +1,10 @@ +! PR middle-end/57393 +! { dg-do compile } +! { dg-options "-g -O2" } + +SUBROUTINE pr57393 ( a1, a2, a3, a4, a5, a6, a7 ) + COMPLEX(kind=8), DIMENSION(:), INTENT(IN) :: a1 + INTEGER, DIMENSION(:), INTENT(IN) :: a2, a3, a5, a6 + COMPLEX(kind=8), DIMENSION(:), INTENT(INOUT) :: a4 + a4(a6(1)+1:a6(1)+a5(1))=a1(a3(1)+1:a3(1)+a2(1)) +END SUBROUTINE pr57393 Index: Fortran/gfortran/regression/pr57553.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57553.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/57553 - bad error message for invalid use of STORAGE_SIZE +! +! Testcase contributed by Tobias Burnus + +subroutine S (A) + character(len=*), intent(in) :: A + integer, parameter :: ESize = (storage_size(a) + 7) / 8 ! { dg-error "does not reduce to a constant" } +end Index: Fortran/gfortran/regression/pr57904.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57904.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-O2" } + +program test + call test2 () +contains + subroutine test2 () + type t + integer, allocatable :: x + end type t + + type t2 + class(t), allocatable :: a + end type t2 + + type(t2) :: one, two + + allocate (two%a) + one = two + end subroutine test2 +end program test + Index: Fortran/gfortran/regression/pr57910.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57910.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +program strtest + + implicit none + + character(len=:), allocatable:: my_str + + integer, parameter :: slen_init = 7 + integer :: slen = slen_init + + my_str = fstr(slen) + if (slen /= slen_init .or. len(my_str) /= slen .or. my_str /= ' ') then + STOP 1 + endif + +contains + + function fstr(strlen) + integer, value :: strlen + character(len=strlen)::fstr + + strlen = 17 ! Make sure strlen was really passed by value + fstr = ' ' + end function fstr + +end program strtest Index: Fortran/gfortran/regression/pr57987.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr57987.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O3 -fno-ipa-cp -fdump-ipa-inline" } + +program test + call test2 () +contains + subroutine test2 () + type t + integer, allocatable :: x + end type t + + type t2 + class(t), allocatable :: a + end type t2 + + type(t2) :: one, two + + allocate (two%a) + one = two + end subroutine test2 +end program test + +! { dg-final { scan-ipa-dump-not "redefined extern inline functions are not considered for inlining" "inline" } } Index: Fortran/gfortran/regression/pr58027.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr58027.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/58027 +integer, parameter :: i(1)=(/z'ff800000'/) ! { dg-error "cannot appear in" } +print *, isclass +end Index: Fortran/gfortran/regression/pr58290.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr58290.f90 @@ -0,0 +1,33 @@ +! PR ipa/58290 +! { dg-do compile } +! { dg-options "-O1 -fipa-pta" } + +MODULE pr58290 + TYPE b + CHARACTER(10) :: s = '' + END TYPE b + TYPE c + TYPE(b) :: d + END TYPE c + TYPE h + INTEGER, DIMENSION(:), POINTER :: b + END TYPE h +CONTAINS + SUBROUTINE foo(x, y) + LOGICAL, INTENT(IN) :: x + TYPE(c), INTENT(INOUT) :: y + END SUBROUTINE + FUNCTION bar (g) RESULT (z) + TYPE(h), INTENT(IN) :: g + TYPE(c) :: y + CALL foo (.TRUE., y) + z = SIZE (g%b) + END FUNCTION bar + SUBROUTINE baz (g) + TYPE(h), INTENT(INOUT) :: g + INTEGER :: i, j + j = bar(g) + DO i = 1, j + ENDDO + END SUBROUTINE baz +END MODULE Index: Fortran/gfortran/regression/pr58484.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr58484.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -std=legacy" } + SUBROUTINE UMPSE(AIBJ,NOC,NDIM,NOCA,NVIRA,NOCCA,E2) + DIMENSION AIBJ(NOC,NDIM,*) + DO 20 MA=1,NVIRA + DO 20 MI=1,NOCA + DO 10 MB=1,MA + MBI = MI+NOCA*(MB-1) + DO 10 MJ=1,NOCCA + DUM = AIBJ(MJ,MAI,MB)-AIBJ(MJ,MBI,MA) + E2A = E2A-DUM + 10 CONTINUE + 20 CONTINUE + E2 = E2+E2A + END Index: Fortran/gfortran/regression/pr58968.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr58968.f @@ -0,0 +1,96 @@ +C PR rtl-optimization/58968.f +C { dg-do compile { target powerpc*-*-* } } +C { dg-options "-mdejagnu-cpu=power7 -O3 -w -ffast-math -funroll-loops" } + SUBROUTINE MAKTABS(IW,SOME,LBOX1,LBOX2,LBOX3,NSPACE,NA,NB, + * LBST,X, + * NX,IAMA,IAMI,IBMA,IBMI,MNUM,IDIM,MSTA,IBO, + * IDSYM,ISYM1,NSYM, + * NACT,LWRK,KTAB,LGMUL, + * LCON,LCOA,LCOB, + * LANDET,LBNDET,NAST,NBST,LSYMA,LSYMB,LGCOM, + * MINI,MAXI,LSPA,LSPB,LDISB, + * LSAS,LSBS,LSAC,LSBC, + * ITGA,ITGB,IAST,IBST,NCI,NA1EX,NB1EX,FDIRCT) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + LOGICAL SOME + DIMENSION LBOX1(NSPACE),LBOX2(NSPACE),LBOX3(NSPACE),LBST(NSPACE) + DIMENSION X(NX) + DIMENSION IAMA(NSPACE),IAMI(NSPACE),IBMA(NSPACE),IBMI(NSPACE) + DIMENSION MNUM(NSPACE),IDIM(NSPACE),MSTA(NSPACE+1),IBO(NACT) + DIMENSION LWRK(43),KTAB(NSYM),LGMUL(NSYM,NSYM) + DIMENSION LCON(NA) + DIMENSION LCOA(NSYM,ITGA),LCOB(NSYM,ITGB) + DIMENSION LANDET(NSPACE,ITGA),LBNDET(NSPACE,ITGB) + DIMENSION NAST(ITGA+1),NBST(ITGB+1) + DIMENSION LSYMA(IAST),LSYMB(IBST) + DIMENSION LGCOM(ITGB,ITGA) + DIMENSION MINI(NSPACE),MAXI(NSPACE) + DIMENSION LSPA(IAST),LSPB(IBST) + DIMENSION LDISB(NSYM,ITGB,ITGA) + DIMENSION LSAS(NSYM+1,ITGA),LSBS(NSYM+1,ITGB) + DIMENSION LSAC(IAST),LSBC(IBST) + LOGICAL FDIRCT + LCOA = 0 + LCOB = 0 + ISTA1 = LBST(1) + CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX2) + NAST(1) = 0 + NBST(1) = 0 + DO II=1,ITGA + ITOT = 1 + DO JJ=1,NSPACE + ITOT = ITOT * LANDET(JJ,II) + ENDDO + NAST(II+1) = NAST(II) + ITOT + ENDDO + DO II=1,ITGB + ITOT = 1 + DO JJ=1,NSPACE + ITOT = ITOT * LBNDET(JJ,II) + ENDDO + NBST(II+1) = NBST(II) + ITOT + ENDDO + ICOMP = 0 + CALL RESETCO(LBOX1,NSPACE,NA,IAMA,IAMI,LBOX3) + NA1EX = 0 + NB1EX = 0 + CALL RESETCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3) + DO IIB = 1,ITGB + CALL RESETDE(LBOX1,NSPACE,NB,MSTA,LCON) + DO KKB=NBST(IIB)+1,NBST(IIB+1) + DO II=1,NSPACE + LBOX2(II) = LBOX1(II) + ENDDO + IEBS = NB+1 + DO ISPB1=NSPACE,1,-1 + IOC1 = LBOX1(ISPB1) + IEBE = IEBS - 1 + IEBS = IEBS - IOC1 + LBOX2(ISPB1) = LBOX2(ISPB1)-1 + DO IB1=IEBE,IEBS,-1 + IO1 = LCON(IB1) + IGBE = IEBE - LBOX1(ISPB1) + DO ISPB2=ISPB1,NSPACE + IGBS = IGBE + 1 + IGBE = IGBE + LBOX1(ISPB2) + LBOX2(ISPB2) = LBOX2(ISPB2) + 1 + IGBA = MAX(IB1+1,IGBS) + DO IGAP=IGBA,IGBE+1 + DO JJ=ISTA,IEND + NB1EX = NB1EX + 1 + ENDDO + ISTA = LCON(IGAP)+1 + IEND = LCON(IGAP+1)-1 + IF (IGAP.EQ.IGBE) IEND=MSTA(ISPB2+1)-1 + ENDDO + LBOX2(ISPB2) = LBOX2(ISPB2) - 1 + ENDDO + ENDDO + LBOX2(ISPB1) = LBOX2(ISPB1) + 1 + ENDDO + CALL MOVEUP2(LBOX1,NSPACE,NB,MSTA,LCON) + ENDDO + CALL PUSHCO(LBOX1,NSPACE,NB,IBMA,IBMI,LBOX3,IEND) + ENDDO + RETURN + END Index: Fortran/gfortran/regression/pr59107.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59107.f90 @@ -0,0 +1,11 @@ +! { dg-compile } +! { dg-options "-Wsurprising" } + +! There should be no surprising warnings + +program p + Integer :: nargs + intrinsic :: command_argument_count + nargs = command_argument_count() +end + Index: Fortran/gfortran/regression/pr59440-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59440-1.f90 @@ -0,0 +1,23 @@ +! PR fortran/59440 +! { dg-do compile } +! { dg-options "-O2 -g" } + +module pr59440 + implicit none + type t + integer :: grid = 0 + end type t +contains + subroutine read_nml (nnml, s) + integer, intent(in) :: nnml + type(t), intent(out) :: s + integer :: grid + namelist /N/ grid + call read_nml_type_2 + s%grid = grid + contains + subroutine read_nml_type_2 + read (nnml, nml=N) + end subroutine read_nml_type_2 + end subroutine read_nml +end module pr59440 Index: Fortran/gfortran/regression/pr59440-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59440-2.f90 @@ -0,0 +1,16 @@ +! PR fortran/59440 +! { dg-do compile } +! { dg-options "-O2 -g" } + +subroutine foo (nnml, outv) + integer, intent(in) :: nnml + integer, intent(out) :: outv + integer :: grid + namelist /N/ grid + read (nnml, nml=N) + call bar +contains + subroutine bar + outv = grid + end subroutine bar +end subroutine foo Index: Fortran/gfortran/regression/pr59440-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59440-3.f90 @@ -0,0 +1,16 @@ +! PR fortran/59440 +! { dg-do compile } +! { dg-options "-O2 -g" } + +subroutine foo (nnml, outv) + integer, intent(in) :: nnml + integer, intent(out) :: outv + integer :: grid + call bar + outv = grid +contains + subroutine bar + namelist /N/ grid + read (nnml, nml=N) + end subroutine bar +end subroutine foo Index: Fortran/gfortran/regression/pr59700.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59700.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! PR59700 Test case by Steve Kargl +program foo + + implicit none + + character(len=80) msg + integer, parameter :: fd = 10 + integer i1, i2, i3, i4 + real x1, x2, x3, x4 + complex c1, c2 + logical a + + open(unit=fd, status='scratch') + write(fd, '(A)') '1 2 3.4 q' + + rewind(fd) + msg = 'ok' + read(fd, *, err=10, iomsg=msg) i1, i2, i3, i4 +10 if (msg /= 'Bad integer for item 3 in list input') STOP 1 + rewind(fd) + msg = 'ok' + read(fd, *, err=20, iomsg=msg) x1, x2, x3, x4 +20 if (msg /= 'Bad real number in item 4 of list input') STOP 2 + rewind(fd) + msg = 'ok' + read(fd, *, err=30, iomsg=msg) i1, x2, x1, a +30 if (msg /= 'Bad logical value while reading item 4') STOP 3 + rewind(fd) + read(fd, *, err=31, iomsg=msg) i1, x2, a, x1 +31 if (msg /= 'Bad repeat count in item 3 of list input') STOP 4 + close(fd) + open(unit=fd, status='scratch') + write(fd, '(A)') '(1, 2) (3.4, q)' + rewind(fd) + msg = 'ok' + read(fd, *, err=40, iomsg=msg) c1, c2 +40 if (msg /= 'Bad complex floating point number for item 2') STOP 5 + close(fd) +end program foo Index: Fortran/gfortran/regression/pr59706.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59706.f90 @@ -0,0 +1,10 @@ +! PR middle-end/59706 +! { dg-do compile } + + integer i + do concurrent (i=1:2) + end do +contains + subroutine foo + end +end Index: Fortran/gfortran/regression/pr59910.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr59910.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/59910 +! +program main + implicit none + type bar + integer :: limit(1) + end type + type (bar) :: testsuite + data testsuite / bar(reshape(source=[10],shape=[1])) / +end Index: Fortran/gfortran/regression/pr60126.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr60126.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/60126 - ICE on pointer rank remapping +! Based on testcase by Michel Valin + +subroutine simple_bug_demo + implicit none + interface + function offset_ptr_R4(nelements) result (dest) + implicit none + real, pointer, dimension(:) :: dest + integer, intent(IN) :: nelements + end function offset_ptr_R4 + end interface + + real, dimension(:,:), pointer :: R2D + + R2D(-2:2,-3:3) => offset_ptr_R4(100) +end Index: Fortran/gfortran/regression/pr60144.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr60144.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! fortran PR/60144 +! Contributed by Sergio Losilla +! +program ifelif + if a=b ! { dg-error "Missing ... in IF-expression" } + if (a=b ! { dg-error "Missing ... in statement at or before" } + if (a=b then ! { dg-error "Missing ... in statement at or before" } + if ((a=b) ! { dg-error "Expected a right parenthesis in expression" } + if ((a==b ! { dg-error "Expected a right parenthesis in expression" } + if ((a==b) ! { dg-error "Missing ... in statement at or before" } + if ((a==b) then ! { dg-error "Missing ... in statement at or before" } + if (a=b)) ! { dg-error "Missing ... in statement at or before" } + if .TRUE.) ! { dg-error "Missing ... in IF-expression" } + if (.TRUE.) ! { dg-error "Syntax error in IF-clause after" } + if (.TRUE.) the ! { dg-error "Syntax error in IF-clause after" } + if ((.TRUE.) ! { dg-error "Missing ... in statement at or before" } + else if .FALSE.) ! { dg-error "Missing ... in ELSE IF expression" } + else if (.FALSE. ! { dg-error "Missing ... in ELSE IF expression" } + else if (.FALSE.) ! { dg-error "Missing THEN in ELSE IF statement" } + else if (.FALSE.) the ! { dg-error "doesn't match IF label" } + else (.true.) ! { dg-error "Invalid character.s. in ELSE statement after" } + else a=1 ! { dg-error "Invalid character.s. in ELSE statement after" } + if a=b ! { dg-error "Missing ... in IF-expression" } +! end if +end program Index: Fortran/gfortran/regression/pr61209.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61209.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-O -fbounds-check" } +MODULE array_types + INTERFACE array_data + MODULE PROCEDURE array_data_i1d + END INTERFACE + TYPE array_i1d_type + END TYPE array_i1d_type + TYPE array_i1d_obj + TYPE(array_i1d_type), POINTER :: low + END TYPE array_i1d_obj + TYPE dbcsr_type + TYPE(array_i1d_obj) :: local_rows + LOGICAL :: local_indexing + END TYPE dbcsr_type + TYPE dbcsr_obj + TYPE(dbcsr_type) :: m + END TYPE dbcsr_obj +CONTAINS + FUNCTION array_data_i1d(array) RESULT (DATA) + TYPE(array_i1d_obj), INTENT(IN) :: array + INTEGER, DIMENSION(:), POINTER :: DATA + IF (ASSOCIATED (array%low)) THEN + ENDIF + END FUNCTION array_data_i1d + SUBROUTINE dbcsr_make_index_list (matrix, thread_redist) + TYPE(dbcsr_obj), INTENT(INOUT) :: matrix + LOGICAL, INTENT(IN) :: thread_redist + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: blki + INTEGER, DIMENSION(:), POINTER :: local_rows, td + INTEGER :: blk + nthreads = 0 + IF (nthreads .GT. 0 .AND. thread_redist) THEN + IF (matrix%m%local_indexing) THEN + local_rows => array_data (matrix%m%local_rows) + ENDIF + CALL dbcsr_build_row_index_inplace (thr_c, nthreads) + IF (matrix%m%local_indexing) THEN + DO blk = 1, nblks + IF (td(local_rows(blki(1, blk))) .EQ. ithread) THEN + ENDIF + ENDDO + ENDIF + ENDIF + END SUBROUTINE dbcsr_make_index_list +END MODULE Index: Fortran/gfortran/regression/pr61318.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61318.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +module gbl_message + type :: mytype + integer(kind=4) :: e + end type mytype + type(mytype), parameter :: seve = mytype(1) +end module gbl_message + +module gbl_interfaces + interface + subroutine gagout(message) + character(len=*), intent(in) :: message + end subroutine gagout + end interface +end module gbl_interfaces + +program test + use gbl_message + use gbl_interfaces + call gagout(seve%e,'Some string') ! { dg-error "Type mismatch in argument|More actual than formal" } +end program test Index: Fortran/gfortran/regression/pr61335.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61335.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! { dg-require-visibility "" } +! { dg-additional-options "-fbounds-check" } +MODULE cp_units + + INTEGER, PARAMETER :: default_string_length=80, dp=KIND(0.0D0) + + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_units' + INTEGER, SAVE, PRIVATE :: last_unit_id=0, last_unit_set_id=0 + + INTEGER, PARAMETER, PUBLIC :: cp_unit_max_kinds=8, cp_unit_basic_desc_length=15,& + cp_unit_desc_length=cp_unit_max_kinds*cp_unit_basic_desc_length, cp_ukind_max=9 + +CONTAINS + + FUNCTION cp_to_string(i) RESULT(res) + INTEGER, INTENT(in) :: i + CHARACTER(len=6) :: res + + INTEGER :: iostat + REAL(KIND=dp) :: tmp_r + + IF (i>999999 .OR. i<-99999) THEN + tmp_r=i + WRITE (res,fmt='(es6.1)',iostat=iostat) tmp_r + ELSE + WRITE (res,fmt='(i6)',iostat=iostat) i + END IF + IF (iostat/=0) THEN + STOP 7 + END IF + END FUNCTION cp_to_string + + SUBROUTINE cp_unit_create(string) + CHARACTER(len=*), INTENT(in) :: string + + CHARACTER(len=*), PARAMETER :: routineN = 'cp_unit_create', & + routineP = moduleN//':'//routineN + + CHARACTER(default_string_length) :: desc + CHARACTER(LEN=40) :: formatstr + INTEGER :: i_high, i_low, i_unit, & + len_string, next_power + INTEGER, DIMENSION(cp_unit_max_kinds) :: kind_id, power, unit_id + LOGICAL :: failure + + failure=.FALSE. + unit_id=0 + kind_id=0 + power=0 + i_low=1 + i_high=1 + len_string=LEN(string) + i_unit=0 + next_power=1 + DO WHILE(i_lowlen_string) EXIT + i_unit=i_unit+1 + IF (i_unit>cp_unit_max_kinds) THEN + EXIT + END IF + power(i_unit)=next_power + ! parse op + i_low=i_high + DO WHILE(i_low<=len_string) + IF (string(i_low:i_low)/=' ') EXIT + i_low=i_low+1 + END DO + i_high=i_low + DO WHILE(i_high<=len_string) + IF ( string(i_high:i_high)==' '.OR.string(i_high:i_high)=='^'.OR.& + string(i_high:i_high)=='*'.OR.string(i_high:i_high)=='/') EXIT + i_high=i_high+1 + END DO + IF (i_highlen_string) EXIT + + IF (i_high<=len_string) THEN + IF (string(i_low:i_high)=='^') THEN + i_low=i_high+1 + DO WHILE(i_low<=len_string) + IF (string(i_low:i_low)/=' ') EXIT + i_low=i_low+1 + END DO + i_high=i_low + DO WHILE(i_high<=len_string) + SELECT CASE(string(i_high:i_high)) + CASE('+','-','0','1','2','3','4','5','6','7','8','9') + i_high=i_high+1 + CASE default + EXIT + END SELECT + END DO + IF (i_high<=i_low.OR.i_low>len_string) THEN + write(6,*) "BUG : XXX"//string//"XXX integer expected" + STOP 1 + EXIT + END IF + END IF + ENDIF + END DO + END SUBROUTINE cp_unit_create + +END MODULE cp_units + +USE cp_units +CALL cp_unit_create("fs^-1") +END Index: Fortran/gfortran/regression/pr61454.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61454.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + implicit none + integer, parameter :: arr(2) = [ 1, 3 ] + real, parameter :: arr2(2) = [ 1.5, 2.1 ] + integer, parameter :: j = int(sum(arr)) + integer, parameter :: k = ceiling(sum(arr2)) + real(kind=j) :: x1 + real(kind=k) :: x2 + + print *, j, k + print *, x1, x2 + + end Index: Fortran/gfortran/regression/pr61669.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61669.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + write (*,"(a)") char(12) + CHARACTER*80 A /"A"/ ! { dg-error "Unexpected data declaration statement" } + REAL*4 B ! { dg-error "Unexpected data declaration statement" } + write (*,"(a)") char(12) + DATA B / 0.02 / ! { dg-warning "Obsolescent feature: DATA statement" } + END Index: Fortran/gfortran/regression/pr61765.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61765.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + subroutine sub1(x) + integer, intent(in) :: x + entry sub1_c(x) bind(c) + end subroutine sub1 + + subroutine sub2_c(x) bind(c) + integer, intent(in) :: x + entry sub2(x) + end subroutine sub2_c + + subroutine sub3_c(x) bind(c) + integer, intent(in) :: x + entry sub3_c_c(x) bind(c) + end subroutine sub3_c Index: Fortran/gfortran/regression/pr61775.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61775.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR fortran/61775.f90 +program pi + real, allocatable :: x(:) + integer :: n + n = 10000 + x = [ (i,i=1,n) ] + if (x(n) /= 10000) stop 1 +end program pi Index: Fortran/gfortran/regression/pr61921.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61921.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fipa-pta" } +MODULE min_heap + TYPE heap_t + END TYPE heap_t +CONTAINS + ELEMENTAL FUNCTION get_left_child(n) RESULT (child) + INTEGER, INTENT(IN) :: n + END FUNCTION get_left_child + ELEMENTAL FUNCTION get_value(heap, n) RESULT (value) + TYPE(heap_t), INTENT(IN) :: heap + INTEGER, INTENT(IN) :: n + END FUNCTION get_value +END MODULE min_heap + Index: Fortran/gfortran/regression/pr61960.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr61960.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } + +module data_func_mod + implicit none + integer, parameter :: sp = 4 + type :: data_type + real(kind=sp), pointer, dimension(:, :) :: data => null() + integer :: nr_rows = 0, nr_cols = 0 + end type data_type + +contains + + function get_row(this, i) result(row) + implicit none + type(data_type), intent(in) :: this + integer, intent(in) :: i + real(kind=sp), dimension(this%nr_cols) :: row + row = this%data(:, i) + end function get_row + + subroutine print_matrix(m, i, fmt_str) + implicit none + class(data_type), intent(in) :: m + integer, intent(in) :: i + character(len=20), intent(in) :: fmt_str + write (unit=6, fmt=fmt_str) get_row(m, i) + end subroutine print_matrix + +end module data_func_mod Index: Fortran/gfortran/regression/pr62125.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr62125.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR62125 Nested select type not accepted (rejects valid) +module m + implicit none + type, abstract :: t1 + logical :: l + end type t1 + type, extends(t1), abstract :: t2 + integer :: i + end type t2 + type, extends(t2) :: t3 + real :: x + end type t3 +contains + subroutine s(u) + class(t1), intent(in) :: u + if(.not.u%l) STOP 1 + select type(u); class is(t2) + if(u%i.ne.2) STOP 2 + select type(u); class is(t3) + if(u%x.ne.3.5) STOP 3 + end select + end select + end subroutine s +end module m + +program p + use m + implicit none + type(t3) :: var = t3( l=.true. , i=2 , x=3.5 ) + call s(var) +end program p Index: Fortran/gfortran/regression/pr62135.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr62135.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options -Wsurprising } + + PROGRAM PR62135 + IMPLICIT NONE + CHARACTER*1 :: choice + choice = 'x' + SELECT CASE (choice) + ! This triggered an ICE: an unreachable case clause + ! as the last of a list. + CASE ('2':'7','9':'0') ! { dg-warning "can never be matched" } + WRITE(*,*) "barf" + CASE DEFAULT + CONTINUE + END SELECT + END PROGRAM PR62135 + Index: Fortran/gfortran/regression/pr62695.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr62695.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-O -fipa-pta" } + +MODULE dbcsr_dist_operations + TYPE dbcsr_mp_obj + END TYPE dbcsr_mp_obj + INTERFACE + SUBROUTINE dbcsr_mp_new(mp_env, pgrid, mp_group, mynode, numnodes, myprow,& + mypcol) + IMPORT + TYPE(dbcsr_mp_obj), INTENT(OUT) :: mp_env + INTEGER, DIMENSION(0:, 0:), INTENT(IN) :: pgrid + END SUBROUTINE dbcsr_mp_new + END INTERFACE +CONTAINS + SUBROUTINE dbcsr_mp_make_env (mp_env, mp_group, & + nprocs, pgrid_dims, error) + TYPE(dbcsr_mp_obj), INTENT(OUT) :: mp_env + OPTIONAL :: pgrid_dims + INTEGER :: error_handle, group, mynode, & + numnodes, pcol, prow + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: pgrid + INTEGER, DIMENSION(2) :: coord, myploc, npdims + CALL dbcsr_mp_new (mp_env, pgrid, group, mynode, numnodes,& + myprow=myploc(1), mypcol=myploc(2)) + END SUBROUTINE dbcsr_mp_make_env +END MODULE dbcsr_dist_operations Index: Fortran/gfortran/regression/pr63331.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63331.f90 @@ -0,0 +1,5 @@ +! PR fortran/63331 +! { dg-do compile } +! { dg-options "-fcoarray=single -fcompare-debug" } + +include 'intent_out_7.f90' Index: Fortran/gfortran/regression/pr63514.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63514.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! PR fortran/63514.f90 +program foo + + implicit none + + integer, volatile :: n + + n = 0 + + call bar + call bah + + contains + + subroutine bar + integer k + integer, volatile :: m + block + integer, save :: i + integer, volatile :: j + i = 42 + j = 2 * i + k = i + j + n + end block + end subroutine bar + + pure subroutine bah + integer k + integer, volatile :: m ! { dg-error "cannot be specified in a PURE" } + block + integer, save :: i ! { dg-error "cannot be specified in a PURE" } + integer, volatile :: j ! { dg-error "cannot be specified in a PURE" } + i = 42 ! { dg-error "has no IMPLICIT type" } + j = 2 * i ! { dg-error "has no IMPLICIT type" } + k = i + j + n + end block + m = k * m ! { dg-error "has no IMPLICIT type" } + end subroutine bah + +end program foo Index: Fortran/gfortran/regression/pr63778.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63778.f @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } + + SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + IF( M.LT.0 ) THEN + END IF + CALL ZLARF( 'LEFT', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) + END + SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + CHARACTER SIDE(*) + LOGICAL LSAME + COMPLEX*16 C( LDC, * ), V(*), WORK(*), TAU + IF( LSAME( SIDE, 'L' ) ) THEN + IF( TAU.NE.ZERO ) THEN + CALL ZGEMV( 'CONJUGATE TRANSPOSE', M, N, ONE, C, LDC, V, + $ INCV, ZERO, WORK, 1 ) + END IF + END IF + END + LOGICAL FUNCTION LSAME( CA, CB ) + CHARACTER CA(*), CB(*) + END + SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) + COMPLEX*16 A( LDA, * ), X( * ), Y( * ) + CHARACTER TRANS(*) + LOGICAL LSAME + IF( LSAME( TRANS, 'N' ) )THEN + IF( INCY.EQ.1 )THEN + IF( X( JX ).NE.ZERO )THEN + Y( I ) = Y( I ) + TEMP*A( I, J ) + END IF + END IF + END IF + END + SUBROUTINE ZSCAL(N,ZA,ZX,INCX) + COMPLEX*16 ZA,ZX(1) + IF( N.LE.0 .OR. INCX.LE.0 )RETURN + 20 DO 30 I = 1,N + ZX(I) = ZA*ZX(I) + 30 CONTINUE + END Index: Fortran/gfortran/regression/pr63797.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63797.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! PR63797 - Bogus ambiguous reference to 'sqrt' + +module mod1 + implicit none + real, parameter :: z = sqrt (0.0) + real :: w = sqrt (1.0) + interface + pure real function sqrt_ifc (x) + real, intent(in) :: x + end function sqrt_ifc + end interface +contains + pure function myroot () result (f) + procedure(sqrt_ifc), pointer :: f + intrinsic :: sqrt + f => sqrt + end function myroot +end module mod1 + +module mod2 + implicit none + type t + real :: a = 0. + end type + interface sqrt + module procedure sqrt + end interface +contains + elemental function sqrt (a) + type(t), intent(in) :: a + type(t) :: sqrt + sqrt% a = a% a + end function sqrt +end module mod2 + +module mod3 + implicit none + abstract interface + function real_func (x) + real :: real_func + real, intent (in) :: x + end function real_func + end interface + intrinsic :: sqrt + procedure(real_func), pointer :: real_root => sqrt +end module mod3 + +program test + use mod1 + use mod2 + use mod3 + implicit none + type(t) :: x, y + procedure(sqrt_ifc), pointer :: root + root => myroot () + y = sqrt (x) + y% a = sqrt (x% a) + z - w + root (x% a) + y% a = real_root (x% a) +end program test Index: Fortran/gfortran/regression/pr63821.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63821.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O3" } +SUBROUTINE calculates_green_opt() + INTEGER, PARAMETER :: dp=8 + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: green, green1 + ALLOCATE(green(-nrec:nrec),stat=i_all) + DO ikern=1,nrec + green(-ikern)=gleft+gright + IF (ABS(green(ikern)) <= 1.e-20_dp) THEN + nrec=ikern + EXIT + END IF + END DO + ALLOCATE(green1(-nrec:nrec),stat=i_all) + CALL scf_recursion(nrec,green(-nrec),green1(-nrec)) +END SUBROUTINE calculates_green_opt + Index: Fortran/gfortran/regression/pr63883.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr63883.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-ffast-math" } + SUBROUTINE influence_factor ( gftype, error ) + INTEGER, PARAMETER :: dp=8 + INTEGER :: k,n,lb(3),ub(3),dim,pt + COMPLEX(KIND=dp) :: b_m, exp_m, sum_m + DO k = 0, n-2 + DO pt = lb (dim), ub (dim) + sum_m = CMPLX ( 0.0_dp, 0.0_dp,KIND=dp) + b_m = exp_m ** ( n - 1 ) / sum_m + END DO + END DO + END SUBROUTINE influence_factor Index: Fortran/gfortran/regression/pr64107.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64107.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/64107 +! Code contribute by fxcoudert at gcc dot gnu dot org +! Appears to be fixed by patch for PR fortran/83633 +module m1 + +contains + pure integer function foo() + foo = 2 + end function +end module + +subroutine test + use m1 + integer :: x1(foo()) +end subroutine + +module m + use m1 + integer :: x2(foo()) ! { dg-error "array with nonconstant bounds" } +contains + subroutine sub + integer :: x3(foo()) + end subroutine +end module + +program p + use m1 + integer :: x4(foo()) ! { dg-error "array with nonconstant bounds" } +end program Index: Fortran/gfortran/regression/pr64124.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64124.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/64124.f90 + character(len=kind(1)) x + integer(len(x)) y + end Index: Fortran/gfortran/regression/pr64230.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64230.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +Module m + Implicit None + Type, Public :: t1 + Integer, Allocatable :: i(:) + End Type + Type, Public :: t2 + Integer, Allocatable :: i(:) + End Type + Type, Public :: t3 + Type (t2) :: t + End Type + Type, Public :: t4 + End Type + Type, Public, Extends (t4) :: t5 + Type (t1) :: t_c1 + End Type + Type, Public, Extends (t4) :: t6 + Type (t5) :: t_c2 + End Type + Type, Public, Extends (t6) :: t7 + Type (t3) :: t_c3 + End Type +End Module +Program main + Use m + Implicit None + Interface + Subroutine s(t) + Use m + Class (t4), Allocatable, Intent (Out) :: t + End Subroutine + End Interface + Class (t4), Allocatable :: t + Call s(t) + Deallocate (t) +End Program +Subroutine s(t) + Use m + Class (t4), Allocatable, Intent (Out) :: t + Allocate (t7 :: t) +End Subroutine Index: Fortran/gfortran/regression/pr64528.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64528.f90 @@ -0,0 +1,20 @@ +! PR fortran/64528 +! { dg-do compile } +! { dg-options "-O -fno-tree-dce -fno-tree-ccp" } + +program pr64528 + interface + subroutine foo(x) + integer, value :: x + end subroutine foo + end interface + integer :: x + x = 10 + call foo(x) + if(x .ne. 10) then + endif +end program pr64528 +subroutine foo(x) + integer, value :: x + x = 11 +end subroutine foo Index: Fortran/gfortran/regression/pr64530.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64530.f90 @@ -0,0 +1,38 @@ +! { dg-do run } + +program bug + ! Bug triggered with at least three elements + integer, parameter :: asize = 3 + + double precision,save :: ave(asize) + double precision,save :: old(asize) + double precision,save :: tmp(asize) + + ave(:) = 10.d0 + old(:) = 3.d0 + tmp(:) = 0.d0 + + call buggy(2.d0,asize,ave,old,tmp) + if (any (tmp(:) .ne. 3.5)) STOP 1 +end + +subroutine buggy(scale_factor, asize, ave, old, tmp) + + implicit none + ! Args + double precision scale_factor + integer asize + double precision ave(asize) + double precision old(asize) + double precision tmp(asize) + + ! Local + integer i + + do i = 1, asize + tmp(i) = ave(i) - old(i) + old(i) = ave(i) + tmp(i) = tmp(i) / scale_factor + end do + +end subroutine buggy Index: Fortran/gfortran/regression/pr64589.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64589.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Just need to check if compiling and linking is possible. +! +! Check that the _vtab linking issue is resolved. +! Contributed by Damian Rouson + +module m +contains + subroutine fmt() + class(*), pointer :: arg + select type (arg) + type is (integer) + end select + end subroutine +end module + +program p + call getSuffix() +contains + subroutine makeString(arg1) + class(*) :: arg1 + select type (arg1) + type is (integer) + end select + end subroutine + subroutine getSuffix() + call makeString(1) + end subroutine +end + Index: Fortran/gfortran/regression/pr64925.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64925.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/64925 +! Original test case provided by Bill Long +! +subroutine foo(nnn, aaa, bbb, ccc, ddd) + implicit none + integer :: nnn, aaa, bbb(nnn) + integer :: i + do i=1,nnn + aaa = aaa + bbb(ccc(i)) + end do + call ddd(aaa) +contains + integer function ccc(i) ! { dg-error "conflicts with DUMMY" } + integer :: i + ccc = i + end function ccc + subroutine ddd(j) ! { dg-error "conflicts with DUMMY" } + integer j + j = j + 1 + end subroutine ddd +end subroutine foo Index: Fortran/gfortran/regression/pr64980.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr64980.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } + + implicit none + + type :: muli_trapezium_t + integer::dim=0 + end type + + type, extends (muli_trapezium_t) :: muli_trapezium_node_class_t + end type + + class(muli_trapezium_node_class_t), pointer :: node + print *,get_d_value_array(node) + +contains + + function get_d_value_array (this) result (subarray) + class(muli_trapezium_t), intent(in) :: this + real, dimension(this%dim) :: subarray + end function + +end Index: Fortran/gfortran/regression/pr65045.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65045.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Contributed by Walt Brainerd +! +real :: i = 9.9 +i:block + if (i>7.7) then ! { dg-error "is not appropriate for an expression" } + exit i + else ! { dg-error "Unexpected ELSE statement" } + i = 2.2 ! { dg-error "is not a variable" } + end if ! { dg-error "Expecting END BLOCK statement" } +end block i ! { dg-error "Expecting END PROGRAM statement" } +print*,i ! { dg-error "not appropriate for an expression" } +end +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/pr65429.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65429.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR fortran/65429 +program foo + + implicit none + + character(*), parameter :: s(*) = [ character(5) :: 'abcde', 'fghij' ] + character(*), parameter :: t(*) = [ character(31) :: ] + character(*), parameter :: u(*) = [ 'qwerty', 'asdfgh', 'zxcvbn'] + character(*), parameter :: v(*) = ['',''] + + if ((size(s) /= 2).or.(len(s)/=5)) STOP 1 + if ((size(t) /= 0).or.(len(t)/=31)) STOP 2 + if ((size(u) /= 3).or.(len(u)/=6)) STOP 3 + if ((size(v) /= 2).or.(len(v)/=0)) STOP 4 + if ((s(1)/='abcde').or.(s(2)/='fghij')) STOP 5 + if ((u(1)/='qwerty').or.(u(2)/='asdfgh').or.(u(3)/='zxcvbn')) STOP 6 + +end program foo Index: Fortran/gfortran/regression/pr65450.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65450.f90 @@ -0,0 +1,35 @@ +! PR tree-optimization/65450 +! { dg-do run } +! { dg-additional-options "-mtune=amdfam10" { target x86_64-*-* i?86-*-* } } + +program pr65450 + integer :: n, m, o, i, k + double precision :: u(500,60,3), h(500,60,3) + double precision :: v(500,60) + u = 0 + h = 0 + o = 1 + m = 2 + n = 3 + do k = 1, 50 + v = foo (u(:,:,m)) + u(2:499,1:60,n) = u(2:499,1:60,o)+16.d0 + h(1:500,2:59,n) = h(1:500,2:59,o)-4.d0*v(1:500,2:59)-32.0d0 + i = o + o = m + m = n + n = i + end do + if (abs (v(17, 23) + h(17, 23, 2) + 768.0d0) > 0.5d0) STOP 1 +contains + function foo(a) + double precision :: a(:,:) + double precision :: foo(size(a,dim=1),size(a,dim=2)) + integer :: i, j + i = size(a,dim=1) + j = size(a,dim=2) + foo(2:i-1,1:j) = a(3:i,1:j)-a(1:i-2,1:j) + foo(1,1:j) = 2*(a(2,1:j)-a(1,1:j)) + foo(i,1:j) = 2*(a(i,1:j)-a(i-1,1:j)) + end function foo +end program pr65450 Index: Fortran/gfortran/regression/pr65453.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65453.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/65453 +! Contributed by Tobias Burnus +procedure() :: foo ! { dg-error "(1)" } + contains + subroutine foo() ! { dg-error "clashes with procedure" } + end +end ! { dg-error "Two main PROGRAMs" } Index: Fortran/gfortran/regression/pr65504.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65504.f90 @@ -0,0 +1,28 @@ +! PR target/65504 +! { dg-do run } + +program pr65504 + implicit none + type :: T + character (len=256) :: a + character (len=256) :: b + end type T + type (T) :: c + type (T) :: d + c = foo ("test") + d = foo ("test") + if (trim(c%b) .ne. "foo") STOP 1 + contains + type (T) function foo (x) result (v) + character(len=*), intent(in) :: x + select case (x) + case ("test") + v%b = 'foo' + case ("bazx") + v%b = 'barx' + case default + print *, "unknown" + stop + end select + end function foo +end program pr65504 Index: Fortran/gfortran/regression/pr65903.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65903.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! +character(20) :: astring + +100 format ("& notblank !") +200 format ("& !") +300 format ("&!") + +write(astring,100) +if (astring.ne."& notblank !") STOP 1 +!print *, astring +write(astring,200) +if (astring.ne."& !") STOP 2 +!print *, astring +write(astring,300) +if (astring.ne."&!") STOP 3 +!print *, astring + +end Index: Fortran/gfortran/regression/pr65996.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr65996.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-dH" } +! PR 65996.f90. before patch compiler aborted on this program. +program foo + implicit none + character(len=16) :: a,b,c + a="XXX" + b="& + &XXX" + c="XXX & + & XXX" + write(0,*) 'a=',a,' b=',b,' c=',c +endprogram foo Index: Fortran/gfortran/regression/pr66107.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66107.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/66107 +subroutine p + integer n + character(*), parameter :: z(1) = [character(len=n) :: 'x'] ! { dg-error "Cannot initialize parameter array at .1. with variable length elements" } +end subroutine Index: Fortran/gfortran/regression/pr66311.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66311.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-additional-options "-fno-range-check -w" } +! +! Check that we can print large constants +! +! "-fno-range-check -w" is used so the testcase compiles even with targets +! that don't support large integer kinds. + +program test + use iso_fortran_env, only : ikinds => integer_kinds + implicit none + + ! Largest integer kind + integer, parameter :: k = ikinds(size(ikinds)) + integer, parameter :: hk = k / 2 + + if (k <= 8) stop + + call check(9000000000000000000_k, "9000000000000000000") + call check(90000000000000000000_k, "90000000000000000000") + call check(int(huge(1_hk), kind=k), "9223372036854775807") + call check(2_k**63, "9223372036854775808") + call check(10000000000000000000_k, "10000000000000000000") + call check(18446744065119617024_k, "18446744065119617024") + call check(2_k**64 - 1, "18446744073709551615") + call check(2_k**64, "18446744073709551616") + call check(20000000000000000000_k, "20000000000000000000") + call check(huge(0_k), "170141183460469231731687303715884105727") + call check(huge(0_k)-1, "170141183460469231731687303715884105726") + + call check(-9000000000000000000_k, "-9000000000000000000") + call check(-90000000000000000000_k, "-90000000000000000000") + call check(-int(huge(1_hk), kind=k), "-9223372036854775807") + call check(-2_k**63, "-9223372036854775808") + call check(-10000000000000000000_k, "-10000000000000000000") + call check(-18446744065119617024_k, "-18446744065119617024") + call check(-(2_k**64 - 1), "-18446744073709551615") + call check(-2_k**64, "-18446744073709551616") + call check(-20000000000000000000_k, "-20000000000000000000") + call check(-huge(0_k), "-170141183460469231731687303715884105727") + call check(-(huge(0_k)-1), "-170141183460469231731687303715884105726") + call check(-huge(0_k)-1, "-170141183460469231731687303715884105728") + + call check(2_k * huge(1_hk), "18446744073709551614") + call check((-2_k) * huge(1_hk), "-18446744073709551614") + +contains + + subroutine check (i, str) + implicit none + integer(kind=k), intent(in), value :: i + character(len=*), intent(in) :: str + + character(len=100) :: buffer + write(buffer,*) i + if (adjustl(buffer) /= adjustl(str)) STOP 1 + end subroutine + +end + Index: Fortran/gfortran/regression/pr66465.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66465.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Tests the fix for PR66465, in which the arguments of the call to +! ASSOCIATED were falsly detected to have different type/kind. +! +! Contributed by Damian Rouson +! + interface + real function HandlerInterface (arg) + real :: arg + end + end interface + + type TextHandlerTestCase + procedure (HandlerInterface), nopass, pointer :: handlerOut=>null() + end type + + type(TextHandlerTestCase) this + + procedure (HandlerInterface), pointer :: procPtr=>null() + + print*, associated(procPtr, this%handlerOut) +end Index: Fortran/gfortran/regression/pr66545_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66545_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR fortran/66545 +! +subroutine p + complex, parameter :: c1 = (c1) ! { dg-error "before its definition" } + complex, parameter :: c2 = c2 ! { dg-error "before its definition" } + complex :: c3 = (c3) ! { dg-error "has not been declared or is a variable" } + complex :: c4 = c4 ! { dg-error "has not been declared or is a variable" } +end subroutine p + +subroutine q + real, parameter :: r1 = (r1) ! { dg-error "before its definition" } + real, parameter :: r2 = r2 ! { dg-error "before its definition" } + real :: r3 = (r3) ! { dg-error "has not been declared or is a variable" } + real :: r4 = r4 ! { dg-error "has not been declared or is a variable" } +end subroutine q Index: Fortran/gfortran/regression/pr66545_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66545_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Wuninitialized" } +! PR fortran/66545 +! +program foo + implicit none + call p1 + call q1 +end program foo + +subroutine p1 + complex :: c5 + complex :: c6 + c5 = (c5) ! { dg-warning "used uninitialized" } + c6 = c6 ! { dg-warning "used uninitialized" } +end subroutine p1 + +subroutine q1 + real :: r5 + real :: r6 + r5 = (r5) ! { dg-warning "used uninitialized" } + r6 = r6 ! { dg-warning "used uninitialized" } +end subroutine q1 Index: Fortran/gfortran/regression/pr66575.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66575.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! Bug 66575 - Endless compilation on missing end interface +program p + procedure(g) :: g ! { dg-error "may not be used as its own interface" } + procedure(g) ! { dg-error "Syntax error in PROCEDURE statement" } +end Index: Fortran/gfortran/regression/pr66725.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66725.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/66725 +! +program foo + + open(unit=1,access = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,action = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,asynchronous = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,blank = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,decimal = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,delim = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,encoding = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,form = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,pad = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,position = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,round = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,sign = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,status = 999) ! { dg-error "must be of type CHARACTER" } + + close(unit=1, status=999) ! { dg-error "must be of type CHARACTER" } + + write (unit=1, asynchronous=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, delim=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, decimal=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, round=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, sign=257) ! { dg-error "must be of type CHARACTER" } + + write (unit=1, blank=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, pad=257) ! { dg-error "must be of type CHARACTER" } + +end program foo Index: Fortran/gfortran/regression/pr66864.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66864.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/66864 +! +program t + implicit none + real(8) x + x = 2.0d0**26.5d0 + if (floor(x) /= 94906265) STOP 1 + if (floor(2.0d0**26.5d0)/= 94906265) STOP 2 + x = 777666555.6d0 + if (floor(x) /= 777666555) STOP 3 + if (floor(777666555.6d0) /= 777666555) STOP 4 + x = 2000111222.6d0 + if (floor(x) /= 2000111222) STOP 5 + if (floor(2000111222.6d0) /= 2000111222) STOP 6 +end program t Index: Fortran/gfortran/regression/pr66979.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr66979.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/66979 +program p + implicit none + integer::i + flush (iostat=i) ! { dg-error "UNIT number missing" } +end program p Index: Fortran/gfortran/regression/pr67140.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67140.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! +! Check that MVBITS is available for the largest integer kind (PR 67140) +! +program test + use iso_fortran_env + integer, parameter :: k = integer_kinds(size(integer_kinds)) + + integer(kind=k) :: i = 6 + call mvbits(7_k,2,2,i,0) + if (i /= 5) STOP 1 +end Index: Fortran/gfortran/regression/pr67170.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67170.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-fre1" } + +module test_module + integer, parameter :: r=10 + integer :: data(r, r), block(r, r, r) + contains +recursive subroutine foo(arg) +integer, intent(in) :: arg +integer :: loop, x(r), y(r) + + where(data(arg, :) /= 0) + x = data(arg, :) + y = l + elsewhere + x = 1 + y = r + end where + +do loop = x(1), y(1) + if(block(arg, 1, loop) <= 0) cycle + block(arg, 1:4, loop) = block(arg, 1:4, i1) + 1 + call foo(arg + 2) + block(arg, 1:4, loop) = block(arg, 1:4, i1) + 10 +end do +end subroutine foo + +end module test_module +end program + +! { dg-final { scan-tree-dump-times "= \\*arg_\[0-9\]+\\(D\\);" 1 "fre1" } } Index: Fortran/gfortran/regression/pr67219.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67219.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 67149 - this used to throw a spurious error. +function foo(bar) + integer(8) :: foo + integer(4), intent(in) :: bar + integer(4), parameter :: huge_4 = huge(0_4) + foo = (huge_4 - int(bar,kind=8)) +end function Index: Fortran/gfortran/regression/pr67460.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67460.f90 @@ -0,0 +1,24 @@ +! Bogus "all warnings being treated as errors" +! { dg-do compile } +! { dg-options "-std=f2003 -Werror" } +MODULE btree_i8_k_sp2d_v + TYPE btree_node + INTEGER id + TYPE(btree_node_p), DIMENSION(:), POINTER :: subtrees + TYPE(btree_node), POINTER :: parent + END TYPE btree_node + TYPE btree_node_p + TYPE(btree_node), POINTER :: node + END TYPE btree_node_p +CONTAINS + RECURSIVE SUBROUTINE btree_verify_node (tree, node, level, nids, lastv,& + count, num_nodes, max_leaf_level, min_leaf_level, printing) + TYPE(btree_node), INTENT(IN) :: node + INTEGER :: branch + IF (ASSOCIATED (node%subtrees(branch)%node)) THEN + IF (node%subtrees(branch)%node%parent%id .NE. node%id) THEN + WRITE(*,*)'foo' + ENDIF + ENDIF + END SUBROUTINE btree_verify_node +END MODULE btree_i8_k_sp2d_v Index: Fortran/gfortran/regression/pr67496.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67496.f90 @@ -0,0 +1,12 @@ +! PR fortran/67496 +! { dg-do compile } + + type :: a + end type a + type :: b + type (a) :: j(1) + end type b + type(a) :: x + type(b) :: y + y = b((/x/)) +end Index: Fortran/gfortran/regression/pr67524.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67524.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +module m + implicit character(8) (a-z) +contains + function f(x) + integer :: x + integer :: f + real :: e + f = x + return + entry e(x) + e = x + end +end module + +program p + use m + if (f(1) /= 1) STOP 1 + if (e(1) /= 1.0) STOP 2 +end Index: Fortran/gfortran/regression/pr67525.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67525.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/67525 +! Code contributed by Gerhard Steinmetz +! +real function f(x) + select type (x) ! { dg-error "shall be polymorphic" } + end select +end function f + +real function g(x) + select type (x=>null()) ! { dg-error "shall be polymorphic" } + end select +end function g + +subroutine a(x) + select type (x) ! { dg-error "shall be polymorphic" } + end select +end subroutine a Index: Fortran/gfortran/regression/pr67526.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67526.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Original code from gerhard dot steinmetz dot fortran at t-online dot de +! PR fortran/67526 +program p + character :: c1 = 'abc'(: ! { dg-error "error in SUBSTRING" } + character :: c2 = 'abc'(3: ! { dg-error "error in SUBSTRING" } + character :: c3 = 'abc'(:1 ! { dg-error "error in SUBSTRING" } + character :: c4 = 'abc'(2:2 ! { dg-error "error in SUBSTRING" } +end Index: Fortran/gfortran/regression/pr67614.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67614.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/67614 +! +program foo + implicit none + integer, pointer :: z + if (null(z)) 10, 20, 30 ! { dg-error "Invalid NULL" } +10 continue +20 continue +30 continue +end program foo Index: Fortran/gfortran/regression/pr67615.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67615.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/67615 +! +program foo + + implicit none + + integer i(2), j + real x + complex z + + j = 2 + if (j) 10, 20, 30 + + x = -1 + if (x) 10, 20, 30 + + z = (1,2) + if (z) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + + i = [1, 2] + if (i) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + + if ( [1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + if ( [1, -1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + if ( [real :: 1, -1] ) 10, 20, 30 ! { dg-error "Arithmetic IF statement" } + +10 stop +20 stop +30 stop + +end program foo Index: Fortran/gfortran/regression/pr67616.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67616.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/67616 +! Original code contributed by Gerhard Steinmetz +program p + type t + end type + type(t) :: y + data y /t()/ + block + type(t) :: x + data x /t()/ ! Prior to patch, this would ICE. + end block +end Index: Fortran/gfortran/regression/pr67802.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67802.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/67802 +! Original code contribute by gerhard.steinmetz.fortran at t-online.de +program p + character(1.) :: c1 = ' ' ! { dg-error "INTEGER expression expected" } + character(1d1) :: c2 = ' ' ! { dg-error "INTEGER expression expected" } + character((0.,1.)) :: c3 = ' ' ! { dg-error "INTEGER expression expected" } + character(.true.) :: c4 = ' ' ! { dg-error "INTEGER expression expected" } +end program p Index: Fortran/gfortran/regression/pr67803.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67803.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/67803 +! Original code submitted by Gerhard Steinmetz +! +! +program p + character(2) :: x(1) + x = '0' // [character :: 1] ! { dg-error "Incompatible typespec for" } + x = '0' // [character :: 1.] ! { dg-error "Incompatible typespec for" } + x = '0' // [character :: 1d1] ! { dg-error "Incompatible typespec for" } + x = '0' // [character :: (0.,1.)] ! { dg-error "Incompatible typespec for" } + x = '0' // [character :: .true.] ! { dg-error "Incompatible typespec for" } +end Index: Fortran/gfortran/regression/pr67804.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67804.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/67804 - ICE on bad type in structure constructor in DATA statement +! Contributed by G.Steinmetz + +program p + type t + character :: c + end type + type u + character, pointer :: c + end type + type(t) :: x0, x1, x2, x3, x4, x5, x6, x7, x8, x9 + type(u) :: y6 + data x0 /t('a')/ ! OK + data x1 /t(1)/ ! { dg-error "Cannot convert" } + data x2 /t(1.)/ ! { dg-error "Cannot convert" } + data x3 /t(1d1)/ ! { dg-error "Cannot convert" } + data x4 /t((0.,1.))/ ! { dg-error "Cannot convert" } + data x5 /t(.true.)/ ! { dg-error "Cannot convert" } + data x6 /t(null())/ ! { dg-error "neither a POINTER nor ALLOCATABLE" } + data x7 /t(['1'])/ ! { dg-error "The rank of the element" } + data x8 /t([1])/ ! { dg-error "Cannot convert" } + data x9 /t(z'0')/ ! { dg-error "Cannot convert" } + data y6 /u(null())/ ! OK +end Index: Fortran/gfortran/regression/pr67805.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67805.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR fortran/67805 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +subroutine p + integer, parameter :: n = 1 + integer, parameter :: m(3) = [1, 2, 3] + character(len=1) s(2) + s = [character((m(1))) :: 'x', 'y'] ! OK. + s = [character(m(1)) :: 'x', 'y'] ! OK. + s = [character(m) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + ! The next line should case an error, but causes an ICE. + s = [character(m(2:3)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + call foo(s) + s = [character('') :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(['']) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.true.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.false.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1d1]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([(0.,1.)]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + call foo(s) +end subroutine p + +subroutine q + print *, '1: ', [character(.true.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '2: ', [character(.false.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '3: ', [character(1.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '4: ', [character(1d1) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '5: ', [character((0.,1.)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '6: ', [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }. +end subroutine q Index: Fortran/gfortran/regression/pr67805_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67805_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/68108 +! Code contributed by Juergen Reuter (juergen.reuter at desy dot de) +! Test fix for regression caused by PR fortran/67805. +module lexers + implicit none + type :: template_t + character(256) :: charset1 + integer :: len1 + end type template_t + +contains + + subroutine match_quoted (tt, s, n) + type(template_t), intent(in) :: tt + character(*), intent(in) :: s + integer, intent(out) :: n + character(tt%len1) :: ch1 + ch1 = tt%charset1 + end subroutine match_quoted + +end module lexers Index: Fortran/gfortran/regression/pr67884.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67884.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/67884 +! Original code contribute by Gerhard Steinmetz +program p + integer i + print *, [(f(i), i=1,3)] + print *, [(g(i), i=1,3)] + contains + function f(n) ! { dg-error "has a deferred type parameter" } + integer :: n + character(:) :: f + character(3) :: c = 'abc' + f = c(n:n) + end + function g(n) result(z) ! { dg-error "has a deferred type parameter" } + integer :: n + character(:) :: z + character(3) :: c = 'abc' + z = c(n:n) + end +end program p Index: Fortran/gfortran/regression/pr67885.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67885.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR fortran/67885 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +program p + block + integer, parameter :: a(2) = [1, 2] + integer :: x(2) + x = a + if (x(1) /= 1) STOP 1 + end block +end Index: Fortran/gfortran/regression/pr67900.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67900.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/67900 +! Original code contributed by Giorgian Borca-Tasciuc +! giorgianb at gmail dot com +! +program main + implicit none + interface f + function f_real(x) + real, bind(c) :: x + real :: f_real + end function f_real + + function f_integer(x) + integer, bind(c) :: x + integer :: f_integer + end function f_integer + end interface f +end program main Index: Fortran/gfortran/regression/pr67939.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67939.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/67939 +! Original code by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +program p + character(100) :: x + data x(998:99) /'ab'/ ! { dg-warning "Unused initialization string" } + call a +end + +subroutine a + character(2) :: x + data x(:-1) /'ab'/ ! { dg-warning "Unused initialization string" } +end subroutine a + +subroutine b + character(8) :: x + data x(3:1) /'abc'/ ! { dg-warning "Unused initialization string" } +end subroutine b + Index: Fortran/gfortran/regression/pr67987.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr67987.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/67987 +! PR fortran/67988 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +subroutine p + character(-8) :: c = ' ' +end subroutine p + +subroutine pp + character(3), parameter :: c = 'abc' + character(3) :: x(1) + x = c(:-2) + print *, len(trim(x(1))) + x = [ c(:-2) ] + print *, len(trim(x(1))) +end subroutine pp + Index: Fortran/gfortran/regression/pr68019.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68019.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Original code from Gerhard Steinmetz +! Gerhard dot Steinmetz for fortran at t-online dot de +! PR fortran/68019 +! +program p + integer :: i + type t + integer :: n + end type + type(t), parameter :: vec(*) = [(t(i), i = 1, 4)] + type(t), parameter :: arr(*) = reshape(vec, [2, 2]) ! { dg-error "Rank mismatch" } +end Index: Fortran/gfortran/regression/pr68053.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68053.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR fortran/68053 +! Original code contributed by Gerhard Steinmetz +! +program p + integer, parameter :: n(3) = [1,2,3] + integer, parameter :: x(1) = 7 + integer, parameter :: z(n(2):*) = x + if (lbound(z,1) /= 2) STOP 1 +end Index: Fortran/gfortran/regression/pr68054.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68054.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/68054 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +!program p + real, protected :: x ! { dg-error "only allowed in specification" } +end Index: Fortran/gfortran/regression/pr68055.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68055.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/68055 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! + integer*3 c ! { dg-error "not supported at" } + real*9 x ! { dg-error "not supported at" } + logical*11 a ! { dg-error "not supported at" } + complex*42 z ! { dg-error "not supported at" } + c = 1 + x = 1 + call foo(a) +end Index: Fortran/gfortran/regression/pr68078.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68078.f90 @@ -0,0 +1,55 @@ +! { dg-do run { target i?86-*-linux* x86_64-*-linux* } } +! { dg-additional-sources set_vm_limit.c } +! +! This test calls set_vm_limit to set an artificially low address space +! limit. set_vm_limit calls setrlimit, which has some portability +! considerations. setrlimit gets errors on arm*linux and aarch64*linux, +! and when the main program calls malloc(), it in turn fails on Darwin. +! The code being tested is portable, calling ALLOCATED() or ASSOCIATED() +! to verify that allocation was successful, so the operating assumption +! is that as long as this test runs on at least one system, we can call +! it good. + +USE :: ISO_C_BINDING !, only: C_INT +IMPLICIT NONE + +INTERFACE + SUBROUTINE set_vm_limit(n) bind(C) + import + integer(C_INT), value, intent(in) :: n + END SUBROUTINE set_vm_limit +END INTERFACE + +TYPE foo + INTEGER, DIMENSION(10000) :: data = 42 +END TYPE +TYPE(foo), POINTER :: foo_ptr +TYPE(foo), ALLOCATABLE :: foo_obj +TYPE(foo), ALLOCATABLE, DIMENSION(:) :: foo_array + +INTEGER istat + +CALL set_vm_limit(1000000) + +DO + ALLOCATE(foo_ptr, stat = istat) + IF (istat .NE. 0) THEN + PRINT *, "foo_ptr allocation failed" + EXIT + ENDIF +ENDDO + +ALLOCATE(foo_obj, stat = istat) +IF (istat .NE. 0) THEN + PRINT *, "foo_obj allocation failed" +ENDIF + +ALLOCATE(foo_array(5), stat = istat) +IF (istat .NE. 0) THEN + PRINT *, "foo_array allocation failed" +ENDIF + +END +! { dg-output " *foo_ptr allocation failed(\n|\r\n|\r)" } +! { dg-output " *foo_obj allocation failed(\n|\r\n|\r)" } +! { dg-output " *foo_array allocation failed(\n|\r\n|\r)" } Index: Fortran/gfortran/regression/pr68146.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68146.f @@ -0,0 +1,16 @@ +C PR middle-end/68146 +C { dg-do compile } +C { dg-options "-O2 -w" } + SUBROUTINE CJYVB(V,Z,V0,CBJ,CDJ,CBY,CYY) + IMPLICIT DOUBLE PRECISION (A,B,G,O-Y) + IMPLICIT COMPLEX*16 (C,Z) + DIMENSION CBJ(0:*),CDJ(0:*),CBY(0:*) + N=INT(V) + CALL GAMMA2(VG,GA) + DO 65 K=1,N + CBY(K)=CYY +65 CONTINUE + CDJ(0)=V0/Z*CBJ(0)-CBJ(1) + DO 70 K=1,N +70 CDJ(K)=-(K+V0)/Z*CBJ(K)+CBJ(K-1) + END Index: Fortran/gfortran/regression/pr68151.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68151.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/68151 +! Original code contribute by Gerhard Steinmetz +! +! +program p + integer :: k = 1 + select case (k) + case (:huge(1._4)) ! { dg-error "Expression in CASE" } + case (:huge(2._8)) ! { dg-error "Expression in CASE" } + case ((1.0,2.0)) ! { dg-error "Expression in CASE" } + end select +end Index: Fortran/gfortran/regression/pr68153.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68153.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/68153 +! Original code contribute by Gerhard Steinmetz +! +! +program foo + integer, parameter :: a(2) = [2, -2] + integer, parameter :: b(2,2) = reshape([1, 2, 3, 4], a) ! { dg-error "negative" } +end program foo Index: Fortran/gfortran/regression/pr68154.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68154.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/68154 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +program p + character(1), parameter :: x1(2) = 'a' + character(*), parameter :: x2(2) = x1 + character(*), parameter :: x3(*) = x1 +end Index: Fortran/gfortran/regression/pr68224.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68224.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/68224 +! Original code contribute by Gerhard Steinmetz +! +! +program p + integer, parameter :: a(null()) = [1, 2] ! { dg-error "scalar INTEGER expression" } + integer, parameter :: b(null():*) = [1, 2] ! { dg-error "scalar INTEGER expression" } + integer, parameter :: c(1:null()) = [1, 2] ! { dg-error "scalar INTEGER expression" } +end program p Index: Fortran/gfortran/regression/pr68227.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68227.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/68227 +! Original code contributed by Gerhard Steinmetz +! +! +program p + + type t + end type + + type t2 + type(t), pointer :: a + end type + + type(t), target :: x + type(t2), pointer :: y(:) + integer :: i + integer :: n = 2 + + allocate (y(n)) + forall (i=1:n) y(i)%a = x + +end program p Index: Fortran/gfortran/regression/pr68251.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68251.f90 @@ -0,0 +1,1048 @@ +! PR middle-end/68251 +! Reduced testcase by Joost VandeVondele + +! { dg-do compile } +! { dg-options "-O3" } + +MODULE hfx_contract_block + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE contract_block(ma_max,mb_max,mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(mb_max*md_max), kbc(mb_max*mc_max), & + kad(ma_max*md_max), kac(ma_max*mc_max), pbd(mb_max*md_max), & + pbc(mb_max*mc_max), pad(ma_max*md_max), pac(ma_max*mc_max), & + prim(ma_max*mb_max*mc_max*md_max), scale + SELECT CASE(ma_max) + CASE(1) + SELECT CASE(mb_max) + CASE(1) + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(2) + CALL block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + END SELECT + END SELECT + END SELECT + SELECT CASE(mb_max) + CASE(1) + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(7) + CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + CALL block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(mb_max) + CASE(1) + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + CASE(1) + CALL block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + SELECT CASE(md_max) + CASE(1) + CALL block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + SELECT CASE(md_max) + CASE(1) + CALL block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + SELECT CASE(mc_max) + CASE(1) + SELECT CASE(md_max) + END SELECT + END SELECT + END SELECT + SELECT CASE(mb_max) + CASE(1) + CALL block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + END SELECT + END SELECT + END SUBROUTINE contract_block + SUBROUTINE block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(1*1), kac(1*1), pbd(1*1), & + pbc(1*1), pad(1*1), pac(1*1), prim(1*1*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_1_1_1 + SUBROUTINE block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(1*2), kac(1*1), pbd(1*2), & + pbc(1*1), pad(1*2), pac(1*1), prim(1*1*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_1_1_2 + SUBROUTINE block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*md_max), kbc(1*11), kad(1*md_max), kac(1*11), & + pbd(1*md_max), pbc(1*11), pad(1*md_max), pac(1*11), & + prim(1*1*11*md_max), scale + DO md = 1,md_max + DO mc = 1,11 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_1_11 + SUBROUTINE block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(1*2), kac(1*1), pbd(2*2), & + pbc(2*1), pad(1*2), pac(1*1), prim(1*2*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_2 + SUBROUTINE block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(1*3), kac(1*1), pbd(2*3), & + pbc(2*1), pad(1*3), pac(1*1), prim(1*2*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_3 + SUBROUTINE block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*4), kbc(2*1), kad(1*4), kac(1*1), pbd(2*4), & + pbc(2*1), pad(1*4), pac(1*1), prim(1*2*1*4), scale + DO md = 1,4 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_4 + SUBROUTINE block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*5), kbc(2*1), kad(1*5), kac(1*1), pbd(2*5), & + pbc(2*1), pad(1*5), pac(1*1), prim(1*2*1*5), scale + DO md = 1,5 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_5 + SUBROUTINE block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*6), kbc(2*1), kad(1*6), kac(1*1), pbd(2*6), & + pbc(2*1), pad(1*6), pac(1*1), prim(1*2*1*6), scale + DO md = 1,6 + DO mc = 1,1 + DO mb = 1,2 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_6 + SUBROUTINE block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*7), kbc(2*1), kad(1*7), kac(1*1), pbd(2*7), & + pbc(2*1), pad(1*7), pac(1*1), prim(1*2*1*7), scale + DO md = 1,7 + DO mc = 1,1 + DO mb = 1,2 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_7 + SUBROUTINE block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*2), kbc(2*2), kad(1*2), kac(1*2), pbd(2*2), & + pbc(2*2), pad(1*2), pac(1*2), prim(1*2*2*2), scale + DO md = 1,2 + DO mc = 1,2 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_2_2 + SUBROUTINE block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*4), kbc(2*2), kad(1*4), kac(1*2), pbd(2*4), & + pbc(2*2), pad(1*4), pac(1*2), prim(1*2*2*4), scale + DO md = 1,4 + DO mc = 1,2 + DO mb = 1,2 + kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_1_2_2_4 + SUBROUTINE block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*4), kad(1*1), kac(1*4), pbd(2*1), & + pbc(2*4), pad(1*1), pac(1*4), prim(1*2*4*1), scale + DO md = 1,1 + DO mc = 1,4 + DO mb = 1,2 + kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_1_2_4_1 + SUBROUTINE block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*6), kad(1*1), kac(1*6), pbd(2*1), & + pbc(2*6), pad(1*1), pac(1*6), prim(1*2*6*1), scale + DO md = 1,1 + DO mc = 1,6 + DO mb = 1,2 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_2_6_1 + SUBROUTINE block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*7), kad(1*1), kac(1*7), pbd(2*1), & + pbc(2*7), pad(1*1), pac(1*7), prim(1*2*7*1), scale + DO md = 1,1 + DO mc = 1,7 + DO mb = 1,2 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_2_7_1 + SUBROUTINE block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(1*1), kac(1*1), pbd(3*1), & + pbc(3*1), pad(1*1), pac(1*1), prim(1*3*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_3_1_1 + SUBROUTINE block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*3), kbc(3*1), kad(1*3), kac(1*1), pbd(3*3), & + pbc(3*1), pad(1*3), pac(1*1), prim(1*3*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,3 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_3_1_3 + SUBROUTINE block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*4), kbc(3*1), kad(1*4), kac(1*1), pbd(3*4), & + pbc(3*1), pad(1*4), pac(1*1), prim(1*3*1*4), scale + DO md = 1,4 + DO mc = 1,1 + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_3_1_4 + SUBROUTINE block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*5), kbc(3*1), kad(1*5), kac(1*1), pbd(3*5), & + pbc(3*1), pad(1*5), pac(1*1), prim(1*3*1*5), scale + DO md = 1,5 + DO mc = 1,1 + DO mb = 1,3 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_3_1_5 + SUBROUTINE block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*6), kbc(3*1), kad(1*6), kac(1*1), pbd(3*6), & + pbc(3*1), pad(1*6), pac(1*1), prim(1*3*1*6), scale + DO md = 1,6 + DO mc = 1,1 + DO mb = 1,3 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_3_1_6 + SUBROUTINE block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(1*md_max), kac(1*1), & + pbd(3*md_max), pbc(3*1), pad(1*md_max), pac(1*1), prim(1*3*1*md_max), & + scale + DO md = 1,md_max + DO mc = 1,1 + DO mb = 1,3 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_3_1 + SUBROUTINE block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(1*1), kac(1*2), pbd(3*1), & + pbc(3*2), pad(1*1), pac(1*2), prim(1*3*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_3_2_1 + SUBROUTINE block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*2), kbc(3*2), kad(1*2), kac(1*2), pbd(3*2), & + pbc(3*2), pad(1*2), pac(1*2), prim(1*3*2*2), scale + DO md = 1,2 + DO mc = 1,2 + DO mb = 1,3 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_3_2_2 + SUBROUTINE block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*3), kbc(3*2), kad(1*3), kac(1*2), pbd(3*3), & + pbc(3*2), pad(1*3), pac(1*2), prim(1*3*2*3), scale + kbc(1:3*2) = 0.0_dp + DO md = 1,3 + DO mc = 1,2 + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_3_2_3 + SUBROUTINE block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*1), kbc(3*3), kad(1*1), kac(1*3), pbd(3*1), & + pbc(3*3), pad(1*1), pac(1*3), prim(1*3*3*1), scale + DO md = 1,1 + DO mc = 1,3 + DO mb = 1,3 + kbd((md-1)*3+mb) = kbd((md-1)*3+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_1_3_3_1 + SUBROUTINE block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*2), kbc(3*3), kad(1*2), kac(1*3), pbd(3*2), & + pbc(3*3), pad(1*2), pac(1*3), prim(1*3*3*2), scale + DO md = 1,2 + DO mc = 1,3 + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_3_3_2 + SUBROUTINE block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*md_max), kbc(3*5), kad(1*md_max), kac(1*5), & + pbd(3*md_max), pbc(3*5), pad(1*md_max), pac(1*5), prim(1*3*5*md_max), & + scale + kbd(1:3*md_max) = 0.0_dp + DO md = 1,md_max + END DO + END SUBROUTINE block_1_3_5 + SUBROUTINE block_1_3_6(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + DO md = 1,md_max + END DO + END SUBROUTINE block_1_3_6 + SUBROUTINE block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(1*1), kac(1*1), pbd(4*1), & + pbc(4*1), pad(1*1), pac(1*1), prim(1*4*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,4 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_4_1_1 + SUBROUTINE block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*2), kbc(4*1), kad(1*2), kac(1*1), pbd(4*2), & + pbc(4*1), pad(1*2), pac(1*1), prim(1*4*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_1_2 + SUBROUTINE block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*3), kbc(4*1), kad(1*3), kac(1*1), pbd(4*3), & + pbc(4*1), pad(1*3), pac(1*1), prim(1*4*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_1_3 + SUBROUTINE block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*1), kbc(4*2), kad(1*1), kac(1*2), pbd(4*1), & + pbc(4*2), pad(1*1), pac(1*2), prim(1*4*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_2_1 + SUBROUTINE block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*2), kbc(4*2), kad(1*2), kac(1*2), pbd(4*2), & + pbc(4*2), pad(1*2), pac(1*2), prim(1*4*2*2), scale + DO md = 1,2 + DO mc = 1,2 + DO mb = 1,4 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_4_2_2 + SUBROUTINE block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*1), kbc(4*3), kad(1*1), kac(1*3), pbd(4*1), & + pbc(4*3), pad(1*1), pac(1*3), prim(1*4*3*1), scale + DO md = 1,1 + DO mc = 1,3 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_3_1 + SUBROUTINE block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*md_max), kbc(4*3), kad(1*md_max), kac(1*3), & + pbd(4*md_max), pbc(4*3), pad(1*md_max), pac(1*3), prim(1*4*3*md_max), & + scale + DO md = 1,md_max + DO mc = 1,3 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_3 + SUBROUTINE block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*1), kbc(4*4), kad(1*1), kac(1*4), pbd(4*1), & + pbc(4*4), pad(1*1), pac(1*4), prim(1*4*4*1), scale + DO md = 1,1 + DO mc = 1,4 + DO mb = 1,4 + kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_4_4_1 + SUBROUTINE block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*md_max), kbc(4*4), kad(1*md_max), kac(1*4), & + pbd(4*md_max), pbc(4*4), pad(1*md_max), pac(1*4), prim(1*4*4*md_max), & + scale + DO md = 1,md_max + DO mc = 1,4 + DO mb = 1,4 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_4_4 + SUBROUTINE block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(5*3), kbc(5*1), kad(1*3), kac(1*1), pbd(5*3), & + pbc(5*1), pad(1*3), pac(1*1), prim(1*5*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,5 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_5_1_3 + SUBROUTINE block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(1*md_max), kac(1*1), & + pbd(5*md_max), pbc(5*1), pad(1*md_max), pac(1*1), prim(1*5*1*md_max), & + scale + DO md = 1,md_max + DO mc = 1,1 + DO mb = 1,5 + kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_5_1 + SUBROUTINE block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(1*1), kac(1*1), pbd(6*1), & + pbc(6*1), pad(1*1), pac(1*1), prim(1*6*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,6 + DO ma = 1,1 + kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_6_1_1 + SUBROUTINE block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(6*2), kbc(6*1), kad(1*2), kac(1*1), pbd(6*2), & + pbc(6*1), pad(1*2), pac(1*1), prim(1*6*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,6 + DO ma = 1,1 + kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_1_6_1_2 + SUBROUTINE block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(6*3), kbc(6*1), kad(1*3), kac(1*1), pbd(6*3), & + pbc(6*1), pad(1*3), pac(1*1), prim(1*6*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,6 + kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_6_1_3 + SUBROUTINE block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(6*1), kbc(6*2), kad(1*1), kac(1*2), pbd(6*1), & + pbc(6*2), pad(1*1), pac(1*2), prim(1*6*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,6 + kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_6_2_1 + SUBROUTINE block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(2*3), kac(2*1), pbd(1*3), & + pbc(1*1), pad(2*3), pac(2*1), prim(2*1*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,2 + kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_2_1_1_3 + SUBROUTINE block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(2*4), kac(2*1), pbd(1*4), & + pbc(1*1), pad(2*4), pac(2*1), prim(2*1*1*4), scale + DO md = 1,4 + DO mc = 1,1 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_1_1_4 + SUBROUTINE block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(2*5), kac(2*1), pbd(1*5), & + pbc(1*1), pad(2*5), pac(2*1), prim(2*1*1*5), scale + DO md = 1,5 + DO mc = 1,1 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_1_1_5 + SUBROUTINE block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(2*6), kac(2*1), pbd(1*6), & + pbc(1*1), pad(2*6), pac(2*1), prim(2*1*1*6), scale + DO md = 1,6 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,2 + kad((md-1)*2+ma) = kad((md-1)*2+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_2_1_1_6 + SUBROUTINE block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(2*1), kac(2*2), pbd(1*1), & + pbc(1*2), pad(2*1), pac(2*2), prim(2*1*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,1 + DO ma = 1,2 + kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_2_1_2_1 + SUBROUTINE block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(2*2), kac(2*2), pbd(1*2), & + pbc(1*2), pad(2*2), pac(2*2), prim(2*1*2*2), scale + DO md = 1,2 + DO mc = 1,2 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_1_2_2 + SUBROUTINE block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*4), kbc(1*2), kad(2*4), kac(2*2), pbd(1*4), & + pbc(1*2), pad(2*4), pac(2*2), prim(2*1*2*4), scale + DO md = 1,4 + DO mc = 1,2 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_1_2_4 + SUBROUTINE block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(2*1), kac(2*1), pbd(2*1), & + pbc(2*1), pad(2*1), pac(2*1), prim(2*2*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_2_1_1 + SUBROUTINE block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(2*1), kac(2*2), pbd(2*1), & + pbc(2*2), pad(2*1), pac(2*2), prim(2*2*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,2 + kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_2_2_2_1 + SUBROUTINE block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(2*1), kac(2*3), pbd(2*1), & + pbc(2*3), pad(2*1), pac(2*3), prim(2*2*3*1), scale + DO md = 1,1 + DO mc = 1,3 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_2_2_3_1 + SUBROUTINE block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(3*md_max), kac(3*1), & + pbd(2*md_max), pbc(2*1), pad(3*md_max), pac(3*1), prim(3*2*1*md_max), & + scale + DO md = 1,md_max + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_3_2_1 + SUBROUTINE block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(3*1), kac(3*1), pbd(5*1), & + pbc(5*1), pad(3*1), pac(3*1), prim(3*5*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,5 + DO ma = 1,3 + kad((md-1)*3+ma) = kad((md-1)*3+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_3_5_1_1 + SUBROUTINE block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(3*md_max), kac(3*1), & + pbd(5*md_max), pbc(5*1), pad(3*md_max), pac(3*1), prim(3*5*1*md_max), & + scale + DO md = 1,md_max + DO mc = 1,1 + DO mb = 1,5 + kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_3_5_1 + SUBROUTINE block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(3*md_max), & + kac(3*mc_max), pbd(6*md_max), pbc(6*mc_max), pad(3*md_max), & + pac(3*mc_max), prim(3*6*mc_max*md_max), scale + kbd(1:6*md_max) = 0.0_dp + END SUBROUTINE block_3_6 + SUBROUTINE block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(3*md_max), & + kac(3*mc_max), pbd(9*md_max), pbc(9*mc_max), pad(3*md_max), & + pac(3*mc_max), prim(3*9*mc_max*md_max), scale + DO md = 1,md_max + DO mc = 1,mc_max + DO mb = 1,9 + DO ma = 1,3 + kac((mc-1)*3+ma) = kac((mc-1)*3+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_3_9 + SUBROUTINE block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(4*2), kac(4*1), pbd(1*2), & + pbc(1*1), pad(4*2), pac(4*1), prim(4*1*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,1 + DO ma = 1,4 + kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_4_1_1_2 + SUBROUTINE block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(4*3), kac(4*1), pbd(1*3), & + pbc(1*1), pad(4*3), pac(4*1), prim(4*1*1*3), scale + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,1 + kbd((md-1)*1+mb) = kbd((md-1)*1+mb) - ks_bd + END DO + END DO + END DO + END SUBROUTINE block_4_1_1_3 + SUBROUTINE block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(4*4), kac(4*1), pbd(1*4), & + pbc(1*1), pad(4*4), pac(4*1), prim(4*1*1*4), scale + DO md = 1,4 + DO mc = 1,1 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_4_1_1_4 + SUBROUTINE block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(4*md_max), kac(4*1), & + pbd(1*md_max), pbc(1*1), pad(4*md_max), pac(4*1), prim(4*1*1*md_max), & + scale + DO md = 1,md_max + DO mc = 1,1 + DO mb = 1,1 + kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_4_1_1 + SUBROUTINE block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(4*md_max), kac(4*4), & + pbd(1*md_max), pbc(1*4), pad(4*md_max), pac(4*4), prim(4*1*4*md_max), & + scale + kbd(1:1*md_max) = 0.0_dp + END SUBROUTINE block_4_1_4 + SUBROUTINE block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(4*2), kac(4*1), pbd(2*2), & + pbc(2*1), pad(4*2), pac(4*1), prim(4*2*1*2), scale + DO md = 1,2 + DO mc = 1,1 + DO mb = 1,2 + DO ma = 1,4 + kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_4_2_1_2 + SUBROUTINE block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(4*md_max), kac(4*2), & + pbd(2*md_max), pbc(2*2), pad(4*md_max), pac(4*2), prim(4*2*2*md_max), & + scale + DO md = 1,md_max + DO mc = 1,2 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_4_2_2 + SUBROUTINE block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(4*1), kac(4*1), pbd(3*1), & + pbc(3*1), pad(4*1), pac(4*1), prim(4*3*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,3 + DO ma = 1,4 + kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_4_3_1_1 + SUBROUTINE block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(4*md_max), & + kac(4*mc_max), pbd(3*md_max), pbc(3*mc_max), pad(4*md_max), & + pac(4*mc_max), prim(4*3*mc_max*md_max), scale + DO md = 1,md_max + DO mc = 1,mc_max + DO mb = 1,3 + kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_4_3 + SUBROUTINE block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(4*1), kac(4*1), pbd(4*1), & + pbc(4*1), pad(4*1), pac(4*1), prim(4*4*1*1), scale + DO md = 1,1 + DO mc = 1,1 + DO mb = 1,4 + DO ma = 1,4 + kad((md-1)*4+ma) = kad((md-1)*4+ma)-tmp*p_bc + END DO + END DO + END DO + END DO + END SUBROUTINE block_4_4_1_1 + SUBROUTINE block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(15*md_max), & + kac(15*mc_max), pbd(15*md_max), pbc(15*mc_max), pad(15*md_max), & + pac(15*mc_max), prim(15*15*mc_max*md_max), scale + DO md = 1,md_max + DO mc = 1,mc_max + DO mb = 1,15 + kbc((mc-1)*15+mb) = kbc((mc-1)*15+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_15_15 +END MODULE hfx_contract_block Index: Fortran/gfortran/regression/pr68283.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68283.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +MODULE neb_utils + IMPLICIT NONE + INTEGER, PARAMETER :: dp=8 + TYPE neb_var_type + REAL(KIND=dp), DIMENSION(:, :), POINTER :: xyz, int, wrk + END TYPE neb_var_type +CONTAINS + SUBROUTINE get_neb_force() + INTEGER :: i + TYPE(neb_var_type), POINTER :: forces + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dtmp1, wrk + dtmp1 = forces%wrk(:,i)-dot_product_band ! { dg-error "Symbol 'dot_product_band' at .1. has no IMPLICIT type" } + END SUBROUTINE get_neb_force +END MODULE neb_utils Index: Fortran/gfortran/regression/pr68318_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68318_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O0" } +! PR fortran/68318 +! Original code submitted by Gerhard Steinmetz +! +! +module m + implicit none +contains + subroutine s1 + entry e ! { dg-error "(2)" } + end + subroutine s2 + entry e ! { dg-error "is already defined" } + end +end module +! { dg-prune-output "Duplicate ENTRY attribute specified" } + Index: Fortran/gfortran/regression/pr68318_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68318_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/68318 +! Original code submitted by Gerhard Steinmetz +! +! +module m1 + implicit none +contains + subroutine s1 + entry e + end +end module + +module m2 + use m1 ! { dg-error "(2)" } + implicit none +contains + subroutine s2 + entry e ! { dg-error "is already defined" } + end +end module +! { dg-prune-output "Cannot change attribute" } Index: Fortran/gfortran/regression/pr68319.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68319.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/68319 +! +subroutine foo + + interface + + real function bar(i) + f(i) = 2 * i ! { dg-error "cannot appear within" } + end function bar + + real function bah(j) + entry boo(j) ! { dg-error "cannot appear within" } + end function bah + + real function fu(j) + data i /1/ ! { dg-error "cannot appear within" } + end function fu + + real function fee(j) +10 format('(A)') ! { dg-error "cannot appear within" } + end function fee + + end interface + +end subroutine foo Index: Fortran/gfortran/regression/pr68379-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68379-1.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O3" } +MODULE qs_efield_berry + TYPE cp_error_type + END TYPE + INTEGER, PARAMETER :: dp=8 + TYPE qs_energy_type + REAL(KIND=dp), POINTER :: efield + END TYPE + TYPE qs_environment_type + END TYPE + INTERFACE + SUBROUTINE foo(qs_env,energy,error) + IMPORT + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(cp_error_type) :: error + TYPE(qs_energy_type), POINTER :: energy + END SUBROUTINE + END INTERFACE +CONTAINS + SUBROUTINE qs_efield_mo_derivatives() + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(cp_error_type) :: error + COMPLEX(dp) :: zi(3), zphase(3) + REAL(dp) :: ci(3) + TYPE(qs_energy_type), POINTER :: energy + CALL foo(qs_env, energy, error) + zi = zi * zphase + ci = AIMAG(LOG(zi)) + DO idir=1,3 + ener_field=ener_field+ci(idir)*fieldfac(idir) + END DO + energy%efield=ener_field + END SUBROUTINE qs_efield_mo_derivatives +END MODULE qs_efield_berry Index: Fortran/gfortran/regression/pr68379-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68379-2.f @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast" } +! { dg-additional-options "-mavx" { target x86_64-*-* i?86-*-* } } + + SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) + IMPLICIT REAL(4) (A-H, O-Z) + DIMENSION CC(IDO,4,L1), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) + 102 DO 104 K=1,L1 + DO 103 I=2,IDO,2 + TI1 = CC(I,1,K)-CC(I,3,K) + TI2 = CC(I,1,K)+CC(I,3,K) + TI3 = CC(I,2,K)+CC(I,4,K) + TR2 = CC(I-1,1,K)+CC(I-1,3,K) + TI4 = CC(I-1,2,K)-CC(I-1,4,K) + TR3 = CC(I-1,2,K)+CC(I-1,4,K) + CH(I-1,K,1) = TR2+TR3 + CH(I,K,1) = TI2+TI3 + CI4 = TI1-TI4 + CH(I-1,K,4) = CI4 + CH(I,K,4) = CI4 + 103 CONTINUE + 104 CONTINUE + RETURN + END Index: Fortran/gfortran/regression/pr68544.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68544.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PF fortran/68544 +program p + real x + type t + end type + x = f(t) ! { dg-error "used as an actual argument" } +end +subroutine b + type t + end type + print *, shape(t) ! { dg-error "used as an actual argument" } +end Index: Fortran/gfortran/regression/pr68566.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68566.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +program p + character(len=20) s1, s2 + integer, allocatable :: n(:) + n = [2,1] + s1 = '1 5 2 6 3 0 4 0' + write(s2,'(8(I0,1x))') reshape ([1,2,3,4,5,6], [2,4], [0,0], [2,1]) + if (trim(s1) /= trim(s2)) STOP 1 + write(s2,'(8(I0,1x))') reshape ([1,2,3,4,5,6], [2,4], [0,0], n) + if (trim(s1) /= trim(s2)) STOP 2 + write(s2,'(8(I0,1x))') reshape ([1,2,3,4,5,6], [2,4], [0,0], [n]) + if (trim(s1) /= trim(s2)) STOP 3 +end Index: Fortran/gfortran/regression/pr68592.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68592.f @@ -0,0 +1,20 @@ +! PR tree-optimization/68592 +! { dg-do compile } +! { dg-require-profiling "-fprofile-generate" } +! { dg-options "-Ofast -fprofile-generate" } +! { dg-additional-options "-mavx" { target x86_64-*-* i?86-*-* } } + PARAMETER (MXCPGA=320,ZERO=0.0) + DIMENSION CPNORM(MXCPGA),CDNORM(MXCPGA), + * CFNORM(MXCPGA) + KTYPIL = KTYPI() + DO 84 K=1,NOGTF + LMP=LMP+1 + CFNORM(LMP)=ZERO + IF (KTYPIL.EQ.1) LMP=CMPILMP + IF (KTYPIL.EQ.2) CPNORM(LMP)=CMPILMP + IF (KTYPIL.EQ.3) CDNORM(LMP)=CMPILMP + IF (KTYPIL.EQ.4) LMP=CMPILMP + IF (KTYPIL.EQ.6) LMP=CMPILMP + 84 CONTINUE + CALL MMPNOR(CPNORM,CDNORM,CFNORM) + END Index: Fortran/gfortran/regression/pr68627.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68627.f @@ -0,0 +1,18 @@ +! { dg-do compile { target { { i?86-*-* x86_64-*-* } && { ! { ia32 } } } } } + +! { dg-options "-Ofast -fno-tree-slp-vectorize -mavx512f -ffixed-xmm1 -ffixed-xmm2 -ffixed-xmm3 -ffixed-xmm4 -ffixed-xmm5 -ffixed-xmm6 -ffixed-xmm7 -ffixed-xmm8 -ffixed-xmm9 -ffixed-xmm10 -ffixed-xmm11 -ffixed-xmm12 -ffixed-xmm13 -ffixed-xmm14 -ffixed-xmm15" } + + IMPLICIT REAL*8(A-H,O-Z) + ALLOCATABLE DD1(:), DD2(:), WY(:,:) + ALLOCATE( DD1(MAX), DD2(MAX), WY(MAX,MAX)) + DO J = J1,J2 + DO I = I1, I2 + DD1(I) = D1 * (WY(I-2,J) - WY(I+2,J) + + > (WY(I+1,J) - WY(I-1,J))) + END DO + DO I = I1, INT(D2 * D3(I)) + END DO + END DO + END + +! { dg-final { scan-assembler-not "vbroadcastsd\[ \\t\]+%xmm\[0-9\]+, %ymm\[0-9\]+" } } Index: Fortran/gfortran/regression/pr68817.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68817.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } + SUBROUTINE TEST(A,B,C) + DIMENSION B(3),C(1000,10) + DO I = 1,3 + I3=I*3 + B(1) = B(1) + (C(K,I3+1)-A) + B(3) = B(3) + (C(K,I3+3)-A) + ENDDO + END + Index: Fortran/gfortran/regression/pr68864.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr68864.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! Contributed by Hossein Talebi +! +! +Module part_base2_class + + implicit none + + type :: ty_moc1 + integer l + end type ty_moc1 + integer,parameter :: MAX_NUM_ELEMENT_TYPE=32 + + type :: ty_element_index2 + + class(ty_moc1),allocatable :: element + class(ty_moc1),allocatable :: element_th(:) + + endtype ty_element_index2 + + type :: ty_part_base2 + type(ty_element_index2)::element_index(MAX_NUM_ELEMENT_TYPE) + end type ty_part_base2 + + class(ty_part_base2),allocatable :: part_tmp_obj + +End Module part_base2_class + + use part_base2_class + allocate (part_tmp_obj) + allocate (part_tmp_obj%element_index(1)%element, source = ty_moc1(1)) + allocate (part_tmp_obj%element_index(1)%element_th(1), source = ty_moc1(99)) + allocate (part_tmp_obj%element_index(32)%element_th(1), source = ty_moc1(999)) + + do i = 1, MAX_NUM_ELEMENT_TYPE + if (allocated (part_tmp_obj%element_index(i)%element_th)) then + print *, i, part_tmp_obj%element_index(i)%element_th(1)%l + end if + end do + deallocate (part_tmp_obj) + +end Index: Fortran/gfortran/regression/pr69055.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69055.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fsanitize=float-cast-overflow" } + +subroutine pr69055 + implicit none + integer :: n + real(8) :: b + b = huge(1.0D0) + n = b +end subroutine pr69055 Index: Fortran/gfortran/regression/pr69155.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69155.f90 @@ -0,0 +1,15 @@ +! PR tree-optimization/69155 +! { dg-do compile } + +function pr69155 (a, b) + complex(kind=8), value :: a, b + if (dimag (a) .lt. 10) then + 1 continue + if (dble (a) .lt. 10) then + b = b - 1 / a + a = a + 1 + goto 1 + end if + end if + pr69155 = a + b +end Index: Fortran/gfortran/regression/pr69395.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69395.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +program p +real, dimension(1,2,1,2,1,2,1,2), codimension[1,2,1,2,1,2,*] :: y +real, dimension(1,2,1,2,1,2,1,2), codimension[1,2,1,2,1,2,1,*] :: z ! { dg-error "allowed dimensions" } +end Index: Fortran/gfortran/regression/pr69398.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69398.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/69398 +! Contributed by Gerhard Steinmetz +program p + type t + end type + class(t), allocatable :: z(:) + target :: z(:) ! { dg-error "Duplicate DIMENSION attribute" } + allocate (z(2)) +end + Index: Fortran/gfortran/regression/pr69419.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69419.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/69419 - ICE on invalid coarray in common + +blockdata b + real x ! { dg-error "must be in COMMON" } + common /c/ x[*] ! { dg-error "cannot be a coarray" } + data x /1.0/ +end Index: Fortran/gfortran/regression/pr69455_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69455_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +program foo + block + use, intrinsic :: iso_c_binding, only: wp => c_float, ik => c_int + if (ik /= 4) stop 1 + if (wp /= 4) stop 2 + end block + block + use, intrinsic :: iso_c_binding, only: wp => c_double, ik => c_int64_t + if (ik /= 8) stop 3 + if (wp /= 8) stop 4 + end block +end program foo + Index: Fortran/gfortran/regression/pr69455_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69455_2.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +program foo + block + use, intrinsic :: ISO_FORTRAN_ENV, only: wp => REAL32, ik => INT32 + if (ik /= 4) stop 1 + if (wp /= 4) stop 2 + end block + block + use, intrinsic :: ISO_FORTRAN_ENV, only: wp => REAL64, ik => INT64 + if (ik /= 8) stop 3 + if (wp /= 8) stop 4 + end block +end program foo Index: Fortran/gfortran/regression/pr69497.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69497.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR69497 +program p + block + do + end block ! { dg-error "Expecting END DO statement" } +end ! { dg-error "END DO statement expected" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/pr69499.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69499.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/69499 +! Contributed by Gerhard Steinmetz. +module m + class(*) :: z ! { dg-error "must be dummy, allocatable or pointer" } + select type (x => z) ! { dg-error "cannot appear in this scope" } +end Index: Fortran/gfortran/regression/pr69514_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69514_1.f90 @@ -0,0 +1,5 @@ +! { dg-do run } +program foo + real, parameter :: x(3) = 2.0 * [real :: 1, 2, 3 ] + if (any(x /= [2., 4., 6.])) STOP 1 +end program foo Index: Fortran/gfortran/regression/pr69514_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69514_2.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +program p + implicit none + + real , parameter :: arr(3) = [ real :: 2, 2.5, (1.5, 2.5) ] + real , parameter :: ari(3) = [ integer :: 2, 2.5, (1.5, 2.5) ] + real , parameter :: arc(3) = [ complex :: 2, 2.5, (1.5, 2.5) ] + integer, parameter :: air(3) = [ real :: 2, 2.5, (1.5, 2.5) ] + integer, parameter :: aii(3) = [ integer :: 2, 2.5, (1.5, 2.5) ] + integer, parameter :: aic(3) = [ complex :: 2, 2.5, (1.5, 2.5) ] + complex, parameter :: acr(3) = [ real :: 2, 2.5, (1.5, 2.5) ] + complex, parameter :: aci(3) = [ integer :: 2, 2.5, (1.5, 2.5) ] + complex, parameter :: acc(3) = [ complex :: 2, 2.5, (1.5, 2.5) ] + + real , parameter :: mrr(3) = 4.5 * [ real :: 2, 2.5, (3.5, 4.0) ] + real , parameter :: mri(3) = 4.5 * [ integer :: 2, 2.5, (3.5, 4.0) ] + real , parameter :: mrc(3) = 4.5 * [ complex :: 2, 2.5, (3.5, 4.0) ] + integer, parameter :: mir(3) = 4 * [ real :: 2, 2.5, (3.5, 4.0) ] + integer, parameter :: mii(3) = 4 * [ integer :: 2, 2.5, (3.5, 4.0) ] + integer, parameter :: mic(3) = 4 * [ complex :: 2, 2.5, (3.5, 4.0) ] + complex, parameter :: mcr(3) = (4.5, 5.5) * [ real :: 2, 2.5, (3.5, 4.0) ] + complex, parameter :: mci(3) = (4.5, 5.5) * [ integer :: 2, 2.5, (3.5, 4.0) ] + complex, parameter :: mcc(3) = (4.5, 5.5) * [ complex :: 2, 2.5, (3.5, 4.0) ] + + if (any(arr /= [2.00, 2.50, 1.50])) STOP 1 + if (any(ari /= [2.00, 2.00, 1.00])) STOP 2 + if (any(arc /= [2.00, 2.50, 1.50])) STOP 3 + + if (any(air /= [2, 2, 1])) STOP 4 + if (any(aii /= [2, 2, 1])) STOP 5 + if (any(aic /= [2, 2, 1])) STOP 6 + + if (any(acr /= [(2.00, 0.00), (2.50, 0.00), (1.50, 0.00)])) STOP 7 + if (any(aci /= [(2.00, 0.00), (2.00, 0.00), (1.00, 0.00)])) STOP 8 + if (any(acc /= [(2.00, 0.00), (2.50, 0.00), (1.50, 2.50)])) STOP 9 + + if (any(mrr /= [9.00, 11.25, 15.75])) STOP 10 + if (any(mri /= [9.00, 9.00, 13.50])) STOP 11 + if (any(mrc /= [9.00, 11.25, 15.75])) STOP 12 + + if (any(mir /= [8, 10, 14])) STOP 13 + if (any(mii /= [8, 8, 12])) STOP 14 + if (any(mic /= [8, 10, 14])) STOP 15 + + if (any(mcr /= [(9.00, 11.00), (11.25, 13.75), (15.75, 19.25)])) STOP 16 + if (any(mci /= [(9.00, 11.00), ( 9.00, 11.00), (13.50, 16.50)])) STOP 17 + if (any(mcc /= [(9.00, 11.00), (11.25, 13.75), (-6.25, 37.25)])) STOP 18 + +end program p Index: Fortran/gfortran/regression/pr69554-1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69554-1.F90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-fdiagnostics-show-caret" } +! { dg-allow-blank-lines-in-output 1 } + +program main + goto 1000 +1000 continue ! first instance + a = a + a = a + a = a +1000 continue ! second instance +end + +#if 0 +! { dg-locus "4" "" { target *-*-* } "7" } +! { dg-begin-multiline-output "" } + + 1000 continue ! first instance + 1 +! { dg-end-multiline-output "" } +! { dg-locus "4" "" { target *-*-* } "11" } +! { dg-begin-multiline-output "" } + + 1000 continue ! second instance + 2 +Error: Duplicate statement label 1000 at (1) and (2) +! { dg-end-multiline-output "" } +#endif Index: Fortran/gfortran/regression/pr69554-2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69554-2.F90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdiagnostics-show-caret" } +! { dg-allow-blank-lines-in-output 1 } + +program main + goto 1000 +1000 continue ! first instance +1000 continue ! second instance +end + +#if 0 +! { dg-locus "4" "" { target *-*-* } "7" } +! { dg-begin-multiline-output "" } + + 1000 continue ! first instance + 1 + 1000 continue ! second instance + 2 +Error: Duplicate statement label 1000 at (1) and (2) +! { dg-end-multiline-output "" } +#endif Index: Fortran/gfortran/regression/pr69603.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69603.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fimplicit-none" } +! PR fortran/69603 - segfault with -fimplicit-none and proc_ptr_comp_24.f90 +! Based on reduced testcase by Dominique d'Humieres +PROGRAM prog + implicit none + TYPE object + PROCEDURE(), POINTER, NOPASS :: f + END TYPE object + TYPE (object) :: o1 + CALL set_func(o1%f) +CONTAINS + SUBROUTINE set_func(f) + PROCEDURE(), POINTER :: f + END SUBROUTINE set_func +END PROGRAM prog Index: Fortran/gfortran/regression/pr69739.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69739.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR69739 in which the statement +! R = operate(A, X) caused an ICE. +! +! Contributed by John +! +module test + + implicit none + type, public :: sometype + real :: a = 0. + end type +contains + + function dosomething(A) result(r) + type(sometype), intent(IN) :: A(:,:,:) + integer :: N + real, allocatable :: R(:), X(:) + + N = PRODUCT(UBOUND(A)) + allocate (R(N),X(N)) + X = [(real(N), N = 1, size(X, 1))] + R = operate(A, X) + end function + + function operate(A, X) + type(sometype), intent(IN) :: A(:,:,:) + real, intent(IN) :: X(:) + real :: operate(1:PRODUCT(UBOUND(A))) + + operate = x + end function +end module test + + use test + type(sometype) :: a(2, 2, 2) + if (any(int (dosomething(a)) .ne. [1,2,3,4,5,6])) STOP 1 +end Index: Fortran/gfortran/regression/pr69867.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69867.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +program p + type t + character(1) :: c(1)=[1] ! { dg-error "convert INTEGER.4. to CHARACTER.1." } + end type +end Index: Fortran/gfortran/regression/pr69955.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69955.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +program p + implicit none + + type :: t1 + integer, allocatable :: t(:) + end type t1 + + type :: t2 + type(t1), allocatable :: x1(:) + end type t2 + + type(t2) :: var(10) + + integer :: i + + do i= 1, 10 + allocate(var(i)%x1(100)) + allocate(var(i)%x1(1)%t(100)) + enddo + + open(unit = 37, file = "/dev/null", status = "old") + + call s(1) + + close(unit = 37) + + do i=1,10 + deallocate(var(i)%x1) + enddo + +contains + + subroutine s(counter) + implicit none + integer, intent(in) :: counter + integer :: i, j, n + + do j=1, counter + n = size( [ ( var(i)%x1 , i = 1, size(var) ) ] ) + write(unit = 37, fmt = '(i5)') n + enddo + end subroutine + +end program p +! { dg-final { scan-tree-dump-times "__builtin_malloc" 4 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } } Index: Fortran/gfortran/regression/pr69962.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69962.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +program p + integer :: n = 1 + character(3), parameter :: x(2) = ['abc', 'xyz'] + character(2), parameter :: y(2) = [x(2)(2:3), x(n)(1:2)] ! { dg-error "CHARACTER length must be a constant" } +end Index: Fortran/gfortran/regression/pr69987.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr69987.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-O3 -fprefetch-loop-arrays -w" } + +MODULE cp_lbfgs + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & + csave, lsave, isave, dsave) + REAL(KIND=dp) :: x(n), l(n), u(n) + REAL(KIND=dp) :: f, g(n), factr, pgtol, ws(n, m), wy(n, m), sy(m, m), & + ss(m, m), wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), z(n), r(n), d(n), & + t(n), wa(8*m) + CHARACTER(len=60) :: task + IF (task == 'START') THEN + IF (task(1:5) == 'FG_LN') GOTO 666 + ENDIF +222 CONTINUE + DO 40 i = 1, n + d(i) = z(i) - x(i) +40 ENDDO +666 CONTINUE + IF (info /= 0 .OR. iback >= 20) THEN + CALL dcopy(n,r,1,g,1) + ENDIF + GOTO 222 + END SUBROUTINE mainlb +END MODULE cp_lbfgs + Index: Fortran/gfortran/regression/pr70006.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70006.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +program test + print 1, 'string 1' ! { dg-error "FORMAT label 1" " " } + print 1, 'string 2' ! { dg-error "FORMAT label 1" " " } +!1 format(a) + goto 2 ! { dg-error "Label 2 referenced" " " } + goto 2 ! { dg-error "Label 2 referenced" " " } +!2 continue +end program Index: Fortran/gfortran/regression/pr70040.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70040.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR 70040 - used to cause an ICE. +! Test case by Martin Reinecke +program bugrep + implicit none + type :: string + character (len=:), allocatable :: s + end type + + integer l + type(string), allocatable, dimension(:) :: foo + character(len=:),allocatable ::tmp + allocate(foo(20)) + do l= 1, 20 + tmp = foo(5)%s + foo(5)%s = foo(l)%s + foo(l)%s = tmp + enddo +end program Index: Fortran/gfortran/regression/pr70070.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70070.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/70070 - ICE on initializing character data beyond min/max bound + +program p + character(1) :: a, b + data (a(i:i),i=0,0) /1*'#'/ ! { dg-error "Substring start index" } + data (b(i:i),i=2,3) /2*'#'/ ! { dg-error "Substring end index" } +end Index: Fortran/gfortran/regression/pr70330.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70330.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-additional-options "-Wall -Wextra -Wno-unused-dummy-argument" } +! PR fortran/70330 - this used to cause an ICE. +! Test case by Vladimir Fuka +function f(o) ! { dg-warning "Return value of function" } + optional o +end function f Index: Fortran/gfortran/regression/pr70409.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70409.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR fortran/70409 +! Contriubted by Harald Anlauf +program foo + integer, parameter :: huge_1 = huge(0_1) + character( huge_1 ), parameter :: x = 'abc' + character( huge(0_1) ), parameter :: y = 'abc' + character( huge(0_1)+0 ), parameter :: z = 'abcdef' + character( huge(0_1) ) :: a = 'abc' + integer, parameter :: huge_2 = huge(0_2) + character( huge_2 ), parameter :: u = 'abc' + character( huge(0_2) ), parameter :: v = 'abc' + character(int(huge(0_2),4)), parameter :: w = 'abcdef' + character( huge(0_2) ) :: b = 'abc' + if (len(x) /= huge_1) stop 1 + if (len(y) /= huge_1) stop 2 + if (len(z) /= huge_1) stop 3 + if (len(a) /= huge_1) stop 4 + if (len(u) /= huge_2) stop 5 + if (len(v) /= huge_2) stop 6 + if (len(w) /= huge_2) stop 7 + if (len(b) /= huge_2) stop 8 +end program foo Index: Fortran/gfortran/regression/pr70673.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70673.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Test the fix for PR70673 +! +! Contributed by David Kinniburgh +! +module m +contains + subroutine s(inp) + character(*), intent(in) :: inp + character(:), allocatable :: a + a = inp + a = a ! This used to ICE too + if ((len (a) .ne. 5) .or. (a .ne. "hello")) STOP 1 + a = a(2:3) ! Make sure that temporary creation is not broken. + if ((len (a) .ne. 2) .or. (a .ne. "el")) STOP 2 + deallocate (a) + end subroutine s +end module m + + use m + call s("hello") +end Index: Fortran/gfortran/regression/pr70673_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70673_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! Test the fix for PR70673 +! +! Contributed by David Kinniburgh +! +module m +contains + subroutine s(inp) + character(*), intent(in) :: inp + character(:), allocatable :: a + a = a ! This used to ICE. + a = inp + a = a ! This used to ICE too + if ((len (a) .ne. 5) .or. (a .ne. "hello")) STOP 1 + a = a(2:3) ! Make sure that temporary creation is not broken. + if ((len (a) .ne. 2) .or. (a .ne. "el")) STOP 2 + deallocate (a) + a = a ! This would ICE too. + end subroutine s +end module m + + use m + call s("hello") +end Index: Fortran/gfortran/regression/pr70754.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70754.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +module m + implicit none + private + save + + integer, parameter, public :: & + ii4 = selected_int_kind(6), & + rr8 = selected_real_kind(13) + + integer (ii4), dimension(40,40,199), public :: xyz + public :: foo +contains + subroutine foo(a) + real (rr8), dimension(40,40), intent(out) :: a + real (rr8), dimension(40,40) :: b + integer (ii4), dimension(40,40) :: c + integer i, j + + j = 10 + do i=11,30 + b(i,j) = 123 * a(i,j) + 34 * a(i,j+1) & + + 34 * a(i,j-1) + a(i+1,j+1) & + + a(i+1,j-1) + a(i-1,j+1) & + + a(i-1,j-1) + c(i,j) = 123 + end do + + where ((xyz(:,:,2) /= 0) .and. (c /= 0)) + a = b/real(c) + elsewhere + a = 456 + endwhere + end subroutine foo +end module m Index: Fortran/gfortran/regression/pr70853.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70853.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/70853 +! Contributed by Gerhard Steinmetz +program p + real, pointer :: z(:) + z(1:2) => null() ! { dg-error "pointer target shall not be NULL" } + z(2:1) => null() ! { dg-error "pointer target shall not be NULL" } +end Index: Fortran/gfortran/regression/pr70870_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70870_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/70870 +! Contributed by Vittorio Zecca + type t + integer :: g=0 ! default initialization + end type + type(t) :: v2 + data v2/t(2)/ ! { dg-error "default initialization shall not" } + end Index: Fortran/gfortran/regression/pr70931.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70931.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-g" } +program p + type t + integer :: a + integer :: b(0) + end type +! type(t), parameter :: z = t(1, [2]) ! original invalid code + type(t), parameter :: z = t(1, [integer::]) + print *, z +end Index: Fortran/gfortran/regression/pr70937.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr70937.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target lto } +! { dg-options "-flto" } + SUBROUTINE dbcsr_test_read_args(narg, args) + CHARACTER(len=*), DIMENSION(:), & + INTENT(out) :: args + CHARACTER(len=80) :: line + DO + args(narg) = line + ENDDO + END SUBROUTINE dbcsr_test_read_args Index: Fortran/gfortran/regression/pr71047.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71047.f08 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Fortran/PR71047 +! + +module m + implicit none + + type, abstract :: c_abstr + integer :: i = 0 + end type c_abstr + + type, extends(c_abstr) :: t_a + class(c_abstr), allocatable :: f + end type t_a + + type, extends(c_abstr) :: t_b + end type t_b + +contains + + subroutine set(y,x) + class(c_abstr), intent(in) :: x + type(t_a), intent(out) :: y + allocate( y%f , source=x ) + end subroutine set + +end module m + + +program p + use m + implicit none + + type(t_a) :: res + type(t_b) :: var + + call set( res , var ) + write(*,*) res%i + +end program p + +! +! Check to ensure the vtable is actually initialized. +! +! { dg-final { scan-tree-dump "t_a\\.\\d+\\.f\\._vptr =" "original" } } +! Index: Fortran/gfortran/regression/pr71067_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71067_1.f90 @@ -0,0 +1,5 @@ +program p + integer :: i = 0 + integer :: z(2) + data z /2*i/ ! { dg-error "must be a PARAMETER in DATA" } +end Index: Fortran/gfortran/regression/pr71067_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71067_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + integer :: a(2), b(2), c(2) + data a /2*b1'/ ! { dg-error "must be a PARAMETER in DATA" } + data b /2*o1' ! { dg-error "must be a PARAMETER in DATA" } + data c /2*z1 ! { dg-error "must be a PARAMETER in DATA" } +end Index: Fortran/gfortran/regression/pr71085.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71085.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR 71085 +! +! Testcase from PR by Vladimir Fuka +! +program pr71085 + print *, f() +contains + function f() + integer :: f(iargc()*10) + end +end Index: Fortran/gfortran/regression/pr71204.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71204.f90 @@ -0,0 +1,17 @@ +! PR fortran/71204 +! { dg-do compile } +! { dg-options "-O0" } + +module pr71204 + character(10), allocatable :: z(:) +end module + +subroutine s1 + use pr71204 + z(2) = z(1) +end + +subroutine s2 + use pr71204 + z(2) = z(1) +end Index: Fortran/gfortran/regression/pr71230-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71230-1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-O2 -fbounds-check -ffast-math" } + FUNCTION pw_integral_aa ( cc ) RESULT ( integral_value ) + COMPLEX(KIND=8), DIMENSION(:), POINTER :: cc + integral_value = accurate_sum ( CONJG ( cc (:) ) * cc (:) ) + END FUNCTION pw_integral_aa Index: Fortran/gfortran/regression/pr71230-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71230-2.f90 @@ -0,0 +1,67 @@ +! { dg-do compile } +! { dg-options "-O2 -ffast-math" } + +MODULE xc_b97 + INTEGER, PARAMETER :: dp=8 + PRIVATE + PUBLIC :: b97_lsd_eval +CONTAINS + SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params) + INTEGER, INTENT(in) :: grad_deriv + INTEGER :: handle, npoints, param, stat + LOGICAL :: failure + REAL(kind=dp) :: epsilon_drho, epsilon_rho, & + scale_c, scale_x + REAL(kind=dp), DIMENSION(:, :, :), POINTER :: dummy, e_0, e_ndra, & + e_ndra_ndra, e_ndra_ndrb, e_ndra_ra, e_ndra_rb, e_ndrb, e_ndrb_ndrb, & + e_ndrb_ra, e_ndrb_rb, e_ra, e_ra_ra, e_ra_rb, e_rb, e_rb_rb, & + norm_drhoa, norm_drhob, rhoa, rhob + IF (.NOT. failure) THEN + CALL b97_lsd_calc(& + rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa,& + norm_drhob=norm_drhob, e_0=e_0, & + e_ra=e_ra, e_rb=e_rb, & + e_ndra=e_ndra, e_ndrb=e_ndrb, & + e_ra_ra=e_ra_ra, e_ra_rb=e_ra_rb, e_rb_rb=e_rb_rb,& + e_ra_ndra=e_ndra_ra, e_ra_ndrb=e_ndrb_ra, & + e_rb_ndrb=e_ndrb_rb, e_rb_ndra=e_ndra_rb,& + e_ndra_ndra=e_ndra_ndra, e_ndrb_ndrb=e_ndrb_ndrb,& + e_ndra_ndrb=e_ndra_ndrb,& + grad_deriv=grad_deriv, npoints=npoints, & + epsilon_rho=epsilon_rho,epsilon_drho=epsilon_drho,& + param=param,scale_c_in=scale_c,scale_x_in=scale_x) + END IF + END SUBROUTINE b97_lsd_eval + SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& + e_0, e_ra, e_rb, e_ndra, e_ndrb, & + e_ra_ndra,e_ra_ndrb, e_rb_ndra, e_rb_ndrb,& + e_ndra_ndra, e_ndrb_ndrb, e_ndra_ndrb, & + e_ra_ra, e_ra_rb, e_rb_rb,& + grad_deriv,npoints,epsilon_rho,epsilon_drho, & + param, scale_c_in, scale_x_in) + REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drhoa, & + norm_drhob + REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_ra, e_rb, e_ndra, & + e_ndrb, e_ra_ndra, e_ra_ndrb, e_rb_ndra, e_rb_ndrb, e_ndra_ndra, & + e_ndrb_ndrb, e_ndra_ndrb, e_ra_ra, e_ra_rb, e_rb_rb + INTEGER, INTENT(in) :: grad_deriv, npoints + REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_drho + INTEGER, INTENT(in) :: param + REAL(kind=dp), INTENT(in) :: scale_c_in, scale_x_in + REAL(kind=dp) :: A_1, A_2, A_3, alpha_1_1, alpha_1_2, alpha_1_3, alpha_c, & + rs_b, rs_brhob, rs_brhobrhob, rsrhoa, rsrhoarhoa, rsrhoarhob, rsrhob, & + t1014, t102, t1047, t1049, t105, t106, t107 + rsrhoa = -t4 * t212 * t208 / 0.12e2_dp + t235 = t224 * rsrhoa / 0.2e1_dp + beta_2_1 * rsrhoa + & + 0.3e1_dp / 0.2e1_dp * t228 * rsrhoa + t50 * t48 * rsrhoa * t232 + t237 = t235 * t236 + e_c_u_0rhoa = -0.2e1_dp * t216 * rsrhoa * t56 + t222 * t237 + epsilon_c_unifrhoa = e_c_u_0rhoa + t285 * t110 + t287 * t110 - & + t293 + t295 * t108 + t297 * t108 + t301 + e_lsda_c_abrhoa = epsilon_c_unifrhoa * rho + epsilon_c_unif - e_lsda_c_arhoa + exc_rhoa = scale_x * (e_lsda_x_arhoa * gx_a + e_lsda_x_a * gx_arhoa) + & + scale_c * (e_lsda_c_abrhoa * gc_ab + e_lsda_c_ab * gc_abrhoa + & + e_lsda_c_arhoa * gc_a + e_lsda_c_a * gc_arhoa) + e_ra(ii)=e_ra(ii)+exc_rhoa + END SUBROUTINE b97_lsd_calc +END MODULE xc_b97 Index: Fortran/gfortran/regression/pr71252.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71252.f90 @@ -0,0 +1,88 @@ + +! { dg-do compile } +! { dg-options "-O1 -ffast-math" } + +MODULE xc_b97 + INTEGER, PARAMETER :: dp=8 + PRIVATE + PUBLIC :: b97_lda_info, b97_lsd_info, b97_lda_eval, b97_lsd_eval +CONTAINS + SUBROUTINE b97_lsd_eval(rho_set,deriv_set,grad_deriv,b97_params) + INTEGER, INTENT(in) :: grad_deriv + INTEGER :: handle, npoints, param, stat + LOGICAL :: failure + REAL(kind=dp) :: epsilon_drho, epsilon_rho, & + scale_c, scale_x + REAL(kind=dp), DIMENSION(:, :, :), POINTER :: dummy, e_0, e_ndra, & + e_ndra_ndra, e_ndra_ndrb, e_ndra_ra, e_ndra_rb, e_ndrb, e_ndrb_ndrb, & + e_ndrb_ra, e_ndrb_rb, e_ra, e_ra_ra, e_ra_rb, e_rb, e_rb_rb, & + norm_drhoa, norm_drhob, rhoa, rhob + IF (.NOT. failure) THEN + CALL b97_lsd_calc(& + rhoa=rhoa, rhob=rhob, norm_drhoa=norm_drhoa,& + norm_drhob=norm_drhob, e_0=e_0, & + e_ra=e_ra, e_rb=e_rb, & + e_ndra=e_ndra, e_ndrb=e_ndrb, & + e_ra_ra=e_ra_ra, e_ra_rb=e_ra_rb, e_rb_rb=e_rb_rb,& + e_ra_ndra=e_ndra_ra, e_ra_ndrb=e_ndrb_ra, & + e_rb_ndrb=e_ndrb_rb, e_rb_ndra=e_ndra_rb,& + e_ndra_ndra=e_ndra_ndra, e_ndrb_ndrb=e_ndrb_ndrb,& + e_ndra_ndrb=e_ndra_ndrb,& + grad_deriv=grad_deriv, npoints=npoints, & + epsilon_rho=epsilon_rho,epsilon_drho=epsilon_drho,& + param=param,scale_c_in=scale_c,scale_x_in=scale_x) + END IF + END SUBROUTINE b97_lsd_eval + SUBROUTINE b97_lsd_calc(rhoa, rhob, norm_drhoa, norm_drhob,& + e_0, e_ra, e_rb, e_ndra, e_ndrb, & + e_ra_ndra,e_ra_ndrb, e_rb_ndra, e_rb_ndrb,& + e_ndra_ndra, e_ndrb_ndrb, e_ndra_ndrb, & + e_ra_ra, e_ra_rb, e_rb_rb,& + grad_deriv,npoints,epsilon_rho,epsilon_drho, & + param, scale_c_in, scale_x_in) + REAL(kind=dp), DIMENSION(*), INTENT(in) :: rhoa, rhob, norm_drhoa, & + norm_drhob + REAL(kind=dp), DIMENSION(*), INTENT(inout) :: e_0, e_ra, e_rb, e_ndra, & + e_ndrb, e_ra_ndra, e_ra_ndrb, e_rb_ndra, e_rb_ndrb, e_ndra_ndra, & + e_ndrb_ndrb, e_ndra_ndrb, e_ra_ra, e_ra_rb, e_rb_rb + INTEGER, INTENT(in) :: grad_deriv, npoints + REAL(kind=dp), INTENT(in) :: epsilon_rho, epsilon_drho + INTEGER, INTENT(in) :: param + REAL(kind=dp), INTENT(in) :: scale_c_in, scale_x_in + REAL(kind=dp) :: A_1, A_2, A_3, alpha_1_1, alpha_1_2, alpha_1_3, alpha_c, & + t133, t134, t1341, t1348, t1351, t1360, t1368, t138, t1388, t139, & + u_x_bnorm_drhobnorm_drhob, u_x_brhob, u_x_brhobnorm_drhob, u_x_brhobrhob + SELECT CASE(grad_deriv) + CASE default + DO ii=1,npoints + IF (rho>epsilon_rho) THEN + IF (grad_deriv/=0) THEN + IF (grad_deriv>1 .OR. grad_deriv<-1) THEN + alpha_c1rhob = alpha_crhob + f1rhob = frhob + t1360 = -0.4e1_dp * t105 * t290 * chirhobrhob + (-0.2e1_dp * t239 & + * t257 + t709 * t1236 * t711 * t62 / 0.2e1_dp - e_c_u_0rhobrhob) * f& + * t108 + t438 * f1rhob * t108 + 0.4e1_dp * t439 * t443 + t1341 * & + 0.4e1_dp * t1348 * t443 + 0.4e1_dp * t1351 * t443 + 0.12e2_dp * t113& + * t107 * t1299 + 0.4e1_dp * t113 * t289 * chirhobrhob + IF (grad_deriv>1 .OR. grad_deriv==-2) THEN + exc_rhob_rhob = scale_x * (-t4 * t6 / t1152 * gx_b / & + 0.6e1_dp + e_lsda_x_brhob * (u_x_b1rhob * t31 + u_x_b * u_x_b1rhob *& + u_x_brhobrhob * c_x_2)) + scale_c * (((e_c_u_0rhobrhob + (0.2e1_dp *& + t726 * t1270 * t278 - t266 * (-t731 * t1205 / 0.4e1_dp + t267 * & + t1205 * t647) * t278 - t757 * t1270 * t759 * t80 / 0.2e1_dp) * f * & + t110 + alpha_crhob * f1rhob * t110 - 0.4e1_dp * t431 * t435 + & + alpha_c1rhob * frhob * t110 + alpha_c * frhobrhob * t110 - 0.4e1_dp & + * t433 * t435 - 0.4e1_dp * t1321 * t435 - 0.4e1_dp * t1324 * t435 - & + 0.12e2_dp * t105 * t796 * t1299 + t1360) * rho + epsilon_c_unifrhob & + * c_css_2)) + e_rb_rb(ii)=e_rb_rb(ii)+exc_rhob_rhob + END IF + END IF ! <1 || >1 + END IF ! /=0 + END IF ! rho>epsilon_rho + END DO + END SELECT + END SUBROUTINE b97_lsd_calc +END MODULE xc_b97 + Index: Fortran/gfortran/regression/pr71523_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71523_1.f90 @@ -0,0 +1,22 @@ +! PR Fortran/71523 +! +! { dg-do compile } +! { dg-options "-fdump-tree-original -finit-local-zero -fautomatic -fmax-stack-var-size=8" } +! +! Make sure that variables larger than max-stack-var-size which become +! static are not given automatic initializers on function entry. +! + +function set(idx, val) + implicit none + integer, intent(in) :: idx, val + integer set + integer arr(100) + + set = arr(idx) + arr(idx) = val + return +end function + +! There should be no automatic initializer for arr +! { dg-final { scan-tree-dump-times "arr = " 0 "original" } } Index: Fortran/gfortran/regression/pr71523_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71523_2.f90 @@ -0,0 +1,38 @@ +! PR Fortran/71523 +! +! { dg-do run } +! { dg-options "-finit-integer=12345 -fautomatic -fmax-stack-var-size=8" } +! +! Make sure that variables larger than max-stack-var-size become +! static and are given the correct _static_ initializer. +! + +function set(idx, val) + implicit none + integer, intent(in) :: idx, val + integer set + integer arr(100) + + set = arr(idx) + arr(idx) = val + return +end function + + integer set, val + + val = set(1, 5) + if (val .ne. 12345) then + STOP 1 + endif + + val = set(1, 10) + if (val .ne. 5) then + STOP 2 + endif + + val = set(1, 100) + if (val .ne. 10) then + STOP 3 + endif + +end Index: Fortran/gfortran/regression/pr71526.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71526.f90 @@ -0,0 +1,21 @@ +! { dg-do link } +! { dg-require-effective-target lto } +! { dg-options "-O2 -flto" } + +MODULE util + INTERFACE sort + MODULE PROCEDURE sort_cv + END INTERFACE +CONTAINS + SUBROUTINE sort_cv ( arr, n, index ) + CHARACTER(LEN=*), INTENT(INOUT) :: arr(1:n) + INTEGER, INTENT(OUT) :: INDEX(1:n) + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: entries + ALLOCATE(entries(max_length,SIZE(arr))) + END SUBROUTINE sort_cv +END MODULE util +USE util +INTEGER, ALLOCATABLE :: ind(:) +character(len=3), ALLOCATABLE :: d(:) +CALL sort(d,N,ind) +END Index: Fortran/gfortran/regression/pr71642.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71642.f90 @@ -0,0 +1,27 @@ +! PR debug/71642 +! { dg-do compile } +! { dg-options "-g" } + +MODULE gauss_colloc + INTEGER, PARAMETER :: dp=8 +CONTAINS +SUBROUTINE collocGauss(h,h_inv,grid,poly,alphai,posi,max_r2,& + periodic,gdim,local_bounds,local_shift,poly_shift,scale,lgrid,error) + REAL(dp), DIMENSION(0:, 0:, 0:), & + INTENT(inout) :: grid + INTEGER, INTENT(inout), OPTIONAL :: lgrid + CONTAINS + SUBROUTINE kloop6 + IF (kJump/=1 .AND. (ikstart+kmax-kstart>=ndim(2)+l_shift(2) .OR.& + ikstart2+kmin-kstart2<=l_ub(2)-ndim(2))) THEN + DO + DO k=kstart2,kend2,-1 + IF ( PRESENT ( lgrid ) ) THEN + grid(ik,ij,ii) = grid(ik,ij,ii) + p_v*res_k + END IF + END DO + END DO + END IF + END SUBROUTINE +END SUBROUTINE +END MODULE gauss_colloc Index: Fortran/gfortran/regression/pr71649.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71649.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR71649 Internal Compiler Error +SUBROUTINE Compiler_Options ( Options, Version, WriteOpt ) ! { dg-error "\(1\)" } + USE ISO_FORTRAN_ENV, ONLY : Compiler_Version, Compiler_Options ! { dg-error "conflicts with the" } + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(OUT) :: Options + CHARACTER (LEN=*), INTENT(OUT) :: Version + LOGICAL, INTENT(IN), OPTIONAL :: WriteOpt + Version = Compiler_Version() ! { dg-error "has no IMPLICIT type" } + Options = Compiler_Options() ! { dg-error "Unexpected use of subroutine name" } + RETURN +END SUBROUTINE Compiler_Options + Index: Fortran/gfortran/regression/pr71688.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71688.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } + +program p + call s +contains + subroutine s + real :: x[*] = 1 + block + end block + x = 2 + end +end Index: Fortran/gfortran/regression/pr71706.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71706.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fcheck=all -fdefault-integer-8" } +! PR fortran/71706 - ICE on using sync images with -fcheck=bounds + +program p + integer, volatile :: me = 1 + sync images (me) + sync images (int (me, 2)) + sync images (int (me, 8)) +end Index: Fortran/gfortran/regression/pr71730.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71730.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +subroutine foo + implicit none + character(len=bar) :: a ! { dg-error "Scalar INTEGER expression" } +end subroutine foo Index: Fortran/gfortran/regression/pr71764.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71764.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! PR71764 +program p + use iso_c_binding, only: c_ptr, c_null_ptr, c_ptr, c_associated, c_loc + logical, target :: rls + real, target :: t = 3.14 + type(c_ptr) :: nullptr,c + real, pointer :: k + nullptr = c_null_ptr + c = nullptr + rls = c_associated(c) + if (rls) STOP 1 + if (c_associated(c)) STOP 2 + c = c_loc(rls) + if (.not. c_associated(c)) STOP 3 + c = nullptr + if (c_associated(c)) STOP 4 + c = c_loc(t) + k => t + call association_test(k, c) +contains + subroutine association_test(a,b) + use iso_c_binding, only: c_associated, c_loc, c_ptr + implicit none + real, pointer :: a + type(c_ptr) :: b + if(c_associated(b, c_loc(a))) then + return + else + STOP 5 + end if + end subroutine association_test +end + Index: Fortran/gfortran/regression/pr71799.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71799.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +subroutine test2(s) +integer(1) :: i +integer (8) :: s + +do i = 10, HUGE(i) - 10, 222 ! { dg-error "overflow converting" } + s = s + 1 +end do + +end subroutine test2 Index: Fortran/gfortran/regression/pr71859.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71859.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +program p + call s(1) + x = abs(s) ! { dg-error "must have a numeric type" } +end +subroutine s(n) + print *, n +end Index: Fortran/gfortran/regression/pr71862.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71862.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +program p + type t + integer :: n = 0 + integer, pointer :: q => null() + end type + type(t) :: x + print *, associated(x%q) + x = f() + print *, associated(x%q) +contains + function f() result (z) ! { dg-error "must be dummy, allocatable or pointer" } + class(t) :: z + print *, associated(z%q) + end +end Index: Fortran/gfortran/regression/pr71883.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71883.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! Test the fix for pr71883, in which an ICE would follow the error. +! +! Contributed by Gerhard Steinmetz +! +program p + character(3), allocatable :: z(:,:) + z(1:2,1:2) = 'abc' + z(2,1) = z(12) ! { dg-error "Rank mismatch in array reference" } + z(21) = z(1,2) ! { dg-error "Rank mismatch in array reference" } +contains + subroutine a + character(3), allocatable :: z(:,:) + z(1:2,1:2) = 'abc' + z(2,1) = z(-1) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(99) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(huge(0)) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(-huge(0)) ! { dg-error "Rank mismatch in array reference" } + z(-1) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(99) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(huge(0)) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(-huge(0)) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + end subroutine + + subroutine b + character(:), allocatable :: z(:,:) + z(1:2,1:2) = 'abc' + z(2,1) = z(-1) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(99) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(huge(0)) ! { dg-error "Rank mismatch in array reference" } + z(2,1) = z(-huge(0)) ! { dg-error "Rank mismatch in array reference" } + z(-1) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(99) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(huge(0)) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + z(-huge(0)) = z(2,1) ! { dg-error "Rank mismatch in array reference" } + end subroutine +end Index: Fortran/gfortran/regression/pr71895.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71895.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +program p + type t + integer :: n + end type + type(t) :: x + class(t) :: y ! { dg-error "must be dummy, allocatable or pointer" } + print *, extends_type_of(x, y) + print *, extends_type_of(y, x) +end Index: Fortran/gfortran/regression/pr71935.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr71935.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + use iso_c_binding + character(len=1, kind=c_char), parameter :: z(2) = 'z' + print *, sizeof(z(3)) ! { dg-warning "is out of bounds" } + print *, c_sizeof(z(3)) ! { dg-warning "is out of bounds" } +end Index: Fortran/gfortran/regression/pr77260_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77260_1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-Wall" } +module foo + + implicit none + + private + public f1,f2 + + contains + + integer function f1() + integer f2 + f1=5 + entry f2 + f2=8 + end function +end module + +program test + use foo + implicit none + print *,f2() +end program Index: Fortran/gfortran/regression/pr77260_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77260_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Wall" } +module foo + + implicit none + + private + public f1,f2 + + contains + + integer function f1() + integer f2 + integer f3 ! { dg-warning "Unused variable" } + f1=5 + entry f2 + f2=8 + end function +end module + +program test + use foo + implicit none + print *,f2() +end program Index: Fortran/gfortran/regression/pr77351.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77351.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR93835 resulted in different but valid error message +program p + integer :: z(4) = [1, 2, 3, 4] + print *, any(shape(z) /= [4,1]) ! { dg-error "Shapes for operands at .1. and .2. are not conformable" } +end + Index: Fortran/gfortran/regression/pr77380.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77380.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -O2" } +program p + integer :: z(2)[*] = 1 + z(:)[1] = z(:)[*] ! { dg-error "must be a scalar at" } +end Index: Fortran/gfortran/regression/pr77391.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77391.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program picky +character(len=:), parameter :: a="whoops" ! { dg-error "POINTER or ALLOCATABLE" } +character(len=:) :: b="whoops" ! { dg-error "POINTER or ALLOCATABLE" } +character(len=:) :: good +pointer good +end program picky Index: Fortran/gfortran/regression/pr77406.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77406.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-w" } +module m + interface s + subroutine s1(*) ! { dg-error "Ambiguous interfaces" } + end + subroutine s2(*) ! { dg-error "Ambiguous interfaces" } + end + end interface + interface t + subroutine t1(*) + end + subroutine t2(*,*) + end + end interface + interface u + subroutine u1(*,x) + end + subroutine u2(*,i) + end + end interface + interface v + subroutine v1(*,*) ! { dg-error "Ambiguous interfaces" } + end + subroutine v2(*,*) ! { dg-error "Ambiguous interfaces" } + end + end interface + interface w + subroutine w1(*,i) ! { dg-error "Ambiguous interfaces" } + end + subroutine w2(*,j) ! { dg-error "Ambiguous interfaces" } + end + end interface +end Index: Fortran/gfortran/regression/pr77414.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77414.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/77414 +subroutine a(x) ! { dg-error "(1)" } + character(*) :: x + contains + subroutine a(x) ! { dg-error " is already defined at" } + character(*) :: x ! { dg-error "Unexpected data declaration statement in CONTAINS section" } + end subroutine a +end subroutine a ! { dg-error "Expecting END PROGRAM statement" } Index: Fortran/gfortran/regression/pr77420_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77420_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +module test_equivalence + real, private :: array1(100) + real, private :: array2(100) + equivalence(array1(3),array2(3)) +end module test_equivalence + +module mymodule + use test_equivalence + real, dimension(:), allocatable :: array1 +end module mymodule + +program test + use mymodule +end program test Index: Fortran/gfortran/regression/pr77420_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77420_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +module test_equivalence + real, private :: array1(100) + real, private :: array2(100) + equivalence(array1,array2) +end module test_equivalence + +module mymodule + use test_equivalence + real, dimension(:), allocatable :: array1 +end module mymodule + +program test + use mymodule +end program test Index: Fortran/gfortran/regression/pr77420_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77420_3.f90 @@ -0,0 +1,8 @@ +! { dg-do link } +! { dg-additional-sources pr77420_4.f90 } +! +module h5global + implicit none + integer :: h5p_default_f, h5p_flags + equivalence(h5p_flags, h5p_default_f) +end module h5global Index: Fortran/gfortran/regression/pr77420_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77420_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile { target { ! *-*-* } } } +! +program bug + use H5GLOBAL + implicit none + integer :: i + i=H5P_DEFAULT_F +end program bug Index: Fortran/gfortran/regression/pr77429.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77429.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + shape(1) = 0 ! { dg-error "expression in variable definition context" } + shape(1,2) = 0 ! { dg-error "expression in variable definition context" } + shape(1,2,3) = 0 ! { dg-error "Too many arguments in call" } + lbound([1]) = 0 ! { dg-error "expression in variable definition context" } +end Index: Fortran/gfortran/regression/pr77460.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77460.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + double precision, parameter :: x = huge(1d0) + print*, sum((/x,-x/)) + print*, sum((/x,x,-x,-x/)) ! { dg-error "overflow" } + print*, sum((/x,-x,1d0/)) + print*, sum((/1d0,x,-x/)) +end Index: Fortran/gfortran/regression/pr77498.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77498.f @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-O2 -fno-tree-vectorize -ffast-math -fdump-tree-pre" } + + subroutine foo(U,V,R,N,A) + integer N + real*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3) + integer I3, I2, I1 +C + do I3=2,N-1 + do I2=2,N-1 + do I1=2,N-1 + R(I1,I2,I3)=V(I1,I2,I3) + * -A(0)*( U(I1, I2, I3 ) ) + * -A(1)*( U(I1-1,I2, I3 ) + U(I1+1,I2, I3 ) + * + U(I1, I2-1,I3 ) + U(I1, I2+1,I3 ) + * + U(I1, I2, I3-1) + U(I1, I2, I3+1) ) + * -A(2)*( U(I1-1,I2-1,I3 ) + U(I1+1,I2-1,I3 ) + * + U(I1-1,I2+1,I3 ) + U(I1+1,I2+1,I3 ) + * + U(I1, I2-1,I3-1) + U(I1, I2+1,I3-1) + * + U(I1, I2-1,I3+1) + U(I1, I2+1,I3+1) + * + U(I1-1,I2, I3-1) + U(I1-1,I2, I3+1) + * + U(I1+1,I2, I3-1) + U(I1+1,I2, I3+1) ) + * -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1) + * + U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1) + * + U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1) + * + U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) ) + enddo + enddo + enddo + return + end + +! PRE shouldn't do predictive commonings job here (and in a bad way) +! ??? It still does but not as bad as it could. Less prephitmps +! would be better, pcom does it with 6. +! { dg-final { scan-tree-dump-times "# prephitmp" 9 "pre" } } Index: Fortran/gfortran/regression/pr77506.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77506.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +program foo + print *, [character(len=*)::'ab','cd'] ! { dg-error "contain an asterisk" } +end program foo Index: Fortran/gfortran/regression/pr77583.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77583.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/77583 - ICE in pp_quoted_string, at pretty-print.c:966 +! Contributed by Gerhard Steinmetz + +pure subroutine sub(s) +contains + pure subroutine s ! { dg-error "conflicts with DUMMY argument" } + end +end Index: Fortran/gfortran/regression/pr77612.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77612.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + +program bad_len + + implicit none + +contains + + subroutine sub + character(len = ICE) :: line ! { dg-error "INTEGER expression expected" } + end subroutine + +end program Index: Fortran/gfortran/regression/pr77632_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77632_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +program foo + implicit none + real, target :: a + real, pointer :: b => a + if (associated(b, a) .eqv. .false.) stop 1 +end program foo Index: Fortran/gfortran/regression/pr77694.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77694.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options -O } +program p + logical x(2), y(2) + x = .true. + y = .nt. x ! { dg-error "Unknown operator" } +end Index: Fortran/gfortran/regression/pr77719.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77719.f90 @@ -0,0 +1,26 @@ +! PR middle-end/77719 +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } + +SUBROUTINE urep_egr(erep,derep,surr) + INTEGER, PARAMETER :: dp=8 + REAL(dp), INTENT(inout) :: erep, derep(3) + REAL(dp), INTENT(in) :: surr(2) + REAL(dp) :: de_z, rz + INTEGER :: isp,spdim,jsp,nsp + IF (n_urpoly > 0) THEN + IF (r < spxr(1,1)) THEN + ispg: DO isp = 1,spdim ! condition ca) + IF (isp /= spdim) THEN + nsp = 5 ! condition cb + DO jsp = 0,nsp + IF( jsp <= 3 ) THEN + ELSE + erep = erep + surr(jsp-3)*rz**(jsp) + ENDIF + END DO + END IF + END DO ispg + END IF + END IF +END SUBROUTINE urep_egr Index: Fortran/gfortran/regression/pr77763.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77763.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fdec" } +block data + structure /s1/ + end structure +end block data Index: Fortran/gfortran/regression/pr77942.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77942.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program p + character, parameter :: c(2) = 'a' + print *, cshift(c(2:1), 1) +end Index: Fortran/gfortran/regression/pr77959.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77959.f90 @@ -0,0 +1,16 @@ +! PR middle-end/77959 +! { dg-do compile } +! { dg-options "-O2" } + +program pr77959 + interface + subroutine foo(x) ! { dg-warning "Type mismatch in argument" } + real :: x + end + end interface + call foo(1.0) +end +subroutine foo(x) + complex :: x + x = x + 1 +end Index: Fortran/gfortran/regression/pr77960.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77960.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/77960 + procedure(g), pointer :: f + f => g + read(99) f ! { dg-error "Expecting variable" } +contains + function g() result(z) + integer :: z(2) + z = 1 + end +end + +subroutine bar(x) + integer, external :: x + read(*,*) x ! { dg-error "Expecting variable" } +end subroutine Index: Fortran/gfortran/regression/pr77978_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77978_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +subroutine a1 + integer, parameter :: i = -666 + stop i ! { dg-error "cannot be negative" } +end subroutine a1 + +subroutine a2 + stop -666 ! { dg-error "cannot be negative" } +end subroutine a2 + +subroutine a3 + integer, parameter :: i = 123456 + stop i ! { dg-error "too many digits" } +end subroutine a3 + +subroutine a4 + stop 123456 ! { dg-error "too many digits" } +end subroutine a4 + +!subroutine a5 +! stop merge(667,668,.true.) +!end subroutine a5 Index: Fortran/gfortran/regression/pr77978_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77978_2.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +subroutine a1 + stop666 ! { dg-error "Blank required in STOP" } +end subroutine a1 Index: Fortran/gfortran/regression/pr77978_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr77978_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +subroutine a1 + integer, parameter :: i = -666 + stop i +end subroutine a1 + +subroutine a2 + stop -666 +end subroutine a2 + +subroutine a3 + integer, parameter :: i = 123456 + stop i +end subroutine a3 + +subroutine a4 + stop 123456 +end subroutine a4 + +subroutine a5 + stop merge(667,668,.true.) +end subroutine a5 Index: Fortran/gfortran/regression/pr78033.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78033.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +subroutine f(n, x, y) + + implicit none + + integer, parameter :: knd = kind(1.e0) + + integer, intent(in) :: n + complex(knd), intent(in) :: x(1:n) + + integer i + real(knd) y(2*n) + + y = [real(x), aimag(x)] + y = [real(x(1:n)), aimag(x(1:n))] + y = [real(knd) :: 1] + y = [real(kind=42) :: 1] ! { dg-error "Invalid type-spec" } + y = [real(kind=knd) :: 1] + y = [real(kind=knd, a=1.)] + y = [real(a=1.)] + y = [real(a=1, kind=knd)] + +end subroutine f Index: Fortran/gfortran/regression/pr78061.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78061.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O3 -fsplit-loops" } + SUBROUTINE SSYMM(C) + REAL C(LDC,*) + LOGICAL LSAME + LOGICAL UPPER + IF (LSAME) THEN + DO 170 J = 1,N + DO 140 K = 1,J + IF (UPPER) THEN + END IF + 140 CONTINUE + DO 160 K = J + 1,N + C(I,J) = B(K) + 160 CONTINUE + 170 CONTINUE + END IF + END Index: Fortran/gfortran/regression/pr78092.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78092.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +program test_stuff + + implicit none + + integer :: ivar1(2,3), ivar2 + + ivar1 = 6 + call poly_sizeof(ivar1, ivar2) + + if (ivar2 /= 4) STOP 1 + + contains + + subroutine poly_sizeof(arg1,arg2) + class(*), intent(in) :: arg1(:,:) + integer, intent(out) :: arg2 + arg2 = sizeof(arg1(1,1)) + end subroutine + +end program test_stuff Index: Fortran/gfortran/regression/pr78240.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78240.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-w" } +! +! PR fortran/78240 +! +! Test a regression where an ICE occurred by passing an invalid reference +! to the error handling routine for non-constant array-specs in DATA list +! initializers. +! +! Error message update with patch for PR fortran/83633 +! +program p + integer x(n) /1/ ! { dg-error "array with nonconstant bounds" } +end +! { dg-prune-output "module or main program" } +! { dg-prune-output "Nonconstant array" } Index: Fortran/gfortran/regression/pr78259.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78259.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/78259 +! +! ICE in gfc_trans_subcomponent_assign +! + +subroutine sub + structure /s/ + union + map + integer n(2) + end map + map + integer(8) m /2/ + end map + end union + end structure + record /s/ r + r.n(1) = 1 +end Index: Fortran/gfortran/regression/pr78278.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78278.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/78278 +program p + character, pointer :: x => null() + data x /null()/ ! { dg-error "GNU Extension: re-initialization" } + print *, associated(x) +end + +subroutine foo + real :: x = 42 + data x /0/ ! { dg-error "GNU Extension: re-initialization" } + print *, x +end subroutine foo Index: Fortran/gfortran/regression/pr78279.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78279.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +program p + integer :: i + real :: z(2,4) + z = 0.0 + do i = 1, 3 + if ( z(i) > z(1,i+1) ) print *, i ! { dg-error "mismatch in array reference" } + end do +end Index: Fortran/gfortran/regression/pr78290.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78290.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR 78290 - used to give an ICE (with VOLATILE) and wrong +! code without it. +! Original test case by Andy Bennet. +PROGRAM main + IMPLICIT NONE + INTEGER,PARAMETER::KI=4 + + TYPE mytype + INTEGER(KIND=KI)::i=1_KI + END TYPE mytype + + TYPE(mytype), DIMENSION(9),TARGET, SAVE::ta + INTEGER(KIND=KI),DIMENSION(3),TARGET, SAVE::ia = 3_KI + INTEGER(KIND=KI),DIMENSION(:),POINTER ::ia2 =>NULL() + INTEGER(KIND=KI),DIMENSION(:),POINTER ::ip =>NULL() + volatile::ip + ALLOCATE(ia2(5)); ia2=2_KI + ip=>ia + if (size(ip) /= 3) stop 1 + CALL sub1(ip) + if (size(ip) /= 5) stop 2 + if (any(ia /= [3,3,3])) stop 3 + if (any (ip /= [2,2,2,2,2])) stop 4 + + ip=>ta%i + +CONTAINS + + SUBROUTINE sub1(ipa) + INTEGER(KIND=KI),DIMENSION(:),POINTER::ipa + ipa => ia2 + END SUBROUTINE sub1 + +END PROGRAM main Index: Fortran/gfortran/regression/pr78297.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78297.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +module m + real :: a(2), b(2) + real :: c(2), d(2) + equivalence (a, b) + equivalence (c, d) + common /xcom/ a +end +block data + use m +end block data Index: Fortran/gfortran/regression/pr78571.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78571.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/78571 +program p + type t + character :: c + end type + character :: x = t('a') ! { dg-error "convert TYPE" } + data x /'b'/ +end Index: Fortran/gfortran/regression/pr78619.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78619.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-Werror -O3" } +! +! Tests the fix for PR78619, in which the recursive use of 'f' at line 13 +! caused an ICE. +! +! Contributed by Gerhard Steinmetz +! + print *, g(1.0) ! 'g' is OK +contains + function f(x) result(z) + real :: x, z + z = sign(1.0, f) ! { dg-error "calling itself recursively|must be the same type" } + end + real function g(x) + real :: x + g = -1 + g = -sign(1.0, g) ! This is OK. + end +end +! { dg-message "all warnings being treated as errors" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/pr78719_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78719_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR fortran/78719 +! Code contributed by Gerhard Steinmetz +program p + + type t + integer :: n + end type + + abstract interface + subroutine h + end + end interface + + procedure(h), pointer :: s + + s => f + call s + s => g + call s + + contains + + subroutine f + end + + subroutine g + end +end program p Index: Fortran/gfortran/regression/pr78719_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78719_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR fortran/78719 +! Code contributed by Gerhard Steinmetz +program p + + type t + integer :: n + end type + + real :: g + + abstract interface + subroutine h + end + end interface + + procedure(h), pointer :: s + + s => f + call s + s => g ! { dg-error "Invalid procedure pointer" } + call s + + contains + + subroutine f + end + + subroutine g ! { dg-error "has an explicit interface" } + end + +end program p ! { dg-error "Syntax error" } Index: Fortran/gfortran/regression/pr78719_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78719_3.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR fortran/78719 +! Code contributed by Gerhard Steinmetz +program p + + type t + integer :: n + end type + + class(t) :: g ! { dg-error "must be dummy, allocatable or pointer" } + + abstract interface + subroutine h + end + end interface + + procedure(h), pointer :: s + + s => f + call s + s => g ! { dg-error "Invalid procedure pointer" } + call s + + contains + + subroutine f + end + + subroutine g ! { dg-error "has an explicit interface" } + end + +end program p ! { dg-error "Syntax error" } Index: Fortran/gfortran/regression/pr78739.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78739.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-w" } +! PR fortran/78739 +! Code contributed Gerhard Steinmetz +function f(n) + f() = n ! { dg-error "conflicts with function name" } +end + +function g() + g(x) = x ! { dg-error "conflicts with function name" } +end + +function a() ! This should cause an error, but cannot be easily detected! + a() = x +end Index: Fortran/gfortran/regression/pr78741.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78741.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/78741 +! Contributed by Gerhard Steinmetz +subroutine s(n, x) + integer :: n + character(n) :: x + character, pointer :: z(:) + x = 'a' + return +entry g(n, x) ! { dg-error "is already defined" } + x = 'b' +contains + subroutine g ! { dg-error "(1)" } + z(1) = x(1:1) + end +end Index: Fortran/gfortran/regression/pr78758.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr78758.f90 @@ -0,0 +1,11 @@ +! PR fortran/78758 +! { dg-do compile } +! { dg-options "-O2 -Wall" } + +integer function pr78758 (x) + character(len=*), intent(in) :: x + character(len=16) :: y + integer, external :: z + y(2:) = " " // adjustl (x(2:)) + pr78758 = z (y) +end function pr78758 Index: Fortran/gfortran/regression/pr79315.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr79315.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-require-effective-target pthread } +! { dg-options "-Ofast -ftree-parallelize-loops=4" } + +SUBROUTINE wsm32D(t, & + w, & + den, & + p, & + delz, & + its,& + ite, & + kts, & + kte & + ) + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: w, & + den, & + p, & + delz + REAL, DIMENSION( its:ite , kts:kte ) :: & + qs, & + xl, & + work1, & + work2, & + qs0, & + n0sfac + diffus(x,y) = 8.794e-5*x**1.81/y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & + /viscos(b,c)**(.5)*(den0/c)**0.25 + do loop = 1,loops + xa=-dldt/rv + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) + endif + qs0(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) + enddo + do i = its, ite + if(t(i,k).ge.t0c) then + work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k)) + endif + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo + enddo ! big loops +END SUBROUTINE wsm32D Index: Fortran/gfortran/regression/pr79886.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr79886.f90 @@ -0,0 +1,17 @@ +! PR fortran/79886 +! { dg-do compile } +! { dg-options "-Wpadded" } + +subroutine pr79886 + type :: foo + integer (kind=1) :: a + integer (kind=8) :: b ! { dg-warning "padding struct to align" } + integer (kind=1) :: c + integer (kind=8) :: d ! { dg-warning "padding struct to align" } + end type + type (foo) :: f + f%a = 1 + f%b = 2 + f%c = 3 + f%d = 4 +end subroutine Index: Fortran/gfortran/regression/pr79966.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr79966.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-O2 -fpeel-loops -finline-functions -fipa-cp-clone -fdump-ipa-inline-details" } + +module TensorProducts + use, intrinsic :: iso_fortran_env + + implicit none + + integer, parameter :: dp = real64 ! KIND for double precision + + type Vect3D + real(dp) :: x, y, z + end type + +contains + + type(Vect3D) pure function MySum(array) + type(Vect3D), intent(in) :: array(:,:) + + mysum = Vect3D(sum(array%x), sum(array%y), sum(array%z)) + end function + + pure subroutine GenerateGrid(N, M, width, height, centre, P) + integer, intent(in) :: N, M + real(dp), intent(in) :: width, height + type(Vect3D), intent(in) :: centre + type(Vect3D), intent(out) :: P(N, M) + real(dp) :: x(N), y(M) + integer :: i, j + + x = ([( i, i = 0, N-1 )] * width/(N-1)) - (width / 2) + centre%x + y = ([( j, j = 0, M-1 )] * height/(M-1)) - (height / 2) + centre%y + do concurrent (i = 1:N) + do concurrent (j = 1:M) + P(i, j) = Vect3D(x(i), y(j), centre%z) + end do + end do + P(2:3,2:3)%z = P(2:3,2:3)%z + 1.0_dp*reshape([2,1,1,-2], [2,2]) + end subroutine + + type(Vect3D) pure function TP_SUM(NU, D, NV) result(tensorproduct) + ! (NU) D (NV)^T, row * matrix * column + ! TODO (#6): TensorProduct: Investigate whether using DO loops triggers a temporary array. + ! copied from Surfaces + real(dp), intent(in) :: NU(4), NV(4) + type(Vect3D), intent(in) :: D(4,4) + integer :: i, j + type(Vect3D) :: P(4,4) + + do concurrent (i = 1:4) + do concurrent (j = 1:4) + P(i,j)%x = NU(i) * D(i,j)%x * NV(j) + P(i,j)%y = NU(i) * D(i,j)%y * NV(j) + P(i,j)%z = NU(i) * D(i,j)%z * NV(j) + end do + end do + tensorproduct = MySum(P) + end function + + subroutine RandomSeed() + integer :: seed_size, clock, i + integer, allocatable, save :: seed(:) + + if (.not. allocated(seed)) then + call random_seed(size=seed_size) + allocate(seed(seed_size)) + call system_clock(count=clock) + seed = clock + 37 * [( i -1, i = 1, seed_size )] + call random_seed(put=seed) + end if + end subroutine + + subroutine RunTPTests() + type(Vect3D) :: tp, P(4,4) + integer, parameter :: i_max = 10000000 + real(dp) :: NU(4,i_max), NV(4,i_max) + real(dp) :: sum + real :: t(2) + integer :: i + +! print *, 'This code variant uses explicit %x, %y and %z to represent the contents of Type(Vect3D).' + call GenerateGrid(4, 4, 20.0_dp, 20.0_dp, Vect3D(0.0_dp,0.0_dp,20.0_dp), P) + call RandomSeed() +! call cpu_time(t(1)) + do i = 1, 4 + call random_number(NU(i,:)) + call random_number(NV(i,:)) + end do +! call cpu_time(t(2)) +! print *, 'Random Numbers, time: ', t(2)-t(1) + sum = 0.0 + call cpu_time(t(1)) + do i = 1, i_max + tp = TP_SUM(NU(:,i), P(1:4,1:4), NV(:,i)) + sum = sum + tp%x + end do + call cpu_time(t(2)) + print *, 'Using SUM, time: ', t(2)-t(1) + print *, 'sum =', sum + end subroutine + + end module + + program Main + use TensorProducts + + implicit none + + call RunTPTests() + end program +! See PR88711. Inliner is currently not able to figure out that inlining tp_sum is a good idea. +! { dg-final { scan-ipa-dump "Inlined tp_sum/\[0-9\]+ into runtptests/\[0-9\]+" "inline" { xfail *-*-* } } } Index: Fortran/gfortran/regression/pr80494.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr80494.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=gnu -O2" } + +subroutine CalcCgr(C,rmax,ordgr_max) + integer, intent(in) :: rmax,ordgr_max + double complex :: Zadj(2,2), Zadj2(2,2) + double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax) + double complex, allocatable :: Cexpgr(:,:,:,:) + double complex :: Caux + integer :: rmaxB,rmaxExp,r,n0,n1,n2,k,l,i,j,m,n,nn + + rmaxB = 2*rmax + rmaxExp = rmaxB + allocate(Cexpgr(0:rmaxExp/2,0:rmaxExp,0:rmaxExp,0:ordgr_max)) + + rloop: do r=0,rmaxExp/2 + do n0=r,1,-1 + do nn=r-n0,0,-1 + do i=1,2 + Caux = Caux - Zadj(i,l) + end do + Cexpgr(n0,0,0,0) = Caux/(2*(nn+1)) + end do + end do + do n1=0,r + n2 = r-n1 + if (r.le.rmax) then + C(0,n1,n2) = Cexpgr(0,n1,n2,0) + end if + end do + end do rloop +end subroutine CalcCgr Index: Fortran/gfortran/regression/pr80668.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr80668.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-finit-derived -finit-integer=12345678" } +! +! PR fortran/80668 +! +! Test a regression where structure constructor expressions were created for +! POINTER components with -finit-derived. +! + +MODULE pr80668 + IMPLICIT NONE + TYPE :: dist_t + INTEGER :: TYPE,nblks_loc,nblks + INTEGER,DIMENSION(:),POINTER :: dist + END TYPE dist_t + +CONTAINS + + SUBROUTINE hfx_new() + TYPE(dist_t) :: dist + integer,pointer :: bob + CALL release_dist(dist, bob) + END SUBROUTINE hfx_new + + SUBROUTINE release_dist(dist,p) + TYPE(dist_t) :: dist + integer, pointer, intent(in) :: p + END SUBROUTINE release_dist +END MODULE Index: Fortran/gfortran/regression/pr80752.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr80752.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/80752 +module exchange_utils + + implicit none + + integer, parameter, public :: knd = 8 + + type, private :: a + logical :: add_vs98 = 0.0_knd ! { dg-error "Cannot convert" } + end type a + + type, private :: x_param_t + type(a) :: m05_m06 + end type x_param_t + + type(x_param_t), public, save :: x_param + +end module exchange_utils + Index: Fortran/gfortran/regression/pr81027.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81027.f90 @@ -0,0 +1,11 @@ +program badarray + implicit none + integer:: j(3) = [1,2,3] + call doubling(j) +contains + subroutine doubling( n) + integer,intent(in)::n(:) + integer::m = size(n) ! { dg-error "Assumed-shape array" } + print *, m ! { dg-error "has no IMPLICIT type" } + end subroutine doubling +end program badarray Index: Fortran/gfortran/regression/pr81175.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81175.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Ofast -fwrapv -std=legacy" } +! { dg-additional-options "-march=broadwell" { target x86_64-*-* i?86-*-* } } + SUBROUTINE ECPDRA(IC4C,FP,FQ,G) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION FP(*),FQ(*),G(*) + DIMENSION CKLU(23,12,12) +! + DO 240 I=IAMIN,IAMAX + DO 240 J=JAMIN,MMAX + DO 230 K=1,NPNP + DO 230 L=1,K + DO 230 MU=1,2*L-1 + CKLTEM= CKLU(MU,L,K) + IF(IC4C.LE.0) THEN + IF(ABS(CKLTEM).GT.TOL) SUM= SUM+FP(N)*CKLTEM + ELSE + IF(ABS(CKLTEM).GT.TOL) SUM= SUM+FQ(N)*CKLTEM + END IF + 230 N= N+1 + G(NN)= G(NN)+DUMJ*SUM + 240 NN= NN+1 + END Index: Fortran/gfortran/regression/pr81303.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81303.f @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -floop-interchange -fdump-tree-linterchange-details" } + + subroutine mat_times_vec(y,x,a,axp,ayp,azp,axm,aym,azm, + $ nb,nx,ny,nz) + implicit none + integer nb,nx,ny,nz,i,j,k,m,l,kit,im1,ip1,jm1,jp1,km1,kp1 + + real*8 y(nb,nx,ny,nz),x(nb,nx,ny,nz) + + real*8 a(nb,nb,nx,ny,nz), + 1 axp(nb,nb,nx,ny,nz),ayp(nb,nb,nx,ny,nz),azp(nb,nb,nx,ny,nz), + 2 axm(nb,nb,nx,ny,nz),aym(nb,nb,nx,ny,nz),azm(nb,nb,nx,ny,nz) + + + do k=1,nz + km1=mod(k+nz-2,nz)+1 + kp1=mod(k,nz)+1 + do j=1,ny + jm1=mod(j+ny-2,ny)+1 + jp1=mod(j,ny)+1 + do i=1,nx + im1=mod(i+nx-2,nx)+1 + ip1=mod(i,nx)+1 + do l=1,nb + y(l,i,j,k)=0.0d0 + do m=1,nb + y(l,i,j,k)=y(l,i,j,k)+ + 1 a(l,m,i,j,k)*x(m,i,j,k)+ + 2 axp(l,m,i,j,k)*x(m,ip1,j,k)+ + 3 ayp(l,m,i,j,k)*x(m,i,jp1,k)+ + 4 azp(l,m,i,j,k)*x(m,i,j,kp1)+ + 5 axm(l,m,i,j,k)*x(m,im1,j,k)+ + 6 aym(l,m,i,j,k)*x(m,i,jm1,k)+ + 7 azm(l,m,i,j,k)*x(m,i,j,km1) + enddo + enddo + enddo + enddo + enddo + return + end + +! { dg-final { scan-tree-dump-times "is interchanged" 1 "linterchange" } } Index: Fortran/gfortran/regression/pr81464.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81464.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "--param parloops-chunk-size=2 -ftree-parallelize-loops=2 -O1" } + +program main + implicit none + real, dimension(:,:),allocatable :: a, b, c + real :: sm + + allocate (a(2,2), b(2,2), c(2,2)) + + call random_number(a) + call random_number(b) + + c = matmul(a,b) + sm = sum(c) + + deallocate(a,b,c) + +end program main Index: Fortran/gfortran/regression/pr81509_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81509_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81509 +program foo +logical :: a = .false. +integer :: i = 42 +integer(8) :: k = 42 +if (kind(ieor(z'ade',i)) /= 4) call abort +if (kind(ior(i,z'1111')) /= 4) call abort +if (kind(ior(1_8,k)) /= 8) call abort +if (kind(iand(k,b'1111')) /= 8) call abort +end program foo + Index: Fortran/gfortran/regression/pr81509_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81509_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=81509 +! +program foo +logical :: a = .false. +integer :: i = 42 +integer(8) :: k +k = iand(z'aaaa', z'1234') ! { dg-error "cannot both be BOZ literal" } +k = and(z'aaaa', z'1234') ! { dg-error "cannot both be BOZ literal" } +k = and(1, z'1234') +k = and(i, z'1234') +k = ieor(z'ade',i) +k = ior(i,z'1111') +k = ior(i,k) ! { dg-error "different kind type parameters" } +k = and(i,k) ! { dg-error "must be the same type" } +k = and(a,z'1234') ! { dg-error "must be INTEGER" } +end program foo + Index: Fortran/gfortran/regression/pr81529.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81529.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=gnu -fno-tree-scev-cprop -Ofast" } + +subroutine CalcCgr(C,rmax,ordgr_max) + integer, intent(in) :: rmax,ordgr_max + double complex :: Zadj(2,2), Zadj2(2,2) + double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax) + double complex, allocatable :: Cexpgr(:,:,:,:) + double complex :: Caux + integer :: rmaxB,rmaxExp,r,n0,n1,n2,k,l,i,j,m,n,nn + + rmaxB = 2*rmax + rmaxExp = rmaxB + allocate(Cexpgr(0:rmaxExp/2,0:rmaxExp,0:rmaxExp,0:ordgr_max)) + + rloop: do r=0,rmaxExp/2 + do n0=r,1,-1 + do nn=r-n0,0,-1 + do i=1,2 + Caux = Caux - Zadj(i,l) + end do + Cexpgr(n0,0,0,0) = Caux/(2*(nn+1)) + end do + end do + do n1=0,r + n2 = r-n1 + if (r.le.rmax) then + C(0,n1,n2) = Cexpgr(0,n1,n2,0) + end if + end do + end do rloop +end subroutine CalcCgr Index: Fortran/gfortran/regression/pr81723.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81723.f @@ -0,0 +1,56 @@ +! { dg-do compile } +! { dg-options "-O3 -fno-automatic -std=legacy" } + + FUNCTION WWERF(Z) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMPLEX*16 WWERF + COMPLEX*16 Z,ZH,R(37),S,T,V,W + + PARAMETER (Z1 = 1, HF = Z1/2, Z10 = 10) + PARAMETER (C1 = 74/Z10, C2 = 83/Z10, C3 = Z10/32, C4 = 16/Z10) + PARAMETER (C = 1.12837 91670 95512 57D0, P = (2*C4)**33) + + DOUBLE PRECISION GREAL,GIMAG,XARG,YARG + COMPLEX*16 ZARG,GCONJG,GCMPLX + GREAL( ZARG)=DREAL( ZARG) + GIMAG( ZARG)=DIMAG( ZARG) + GCONJG(ZARG)=DCONJG(ZARG) + GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG) + + X=Z + Y=GIMAG(Z) + XA=ABS(X) + YA=ABS(Y) + IF(YA .LT. C1 .AND. XA .LT. C2) THEN + ZH=GCMPLX(YA+C4,XA) + R(37)=0 + DO 1 N = 36,1,-1 + T=ZH+N*GCONJG(R(N+1)) + 1 R(N)=HF*T/(GREAL(T)**2+GIMAG(T)**2) + XL=P + S=0 + DO 2 N = 33,1,-1 + XL=C3*XL + 2 S=R(N)*(S+XL) + V=C*S + ELSE + ZH=GCMPLX(YA,XA) + R(1)=0 + DO 3 N = 9,1,-1 + T=ZH+N*GCONJG(R(1)) + 3 R(1)=HF*T/(GREAL(T)**2+GIMAG(T)**2) + V=C*R(1) + END IF + IF(YA .EQ. 0) V=GCMPLX(EXP(-XA**2),GIMAG(V)) + IF(Y .LT. 0) THEN + V=2*EXP(-GCMPLX(XA,YA)**2)-V + IF(X .GT. 0) V=GCONJG(V) + ELSE + IF(X .LT. 0) V=GCONJG(V) + END IF + + WWERF=V + + RETURN + END Index: Fortran/gfortran/regression/pr81735.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81735.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Contributed by Danila +! +program fooprog + implicit none + type FooType + integer, allocatable :: x + end type FooType + + type(FooType), pointer :: bar + + bar => foo() + +contains + function foo() result(res) + type(FooType), pointer :: res + + character(:), allocatable :: rt + rt = "" + res => null() + end function foo +end program fooprog +! { dg-final { scan-tree-dump-times "__builtin_free" 1 "original" } } Index: Fortran/gfortran/regression/pr81849.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81849.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/81849 +program p + implicit none + integer :: n=3 + if (any(g() /= f())) stop 1 + contains + function g() + real g(n) + g = 7 + end function g + function f() result(r) + real r(n) + r = 7 + end function f +end program Index: Fortran/gfortran/regression/pr81889.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr81889.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-O3 -Wall" } + +module m + + type t + integer, dimension(:), pointer :: list + end type + +contains + + subroutine s(n, p, Y) + integer, intent(in) :: n + type(t) :: p + real, dimension(:) :: Y + + real, dimension(1:16) :: xx + + if (n > 3) then + xx(1:n) = 0. + print *, xx(1:n) + else + xx(1:n) = Y(p%list(1:n)) ! { dg-bogus "uninitialized" } + print *, sum(xx(1:n)) + end if + + end subroutine + +end module Index: Fortran/gfortran/regression/pr82004.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr82004.f90 @@ -0,0 +1,18 @@ +! PR middle-end/82004 +! { dg-do run } +! { dg-options "-Ofast" } + + integer, parameter :: r8 = selected_real_kind(13), i4 = kind(1) + integer (i4), parameter :: a = 400, b = 2 + real (r8), parameter, dimension(b) :: c = (/ .001_r8, 10.00_r8 /) + real (r8) :: d, e, f, g, h + real (r8), parameter :: j & + = 10**(log10(c(1))-(log10(c(b))-log10(c(1)))/real(a)) + + d = c(1) + e = c(b) + f = (log10(e)-log10(d))/real(a) + g = log10(d) - f + h = 10**(g) + if (h.ne.j) stop 1 +end Index: Fortran/gfortran/regression/pr82253.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr82253.f90 @@ -0,0 +1,40 @@ +! PR middle-end/82253 +! { dg-do compile { target fortran_real_16 } } +! { dg-options "-Og" } + +module pr82253 + implicit none + private + public :: static_type + type, public :: T + procedure(), nopass, pointer :: testProc => null() + end type + type, public :: S + complex(kind=16), pointer :: ptr + end type + type(T), target :: type_complex32 + interface static_type + module procedure foo + end interface + interface + subroutine bar (testProc) + procedure(), optional :: testProc + end subroutine + end interface + contains + function foo (self) result(res) + complex(kind=16) :: self + type(T), pointer :: res + call bar (testProc = baz) + end function + subroutine baz (buffer, status) + character(len=*) :: buffer + integer(kind=4) :: status + complex(kind=16), target :: obj + type(S) :: self + integer(kind=1), parameter :: zero(storage_size(obj)/8) = 0 + obj = transfer (zero, obj) + self%ptr => obj + write (buffer, *, iostat=status) self%ptr, '#' + end subroutine +end module pr82253 Index: Fortran/gfortran/regression/pr82314.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr82314.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR fortran/82314 - ICE in gfc_conv_expr_descriptor + +program p + implicit none + integer, parameter :: karray(merge(3,7,.true.):merge(3,7,.false.)) = 1 + integer, parameter :: i = size (karray) + integer, parameter :: l = lbound (karray,1) + integer, parameter :: u = ubound (karray,1) + if (l /= 3 .or. u /= 7 .or. i /= 5) stop 1 +end Index: Fortran/gfortran/regression/pr82397.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr82397.f @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-Ofast" } + + subroutine foo(U,V,R,N,A) + integer N + real*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3) + integer I3, I2, I1 +C + do I3=2,N-1 + do I2=2,N-1 + do I1=2,N-1 + R(I1,I2,I3)=V(I1,I2,I3) + * -A(0)*( U(I1, I2, I3 ) ) + * -A(1)*( U(I1-1,I2, I3 ) + U(I1+1,I2, I3 ) + * + U(I1, I2-1,I3 ) + U(I1, I2+1,I3 ) + * + U(I1, I2, I3-1) + U(I1, I2, I3+1) ) + * -A(2)*( U(I1-1,I2-1,I3 ) + U(I1+1,I2-1,I3 ) + * + U(I1-1,I2+1,I3 ) + U(I1+1,I2+1,I3 ) + * + U(I1, I2-1,I3-1) + U(I1, I2+1,I3-1) + * + U(I1, I2-1,I3+1) + U(I1, I2+1,I3+1) + * + U(I1-1,I2, I3-1) + U(I1-1,I2, I3+1) + * + U(I1+1,I2, I3-1) + U(I1+1,I2, I3+1) ) + * -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1) + * + U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1) + * + U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1) + * + U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) ) + enddo + enddo + enddo + return + end + Index: Fortran/gfortran/regression/pr82973.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr82973.f90 @@ -0,0 +1,31 @@ +! PR rtl-optimization/82973 +! { dg-do compile } +! { dg-options "-Ofast -frounding-math" } + +program pr82973 + integer, parameter :: n=16 + real, dimension(n) :: ar, br, modulo_result, floor_result + integer, dimension(n) :: ai, bi , imodulo_result, ifloor_result + ai(1:4) = 5 + ai(5:8) = -5 + ai(9:12) = 1 + ai(13:16) = -1 + bi(1:4) = (/ 3,-3, 1, -1/) + bi(5:8) = bi(1:4) + bi(9:12) = bi(1:4) + bi(13:16) = bi(1:4) + ar = ai + br = bi + modulo_result = modulo(ar,br) + imodulo_result = modulo(ai,bi) + floor_result = ar-floor(ar/br)*br + ifloor_result = nint(real(ai-floor(real(ai)/real(bi))*bi)) + do i=1,n + if (modulo_result(i) /= floor_result(i)) then + STOP 1 + end if + if (imodulo_result(i) /= ifloor_result(i)) then + STOP 2 + end if + end do +end program pr82973 Index: Fortran/gfortran/regression/pr83113.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83113.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/83113 +module mm + implicit none + interface + module function c() + integer, dimension(2) :: c + end function c + end interface +end module mm + +submodule (mm) oo + implicit none +contains + module function c() + integer, dimension(3) :: c + end function c +end submodule oo Index: Fortran/gfortran/regression/pr83149.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83149.f90 @@ -0,0 +1,14 @@ +! Compiled with pr83149_1.f90 +! +module mod1 + integer :: ncells +end module + +module mod2 +contains + function get() result(array) + use mod1 + real array(ncells) + array = 1.0 + end function +end module Index: Fortran/gfortran/regression/pr83149_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83149_1.f90 @@ -0,0 +1,23 @@ +! Compiled with pr83149.f90 +! { dg-do run } +! { dg-compile-aux-modules "pr83149.f90" } +! { dg-additional-sources pr83149.f90 } +! +! Contributed by Neil Carlson +! +subroutine sub(s) + use mod2 + real :: s + s = sum(get()) +end + + use mod1 + real :: s + ncells = 2 + call sub (s) + if (int (s) .ne. ncells) stop 1 + ncells = 10 + call sub (s) + if (int (s) .ne. ncells) stop 2 +end + Index: Fortran/gfortran/regression/pr83149_a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83149_a.f90 @@ -0,0 +1,11 @@ +! Compiled with pr83149_b.f90 +! +module mod + character(8) string +contains + function get_string() result(s) + character(len_trim(string)) s + s = string + end function +end module + Index: Fortran/gfortran/regression/pr83149_b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83149_b.f90 @@ -0,0 +1,15 @@ +! Compiled with pr83149_a.f90 +! { dg-do run } +! { dg-compile-aux-modules "pr83149_a.f90" } +! { dg-additional-sources pr83149_a.f90 } +! +! Contributed by Neil Carlson +! + use mod + string = 'fubar' + select case (get_string()) + case ('fubar') + case default + stop 1 + end select +end Index: Fortran/gfortran/regression/pr83246.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83246.f90 @@ -0,0 +1,9 @@ +! PR fortran/83246 +! { dg-do link } + program dusty_corner + write(*,*)'BLOCK TESTS' + MAKEDATAP: block + integer,parameter :: scratch(*)=[1,2,3] + write(*,*)scratch + endblock MAKEDATAP + end program dusty_corner Index: Fortran/gfortran/regression/pr83864.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83864.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR fortran/83864 +! +! Derived from PR by Contributed by Gerhard Steinmetz +! +program p + implicit none + type t + character :: c(3) = transfer('abc','z',3) + end type t + type(t) :: x + if (any (x%c /= ["a", "b", "c"])) STOP 1 +end Index: Fortran/gfortran/regression/pr83874.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83874.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR fortran/83874 +! There was an ICE while initializing the character arrays +! +! Contributed by Harald Anlauf +! +program charinit + implicit none + type t + character(len=1) :: name + end type t + type(t), parameter :: z(2)= [ t ('a'), t ('b') ] + character(len=1), parameter :: names1(*) = z% name + character(len=*), parameter :: names2(2) = z% name + character(len=*), parameter :: names3(*) = z% name + if (.not. (names1(1) == "a" .and. names1(2) == "b")) STOP 1 + if (.not. (names2(1) == "a" .and. names2(2) == "b")) STOP 2 + if (.not. (names3(1) == "a" .and. names3(2) == "b")) STOP 3 +end program charinit Index: Fortran/gfortran/regression/pr83939.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr83939.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +elemental function f() result(s) ! { dg-error "shall not have an ALLOCATABLE or POINTER" } + allocatable s + allocate(s) + s = 3.5 +end function + +elemental function g() result(s) ! { dg-error "shall not have an ALLOCATABLE or POINTER" } + pointer s + allocate(s) + s = 3.5 +end function Index: Fortran/gfortran/regression/pr84088.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84088.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! +! Test of fix for case in comment #7 of PR84088. +! +! Contributed by Tom de Vries +! +implicit none + integer(kind=4) z + + call foo (z) + +contains + subroutine foo (a) + type (*), dimension (..), contiguous :: a + integer(kind = 4) :: i + if(sizeof (a) .ne. sizeof (i)) STOP 1 + end subroutine foo + +end program Index: Fortran/gfortran/regression/pr84117.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84117.f90 @@ -0,0 +1,7 @@ +! PR tree-optimization/84117 +! { dg-do compile } +! { dg-options "-O3 -ftrapv" } + FUNCTION pw_integral_aa ( cc ) RESULT ( integral_value ) + COMPLEX(KIND=8), DIMENSION(:), POINTER :: cc + integral_value = accurate_sum ( CONJG ( cc (:) ) * cc (:) ) + END FUNCTION pw_integral_aa Index: Fortran/gfortran/regression/pr84155.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84155.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! Test the fix for PR84155 and PR84141. +! +! Contributed by Juergen Reuter +! +module test_case + + implicit none + + type :: array_t + integer, dimension(:), allocatable :: child + contains + procedure :: write_raw => particle_write_raw + end type array_t + + type :: container_t + type(array_t), dimension(:), allocatable :: array + end type container_t + +contains + + subroutine proc () + type(container_t) :: container + integer :: unit, check + integer, parameter :: ival = 42 + + allocate (container%array(1)) + allocate (container%array(1)%child (1), source = [ival]) + + unit = 33 + open (unit, action="readwrite", form="unformatted", status="scratch") + call container%array(1)%write_raw (unit) + rewind (unit) + read (unit) check + close (unit) + if (ival .ne. check) STOP 1 + end subroutine proc + + subroutine particle_write_raw (array, u) + class(array_t), intent(in) :: array + integer, intent(in) :: u + write (u) array%child + end subroutine particle_write_raw + + subroutine particle_read_raw (array) + class(array_t), intent(out) :: array + allocate (array%child (1)) ! comment this out + end subroutine particle_read_raw + +end module test_case + +program main + use test_case + call proc () + end program main Index: Fortran/gfortran/regression/pr84523.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84523.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR84523. +! +! Contributed by Harald Anlauf +! +program gfcbug148 + implicit none + integer, parameter :: nspots = 80 + type t_spot + real, allocatable :: vm(:,:,:) + end type t_spot + type t_rowcol + integer :: nh + type(t_spot), pointer :: spots(:) => NULL () + end type t_rowcol + type(t_rowcol) :: col + call construct (col, nspots) + call destruct (col) + !======================================================================== +contains + !======================================================================== + subroutine construct (rc, nh) + type(t_rowcol) ,intent(out) :: rc ! row or column to set + integer ,intent(in) :: nh ! number of spots in a row + rc%nh = nh + allocate (rc%spots(nh)) + end subroutine construct + !------------------------------------------------------------------------ + subroutine destruct (rc) + type(t_rowcol) ,intent(inout) :: rc ! row or column to free + integer :: k + if (associated (rc%spots)) then + if (size(rc%spots) .ne. nspots) stop 1 + do k=1, size(rc% spots) + if (allocated (rc%spots(k)%vm)) stop 2 ! Would segfault in runtime. + end do + deallocate (rc%spots) + endif + nullify (rc%spots) + end subroutine destruct +end program gfcbug148 Index: Fortran/gfortran/regression/pr84565.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84565.f90 @@ -0,0 +1,7 @@ +! PR fortran/84565 +! { dg-do compile { target aarch64*-*-* } } +! { dg-options "-mlow-precision-sqrt -funsafe-math-optimizations" } +subroutine mysqrt(a) + real(KIND=KIND(0.0D0)) :: a + a=sqrt(a) +end subroutine Index: Fortran/gfortran/regression/pr84734.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84734.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! PR fortran/84734 + integer :: b(huge(1_8)+1_8) = 0 ! { dg-error "Arithmetic overflow" } + end Index: Fortran/gfortran/regression/pr84784.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84784.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdefault-integer-8" } +! { dg-require-effective-target fortran_integer_16 } +! PR fortran/84784 - ICEs: verify_gimple failed with -fdefault-integer-8 + + use iso_fortran_env, only : team_type, STAT_FAILED_IMAGE + implicit none + type(team_type) :: team + integer :: new_team + new_team = mod(this_image(),2)+1 + form team (new_team,team) + change team (team) + if (team_number() /= new_team) STOP 1 + end team + if (image_status (1) == STAT_FAILED_IMAGE) ERROR STOP "cannot recover" + if (runtime_popcnt(0_16) /= 0) STOP 2 + if (runtime_poppar(1_16) /= 1) STOP 3 +contains + integer function runtime_popcnt (i) + integer(kind=16), intent(in) :: i + runtime_popcnt = popcnt(i) + end function + integer function runtime_poppar (i) + integer(kind=16), intent(in) :: i + runtime_poppar = poppar(i) + end function +end Index: Fortran/gfortran/regression/pr84957.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr84957.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 84957 +! +! Testcase derived from PR by G. Steinmetz +! +function f() result(u) + entry g() result(v) +contains + function v(x) result(z) + character :: x(2) + character(sum(len_trim(x))) :: z + end function v + function u(x) result(z) + character :: x(2) + character(sum(len_trim(x))) :: z + end function u +end function f Index: Fortran/gfortran/regression/pr85082.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85082.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +program p + real(4) :: a, b + integer(4) :: n, m + equivalence (a, n) + a = 1024.0 + m = 8 + a = 1024.0 + b = set_exponent(a, m) + n = 8 + a = f(a, n) + b = set_exponent(a, m) +end Index: Fortran/gfortran/regression/pr85138_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85138_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +module fox_m_fsys_format + + interface len + module procedure str_real_sp_len, str_real_sp_fmt_len + end interface + +contains + + pure function str_real_sp_fmt_len(x, fmt) result(n) + real, intent(in) :: x + character(len=*), intent(in) :: fmt + if (.not.checkFmt(fmt)) then + endif + end function str_real_sp_fmt_len + pure function str_real_sp_len(x) result(n) + real, intent(in) :: x + n = len(x, "") + end function str_real_sp_len + pure function str_real_dp_matrix(xa) result(s) + real, intent(in) :: xa + character(len=len(xa)) :: s + end function str_real_dp_matrix + + pure function checkfmt(s) result(a) + logical a + character(len=*), intent(in) :: s + end function checkfmt +end module fox_m_fsys_format Index: Fortran/gfortran/regression/pr85138_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85138_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +module fox_m_fsys_format + interface len + module procedure str_real_dp_len, str_real_dp_fmt_len + end interface +contains + pure function str_real_dp_fmt_len(x, fmt) result(n) + real, intent(in) :: x + character(len=*), intent(in) :: fmt + if (.not.checkFmt(fmt)) then + endif + end function str_real_dp_fmt_len + pure function str_real_dp_len(x) result(n) + real, intent(in) :: x + end function str_real_dp_len + pure function str_real_dp_array_len(xa) result(n) + real, dimension(:), intent(in) :: xa + end function str_real_dp_array_len + pure function str_real_dp_array_fmt_len(xa, fmt) result(n) + real, dimension(:), intent(in) :: xa + character(len=*), intent(in) :: fmt + end function str_real_dp_array_fmt_len + pure function str_real_dp_fmt(x, fmt) result(s) + real, intent(in) :: x + character(len=*), intent(in) :: fmt + character(len=len(x, fmt)) :: s + end function str_real_dp_fmt + pure function checkFmt(fmt) result(good) + character(len=*), intent(in) :: fmt + logical :: good + end function checkFmt +end module fox_m_fsys_format Index: Fortran/gfortran/regression/pr85357.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85357.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +module base + implicit none +contains + subroutine summation(i) + integer, intent(in) :: i + end subroutine +end module + +module extended + use base + implicit none +contains + subroutine summation() ! { dg-error "is already defined" } + end subroutine ! { dg-error "Expecting END MODULE statement" } +end module +! { dg-prune-output "is already defined at" } Index: Fortran/gfortran/regression/pr85520.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85520.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR fortran/85520 +! Original code from Gerhard Steinmetz +program p + character(-huge(1)) :: c = ' ' + if (len(c) /= 0) stop 1 +end Index: Fortran/gfortran/regression/pr85521_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85521_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/85521 +program p + character(3) :: c = 'abc' + character(3) :: z(1) + z = [ c(:-1) ] + print *, z +end Index: Fortran/gfortran/regression/pr85521_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85521_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/85521 +program p + character(3) :: c = 'abc' + character(3) :: z(1) + z = [ c(:-2) ] + print *, z +end Index: Fortran/gfortran/regression/pr85542.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85542.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/85542 +function f(x) + character(*), intent(in) :: x + character((len((x)))) :: f + f = x +end Index: Fortran/gfortran/regression/pr85543.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85543.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/85543 +program p + procedure(), pointer :: z +contains + real(z()) function f() ! { dg-error "in initialization expression at" } + end +end +! { dg-prune-output "Bad kind expression for function" } Index: Fortran/gfortran/regression/pr85687.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85687.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/85687 +! Code original contributed by Gerhard Steinmetz gscfq at t-oline dot de +program p + type t + end type + print *, rank(t) ! { dg-error "used as an actual argument" } +end Index: Fortran/gfortran/regression/pr85779_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85779_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/85779 +type(t) function f() ! { dg-error "is not accessible" } + type f ! { dg-error "already has a basic type" } + end type ! { dg-error "END FUNCTION statement" } +end Index: Fortran/gfortran/regression/pr85779_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85779_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/85779 +type(t) function f() result(z) ! { dg-error "is not accessible" } + type z ! { dg-error "already has a basic type" } + end type ! { dg-error "END FUNCTION statement" } +end + Index: Fortran/gfortran/regression/pr85779_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85779_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/85779 +class(t) function f() ! { dg-error "is not accessible" } + type f ! { dg-error "already has a basic type" } + end type ! { dg-error "END FUNCTION statement" } +end + Index: Fortran/gfortran/regression/pr85780.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85780.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1" } +! PR fortran/85780 +subroutine s(*) bind(c) ! { dg-error "Alternate return dummy argument" } +end +! { dg-prune-output "compilation terminated" } Index: Fortran/gfortran/regression/pr85786.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85786.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! PR fortran/85786 +program test + + implicit none + + type :: p2d + real, pointer :: p(:,:) => null() + end type p2d + + type :: test_cs + type(p2d), pointer :: v(:) => null() + end type test_cs + + type(test_cs), pointer :: cs + real, allocatable, target :: e(:,:) + + allocate(cs) + if (associated(cs) .neqv. .true.) stop 1 + + allocate(cs%v(2)) + if (associated(cs%v) .neqv. .true.) stop 2 + + allocate(e(2,2)) + e = 42 + + if (query_ptr(e, cs) .neqv. .true.) stop 3 + + contains + + logical function query_ptr(f_ptr, cs) + + real, target, intent(in) :: f_ptr(:,:) + type(test_cs), pointer, intent(inout) :: cs + + if (associated(cs)) then + if (associated(cs%v) .neqv. .true.) stop 4 + cs%v(2)%p => f_ptr + if (associated(cs%v(2)%p) .neqv. .true.) stop 5 + query_ptr = associated(cs%v(2)%p, f_ptr) + else + query_ptr = .false. + end if + end function query_ptr + +end program test Index: Fortran/gfortran/regression/pr85796.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85796.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/85796 - Floating point exception with implied do in data statement + +program p + implicit none + integer :: i, j, x(2,2) + data ((x(i,j),i=1,2,j-1),j=1,2) /3*789/ ! { dg-error "step of implied-do loop" } +end Index: Fortran/gfortran/regression/pr85797.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85797.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/83515 - ICE: Invalid expression in gfc_element_size +! PR fortran/85797 - ICE in gfc_element_size, at fortran/target-memory.c:126 +! PR fortran/89904 - ICE in gfortran starting with r270045 + +recursive subroutine a + c = transfer (a, b) ! { dg-error "'SOURCE' argument of 'TRANSFER'" } +end + +recursive subroutine d + c = transfer (b, d) ! { dg-error "'MOLD' argument of 'TRANSFER'" } +end + +subroutine f + use, intrinsic :: iso_c_binding + integer(c_intptr_t) :: b, c + procedure(), pointer :: a + c = transfer (a, b) + c = transfer (transfer (b, a), b) +end + +module m +contains + function f () result (z) + class(*), pointer :: z + end function f + recursive subroutine s (q) + procedure(f) :: q + call s (q) + end subroutine s +end Index: Fortran/gfortran/regression/pr85798.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85798.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +program p + type t + integer, allocatable :: a(:) + end type + type u + real x + type(t) y + end type + type(t) :: z + type(u) :: q + data z%a(1) / 789 / ! { dg-error "Allocatable component" } + data q%y%a(1) / 789 / ! { dg-error "Allocatable component" } +end Index: Fortran/gfortran/regression/pr85816.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85816.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/85816 +! Original code from Martin Diehl +! +! Prior to fixing the problem with the array descriptor, gfortran died with +! Operating system error: Cannot allocate memory +! Integer overflow in xmallocarray +! +program test + implicit none + real(8) :: tensor(3,3) = 4 + integer :: grid(3) = 16 + ! ok + write(6,*) spread(spread(tensor,3,grid(1)),4,grid(1)) + ! ok (note the brackets) + write(6,*) spread((spread(spread(tensor,3,grid(1)),4,grid(2))),5,grid(3)) + ! not ok + write(6,*) spread(spread(spread(tensor,3,grid(1)),4,grid(2)),5,grid(3)) +end program Index: Fortran/gfortran/regression/pr85895.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85895.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/85895 +subroutine p + character(80) :: c(2) + sync memory (errmsg=c) ! { dg-error "scalar CHARACTER variable" } +end subroutine p + +subroutine q + character(80) :: c(2) + sync memory (errmsg=c(1:2)) ! { dg-error "scalar CHARACTER variable" } +end subroutine q + +subroutine r + character(80) :: c(2) + sync memory (errmsg=c(1)) +end subroutine r Index: Fortran/gfortran/regression/pr85938.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85938.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR fortran/85938 +program foo + real a(9), b(3) + integer :: n = 3 + a = 1.0 + b = 1.0 + if (any(matmul(reshape(A, (/ n, n /)), b) /= 3.)) stop 1 +end program Index: Fortran/gfortran/regression/pr85975.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85975.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR fortran/85976 +! Original code from Stephan Kramer +program foo + + implicit none + + call bar(2, 3, 5, 7) + + contains + + subroutine bar(k, l, m, n) + + integer, intent(in) :: k, l, m, n + real :: a(k), b(k,l), c(k,l,m), d(k,l,m,n) + + if (size(spread(A, 1, 1)) /= k) stop 1 + if (size(spread(b, 1, 1)) /= k * l) stop 2 + if (size(spread(c, 1, 1)) /= k * l * m) stop 3 + if (size(spread(d, 1, 1)) /= k * l * m * n) stop 4 + + end subroutine + +end program Index: Fortran/gfortran/regression/pr85996.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr85996.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +module strings + + type string + integer :: len = 0, size = 0 + character, pointer :: chars(:) => null() + end type string + + interface length + module procedure len_s + end interface + + interface char + module procedure s_to_c, s_to_slc + end interface + + interface uppercase + module procedure uppercase_c + end interface + + interface replace + module procedure replace_ccs + end interface + + contains + + elemental function len_s(s) + type(string), intent(in) :: s + integer :: len_s + end function len_s + + pure function s_to_c(s) + type(string),intent(in) :: s + character(length(s)) :: s_to_c + end function s_to_c + + pure function s_to_slc(s,long) + type(string),intent(in) :: s + integer, intent(in) :: long + character(long) :: s_to_slc + end function s_to_slc + + pure function lr_sc_s(s,start,ss) result(l) + type(string), intent(in) :: s + character(*), intent(in) :: ss + integer, intent(in) :: start + integer :: l + end function lr_sc_s + + pure function lr_ccc(s,tgt,ss,action) result(l) + character(*), intent(in) :: s,tgt,ss,action + integer :: l + select case(uppercase(action)) + case default + end select + end function lr_ccc + + function replace_ccs(s,tgt,ss) result(r) + character(*), intent(in) :: s,tgt + type(string), intent(in) :: ss + character(lr_ccc(s,tgt,char(ss),'first')) :: r + end function replace_ccs + + pure function uppercase_c(c) + character(*), intent(in) :: c + character(len(c)) :: uppercase_c + end function uppercase_c + +end module strings Index: Fortran/gfortran/regression/pr86045.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86045.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + logical :: a(2) = (mod([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: b = count(mod([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: c = all(mod([2,3],0) == 0) ! { dg-error "shall not be zero" } + integer :: d = any(mod([2,3],0) == 0) ! { dg-error "shall not be zero" } +end Index: Fortran/gfortran/regression/pr86059.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86059.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/86059 +program foo + integer :: i(2) = [ null(), 1 ] ! { dg-error "cannot appear in an array constructor" } + integer :: j(2) = [ (null(), n = 1, 2) ] ! { dg-error "cannot appear in an array constructor" } + integer k(2) + k = 42 + [1, null()] ! { dg-error "cannot appear in an array constructor" } +end program foo Index: Fortran/gfortran/regression/pr86110.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86110.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/86110 +program p + character(:), allocatable :: x, y + x = 'abc' + y = [x(:)] ! { dg-error "Incompatible ranks 0 and 1" } +end Index: Fortran/gfortran/regression/pr86322_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86322_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +program foo + implicit none + type a + integer i + end type a + type(a), target, save :: b + type(a), pointer :: c + data b%i /42/ + data c%i /b%i/ ! { dg-error "is not rightmost part-ref" } + if (c%i == 42) c%i = 1 ! Unreachable +end program foo Index: Fortran/gfortran/regression/pr86322_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86322_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +program bar + type a + integer :: i + end type a + type b + type(a),pointer :: j + end type b + integer, target, save :: k = 42 + type(b) x + data x%j%i/k/ ! { dg-error "is not rightmost part-ref" } + print *, x%j%i +end program bar Index: Fortran/gfortran/regression/pr86322_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86322_3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +program bar + type a + integer, pointer :: i + end type a + type b + type(a) :: j + end type b + integer, target, save :: k = 42 + type(b) x + data x%j%i/k/ + if (x%j%i /= 42) stop 1 +end program bar Index: Fortran/gfortran/regression/pr86328.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86328.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Test the fix for PR86328 in which temporaries were not being +! assigned for array component references. +! +! Contributed by Martin +! +program ptr_alloc + + type :: t + class(*), allocatable :: val + end type + + type :: list + type(t), dimension(:), pointer :: ll + end type + + integer :: i + type(list) :: a + + allocate(a%ll(1:2)) + do i = 1,2 + allocate(a%ll(i)%val, source=i) + end do + + do i = 1,2 + call rrr(a, i) + end do + + do i = 1,2 + deallocate(a%ll(i)%val) + end do + deallocate (a%ll) +contains + + subroutine rrr(a, i) + type(list), intent(in) :: a + class(*), allocatable :: c + integer :: i + + allocate(c, source=a%ll(i)%val) + select type (c) + type is (integer) + if (c .ne. i) stop 1 + end select + + end subroutine + +end Index: Fortran/gfortran/regression/pr86551.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86551.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/86551 - ICE on invalid code with select type / end select type + +subroutine b + type :: t1 + end type t1 + class(t1) :: c2 + select type (d => c2) + end select type ! { dg-error "Syntax error" } +end ! { dg-error "END SELECT statement expected" } + +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/pr86587.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86587.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/86587 +! Code contirubted by Valentin Clement +! +module mod1 + use iso_c_binding + type, bind(c), private :: mytype + integer(c_int) :: i1, i2 + end type +end module mod1 + +module mod2 + use iso_c_binding + private + type, bind(c) :: mytype + integer(c_int) :: i1, i2 + end type +end module mod2 Index: Fortran/gfortran/regression/pr86760.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr86760.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! +! Test the fix for PR86760 in which temporaries were not being +! assigned for array component references. +! +! Contributed by Chris Hansen +! +MODULE test_nesting_mod + IMPLICIT NONE + TYPE :: test_obj1 + CONTAINS + PROCEDURE :: destroy + END TYPE + + TYPE :: obj_ptr + CLASS(test_obj1), POINTER :: f => NULL() + END TYPE + + TYPE :: obj_container + TYPE(obj_ptr), POINTER, DIMENSION(:) :: v => NULL() + END TYPE + + integer :: ctr = 0 + +CONTAINS + + SUBROUTINE destroy(self) + CLASS(test_obj1), INTENT(INOUT):: self + ctr = ctr + 1 + END SUBROUTINE + + SUBROUTINE container_destroy(self) + type(obj_container), INTENT(INOUT) :: self + INTEGER :: i + DO i=1,ubound(self%v,1) + CALL self%v(i)%f%destroy() + END DO + END SUBROUTINE + +END MODULE + + +PROGRAM test_nesting_ptr + USE test_nesting_mod + IMPLICIT NONE + INTEGER :: i + INTEGER, PARAMETER :: n = 2 + TYPE(obj_container) :: var + + ALLOCATE(var%v(n)) + DO i=1,n + ALLOCATE(test_obj1::var%v(i)%f) + END DO + CALL container_destroy(var) + + if (ctr .ne. 2) stop 1 +END Index: Fortran/gfortran/regression/pr87045.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87045.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds" } +! +! PR fortran/87045 - pointer to array of character +! Contributed by Valery Weber +! This used to give an invalid run-time error + +program test + character(:), dimension(:), allocatable, target :: t + character(:), pointer, dimension(:) :: p + allocate( character(3) :: t(2) ) + t(1) = "abc" + t(2) = "123" + p => t + if (size (p) /= 2) stop 1 + if (len (p) /= 3) stop 2 + if (p(1) /= "abc") stop 3 + if (p(2) /= "123") stop 4 +end program test Index: Fortran/gfortran/regression/pr87117.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87117.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O" } +program p + real(4) :: a, b + integer(4) :: n, m + equivalence (a, n) + a = 1024.0 + m = 8 + a = 1024.0 + b = set_exponent(a, m) + n = 8 + a = f(a, n) + b = set_exponent(a, m) +end Index: Fortran/gfortran/regression/pr87217.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87217.f @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-O3" } + implicit real*8 (a-h,o-z) + common clop6(3),dps(6),aml6(6,6) + dimension y1(3) + dimension dclo(3) + dimension dx(3),dy(3) + save + do 80 ii=1,itco + y1(3)=dps(1) + do 40 l=1,3 + dy(l)=clop6(l)-y1(l) + 40 continue + dczp=abs(dy(3)) + if(dcx.le.c1m10.and.dcz.le.c1m10.and.dcxp.le.c1m10.and.dczp + + .le.c1m10.and.dcy.le.c1m10.and.dcyp.le.c1m10) goto 90 + 80 continue + write(6) itco + ii=itco + 90 continue + if(ii.ne.itco) then + do 65 k=1,3 + do 55 j=1,3 + jj=2*j + kk=2*k + dclo(k)=aml6(kk-1,jj-1)*dx(j)+dclo(k) + dclo(k)=aml6(kk-1,jj)*dy(j)+dclo(k) + 55 continue + 65 continue + endif + end + Index: Fortran/gfortran/regression/pr87360.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87360.f90 @@ -0,0 +1,5 @@ +! PR tree-optimization/87360 +! { dg-do compile } +! { dg-options "-fno-tree-dce -O3 --param max-completely-peeled-insns=0" } + +include 'function_optimize_2.f90' Index: Fortran/gfortran/regression/pr87907.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87907.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/pr87907 +! Original testcase contributed by Gerhard Stienmetz +module m + interface + module function g(x) result(z) + integer, intent(in) :: x + integer, allocatable :: z + end + end interface +end + +submodule(m) m2 + contains + subroutine g(x) ! { dg-error "mismatch in argument" } + end +end + +program p + use m ! { dg-error "has a type" } + integer :: x = 3 + call g(x) ! { dg-error "which is not consistent with" } +end Index: Fortran/gfortran/regression/pr87922.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87922.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/87922 +subroutine p + read(1, asynchronous=['no']) ! { dg-error "must be scalar" } + read(1, asynchronous=[character::]) ! { dg-error "must be scalar" } +end +subroutine q + write(1, asynchronous=['no']) ! { dg-error "must be scalar" } + write(1, asynchronous=[character::]) ! { dg-error "must be scalar" } +end Index: Fortran/gfortran/regression/pr87945_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87945_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/87945 +program p + character :: a, b + data a%len /1/ ! { dg-error "parameter cannot appear in" } + data b%kind /'b'/ ! { dg-error "parameter cannot appear in" } +end Index: Fortran/gfortran/regression/pr87945_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87945_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/87945 +program p + character :: a, b + a%len = 1 ! { dg-error "to a constant expression" } + b%kind = 'b' ! { dg-error "to a constant expression" } +end Index: Fortran/gfortran/regression/pr87991.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87991.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-w" } +! PR fortran/87991 +program p + type t + character(:), pointer :: c + end type + type(t) :: x + allocate (character(3) :: x%c) + data x%c /'abc'/ ! { dg-error "has the pointer attribute" } +end Index: Fortran/gfortran/regression/pr87992.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87992.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +subroutine s(x) + class(*), allocatable :: x + x = '' +end Index: Fortran/gfortran/regression/pr87993.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87993.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! Code contributed by Gerhard Steinmetz +program p + integer, parameter :: a(2) = 1 + integer, parameter :: b = a%kind + if (any(a /= 1)) stop 1 + if (b /= kind(a)) stop 2 +end Index: Fortran/gfortran/regression/pr87994_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87994_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR fortran/87994 +program p + real :: a, b + data b /a%kind/ + if (b /= kind(a)) stop 1 +end Index: Fortran/gfortran/regression/pr87994_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87994_2.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR fortran/87994 +program p + real, parameter :: a = 1.0 + data b /a%kind/ + if (b /= kind(a)) stop 1 +end Index: Fortran/gfortran/regression/pr87994_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr87994_3.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR fortran/87994 +program p + integer, parameter :: a = 1 + integer :: b + data b /a%kind/ + if (b /= kind(a)) stop = 1 +end Index: Fortran/gfortran/regression/pr88025.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88025.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/88025 +program p + type t + character(('')) :: c = 'c' ! { dg-error "Scalar INTEGER expression expected" } + end type +end Index: Fortran/gfortran/regression/pr88048.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88048.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/88048 +program p + integer, parameter :: a(2) = 1 + data a(2) /a(1)/ ! { dg-error "shall not appear in a DATA statement" } + print *, a +end Index: Fortran/gfortran/regression/pr88072.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88072.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/88072 +! Original code contributed by Andrew Wood +module m1 + + implicit none + + type, abstract, public :: t1 + integer, dimension(:), allocatable :: i + contains + procedure(f1), deferred :: f + end type t1 + + type, extends(t1), public :: t2 ! { dg-error "must be ABSTRACT because" } + contains + procedure :: f => f2 ! { dg-error "mismatch for the overriding" } + end type t2 + + abstract interface + function f1(this) ! { dg-error "must be dummy, allocatable or" } + import + class(t1) :: this + class(t1) :: f1 + end function f1 + end interface + contains + type(t2) function f2(this) + class(t2) :: this + end function f2 +end module m1 Index: Fortran/gfortran/regression/pr88116_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88116_1.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +program p + print *, [integer :: 1, [integer(8) :: 2, ['3']]] ! { dg-error "Cannot convert" } +end Index: Fortran/gfortran/regression/pr88116_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88116_2.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +program p + real :: a(2) = [real :: 1, [integer :: (real(k), k=2,1), 2]] + real :: b(1) = [real :: [integer :: (dble(k), k=1,0), 2]] + if (a(1) /= 1. .or. a(2) /= 2. .or. b(1) /= 2.) stop 1 +end + Index: Fortran/gfortran/regression/pr88138.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88138.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +program p + type t + character :: c = 'c' + end type + type(t), parameter :: x = 1.e1 ! { dg-error "Incompatible initialization between a" } + print *, 'a' // x%c +end +! { dg-prune-output "has no IMPLICIT type" } Index: Fortran/gfortran/regression/pr88148.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88148.f90 @@ -0,0 +1,705 @@ +! { dg-do compile } +! { dg-options "-O -fno-tree-fre -fno-tree-sra -ftree-loop-vectorize" } +! { dg-additional-options "-mavx2" { target x86_64-*-* i?86-*-* } } + +module lfk_prec + integer, parameter :: dp=kind(1.d0) +end module lfk_prec + +!*********************************************** + +SUBROUTINE kernel(tk) +!*********************************************************************** +! * +! KERNEL executes 24 samples of Fortran computation * +! TK(1) - total cpu time to execute only the 24 kernels. * +! TK(2) - total Flops executed by the 24 Kernels * +!*********************************************************************** +! * +! L. L. N. L. F O R T R A N K E R N E L S: M F L O P S * +! * +! These kernels measure Fortran numerical computation rates for a * +! spectrum of CPU-limited computational structures. Mathematical * +! through-put is measured in units of millions of floating-point * +! operations executed per Second, called Mega-Flops/Sec. * +! * +! This program measures a realistic CPU performance range for the * +! Fortran programming system on a given day. The CPU performance * +! rates depend strongly on the maturity of the Fortran compiler's * +! ability to translate Fortran code into efficient machine code. * +! [ The CPU hardware capability apart from compiler maturity (or * +! availability), could be measured (or simulated) by programming the * +! kernels in assembly or machine code directly. These measurements * +! can also serve as a framework for tracking the maturation of the * +! Fortran compiler during system development.] * +! * +! Fonzi's Law: There is not now and there never will be a language * +! in which it is the least bit difficult to write * +! bad programs. * +! F.H.MCMAHON 1972 * +!*********************************************************************** + +! l1 := param-dimension governs the size of most 1-d arrays +! l2 := param-dimension governs the size of most 2-d arrays + +! Loop := multiple pass control to execute kernel long enough to ti +! me. +! n := DO loop control for each kernel. Controls are set in subr. +! SIZES + +! ****************************************************************** +use lfk_prec +implicit double precision (a-h,o-z) +!IBM IMPLICIT REAL*8 (A-H,O-Z) + +REAL(kind=dp), INTENT(inout) :: tk +INTEGER :: test !!,AND + +COMMON/alpha/mk,ik,im,ml,il,mruns,nruns,jr,iovec,npfs(8,3,47) +COMMON/beta/tic,times(8,3,47),see(5,3,8,3),terrs(8,3,47),csums(8,3 & + ,47),fopn(8,3,47),dos(8,3,47) + +COMMON/spaces/ion,j5,k2,k3,loop1,laps,loop,m,kr,lp,n13h,ibuf,nx,l, & + npass,nfail,n,n1,n2,n13,n213,n813,n14,n16,n416,n21,nt1,nt2,last,idebug & + ,mpy,loop2,mucho,mpylim,intbuf(16) + +COMMON/spacer/a11,a12,a13,a21,a22,a23,a31,a32,a33,ar,br,c0,cr,di,dk & + ,dm22,dm23,dm24,dm25,dm26,dm27,dm28,dn,e3,e6,expmax,flx,q,qa,r,ri & + ,s,scale,sig,stb5,t,xnc,xnei,xnm + +COMMON/space0/time(47),csum(47),ww(47),wt(47),ticks,fr(9),terr1(47 & + ),sumw(7),start,skale(47),bias(47),ws(95),total(47),flopn(47),iq(7 & + ),npf,npfs1(47) + +COMMON/spacei/wtp(3),mul(3),ispan(47,3),ipass(47,3) + +! ****************************************************************** + + +INTEGER :: e,f,zone +COMMON/ispace/e(96),f(96),ix(1001),ir(1001),zone(300) + +COMMON/space1/u(1001),v(1001),w(1001),x(1001),y(1001),z(1001),g(1001) & + ,du1(101),du2(101),du3(101),grd(1001),dex(1001),xi(1001),ex(1001) & + ,ex1(1001),dex1(1001),vx(1001),xx(1001),rx(1001),rh(2048),vsp(101) & + ,vstp(101),vxne(101),vxnd(101),ve3(101),vlr(101),vlin(101),b5(101) & + ,plan(300),d(300),sa(101),sb(101) + +COMMON/space2/p(4,512),px(25,101),cx(25,101),vy(101,25),vh(101,7), & + vf(101,7),vg(101,7),vs(101,7),za(101,7),zp(101,7),zq(101,7),zr(101 & + ,7),zm(101,7),zb(101,7),zu(101,7),zv(101,7),zz(101,7),b(64,64),c(64,64) & + ,h(64,64),u1(5,101,2),u2(5,101,2),u3(5,101,2) + +! ****************************************************************** + +dimension zx(1023),xz(447,3),tk(6),mtmp(1) +EQUIVALENCE(zx(1),z(1)),(xz(1,1),x(1)) +double precision temp +logical ltmp + + +! ****************************************************************** + +! STANDARD PRODUCT COMPILER DIRECTIVES MAY BE USED FOR OPTIMIZATION + + + + + +CALL trace('KERNEL ') + +CALL SPACE + +mpy= 1 +mpysav= mpylim +loop2= 1 +mpylim= loop2 +l= 1 +loop= 1 +lp= loop +it0= test(0) +loop2= mpysav +mpylim= loop2 +do + +!*********************************************************************** +!*** KERNEL 1 HYDRO FRAGMENT +!*********************************************************************** + + x(:n)= q+y(:n)*(r*zx(11:n+10)+t*zx(12:n+11)) +IF(test(1) <= 0)THEN + EXIT +END IF +END DO + +do +! we must execute DO k= 1,n repeatedly for accurat +! e timing + +!*********************************************************************** +!*** KERNEL 2 ICCG EXCERPT (INCOMPLETE CHOLESKY - CONJUGATE GRADIE +! NT) +!*********************************************************************** + + +ii= n +ipntp= 0 + +do while(ii > 1) +ipnt= ipntp +ipntp= ipntp+ii +ii= ishft(ii,-1) +i= ipntp+1 +!dir$ vector always + x(ipntp+2:ipntp+ii+1)=x(ipnt+2:ipntp:2)-v(ipnt+2:ipntp:2) & + &*x(ipnt+1:ipntp-1:2)-v(ipnt+3:ipntp+1:2)*x(ipnt+3:ipntp+1:2) +END DO +IF(test(2) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 3 INNER PRODUCT +!*********************************************************************** + + +q= dot_product(z(:n),x(:n)) +IF(test(3) <= 0)THEN + EXIT +END IF +END DO +m= (1001-7)/2 + +!*********************************************************************** +!*** KERNEL 4 BANDED LINEAR EQUATIONS +!*********************************************************************** + +fw= 1.000D-25 + +do +!dir$ vector always + xz(6,:3)= y(5)*(xz(6,:3)+matmul(y(5:n:5), xz(:n/5,:3))) + +IF(test(4) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 5 TRI-DIAGONAL ELIMINATION, BELOW DIAGONAL (NO VECTORS +! ) +!*********************************************************************** + + +tmp= x(1) +DO i= 2,n + tmp= z(i)*(y(i)-tmp) + x(i)= tmp +END DO +IF(test(5) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 6 GENERAL LINEAR RECURRENCE EQUATIONS +!*********************************************************************** + + +DO i= 2,n + w(i)= 0.0100D0+dot_product(b(i,:i-1),w(i-1:1:-1)) +END DO +IF(test(6) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 7 EQUATION OF STATE FRAGMENT +!*********************************************************************** + + + x(:n)= u(:n)+r*(z(:n)+r*y(:n))+t*(u(4:n+3)+r*(u(3:n+2)+r*u(2:n+1))+t*( & + u(7:n+6)+q*(u(6:n+5)+q*u(5:n+4)))) +IF(test(7) <= 0)THEN + EXIT +END IF +END DO + +do + + +!*********************************************************************** +!*** KERNEL 8 A.D.I. INTEGRATION +!*********************************************************************** + + +nl1= 1 +nl2= 2 +fw= 2.000D0 + DO ky= 2,n +DO kx= 2,3 + du1ky= u1(kx,ky+1,nl1)-u1(kx,ky-1,nl1) + du2ky= u2(kx,ky+1,nl1)-u2(kx,ky-1,nl1) + du3ky= u3(kx,ky+1,nl1)-u3(kx,ky-1,nl1) + u1(kx,ky,nl2)= u1(kx,ky,nl1)+a11*du1ky+a12*du2ky+a13 & + *du3ky+sig*(u1(kx+1,ky,nl1)-fw*u1(kx,ky,nl1)+u1(kx-1,ky,nl1)) + u2(kx,ky,nl2)= u2(kx,ky,nl1)+a21*du1ky+a22*du2ky+a23 & + *du3ky+sig*(u2(kx+1,ky,nl1)-fw*u2(kx,ky,nl1)+u2(kx-1,ky,nl1)) + u3(kx,ky,nl2)= u3(kx,ky,nl1)+a31*du1ky+a32*du2ky+a33 & + *du3ky+sig*(u3(kx+1,ky,nl1)-fw*u3(kx,ky,nl1)+u3(kx-1,ky,nl1)) + END DO +END DO +IF(test(8) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 9 INTEGRATE PREDICTORS +!*********************************************************************** + + + px(1,:n)= dm28*px(13,:n)+px(3,:n)+dm27*px(12,:n)+dm26*px(11,:n)+dm25*px(10 & + ,:n)+dm24*px(9,:n)+dm23*px(8,:n)+dm22*px(7,:n)+c0*(px(5,:n)+px(6,:n)) +IF(test(9) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 10 DIFFERENCE PREDICTORS +!*********************************************************************** + +!dir$ unroll(2) + do k= 1,n + br= cx(5,k)-px(5,k) + px(5,k)= cx(5,k) + cr= br-px(6,k) + px(6,k)= br + ar= cr-px(7,k) + px(7,k)= cr + br= ar-px(8,k) + px(8,k)= ar + cr= br-px(9,k) + px(9,k)= br + ar= cr-px(10,k) + px(10,k)= cr + br= ar-px(11,k) + px(11,k)= ar + cr= br-px(12,k) + px(12,k)= br + px(14,k)= cr-px(13,k) + px(13,k)= cr + enddo +IF(test(10) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 11 FIRST SUM. PARTIAL SUMS. (NO VECTORS) +!*********************************************************************** + + +temp= 0 +DO k= 1,n + temp= temp+y(k) + x(k)= temp +END DO +IF(test(11) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 12 FIRST DIFF. +!*********************************************************************** + + x(:n)= y(2:n+1)-y(:n) +IF(test(12) <= 0)THEN + EXIT +END IF +END DO +fw= 1.000D0 + +!*********************************************************************** +!*** KERNEL 13 2-D PIC Particle In Cell +!*********************************************************************** + + +do + +! rounding modes for integerizing make no difference here + do k= 1,n + i1= 1+iand(int(p(1,k)),63) + j1= 1+iand(int(p(2,k)),63) + p(3,k)= p(3,k)+b(i1,j1) + p(1,k)= p(1,k)+p(3,k) + i2= iand(int(p(1,k)),63) + p(1,k)= p(1,k)+y(i2+32) + p(4,k)= p(4,k)+c(i1,j1) + p(2,k)= p(2,k)+p(4,k) + j2= iand(int(p(2,k)),63) + p(2,k)= p(2,k)+z(j2+32) + i2= i2+e(i2+32) + j2= j2+f(j2+32) + h(i2,j2)= h(i2,j2)+fw + enddo +IF(test(13) <= 0)THEN + EXIT +END IF +END DO +fw= 1.000D0 + +!*********************************************************************** +!*** KERNEL 14 1-D PIC Particle In Cell +!*********************************************************************** + + + +do + + ix(:n)= grd(:n) +!dir$ ivdep + vx(:n)= ex(ix(:n))-ix(:n)*dex(ix(:n)) + ir(:n)= vx(:n)+flx + rx(:n)= vx(:n)+flx-ir(:n) + ir(:n)= iand(ir(:n),2047)+1 + xx(:n)= rx(:n)+ir(:n) +DO k= 1,n + rh(ir(k))= rh(ir(k))+fw-rx(k) + rh(ir(k)+1)= rh(ir(k)+1)+rx(k) +END DO +IF(test(14) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 15 CASUAL FORTRAN. DEVELOPMENT VERSION. +!*********************************************************************** + + +! CASUAL ORDERING OF SCALAR OPERATIONS IS TYPICAL PRACTICE. +! THIS EXAMPLE DEMONSTRATES THE NON-TRIVIAL TRANSFORMATION +! REQUIRED TO MAP INTO AN EFFICIENT MACHINE IMPLEMENTATION. + + +ng= 7 +nz= n +ar= 0.05300D0 +br= 0.07300D0 +!$omp parallel do private(t,j,k,r,s,i,ltmp) if(nz>98) +do j= 2,ng-1 + do k= 2,nz + i= merge(k-1,k,vf(k,j) < vf((k-1),j)) + t= merge(br,ar,vh(k,(j+1)) <= vh(k,j)) + r= MAX(vh(i,j),vh(i,j+1)) + s= vf(i,j) + vy(k,j)= t/s*SQRT(vg(k,j)**2+r*r) + if(k < nz)then + ltmp=vf(k,j) >= vf(k,(j-1)) + i= merge(j,j-1,ltmp) + t= merge(ar,br,ltmp) + r= MAX(vg(k,i),vg(k+1,i)) + s= vf(k,i) + vs(k,j)= t/s*SQRT(vh(k,j)**2+r*r) + endif + END do + vs(nz,j)= 0.0D0 +END do + vy(2:nz,ng)= 0.0D0 +IF(test(15) <= 0)THEN + EXIT +END IF +END DO +ii= n/3 + +!*********************************************************************** +!*** KERNEL 16 MONTE CARLO SEARCH LOOP +!*********************************************************************** + +lb= ii+ii +k2= 0 +k3= 0 + +do +DO m= 1,zone(1) + j2= (n+n)*(m-1)+1 + DO k= 1,n + k2= k2+1 + j4= j2+k+k + j5= zone(j4) + IF(j5 >= n)THEN + IF(j5 == n)THEN + EXIT + END IF + k3= k3+1 + IF(d(j5) < d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN + go to 200 + END IF + IF(d(j5) == d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN + EXIT + END IF + ELSE + IF(j5-n+lb < 0)THEN + IF(plan(j5) < t)THEN + go to 200 + END IF + IF(plan(j5) == t)THEN + EXIT + END IF + ELSE + IF(j5-n+ii < 0)THEN + IF(plan(j5) < s)THEN + go to 200 + END IF + IF(plan(j5) == s)THEN + EXIT + END IF + ELSE + IF(plan(j5) < r)THEN + go to 200 + END IF + IF(plan(j5) == r)THEN + EXIT + END IF + END IF + END IF + END IF + IF(zone(j4-1) <= 0)THEN + go to 200 + END IF + END DO + EXIT + 200 IF(zone(j4-1) == 0)THEN + EXIT + END IF +END DO +IF(test(16) <= 0)THEN + EXIT +END IF +END DO +dw= 5.0000D0/3.0000D0 + +!*********************************************************************** +!*** KERNEL 17 IMPLICIT, CONDITIONAL COMPUTATION (NO VECTORS) +!*********************************************************************** + +! RECURSIVE-DOUBLING VECTOR TECHNIQUES CAN NOT BE USED +! BECAUSE CONDITIONAL OPERATIONS APPLY TO EACH ELEMENT. + +fw= 1.0000D0/3.0000D0 +tw= 1.0300D0/3.0700D0 + +do +scale= dw +rtmp= fw +e6= tw +DO k= n,2,-1 + e3= rtmp*vlr(k)+vlin(k) + xnei= vxne(k) + vxnd(k)= e6 + xnc= scale*e3 +! SELECT MODEL + IF(max(rtmp,xnei) <= xnc)THEN +! LINEAR MODEL + ve3(k)= e3 + rtmp= e3+e3-rtmp + vxne(k)= e3+e3-xnei + ELSE + rtmp= rtmp*vsp(k)+vstp(k) +! STEP MODEL + vxne(k)= rtmp + ve3(k)= rtmp + END IF + e6= rtmp +END DO +xnm= rtmp +IF(test(17) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 18 2-D EXPLICIT HYDRODYNAMICS FRAGMENT +!*********************************************************************** + + +t= 0.003700D0 +s= 0.004100D0 +kn= 6 +jn= n + zb(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(2:jn,:kn-1))/(zm(2:jn,2:kn)+zm(:jn-1,2:kn)) & + *(zp(:jn-1,2:kn)-zp(2:jn,2:kn)+(zq(:jn-1,2:kn)-zq(2:jn,2:kn))) + za(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(:jn-1,2:kn))/(zm(:jn-1,2:kn)+zm(:jn-1,3:kn+1)) & + *(zp(:jn-1,3:kn+1)-zp(:jn-1,2:kn)+(zq(:jn-1,3:kn+1)-zq(:jn-1,2:kn))) + zu(2:jn,2:kn)= zu(2:jn,2:kn)+ & + s*(za(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(3:jn+1,2:kn)) & + -za(:jn-1,2:kn)*(zz(2:jn,2:kn)-zz(:jn-1,2:kn)) & + -zb(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(2:jn,:kn-1))+ & + zb(2:jn,3:kn+1)*(zz(2:jn, 2:kn)-zz(2:jn,3:kn+1))) + zv(2:jn,2:kn)= zv(2:jn,2:kn)+ & + s*(za(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(3:jn+1,2:kn)) & + -za(:jn-1,2:kn)*(zr(2:jn,2:kn)-zr(:jn-1,2:kn)) & + -zb(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(2:jn,:kn-1))+ & + zb(2:jn,3:kn+1)*(zr(2:jn, 2:kn)-zr(2:jn,3:kn+1))) + zr(2:jn,2:kn)= zr(2:jn,2:kn)+t*zu(2:jn,2:kn) + zz(2:jn,2:kn)= zz(2:jn,2:kn)+t*zv(2:jn,2:kn) +IF(test(18) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 19 GENERAL LINEAR RECURRENCE EQUATIONS (NO VECTORS) +!*********************************************************************** + +kb5i= 0 + +DO k= 1,n + b5(k+kb5i)= sa(k)+stb5*sb(k) + stb5= b5(k+kb5i)-stb5 +END DO +DO k= n,1,-1 + b5(k+kb5i)= sa(k)+stb5*sb(k) + stb5= b5(k+kb5i)-stb5 +END DO +IF(test(19) <= 0)THEN + EXIT +END IF +END DO +dw= 0.200D0 + +!*********************************************************************** +!*** KERNEL 20 DISCRETE ORDINATES TRANSPORT: RECURRENCE (NO VECTORS +!*********************************************************************** + + +do + +rtmp= xx(1) +DO k= 1,n + di= y(k)*(rtmp+dk)-g(k) + dn=merge( max(s,min(z(k)*(rtmp+dk)/di,t)),dw,di /= 0.0) + x(k)= ((w(k)+v(k)*dn)*rtmp+u(k))/(vx(k)+v(k)*dn) + rtmp= ((w(k)-vx(k))*rtmp+u(k))*DN/(vx(k)+v(k)*dn)+ rtmp + xx(k+1)= rtmp +END DO +IF(test(20) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 21 MATRIX*MATRIX PRODUCT +!*********************************************************************** + + px(:25,:n)= px(:25,:n)+matmul(vy(:25,:25),cx(:25,:n)) +IF(test(21) <= 0)THEN + EXIT +END IF +END DO +expmax= 20.0000D0 + + +!*********************************************************************** +!*** KERNEL 22 PLANCKIAN DISTRIBUTION +!*********************************************************************** + +! EXPMAX= 234.500d0 +fw= 1.00000D0 +u(n)= 0.99000D0*expmax*v(n) + +do + + y(:n)= u(:n)/v(:n) + w(:n)= x(:n)/(EXP(y(:n))-fw) +IF(test(22) <= 0)THEN + EXIT +END IF +END DO +fw= 0.17500D0 + +!*********************************************************************** +!*** KERNEL 23 2-D IMPLICIT HYDRODYNAMICS FRAGMENT +!*********************************************************************** + + +do + + DO k= 2,n + do j=2,6 + za(k,j)= za(k,j)+fw*(za(k,j+1)*zr(k,j)-za(k,j)+ & + & zv(k,j)*za(k-1,j)+(zz(k,j)+za(k+1,j)* & + & zu(k,j)+za(k,j-1)*zb(k,j))) + END DO + END DO +IF(test(23) <= 0)THEN + EXIT +END IF +END DO +x(n/2)= -1.000D+10 + +!*********************************************************************** +!*** KERNEL 24 FIND LOCATION OF FIRST MINIMUM IN ARRAY +!*********************************************************************** + +! X( n/2)= -1.000d+50 + +do + m= minloc(x(:n),DIM=1) + +IF(test(24) == 0)THEN + EXIT +END IF +END DO +sum= 0.00D0 +som= 0.00D0 +DO k= 1,mk + sum= sum+time(k) + times(jr,il,k)= time(k) + terrs(jr,il,k)= terr1(k) + npfs(jr,il,k)= npfs1(k) + csums(jr,il,k)= csum(k) + dos(jr,il,k)= total(k) + fopn(jr,il,k)= flopn(k) + som= som+flopn(k)*total(k) +END DO +tk(1)= tk(1)+sum +tk(2)= tk(2)+som +! Dumpout Checksums: file "chksum" +! WRITE ( 7,706) jr, il +! 706 FORMAT(1X,2I3) +! WRITE ( 7,707) ( CSUM(k), k= 1,mk) +! 707 FORMAT(5X,'&',1PE23.16,',',1PE23.16,',',1PE23.16,',') + +CALL track('KERNEL ') +RETURN +END SUBROUTINE kernel Index: Fortran/gfortran/regression/pr88155.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88155.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +program p + type t + integer :: a + end type + type(t) :: x + data x /t()1/ ! { dg-error "No initializer for component" } + print *, x +end Index: Fortran/gfortran/regression/pr88169_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88169_1.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +module foo_nml + implicit none + real :: x = -1 + namelist /foo/ x +end module + +program main + use foo_nml, only: bar => foo, x + implicit none + integer fd + x = 42 + open(newunit=fd, file='tmp.dat', status='replace') + write(fd,nml=bar) + close(fd) + open(newunit=fd, file='tmp.dat', status='old') + read(fd,nml=bar) + if (x /= 42) stop 1 + close(fd) +end program +! { dg-final { cleanup-modules "foo_nml" } } Index: Fortran/gfortran/regression/pr88169_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88169_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +module foo_nml + implicit none + real :: x = -1 + namelist /foo/ x +end module +! +! Yes, implicit typing of local variable 'x'. +! +program main + use foo_nml, only: bar => foo + integer fd + x = 42 + open(newunit=fd, file='tmp.dat', status='replace') + write(fd,nml=bar) + close(fd) + open(newunit=fd, file='tmp.dat', status='old') + read(fd,nml=bar) + close(fd) + call bah + if (x /= 42) stop 1 +end program + +subroutine bah + use foo_nml + integer fd + open(newunit=fd, file='tmp.dat', status='old') + read(fd,nml=foo) + if (x /= -1) stop 2 + close(fd, status='delete') +end subroutine bah Index: Fortran/gfortran/regression/pr88169_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88169_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +module foo_nml + implicit none + real :: x = -1 + namelist /foo/ x +end module + +program main + use foo_nml, only: bar => foo, x + implicit none + real a + namelist /bar/a ! { dg-error "already is USE associated" } +end program +! { dg-final { cleanup-modules "foo_nml" } } Index: Fortran/gfortran/regression/pr88205.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88205.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/88205 +subroutine s1 + real, parameter :: status = 0 + open (newunit=n, status=status) ! { dg-error "must be of type CHARACTER" } +end +subroutine s2 + complex, parameter :: status = 0 + open (newunit=n, status=status) ! { dg-error "must be of type CHARACTER" } +end +program p + logical, parameter :: status = .false. + open (newunit=a, status=status) ! { dg-error "must be of type CHARACTER" } +end Index: Fortran/gfortran/regression/pr88206.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88206.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/88206 +program p + integer, parameter :: z(4) = [1,2,3,4] + integer :: k = 2 + print *, [real(z(k))] +end + Index: Fortran/gfortran/regression/pr88228.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88228.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! PR fortran/88228 +program p + integer :: n = .not. 1 + integer :: j = .true. .or. 1 +end + Index: Fortran/gfortran/regression/pr88248.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88248.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! +! PR88248 - [F18] Bogus warning about obsolescent feature: Labeled DO statement +! +program pr88248 + character*80 text ! { dg-warning "Old-style character length" } + f(x) = x ! { dg-warning "Statement function" } + call foo (*99) ! { dg-warning "Alternate-return argument" } + data y / 1.0 / ! { dg-warning "DATA statement" } + goto (1,99) i+1 ! { dg-warning "Computed GOTO" } + ! No warning should be printed below + goto 1 +1 continue + open (10, err=99) + close (10, err=99) + backspace (10, err=99) + endfile (10, err=99) + rewind (10, err=99) + flush (10, err=99) + inquire (10, err=99) + read (*, end=99) text +99 continue +end + +subroutine foobar () +entry bar () ! { dg-warning "ENTRY statement" } +end subroutine foobar Index: Fortran/gfortran/regression/pr88249.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88249.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + backspace (err=1) ! { dg-error "UNIT number missing" } + endfile (err=1) ! { dg-error "UNIT number missing" } + flush (err=1) ! { dg-error "UNIT number missing" } + rewind (err=1) ! { dg-error "UNIT number missing" } +end Index: Fortran/gfortran/regression/pr88269.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88269.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/88269 +program p + write (end=1e1) ! { dg-error "tag not allowed" } +end + Index: Fortran/gfortran/regression/pr88299.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88299.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! +! PR 85839: [F18] COMMON in a legacy module produces bogus warnings +! in dependent code + +module legacy + integer :: major, n + common /version/ major ! { dg-warning "obsolescent feature" } + public :: n + private +end module legacy + +module mod1 + use legacy, only: n ! No warning expected here +end module mod1 Index: Fortran/gfortran/regression/pr88326.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88326.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/88326 - ICE in gfc_conv_array_initializer + +program p + character, parameter :: x(3) = ['a','b','c'] + character :: y(1) = transfer('', x) ! { dg-error "Different shape for array assignment" } + character(0) :: z(1) = transfer('', x) ! { dg-error "Different shape for array assignment" } + character :: u(0) = transfer('', x) + print *, y, z, u +end Index: Fortran/gfortran/regression/pr88328.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88328.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/88328 +program p + character(3), parameter :: a(0) = [character(3)::] + print a ! { dg-error "zero-sized array" } +end Index: Fortran/gfortran/regression/pr88357_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88357_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +program p + type t + end type + class(t) :: x[*] ! { dg-error "must be dummy, allocatable or pointer" } + associate (y => x) + end associate +end Index: Fortran/gfortran/regression/pr88357_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88357_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +program p + type t + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + associate (y => x) + end associate +end Index: Fortran/gfortran/regression/pr88376.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88376.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +module m + integer :: n +contains + subroutine s + character(n(3)) :: c ! { dg-error "not a function" } + end +end Index: Fortran/gfortran/regression/pr88379.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88379.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR fortran/88379 - ICE with allocatable coarray, class and associate + +program p + type t + end type t + class(t), allocatable :: x[:] + associate (y => x) + end associate +end Index: Fortran/gfortran/regression/pr88467.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88467.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +program foo + print *, [integer :: 1, [integer(8) :: 2, '3']] ! { dg-error "Cannot convert" } +end program foo Index: Fortran/gfortran/regression/pr88611.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88611.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8 -fno-tree-forwprop -O3 -fno-tree-ccp" } +! PR 82869 +! A temp variable of type logical was incorrectly transferred +! to the I/O library as a logical type of a different kind. +program pr82869_8 + use, intrinsic :: iso_c_binding + type(c_ptr) :: p = c_null_ptr + character(len=4) :: s + write (s, *) c_associated(p), c_associated(c_null_ptr) + if (s /= ' F F') then + STOP 1 + end if +end program pr82869_8 Index: Fortran/gfortran/regression/pr88833.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88833.f90 @@ -0,0 +1,9 @@ +! { dg-do assemble { target aarch64_asm_sve_ok } } +! { dg-options "-O3 -march=armv8.2-a+sve --save-temps" } + +subroutine foo(x) + real :: x(100) + x = x + 10 +end subroutine foo + +! { dg-final { scan-assembler {\twhilelo\tp[0-9]+\.s, wzr, (w[0-9]+).*\twhilelo\tp[0-9]+\.s, w[0-9]+, \1} } } Index: Fortran/gfortran/regression/pr88902.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88902.f90 @@ -0,0 +1,6 @@ +! PR fortran/88902 +! { dg-do compile } +! { dg-require-effective-target lto } +! { dg-options "-flto --param ggc-min-heapsize=0" } + +include 'pr50069_2.f90' Index: Fortran/gfortran/regression/pr88932.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88932.f90 @@ -0,0 +1,143 @@ +! { dg-do compile } +! { dg-options "-O1 -fpredictive-commoning -fno-tree-ch -fno-tree-dominator-opts -fno-tree-fre" } +! +! PR tree-optimization/88932 +! + +implicit none + +interface + subroutine check_value(b, n, val) + integer :: b(..) + integer, value :: n + integer :: val(n) + end subroutine +end interface + +integer, target :: x(2:5,4:7), y(-4:4) +integer, allocatable, target :: z(:,:,:,:) +integer, allocatable :: val(:) +integer :: i + +allocate(z(1:4, -2:5, 4, 10:11)) + +if (rank(x) /= 2) STOP 1 +val = [(2*i+3, i = 1, size(x))] +x = reshape (val, shape(x)) +call foo(x, rank(x), lbound(x), ubound(x), val) +call foo2(x, rank(x), lbound(x), ubound(x), val) +call bar(x,x,.true.) +call bar(x,prsnt=.false.) + +if (rank(y) /= 1) STOP 2 +val = [(2*i+7, i = 1, size(y))] +y = reshape (val, shape(y)) +call foo(y, rank(y), lbound(y), ubound(y), val) +call foo2(y, rank(y), lbound(y), ubound(y), val) +call bar(y,y,.true.) +call bar(y,prsnt=.false.) + +if (rank(z) /= 4) STOP 3 +val = [(2*i+5, i = 1, size(z))] +z(:,:,:,:) = reshape (val, shape(z)) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo2(z, rank(z), lbound(z), ubound(z), val) +call bar(z,z,.true.) +call bar(z,prsnt=.false.) + +contains + subroutine bar(a,b, prsnt) + integer, pointer, optional, intent(in) :: a(..),b(..) + logical, value :: prsnt + if (.not. associated(a)) STOP 4 + if (present(b)) then + ! The following is not valid. + ! Technically, it could be allowed and might be in Fortran 2015: + ! if (.not. associated(a,b)) STOP 5 + else + if (.not. associated(a)) STOP 6 + end if + if (.not. present(a)) STOP 7 + if (prsnt .neqv. present(b)) STOP 8 + end subroutine + + ! POINTER argument - bounds as specified before + subroutine foo(a, rnk, low, high, val) + integer,pointer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + + + if (rank(a) /= rnk) STOP 9 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 10 + if (size(a) /= product (high - low +1)) STOP 11 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 12 + if (high(1) /= ubound(a,1)) STOP 13 + if (size (a,1) /= high(1)-low(1)+1) STOP 14 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 15 + if (high(i) /= ubound(a,i)) STOP 16 + if (size (a,i) /= high(i)-low(i)+1) STOP 17 + end do + call check_value (a, rnk, val) + call foo2(a, rnk, low, high, val) + end subroutine + + ! Non-pointer, non-allocatable bounds. lbound == 1 + subroutine foo2(a, rnk, low, high, val) + integer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 18 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 19 + if (size(a) /= product (high - low +1)) STOP 20 + + if (rnk > 0) then + if (1 /= lbound(a,1)) STOP 21 + if (high(1)-low(1)+1 /= ubound(a,1)) STOP 22 + if (size (a,1) /= high(1)-low(1)+1) STOP 23 + end if + + do i = 1, rnk + if (1 /= lbound(a,i)) STOP 24 + if (high(i)-low(i)+1 /= ubound(a,i)) STOP 25 + if (size (a,i) /= high(i)-low(i)+1) STOP 26 + end do + call check_value (a, rnk, val) + end subroutine foo2 + + ! ALLOCATABLE argument - bounds as specified before + subroutine foo3 (a, rnk, low, high, val) + integer, allocatable, intent(in), target :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 27 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 28 + if (size(a) /= product (high - low +1)) STOP 29 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 30 + if (high(1) /= ubound(a,1)) STOP 31 + if (size (a,1) /= high(1)-low(1)+1) STOP 32 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 33 + if (high(i) /= ubound(a,i)) STOP 34 + if (size (a,i) /= high(i)-low(i)+1) STOP 35 + end do + call check_value (a, rnk, val) + call foo(a, rnk, low, high, val) + end subroutine +end Index: Fortran/gfortran/regression/pr88934.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88934.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O -ftree-vectorize" } +! { dg-additional-options "-mvsx" { target powerpc*-*-* } } +integer, parameter :: a=3 + integer , dimension(a,a) :: b + logical, dimension(a,a) :: c + do i=0,1 + b = ltoi(c) + do j=0,if + if (anymatmul(b) /= 0) then + end if + end do + end do +contains + elemental function ltoi(d) + logical, intent(in) :: d + if (d) then + ltoi = 1 + else + ltoi = 0 + end if + end +end Index: Fortran/gfortran/regression/pr88964.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr88964.f90 @@ -0,0 +1,57 @@ +! PR tree-optimization/88964 +! { dg-do compile } +! { dg-options "-O3 -fno-tree-forwprop --param sccvn-max-alias-queries-per-access=1" } + +MODULE pr88964 + INTEGER, PARAMETER :: dp=8 + REAL(KIND=dp) :: p, q, o +CONTAINS + SUBROUTINE foo(a,b,c,f,h) + IMPLICIT NONE + INTEGER :: a, b, c + REAL(KIND=dp) :: f(b*c), h(a*c) + CALL bar(h) + CALL baz(f) + CALL qux(h) + END SUBROUTINE foo + SUBROUTINE bar(h) + IMPLICIT NONE + REAL(KIND=dp) :: h(1*1) + INTEGER :: r, s, t, u + DO u = 1,3 + DO t = 1,1 + DO s = 1,3 + DO r = 1,1 + h((t-1)*1+r) = h((t-1)*1+r)-p*o + END DO + END DO + END DO + END DO + END SUBROUTINE bar + SUBROUTINE baz(f) + IMPLICIT NONE + REAL(KIND=dp) :: f(3*1) + INTEGER :: s, t, u + DO u = 1,4 + DO t = 1,1 + DO s = 1,3 + f((t-1)*3+s) = f((t-1)*3+s) - q + END DO + END DO + END DO + END SUBROUTINE baz + SUBROUTINE qux(h) + IMPLICIT NONE + REAL(KIND=dp) :: h(1*1) + INTEGER :: r, s, t, u + DO u = 1,5 + DO t = 1,1 + DO s = 1,3 + DO r = 1,1 + h((t-1)*1+r) = h((t-1)*1+r)-p*o + END DO + END DO + END DO + END DO + END SUBROUTINE qux +END MODULE pr88964 Index: Fortran/gfortran/regression/pr89077.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89077.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! +! PR fortran/89077 - ICE using * as len specifier for character parameter + +program test + implicit none + integer :: i + character(*), parameter :: s = 'abcdef' + character(*), parameter :: t = transfer ([(s(i:i), i=1,len(s))], s) + if (len (t) /= len (s) .or. t /= s) stop 1 +end Index: Fortran/gfortran/regression/pr89084.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89084.f90 @@ -0,0 +1,23 @@ +! PR fortran/89084 +! { dg-do run } + +integer function foo () + write (*,*) 'foo' + block + integer, parameter :: idxs(3) = (/ 1, 2, 3 /) + integer :: i + foo = 0 + do i = 1, size(idxs) + foo = foo + idxs(i) + enddo + end block +end function foo +program pr89084 + integer :: i + interface + integer function foo () + end function + end interface + i = foo () + if (i.ne.6) stop 1 +end Index: Fortran/gfortran/regression/pr89253.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89253.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-fsplit-loops -fno-tree-dominator-opts -std=legacy -w" } + program jr + integer :: w5, pg, zh + w5 = 0 + write (w5) + assign 0002 to w5 + do pg = 1, 3 + if (pg .eq. 1) then + do zh = 1, pg + end do + else + goto w5 + 0001 zh = 0 + 0002 zh = 0 + assign 0001 to w5 + endif + end do + end Index: Fortran/gfortran/regression/pr89266.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89266.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR fortran/89266 - ICE with TRANSFER of len=0 character array constructor + +program test + implicit none + character(*), parameter :: n = '' + character(*), parameter :: o = transfer ([''], n) + character(*), parameter :: p = transfer ( n , n) + character(*), parameter :: q = transfer ([n], n) + character(6), save :: r = transfer ([''], n) + character(6), save :: s = transfer ( n , n) + character(6), save :: t = transfer ([n], n) + integer, parameter :: a(0) = 0 + integer, parameter :: b(0) = transfer (a, a) + integer, save :: c(0) = transfer (a, a) + if (len (o) /= 0) stop 1 + if (len (p) /= 0) stop 2 + if (len (q) /= 0) stop 3 + if (r /= "") stop 4 + if (s /= "") stop 5 + if (t /= "") stop 6 + if (size (b) /= 0 .or. any (b /= 0)) stop 7 + if (size (c) /= 0 .or. any (c /= 0)) stop 8 +end program test Index: Fortran/gfortran/regression/pr89344.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89344.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +program demo_setval + call setval(value) + write(*,*)'VALUE=',value + contains + subroutine setval(value) + class(*),intent(in) :: value + select type(value) + type is (integer) + value = 10 ! { dg-error "in variable definition context" } + type is (real) + value = 10.20 ! { dg-error "in variable definition context" } + end select + end subroutine setval +end program demo_setval Index: Fortran/gfortran/regression/pr89451.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89451.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2" } +program lh + call za(0) + call za(0) +contains + subroutine za(wl) + integer wl + wl = 1 + end subroutine za +end program lh Index: Fortran/gfortran/regression/pr89492.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89492.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/89492 - Endless compilation of an invalid TRANSFER after r269177 +! Test error recovery for invalid uses of TRANSFER +! Test proper simplification for MOLD with size 0 +! +! Derived from original testcase by Dominique d'Humieres + +program bug4a + implicit none + type bug4 +! Intentionally left empty + end type bug4 + integer, parameter :: k = size(transfer('',[''])) ! k = 0 + integer, parameter :: i = len (transfer('',[''])) ! i = 0 + integer, parameter :: l = len (transfer('', '' )) ! l = 0 + integer, parameter :: m(k) = k + integer, parameter :: j(i) = i + integer, parameter :: n(l) = l + print *, k,i,l,m,j,n + print *, transfer(1,['']) ! { dg-error "shall not have storage size 0" } + print *, transfer(1, '' ) ! No error + print *, size(transfer(1,[''])) ! { dg-error "shall not have storage size 0" } + print *, len (transfer(1, '' )) ! No error + print *, size(transfer([1],[bug4()])) ! { dg-error "shall not have storage size 0" } + print *, transfer(transfer([1],[bug4()]),[1]) ! { dg-error "shall not have storage size 0" } +end program bug4a Index: Fortran/gfortran/regression/pr89574.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89574.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! PR fortran/89574 - ICE in conv_function_val, at fortran/trans-expr.c:3792 + +module mod1 +contains + subroutine init + end subroutine +end module + +module mod2 +contains + subroutine init + end subroutine +end module + +module init + use mod1, only : test_init1 => init + use mod2, only : test_init2 => init + implicit none +contains + subroutine sub + call test_init1 + call test_init2 + call init + contains + subroutine init + end subroutine + end subroutine +end module Index: Fortran/gfortran/regression/pr89646.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89646.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR fortran/89646 +! Original testcase contributed by Ian Harvey +! +! This code use to give spurious warnings about aliasing. +! +module m + implicit none + type :: t + end type t + contains + ! To reproduce, both actual arguments must be TARGET, + ! both arguments must be of derived type. + subroutine s + type(t), target :: a(5) + type(t), target :: b(5) + call move(a, b) + end subroutine s + ! To reproduce, called procedure must be elemental. + elemental subroutine move(x, y) + type(t), intent(inout) :: x + type(t), intent(out) :: y + end subroutine move +end module m Index: Fortran/gfortran/regression/pr89647.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89647.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Code contributed by Ian Harvey + MODULE m1 + IMPLICIT NONE + PUBLIC :: False + PUBLIC :: True + CONTAINS + FUNCTION False() RESULT(b) + LOGICAL :: b + b = .FALSE. + END FUNCTION False + + FUNCTION True() RESULT(b) + LOGICAL :: b + b = .TRUE. + END FUNCTION True + END MODULE m1 + + MODULE m2 + USE m1 + IMPLICIT NONE + TYPE, ABSTRACT :: t_parent + CONTAINS + PROCEDURE(False), DEFERRED, NOPASS :: Binding + END TYPE t_parent + CONTAINS + SUBROUTINE s + TYPE, EXTENDS(t_parent) :: t_extension + CONTAINS + PROCEDURE, NOPASS :: Binding => True + END TYPE t_extension + END SUBROUTINE s + END MODULE m2 Index: Fortran/gfortran/regression/pr89664.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89664.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-Ofast" } + +subroutine s (x) + real :: x + call sub (x) +end +subroutine sub (x) + real :: x, y + logical :: a, b + real :: f1, f2, f3, f4 + y = f1() + a = .false. + if ( f2() > f3() ) a = .true. + b = .false. + if ( f2() > f4() ) b = .true. + if ( a ) then + x = 1.0 + else if ( b ) then + x = 1.0/y**2 + else + x = 1.0/y - y**2 + end if +end Index: Fortran/gfortran/regression/pr89943_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89943_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/89943 +! Code contributed by Alberto Luaces +module Foo_mod + + implicit none + + interface + module subroutine runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer(c_int32_t) , intent(in) :: ndim + end subroutine runFoo4C + end interface + + contains + +end module Foo_mod + +submodule(Foo_mod) Foo_smod + + contains + + module subroutine runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer(c_int32_t) , intent(in) :: ndim + end subroutine runFoo4C + +end submodule Foo_smod + Index: Fortran/gfortran/regression/pr89943_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89943_2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/89943 +! Code contributed by Alberto Luaces +module Foo_mod + + implicit none + + interface + module function runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer runFoo4c + integer(c_int32_t) , intent(in) :: ndim + end function runFoo4C + end interface + + contains + +end module Foo_mod + +submodule(Foo_mod) Foo_smod + + contains + + module function runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer runFoo4c + integer(c_int32_t) , intent(in) :: ndim + end function runFoo4C + +end submodule Foo_smod + Index: Fortran/gfortran/regression/pr89943_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89943_3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +module Foo_mod + + implicit none + + interface + module subroutine runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer(c_int32_t) , intent(in) :: ndim + end subroutine runFoo4C + end interface + + contains + +end module Foo_mod + +submodule(Foo_mod) Foo_smod + + contains + + module subroutine runFoo4C(ndim) bind(C, name="runFu") ! { dg-error "Mismatch in BIND" } + use, intrinsic :: iso_c_binding ! { dg-error "Unexpected USE statement" } + implicit none ! { dg-error "Unexpected IMPLICIT NONE statement" } + integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Unexpected data declaration" } + end subroutine runFoo4C ! { dg-error " Expecting END SUBMODULE" } + +end submodule Foo_smod Index: Fortran/gfortran/regression/pr89943_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89943_4.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +module Foo_mod + + implicit none + + interface + module function runFoo4C(ndim) bind(C, name="runFoo") + use, intrinsic :: iso_c_binding + implicit none + integer runFoo4c + integer(c_int32_t) , intent(in) :: ndim + end function runFoo4C + end interface + + contains + +end module Foo_mod + +submodule(Foo_mod) Foo_smod + + contains + + module function runFoo4C(ndim) bind(C, name="runFu") ! { dg-error "Mismatch in BIND" } + use, intrinsic :: iso_c_binding ! { dg-error "Unexpected USE statement in" } + implicit none ! { dg-error "Unexpected IMPLICIT NONE statement" } + integer(c_int32_t) , intent(in) :: ndim ! { dg-error "Unexpected data declaration" } + end function runFoo4C ! { dg-error "Expecting END SUBMODULE" } + +end submodule Foo_smod Index: Fortran/gfortran/regression/pr89956.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr89956.f90 @@ -0,0 +1,16 @@ +! { dg-options "-O3 -fno-tree-forwprop -fno-tree-pre -fno-tree-dominator-opts -fno-code-hoisting -ffast-math" } + +module de +contains + function zu (az, xx) result (q3) + real :: az, xx, q3 + + q3 = 1.0 - lz (az, xx) - lz (xx, az) + end function zu + + function lz (ho, gh) result (ye) + real :: ho, gh, ye + + ye = sqrt (ho) - ho * gh + end function lz +end module de Index: Fortran/gfortran/regression/pr90002.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90002.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! Contributed by Arseny Solokha +module pc + integer, dimension(1) :: zw[1:1,1:*] +end module pc Index: Fortran/gfortran/regression/pr90021.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90021.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fno-tree-loop-ivcanon -O1 -floop-interchange -fno-tree-ccp -fno-tree-ch -fipa-pta" } +! PR tree-optimization/90021 + +MODULE a + INTEGER b +CONTAINS + SUBROUTINE bar(c) + REAL c(1) + INTEGER g, d, e, f + DO g = 1,3 + DO f = 1,1 + DO e = 1,3 + DO d = 1,1 + c(f-1+d) = c(f-1+d)*b + END DO + END DO + END DO + END DO + END + END Index: Fortran/gfortran/regression/pr90290.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90290.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +program errorstop + integer :: ec + read *, ec + stop ec ! { dg-error "STOP code at " } +end program Index: Fortran/gfortran/regression/pr90344.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90344.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-ffrontend-optimize" } +! PR 90344 - this used to ICE. +! Test case by Urban Jost. +module M_xterm +contains + elemental function func1(ch) result(res) + character,intent(in) :: ch + logical :: res + res=.true. + end function func1 + elemental function func2(ch) result(res) + character,intent(in) :: ch + logical :: res + res=.false. + end function func2 + pure function s2a(string) RESULT (array) + character(len=*),intent(in) :: string + character(len=1) :: array(len(string)) + forall(i=1:len(string)) array(i) = string(i:i) + end function s2a + subroutine sub1() + write(*,*)all(func1(s2a('ABCDEFG')).or.func2(s2a('ABCDEFG'))) + end subroutine sub1 +end module M_xterm Index: Fortran/gfortran/regression/pr90385.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90385.f90 @@ -0,0 +1,6 @@ +! PR tree-optimization/90385 +! { dg-do compile } +! { dg-require-effective-target pthread } +! { dg-options "-O1 -ftree-parallelize-loops=2 -fno-tree-ccp -fno-tree-ch -fno-tree-copy-prop -fno-tree-forwprop -fno-tree-sink --param parloops-min-per-thread=5" } + +include 'array_constructor_47.f90' Index: Fortran/gfortran/regression/pr90985.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90985.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: datai,dataj + datai = a%i + dataj = a%j ! { dg-error "is not a member of the" } + end subroutine mysub +end module mymod Index: Fortran/gfortran/regression/pr90988_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90988_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: publici,publicj + publici = a%i + publicj = a%j ! { dg-error "is not a member" } + end subroutine mysub +end module mymod Index: Fortran/gfortran/regression/pr90988_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90988_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: privatei,privatej + privatei = a%i + privatej = a%j ! { dg-error "is not a member" } + end subroutine mysub +end module mymod Index: Fortran/gfortran/regression/pr90988_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90988_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: protectedi,protectedj + protectedi = a%i + protectedj = a%j ! { dg-error "is not a member" } + end subroutine mysub +end module mymod Index: Fortran/gfortran/regression/pr90988_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr90988_4.f @@ -0,0 +1,11 @@ +c { dg-do compile } +c { dg-require-visibility "" } + module foo + implicit none + real a,b,c + integer i,j,k + public a,b + publicc + private i,j + privatek + end module foo Index: Fortran/gfortran/regression/pr91003.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91003.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-Ofast" } + SUBROUTINE FOO(N, A, B, C, D, E, F, G) + COMPLEX A(*) + LOGICAL H + INTEGER G + REAL I, C, J, F, F1, F2, K, E, L, M, B, D + DO JC = 1, N + K = F*REAL(A(JC)) + Z = F*AIMAG(A(JC)) + H = .FALSE. + L = G + IF(ABS(Z).LT.D .AND. I.GE. MAX(D, B*C, B*J)) THEN + H = .TRUE. + L = (D / F1) / MAX(D, F2*I) + END IF + IF(ABS(K).LT.D .AND. C.GE. MAX(D, B*I, B*J)) THEN + L = MAX(L, (D / F1) / MAX(D, F2*C)) + END IF + IF(ABS(E).LT.D .AND. J.GE. MAX(D, B*C, B*I)) THEN + H = .TRUE. + L = MAX(L, (D / BNRM1) / MAX(D, BNRM2*J)) + END IF + IF(H) THEN + M = (L*D)*MAX(ABS(K), ABS(Z), ABS(E)) + END IF + IF(H) THEN + K = (L*REAL(A(JC)))*F + Z = (L*AIMAG(A(JC)))*F + END IF + A(JC) = CMPLX(K, Z) + END DO + END Index: Fortran/gfortran/regression/pr91296.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91296.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-Waliasing" } +! PR fortran/91296 +! Code contributed by Chinoune Mehdi +module m + implicit none + integer, parameter :: sp = selected_real_kind(6) + +contains + pure subroutine s(a,b,c) + real(sp), intent(in) :: a, b + real(sp), intent(out) :: c + c = a + b + end subroutine s +end module m + +program test + use m + implicit none + real(sp) :: a + complex(sp) :: c + + c = (1._sp,1._sp) + call s(c%re,c%im,a) ! *** This use to cause an ICE. *** + print*,a + +end program test Index: Fortran/gfortran/regression/pr91359_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91359_1.f @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/91359 +! Orginal code contributed by Brian T. Carcich +! + logical function zero() + goto 2 +1 return +2 zero = .false. + if (.not.zero) goto 1 + return + end + + program test_zero + logical zero + if (zero()) stop 1 + end Index: Fortran/gfortran/regression/pr91359_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91359_2.f @@ -0,0 +1,16 @@ +! { dg-do run } +! PR fortran/91359 +! Orginal code contributed by Brian T. Carcich +! + logical function zero() result(a) + goto 2 +1 return +2 a = .false. + if (.not.a) goto 1 + return + end + + program test_zero + logical zero + if (zero()) stop 1 + end Index: Fortran/gfortran/regression/pr91372.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91372.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! PR fortran/91372 +module module_sf_lake + implicit none + integer, parameter :: r8 = selected_real_kind(12) + integer, private :: i + real(r8) :: sand(2) ! percent sand + data(sand(i), i=1,2)/92.,80./ +end module module_sf_lake Index: Fortran/gfortran/regression/pr91471.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91471.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/91471 +! Code contributed by Sameeran Joshi +! +! This invalid code (x(1) is referenced, but never set) caused an ICE due +! to hitting a gfc_internal_error() in primary.c (gfc_variable_attr). The +! fix is to remove that gfc_internal_error(). +! +program dynamic + implicit none + integer, dimension(:), allocatable :: x + allocate(x(1)) + stop x(1) +end program dynamic Index: Fortran/gfortran/regression/pr91485.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91485.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +module foo + implicit none + interface operator(.x.) + module procedure product + end interface operator(.x.) + contains + function product(x, y) + real, intent(in) :: x, y + real :: product + product = x * y + end function product +end module foo + +module gfcbug155 + implicit none + contains + subroutine print_prod (x, y) + use foo, only : operator(.x.) + implicit none + real :: x, y + print *, x .x. y + end subroutine print_prod +end module gfcbug155 Index: Fortran/gfortran/regression/pr91496.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91496.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +subroutine foo (a, b, c, n) + implicit none + real a(*), b(*), c(*) + integer :: i, n + external bar +!DIR$ unroll (4) +!GCC$ unroll 4 + do i = 1, n + a(i) = b(i) + c(i) + end do +!DIR$ ivdep +!GCC$ ivdep + do i = 1, n + a(i) = b(i) + c(i) + end do +!DIR$ vector +!GCC$ vector + do i = 1, n + a(i) = b(i) + c(i) + end do +!DIR$ novector +!GCC$ novector + do i = 1, n + a(i) = b(i) + c(i) + end do +!GCC$ ivdep +!GCC$ vector + do i = 1, n + a(i) = b(i) + c(i) + end do +!DIR$ noinline +!GCC$ noinline ! { dg-warning "Unclassifiable GCC directive" } + call bar (a) +end subroutine foo +! { dg-final { scan-tree-dump-times "ANNOTATE_EXPR" 6 "original" } } Index: Fortran/gfortran/regression/pr91497.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91497.f90 @@ -0,0 +1,128 @@ +! { dg-do compile } +! { dg-require-effective-target fortran_real_10 } +! { dg-require-effective-target fortran_real_16 } +! { dg-options "-Wall" } +! Code contributed by Manfred Schwarb +! PR fortran/91497 +! +! Prior to applying the patch for this PR, the following code +! would generate numerous conversion warnings. +! +program foo + + real(4) a,aa + real(8) b,bb + real(10) c,cc + real(16) d + integer(2) e,ee + integer(4) f,ff + integer(8) g,gg + PARAMETER(a=3.1415927_4) + PARAMETER(b=3.1415927_8) + PARAMETER(c=3.1415927_10) + PARAMETER(d=3.1415927_16) + PARAMETER(e=123_2) + PARAMETER(f=123_4) + PARAMETER(g=123_8) + + aa=REAL(b) + aa=REAL(c) + aa=REAL(d) + aa=REAL(e) + aa=REAL(f) + aa=REAL(g) + aa=FLOAT(f) + aa=FLOOR(b) + aa=FLOOR(c) + aa=FLOOR(d) + aa=CEILING(b) + aa=CEILING(c) + aa=CEILING(d) + !---DEC specific type conversions (-fdec): + !!aa=FLOATI(e) + !!aa=FLOATJ(f) + !!aa=FLOATK(g) + aa=SNGL(c) + aa=SNGL(d) + bb=REAL(c, kind=8) + bb=REAL(d, kind=8) + bb=DBLE(c) + bb=DBLE(d) + bb=DFLOAT(g) + bb=FLOOR(c) + bb=FLOOR(d) + bb=CEILING(c) + bb=CEILING(d) + cc=REAL(d, kind=10) + cc=FLOOR(d) + cc=CEILING(d) + + aa=AINT(b) + aa=ANINT(b) + aa=AINT(c) + aa=ANINT(c) + aa=AINT(d) + aa=ANINT(d) + bb=DINT(b) + bb=DNINT(b) + + ee=INT(a, kind=2) + ee=NINT(a, kind=2) + ee=INT(b, kind=2) + ee=NINT(b, kind=2) + ee=INT(c, kind=2) + ee=NINT(c, kind=2) + ee=INT(d, kind=2) + ee=NINT(d, kind=2) + ee=INT(f, kind=2) + ee=INT(g, kind=2) + ee=IFIX(a) + ee=IDINT(b) + ee=IDNINT(b) + ee=INT2(a) + ee=INT2(b) + ee=INT2(c) + ee=INT2(d) + ee=INT2(f) + ee=INT2(g) + + ff=INT(a, kind=4) + ff=NINT(a, kind=4) + ff=INT(b, kind=4) + ff=NINT(b, kind=4) + ff=INT(c, kind=4) + ff=NINT(c, kind=4) + ff=INT(d, kind=4) + ff=NINT(d, kind=4) + ff=INT(f, kind=4) + ff=INT(g, kind=4) + ff=IFIX(a) + ff=IDINT(b) + ff=IDNINT(b) + !---LONG support got removed: + !!ff=LONG(a) + !!ff=LONG(b) + !!ff=LONG(c) + !!ff=LONG(d) + !!ff=LONG(g) + + gg=INT(a, kind=8) + gg=NINT(a, kind=8) + gg=INT(b, kind=8) + gg=NINT(b, kind=8) + gg=INT(c, kind=8) + gg=NINT(c, kind=8) + gg=INT(d, kind=8) + gg=NINT(d, kind=8) + gg=INT(f, kind=8) + gg=INT(g, kind=8) + gg=IFIX(a) + gg=IDINT(b) + gg=IDNINT(b) + gg=INT8(a) + gg=INT8(b) + gg=INT8(c) + gg=INT8(d) + gg=INT8(g) +end + Index: Fortran/gfortran/regression/pr91497_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91497_2.f90 @@ -0,0 +1,124 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! Code contributed by Manfred Schwarb +! PR fortran/91497 +! +! Prior to applying the patch for this PR, the following code +! would generate numerous conversion warnings. +! Additional test case to cover all targets. +! +program foo + + real(4) a, aa + real(8) b, bb + integer(2) e, ee + integer(4) f, ff + integer(8) g, gg + complex(4) ww + complex(8) xx + PARAMETER(a=3.1415927_4) + PARAMETER(b=3.1415927_8) + PARAMETER(e=123_2) + PARAMETER(f=123_4) + PARAMETER(g=123_8) + + aa=REAL(b) ! was: Change of value in conversion from 'REAL(8)' to 'REAL(4)' + aa=REAL(e) + aa=REAL(f) + aa=REAL(g) + aa=REAL(b, kind=4) ! was: Change of value in conversion from 'REAL(8)' to 'REAL(4)' + bb=REAL(a, kind=8) + + aa=FLOAT(f) + bb=DFLOAT(g) + aa=SNGL(b) ! was: Change of value in conversion from 'REAL(8)' to 'REAL(4)' + aa=AINT(a) + bb=AINT(b) + aa=AINT(b, kind=4) + bb=DINT(b) + aa=ANINT(a) + bb=ANINT(b) + aa=ANINT(b, kind=4) + bb=DNINT(b) + aa=AMAX0(f, f) + aa=AMIN0(f, f) + aa=AMAX0(g, g) + aa=AMIN0(g, g) + + ee=INT(a) + ee=INT(a, kind=2) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(2)' + ee=INT(b, kind=2) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(2)' + ee=INT(f, kind=2) + ee=INT(g, kind=2) + ff=INT(b) + ff=INT(a, kind=4) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(4)' + ff=INT(b, kind=4) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(4)' + ff=INT(f, kind=4) + ff=INT(g, kind=4) + gg=INT(a) + gg=INT(a, kind=8) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(8)' + gg=INT(b, kind=8) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(8)' + gg=INT(f, kind=8) + gg=INT(g, kind=8) + + ee=IFIX(a) + ff=IFIX(a) + gg=IFIX(a) + ee=IDINT(b) + ff=IDINT(b) + gg=IDINT(b) + ee=INT2(a) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(2)' + ee=INT2(b) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(2)' + ee=INT2(f) + ee=INT2(g) + gg=INT8(a) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(8)' + gg=INT8(b) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(8)' + gg=INT8(f) + gg=INT8(g) + + ff=FLOOR(b) + ee=FLOOR(b, kind=2) + ff=FLOOR(b, kind=4) + gg=FLOOR(b, kind=8) + ff=CEILING(b) + ee=CEILING(b, kind=2) + ff=CEILING(b, kind=4) + gg=CEILING(b, kind=8) + ff=MAX1(a, a) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(4)' + ff=MIN1(a, a) ! was: Change of value in conversion from 'REAL(4)' to 'INTEGER(4)' + gg=MAX1(b, b) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(4)' + gg=MIN1(b, b) ! was: Change of value in conversion from 'REAL(8)' to 'INTEGER(4)' + + ee=NINT(a, kind=2) + ee=NINT(b, kind=2) + ff=NINT(a) + ff=NINT(b) + ff=NINT(a, kind=4) + ff=NINT(b, kind=4) + gg=NINT(a, kind=8) + gg=NINT(b, kind=8) + ee=IDNINT(b) + ff=IDNINT(b) + gg=IDNINT(b) + + ww=COMPLEX(a, a) + ww=COMPLEX(e, e) + ww=COMPLEX(g, g) + ww=COMPLEX(a, g) + xx=COMPLEX(b, g) + ww=CMPLX(a, a) + ww=CMPLX(b, b, kind=4) + xx=CMPLX(a, a, kind=8) + + aa=REAL(ww) + bb=REAL(xx) + aa=REALPART(ww) + bb=REALPART(xx) + aa=AIMAG(ww) + bb=AIMAG(xx) + aa=IMAG(ww) + bb=IMAG(xx) + bb=DIMAG(xx) + aa=IMAGPART(ww) + bb=IMAGPART(xx) +end Index: Fortran/gfortran/regression/pr91552.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91552.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR fortran/91552 +! Code contributed by Gerhard Steinmetz. +program p + real :: y(3), z(4) + y = 2.0 * [real :: 1, [2], 3] + z = 2.0 * [real :: 1, [2, [4]], 3] + if (any(y /= [2., 4., 6.])) stop 1 + if (any(z /= [2., 4., 8., 6.])) stop 2 +end Index: Fortran/gfortran/regression/pr91553.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91553.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! Code contributed by Gerhard Steinmetz +program p + complex z(1) + z = (1.0, 2.0) * [real :: (3.0 + 4.0)] + if (real(z(1)) /= 7.) stop 1 + if (aimag(z(1)) /= 14.) stop 2 +end Index: Fortran/gfortran/regression/pr91564.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91564.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/91564 +! Contributed by Gerhard Steinmetz. +program p + integer i, j + call kill (1, 2, 3) ! { dg-error "shall be an INTENT" } + i = 42 + call bar(i, j) +end + +subroutine bar(n, m) + integer, intent(in) :: n + integer, intent(inout) :: m + call kill (1, 3, n) ! { dg-error "shall be an INTENT" } + call kill (1, 3, m) +end subroutine bar Index: Fortran/gfortran/regression/pr91565.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91565.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/91565 +! Contributed by Gerhard Steinmetz +program p + integer, parameter :: a(2) = [2,2] + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "ORDER at .1. is not a permutation of the size of SHAPE at .2." } +end + +subroutine foo + integer, parameter :: a(1) = 1 + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" } +end + +subroutine bar + integer, parameter :: a(1,2) = 1 + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "are different" } +end Index: Fortran/gfortran/regression/pr91566.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91566.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Code contributed by Gerhard Steinmetz +program p + call q + call r +end program p + +subroutine q + print *, -merge([3,4], 0, [.false.,.true.]) +end + +subroutine r + print *, 2 + merge([3,4], 0, [.false.,.true.]) +end Index: Fortran/gfortran/regression/pr91568.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91568.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Ofast" } + subroutine h3dall(z,hvec,hder,nterms) + complex *16 hvec(0:1),hder(0:1) + complex *16 z,zinv,ztmp/1.0/ + zinv=1.0/z + do i=1,nterms + ztmp=zinv*i + hder(i)=hvec(i-1)-ztmp*hvec(i) + enddo + end Index: Fortran/gfortran/regression/pr91577.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91577.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-additional-options "--param max-completely-peel-loop-nest-depth=1" } +! PR 27662. Don't zero the first stride to indicate a temporary. It +! may be used later. +program pr27662 + implicit none + real(kind=kind(1.0d0)), dimension (2, 2):: x, y, z; + integer i, j + x(1,1) = 1.d0 + x(2,1) = 0.d0 + x(1,2) = 0.d0 + x(2,2) = 1.d0 + z = matmul (x, transpose (test ())) + do i = 1, size (x, 1) + do j = 1, size (x, 2) + if (x (i, j) .ne. z (i, j)) STOP 1 + end do + end do + +contains + function test () result (res) + real(kind=kind(1.0d0)), dimension(2,2) :: res + res(1,1) = 1.d0 + res(2,1) = 0.d0 + res(1,2) = 0.d0 + res(2,2) = 1.d0 + end function +end Index: Fortran/gfortran/regression/pr91587.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91587.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/91587 +! Code contributed by Gerhard Steinmetz +program p + backspace(err=!) ! { dg-error "Invalid value for" } + flush(err=!) ! { dg-error "Invalid value for" } + rewind(err=!) ! { dg-error "Invalid value for" } +end + +subroutine bar ! An other matcher runs, and gives a different error. + endfile(err=!) ! { dg-error "Expecting END" } +end Index: Fortran/gfortran/regression/pr91589.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91589.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Check the fix for PR91589, in which the invalid expression caused an ICE. +! Other statements using this invalid expression cause "Unclassifiable statement at..." +! +! Contributed by Gerhardt Steinmetz +! +program p + type t + integer :: a + end type + type(t) :: x = t(1) + call sub (x%a%a) ! { dg-error "is not an inquiry reference" } +end + Index: Fortran/gfortran/regression/pr91641.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91641.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/91641 +! Code conyributed by Gerhard Steinmetz +program p + real, pointer :: z(:) + print *, is_contiguous (null(z)) ! { dg-error "shall be an associated" } +end Index: Fortran/gfortran/regression/pr91642.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91642.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/91642 +! Code contributed by Gerhard Steinmetz +program p + integer i + integer :: iol + integer, external :: null + i = 0 + inquire (iolength=iol) null() + if (iol == 4) stop 1 +end + +subroutine q + integer i + integer :: iol + i = 0 + inquire (iolength=iol) i, null() ! { dg-error "cannot appear in INQUIRE" } + if (iol == 4) stop 2 +end Index: Fortran/gfortran/regression/pr91649.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91649.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/91649 +! Code originally contributed by Gerhard Steinmetz +subroutine p + logical :: back = .true. + integer :: x(1) = findloc([1, 2, 1], '1', back=back) ! { dg-error "must be in type conformance" } + print *, x +end + +subroutine q + type t + end type + logical :: back = .false. + integer :: x(1) = findloc([1, 2, 1], t(), back=back) ! { dg-error "must be of intrinsic type" } + print *, x +end + +subroutine s + character(4) :: c = '1234' + integer :: x(1) = findloc([1, 2, 1], c, back=.true.) ! { dg-error "must be in type conformance" } + print *, x +end + Index: Fortran/gfortran/regression/pr91650_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91650_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/91650 +! Code contributed by Gerhard Steinmetz. +program p + print *, b'10110' ! { dg-error "cannot appear in an output IO list" } + print *, o'10110' ! { dg-error "cannot appear in an output IO list" } + print *, z'10110' ! { dg-error "cannot appear in an output IO list" } +end Index: Fortran/gfortran/regression/pr91650_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91650_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fallow-invalid-boz" } +! PR fortran/91650 +! Code contributed by Gerhard Steinmetz. +program p + character(len=60) str + write(str,*) b'10110' ! { dg-warning "cannot appear in an output IO list" } + if (trim(adjustl(str)) /= '22') stop 1 + write(str,*) o'10110' ! { dg-warning "cannot appear in an output IO list" } + if (trim(adjustl(str)) /= '4168') stop 2 + write(str,*) z'10110' ! { dg-warning "cannot appear in an output IO list" } + if (trim(adjustl(str)) /= '65808') stop 3 +end Index: Fortran/gfortran/regression/pr91660_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91660_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/91660 +! Code contributed by Gerhard Steinmetz +program p + type t + end type + type (t x ! { dg-error "Malformed type-spec" } + x = t() ! { dg-error "Cannot convert" } +end Index: Fortran/gfortran/regression/pr91660_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91660_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/91660 +program foo + type(doubleprecision :: x ! { dg-error "Malformed type-spec" } + type(double precision :: y ! { dg-error "Malformed type-spec" } + type(character(len=3) :: a ! { dg-error "Malformed type-spec" } + type(doublecomplex :: b ! { dg-error "Malformed type-spec" } + type(double complex :: c ! { dg-error "Malformed type-spec" } +end program foo Index: Fortran/gfortran/regression/pr91661.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91661.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR fortran/91661 +! Contributed by Gerhard Steinmetz +! Verify that fix for PR92996 also fixes this one +program p + integer, parameter :: a(2) = 2 + integer, parameter :: b(a(1)) = 3 + integer, parameter :: c = dot_product(b, b) + integer, parameter :: d(a(1)+a(2)) = 3 + integer, parameter :: e = size (d,dim=1) + if (c /= 18) stop 1 ! This used to ICE + if (e /= 4) stop 2 ! This used to ICE +end Index: Fortran/gfortran/regression/pr91714.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91714.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Contributed by Gerhard Steinmetz +program p + typea ! { dg-error "Mangled derived type" } + integer b + end type ! { dg-error "Expecting END PROGRAM" } + type(a) :: c ! { dg-error "is being used before it" } + c = a(1) + print *, c +end Index: Fortran/gfortran/regression/pr91715.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91715.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/91715 +! Code contributed Gerhard Steinmetz +character(1function f() ! { dg-error "Syntax error in CHARACTER" } +end Index: Fortran/gfortran/regression/pr91716.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91716.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/91716 +! Code contributed by Gerhard Steinmetz +module m + type t + character :: c(2) = [character(-1) :: 'a', 'b'] + end type +end Index: Fortran/gfortran/regression/pr91727.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91727.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Code contributed by Gerhard Steinmetz. +program p + type t + class(*), allocatable :: a + end type + type(t) :: x + allocate (x%a, source=[1]) ! { dg-error "have the same rank as" } +end Index: Fortran/gfortran/regression/pr91784.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91784.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR fortran/91784 +! Code originally contributed by Gerhard Steinmetz +program p + complex :: x(1) + x = (1.0, 2.0) * [real :: -(3.0 + 4.0)] + if (int(real(x(1))) /= -7) stop 1 + if (int(aimag(x(1))) /= -14) stop 2 +end Index: Fortran/gfortran/regression/pr91785.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91785.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/91785 +! Code contributed by Gerhard Steinmetz +program p + complex :: a(*) ! { dg-error "Assumed size array at" } + real :: b(2) + b = a%im ! { dg-error "upper bound in the last dimension" } +end Index: Fortran/gfortran/regression/pr91801.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91801.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/91801 +! Code contributed by Gerhard Steinmetz +program p + integer, parameter :: a(2) = [2,0] + print *, reshape([1,2,3,4,5,6], [2,3], order=a) ! { dg-error "Element with a value of 0 in ORDER at .1. must be in the range .1, ..., 2. for the RESHAPE intrinsic near .2." } +end Index: Fortran/gfortran/regression/pr91802.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91802.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! Code contributed by Gerhard Steinmetz +! PR fortran/91802 +module m + real :: x + dimension :: x(1,2,1,2,1,2,1,2) + codimension :: x[1,2,1,2,1,2,1,*] ! { dg-error "exceeds 15" } +end Index: Fortran/gfortran/regression/pr91862.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91862.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Check that PR91862 remains fixed by patch for PRs 96100/101. +! +! Contributed by Gerhard Steinmetz <>gscfq@t-online.de> +! + call foo + call bar +contains + + subroutine foo + integer :: i + character(3) :: a(3) = 'abc' + character(1) :: b(1) + b = [([ (a(1)(i:1), i=1,1) ])] + print *, b + end subroutine + + subroutine bar + integer :: i + character(3) :: a(3) = 'abc' + character(1) :: b(1) + b = [([ (a(1)(1:i), i=1,1) ])] + print *, b + end subroutine +end Index: Fortran/gfortran/regression/pr91864.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91864.f90 @@ -0,0 +1,22 @@ +program p + integer :: i + read (*,*) i%kind ! { dg-error "Expecting variable or io-implied-do" } +end + +subroutine t + integer, allocatable :: x(:) + integer :: stat + allocate (x(3), stat=stat%kind) ! { dg-error "cannot be a constant" } +end + +subroutine u + integer, allocatable :: x(:) + integer :: stat + allocate (x(3), stat%kind=stat) ! { dg-error "Unexpected constant" } +end + +subroutine v + integer, allocatable :: x(:) + integer :: stat + deallocate (x, stat%kind=stat) ! { dg-error "Unexpected constant" } +end Index: Fortran/gfortran/regression/pr91913.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91913.f90 @@ -0,0 +1,5 @@ +! PR target/91913 +! { dg-do compile } +! { dg-options "-std=legacy -Ofast --param max-cse-insns=0 -fno-schedule-insns -fsanitize=null" } + +include 'string_ctor_1.f90' Index: Fortran/gfortran/regression/pr91942.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91942.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/91942 +! Code contributed by Gerhard Steinmetz +program p + integer :: i + backspace (iostat=i%kind) ! { dg-error "Expecting a variable at" } + endfile (iostat=i%kind) ! { dg-error "Expecting END PROGRAM" } + flush (iostat=i%kind) ! { dg-error "Expecting a variable at" } + rewind (iostat=i%kind) ! { dg-error "Expecting a variable at" } +end Index: Fortran/gfortran/regression/pr91943.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91943.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/91943 +! Code contributed by Gerhard Steinmetz +program p + print *, f(b'1001') ! { dg-error "cannot appear as an actual argument" } + call sub(b'1001') ! { dg-error "cannot appear as an actual argument" } +end Index: Fortran/gfortran/regression/pr91945.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91945.f90 @@ -0,0 +1,5 @@ +! PR tree-optimization/91945 +! { dg-do compile } +! { dg-options "-O3 -fstack-arrays -fno-guess-branch-probability" } + +include 'result_in_spec_1.f90' Index: Fortran/gfortran/regression/pr91959.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr91959.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/91959 +! Code contributed by Gerhard Steinmetz +program p + implicit none + integer :: %a ! { dg-error "Invalid character" } + a = 1 ! { dg-error "has no IMPLICIT type" } + print *, a +end Index: Fortran/gfortran/regression/pr92018.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92018.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/92018 +subroutine sub (f) + integer :: f + print *, f(b'11') ! { dg-error "cannot appear as an actual" } + print *, f(o'11') ! { dg-error "cannot appear as an actual" } + print *, f(z'11') ! { dg-error "cannot appear as an actual" } +end Index: Fortran/gfortran/regression/pr92019.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92019.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/92019 +program foo + integer :: a(4) = [1, 2, 3, 4] + print *, a(z'1') ! { dg-error "Invalid BOZ literal constant" } + print *, a(1:z'3') ! { dg-error "Invalid BOZ literal constant" } + print *, a(1:2:z'2') ! { dg-error "Invalid BOZ literal constant" } + print *, a([z'2',z'1']) ! { dg-error "cannot appear in an array constructor" } +end program foo Index: Fortran/gfortran/regression/pr92050.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92050.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! { dg-shouldfail "above upper bound" } +! +! PR fortran/92050 +! +! +module buggy + implicit none (type, external) + + type :: par + contains + procedure, public :: fun => fun_par + end type par + + type comp + class(par), allocatable :: p + end type comp + + type foo + type(comp), allocatable :: m(:) + end type foo + +contains + + function fun_par(this) + class(par) :: this + integer :: fun_par(1) + fun_par = 42 + end function fun_par + + subroutine update_foo(this) + class(foo) :: this + write(*,*) this%m(1)%p%fun() + end subroutine update_foo + + subroutine bad_update_foo(this) + class(foo) :: this + write(*,*) this%m(2)%p%fun() + end subroutine bad_update_foo +end module buggy + +program main + use buggy + implicit none (type, external) + type(foo) :: x + allocate(x%m(1)) + allocate(x%m(1)%p) + call update_foo(x) + call bad_update_foo(x) +end program main + +! { dg-output "At line 39 of file .*pr92050.f90.*Fortran runtime error: Index '2' of dimension 1 of array 'this%m' above upper bound of 1" } Index: Fortran/gfortran/regression/pr92094.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92094.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-O3" } + subroutine hesfcn(n, x, h, ldh) + integer n,ldh + double precision x(n), h(ldh) + + integer i,j,k,kj + double precision th,u1,u2,v2 + + kj = 0 + do 770 j = 1, n + kj = kj - j + do 760 k = 1, j + kj = kj + 1 + v2 = 2 * x(k) - 1 + u1 = 0 + u2 = 2 + do 750 i = 1, n + h(kj) = h(kj) + u2 + th = 4 * v2 + u2 - u1 + u1 = u2 + u2 = th + th = v2 - 1 + 750 continue + 760 continue + 770 continue + + end Index: Fortran/gfortran/regression/pr92161.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92161.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O1 -ftree-loop-vectorize -fno-signed-zeros -fno-trapping-math" } +! { dg-additional-options "-mvsx" { target { powerpc*-*-* } } } + COMPLEX FUNCTION R1 (ZR, CC, EA, U6) + + INTEGER ZR, U6, FZ, J2 + COMPLEX EA(*), CC + DOUBLE PRECISION OS, GA, YU, XT + + OS = DBLE(REAL(CC)) + GA = DBLE(AIMAG(CC)) + J2 = 1 + + DO 5 FZ = 1, ZR + YU = DBLE(REAL(EA(J2))) + XT = DBLE(AIMAG(EA(J2))) + OS = OS + (YU * 2) - (XT * 2) + GA = GA + (YU * 3) + (XT * 3) + J2 = J2 + U6 + 5 CONTINUE + R1 = CMPLX(REAL(OS), REAL(GA)) + RETURN + END Index: Fortran/gfortran/regression/pr92208.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92208.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/92208 +! +! Contributed by Nils Reiche +! +program stringtest + implicit none + integer, parameter :: noVars = 2 + +! print*, "varNames: ", createVarnames("var",noVars) + call function1(noVars,createVarnames("var",noVars),"path") + +contains + +function createVarnames(string,noVars) result(stringArray) + implicit none + character(len=*), intent(in) :: string + integer, intent(in) :: noVars + character(len=len_trim(string)+6), dimension(noVars) :: stringArray + integer :: i + do i=1,noVars + write(stringArray(i),'(a,i0)') string, i + enddo +end function createVarnames + +subroutine function1(noVars,varNames,path) + implicit none + integer, intent(in) :: noVars + character(len=*), intent(in) :: path + character(len=*), dimension(noVars) :: varNames + + if (path /= 'path') stop 1 + if (any(varNames /= ['var1', 'var2'])) stop 2 + !print*, "function1-path : ", trim(path) + !print*, "function1-varNames: ", varNames +end subroutine function1 + +end program stringtest Index: Fortran/gfortran/regression/pr92277.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92277.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR fortran/92277 +! +! Contributed by José Rui Faustino de Sousa +! +module arr_m + implicit none +contains + subroutine arr_set(this, that) + integer, intent(out) :: this(..) + integer, optional, intent(out) :: that(..) + + interface + subroutine arr_set_c(this) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + implicit none + integer(kind=c_int), intent(out) :: this(..) + end subroutine arr_set_c + subroutine arr_set_c_opt(this) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + implicit none + integer(kind=c_int), optional, intent(out) :: this(..) + end subroutine arr_set_c_opt + end interface + + call arr_set_c(this) + call arr_set_c(that) + call arr_set_c_opt(this) + call arr_set_c_opt(that) + end subroutine arr_set +end module arr_m Index: Fortran/gfortran/regression/pr92537.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92537.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-vectorize -fno-inline" } +! { dg-additional-options "-march=skylake" { target x86_64-*-* i?86-*-* } } +MODULE pr93527 + implicit none + integer, parameter :: wp = kind (1.d0) + interface p_min + module procedure p_min_wp + end interface +contains + subroutine foo (pr) + real(wp), pointer :: pr(:) + integer :: nzd + real(wp) :: pmin + real(wp) :: pmin_diag + integer :: i + nzd = 15 + allocate (pr(nzd)) + pmin_diag = 4000._wp + pmin = p_min(pmin_diag) + pmin = min (pmin,pmin_diag) + pr(1) = log(pmin) + do i=1,nzd-1 + pr(i+1) = log(pmin) + i + end do + end subroutine foo + function p_min_wp (x) result (p_min) + real(wp), intent(in) :: x + real(wp) :: p_min + p_min = x + end function p_min_wp +end module pr93527 Index: Fortran/gfortran/regression/pr92629.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92629.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! +! Test the fix for PR92629. +program bge_tests + if (bge (huge (1_1), 128_1)) stop 1 + if (bge ( 128_1 , 255_1)) stop 2 + if (bge (huge (1_2), 32768_2)) stop 3 + if (bge (huge (1_4), 2147483648_4)) stop 4 + if (bge (huge (1_8), 9223372036854775808_8)) stop 5 +end program Index: Fortran/gfortran/regression/pr92781.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92781.f90 @@ -0,0 +1,11 @@ +! PR fortran/92781 +! { dg-do compile } + +function foo () + character(:), allocatable :: foo + call bar () + foo = 'abc' +contains + subroutine bar + end +end Index: Fortran/gfortran/regression/pr92874.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92874.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2" } +! PR fortran/92874 +program p + call s('a') + call s('abc') +end +subroutine s(x) + character(*) :: x + print *, (x(1:1) == x(1:)) +end Index: Fortran/gfortran/regression/pr92882.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92882.f @@ -0,0 +1,4 @@ +C PR rtl-optimization/92882 +C { dg-do compile } +C { dg-options "-O2 -fno-inline" } + INCLUDE 'secnds.f' Index: Fortran/gfortran/regression/pr92897.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92897.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! Test contributed by Gerhard Steinmetz +type(t) function f() ! { dg-error "has not been declared" } + dimension :: t(1,2,1,2,1,2,1,2) + codimension :: t[1,2,1,2,1,2,1,*] ! { dg-error "rank \\+ corank of" } +end +! { dg-prune-output "which has not been defined" } Index: Fortran/gfortran/regression/pr92898.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92898.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/92898 +! Code contributed by Gerhard Steinmetz +program p + print *, is_contiguous (null()) ! { dg-error "shall be an associated" } +end Index: Fortran/gfortran/regression/pr92990.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92990.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/92990 +! Verify fix of error message for NULLIFY vs. pointer assignment (PR70853) +program p + integer, pointer :: x(:) + type t + integer, pointer :: y(:) + end type t + type(t) :: z + nullify (x(1:2)) ! { dg-error "does not allow bounds remapping" } + nullify (z%y(:)) ! { dg-error "does not allow bounds remapping" } +end Index: Fortran/gfortran/regression/pr92993.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr92993.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Original by G. Steinmetz + +function f(x) + integer, intent(in) :: x + integer :: f + f = x +end + +program p + interface + function f(x) ! { dg-error "POINTER attribute mismatch in function result" } + integer, intent(in) :: x + integer, pointer :: f + end + end interface + integer :: a(2) = [1, 2] + if ( a(2) .ne. f(a(2)) ) stop 1 +end + Index: Fortran/gfortran/regression/pr93263_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93263_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -fdump-tree-original" } +! +! Test contributed by Mark Eggleston + +program main + implicit none + call check(2) +end + +recursive subroutine check(n) + implicit none + integer n, a + a = 10 + print*,"n=",n + if (n==1) then + a=a-1 + print*,"assigning a=",a + else + a=a-2 + print*,"assigning a=",a + call check(n-1) + endif + print*,"a=",a +end + +! { dg-final { scan-tree-dump-not "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "integer\\(kind=4\\) a" "original" } } + Index: Fortran/gfortran/regression/pr93263_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93263_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! Test contributed by Tobias Burnus + + integer :: cnt + cnt = 0 + call sub() + if (cnt /= 5) stop 1 +contains + recursive subroutine sub() + save + logical :: first = .true. + integer :: i + cnt = cnt + 1 + if (first) then + first = .false. + i = 1 + end if + print *, "Hello", i + i = i + 1 + if (i <= 5) call sub() + end subroutine +end + Index: Fortran/gfortran/regression/pr93337.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93337.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/93337 - ICE in gfc_dt_upper_string, at fortran/module.c:441 + +program p + type t + character(:), allocatable :: a + end type t + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + x = x ! { dg-error "must not be polymorphic in intrinsic assignment" } +end Index: Fortran/gfortran/regression/pr93364.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93364.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/93364 - check fix for ICE in gfc_set_array_spec + +type(t) function f() + codimension :: t[1,2,1,2,1,2,1,*] + dimension :: t(1,2,1,2,1,2,1,2) +end + +! { dg-error "has not been declared" " " { target *-*-* } 6 } +! { dg-error "is of type 't'" " " { target *-*-* } 6 } +! { dg-error "rank \\+ corank of" " " { target *-*-* } 8 } Index: Fortran/gfortran/regression/pr93365.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93365.f90 @@ -0,0 +1,15 @@ +! { dg-do run } + +program p + logical, parameter :: a(0) = .true. + real, parameter :: b(0) = 0 + complex, parameter :: c(0) = 0 + integer :: d + data d /a%kind/ + data e /b%kind/ + data f /c%kind/ + if (d .ne. kind(a)) stop 1 + if (e .ne. kind(b)) stop 2 + if (f .ne. kind(c)) stop 3 +end + Index: Fortran/gfortran/regression/pr93366.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93366.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument + +program p + print *, kind (null()) ! { dg-error "NULL at" } + print *, [ merge(null(), [1] ,.true.) ] ! { dg-error "NULL at" } + print *, [ merge([1] , null(),.true.) ] ! { dg-error "NULL at" } + print *, [ merge(null(), null(),.true.) ] ! { dg-error "NULL at" } + print *, shape (null()) ! { dg-error "NULL at" } + print *, sizeof (null()) ! { dg-error "NULL at" } + print *, spread (null(),1,1) ! { dg-error "NULL at" } + print *, transfer ( 1 , null()) ! { dg-error "NULL at" } + print *, transfer ([1], null()) ! { dg-error "NULL at" } + print *, transfer (null(), 1) ! { dg-error "NULL at" } + print *, transfer (null(), [1]) ! { dg-error "NULL at" } + print *, transfer (null(), null()) ! { dg-error "NULL at" } +end Index: Fortran/gfortran/regression/pr93423.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93423.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/93423 - ICE on invalid with argument list for module procedure + +module t + type :: b + contains + procedure :: p => bp + end type b + interface + module function bp(s) + class(b), intent(inout) :: s + integer, pointer :: bp + end function + end interface +end module t + +submodule (t) ts +contains + module procedure bp(s) ! { dg-error "must be in a generic module interface" } + end procedure bp ! { dg-error "Expecting END SUBMODULE statement" } +end submodule ts Index: Fortran/gfortran/regression/pr93461.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93461.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/93461 +module aModuleWithAnAllowedName + interface + module subroutine aShortName() + end subroutine aShortName + end interface +end module aModuleWithAnAllowedName + +submodule (aModuleWithAnAllowedName) aSubmoduleWithAVeryVeryVeryLongButEntirelyLegalName +contains + subroutine aShortName() + call aSubroutineWithAVeryLongNameThatWillCauseAProblem() + call aSubroutineWithAVeryLongNameThatWillCauseAProblemAlso() + end subroutine aShortName + + subroutine aSubroutineWithAVeryLongNameThatWillCauseAProblem() + end subroutine aSubroutineWithAVeryLongNameThatWillCauseAProblem + + subroutine aSubroutineWithAVeryLongNameThatWillCauseAProblemAlso() + end subroutine aSubroutineWithAVeryLongNameThatWillCauseAProblemAlso +end submodule aSubmoduleWithAVeryVeryVeryLongButEntirelyLegalName Index: Fortran/gfortran/regression/pr93473.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93473.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-ffree-line-length-none" } +! PR fortran/93473 +module aModestlyLongModuleName + + type :: aTypeWithASignificantlyLongNameButStillAllowedOK + end type aTypeWithASignificantlyLongNameButStillAllowedOK + + interface + module function aFunctionWithALongButStillAllowedName(parameters) result(self) + type(aTypeWithASignificantlyLongNameButStillAllowedOK) :: self + end function aFunctionWithALongButStillAllowedName + end interface + +end module aModestlyLongModuleName + +submodule (aModestlyLongModuleName) aTypeWithASignificantlyLongNameButStillAllowedOK_ + +contains + + module procedure aFunctionWithALongButStillAllowedName + class(*), pointer :: genericObject + end procedure aFunctionWithALongButStillAllowedName + +end submodule aTypeWithASignificantlyLongNameButStillAllowedOK_ + +submodule (aModestlyLongModuleName:aTypeWithASignificantlyLongNameButStillAllowedOK_) aSubmoduleWithASignificantlyLongButStillAllowedName__ +end submodule aSubmoduleWithASignificantlyLongButStillAllowedName__ Index: Fortran/gfortran/regression/pr93484_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93484_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +program p + implicit none + integer :: x(4) = [1,2,3,4] + print *, [real(x(k))] ! { dg-error "Symbol 'k' at .1. has no IMPLICIT type" } +end + Index: Fortran/gfortran/regression/pr93484_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93484_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +program p + implicit none + integer, parameter :: x(4) = [1,2,3,4] + print *, [real(x(k))] ! { dg-error "Symbol 'k' at .1. has no IMPLICIT type" } +end + Index: Fortran/gfortran/regression/pr93486.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93486.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/93486 +module ivs + interface l + module procedure l_ + end interface l +contains + function l_() + end function l_ +end module ivs + +module aModeratleyLongModuleName + use ivs + interface + module subroutine cmo() + end subroutine cmo + end interface +end module aModeratleyLongModuleName + +submodule (aModeratleyLongModuleName) aNameForASubmoduleThatIsVeryLongButWhichIsLegalStill +contains + module procedure cmo + end procedure cmo +end submodule aNameForASubmoduleThatIsVeryLongButWhichIsLegalStill + +submodule (aModeratleyLongModuleName:aNameForASubmoduleThatIsVeryLongButWhichIsLegalStill) sb +end submodule sb + +submodule (aModeratleyLongModuleName:sb) sc +end submodule sc Index: Fortran/gfortran/regression/pr93497.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93497.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } + +program p + print *, [character(((/1/))) :: 'a','b'] ! { dg-error "Scalar INTEGER expression expected" } + print *, [character(([1])) :: 'a','b'] ! { dg-error "Scalar INTEGER expression expected" } + print *, [character(1+[1]) :: 'a','b'] ! { dg-error "Scalar INTEGER expression expected" } +end + Index: Fortran/gfortran/regression/pr93498_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93498_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! Test case by G. Steinmetz + +program p + character(len=1, kind=1) :: x(3) = ['a', 'b', 'c'] + character(len=1, kind=4) :: y = 4_'b' + print *, findloc(x, y) ! { dg-error " must be in type conformance" } + print *, findloc(x, y, 1) ! { dg-error " must be in type conformance" } +end + Index: Fortran/gfortran/regression/pr93498_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93498_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! Test case by G. Steinmetz + +program p + character(len=1, kind=4) :: x(3) = [4_'a', 4_'b', 4_'c'] + character(len=1, kind=1) :: y = 'b' + print *, findloc(x, y) ! { dg-error " must be in type conformance" } + print *, findloc(x, y, 1) ! { dg-error " must be in type conformance" } +end + + Index: Fortran/gfortran/regression/pr93499.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93499.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 93499 - this used to ICE. Original test case by Gerhard Steinmetz. + +program p + integer :: a((0.)/0) ! { dg-error "must be constant of INTEGER type" } + type t(n) + integer, len :: n + end type t + type(t((0)/0)) :: x ! { dg-error "does not simplify to an INTEGER constant" } +end Index: Fortran/gfortran/regression/pr93524.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93524.c @@ -0,0 +1,33 @@ +/* Test the fix for PR93524, in which CFI_allocate was computing + sm incorrectly for dimensions > 2. */ + +#include // For size_t +#include + +void my_fortran_sub_1 (CFI_cdesc_t *dv); +void my_fortran_sub_2 (CFI_cdesc_t *dv); + +int main () +{ + CFI_CDESC_T (3) a; + CFI_cdesc_t *dv = (CFI_cdesc_t *) &a; + // dv, base_addr, attribute, type, elem_len, rank, extents + CFI_establish (dv, NULL, CFI_attribute_allocatable, CFI_type_float, 0, 3, NULL); + + if (dv->base_addr != NULL) + return 1; // shall not be allocated + + CFI_index_t lower_bounds[] = {-10, 0, 3}; + CFI_index_t upper_bounds[] = {10, 5, 10}; + size_t elem_len = 0; // only needed for strings + if (CFI_SUCCESS != CFI_allocate (dv, lower_bounds, upper_bounds, elem_len)) + return 2; + + if (!CFI_is_contiguous (dv)) + return 2; // allocatables shall be contiguous,unless a strided section is used + + my_fortran_sub_1 (dv); + my_fortran_sub_2 (dv); + CFI_deallocate (dv); + return 0; +} Index: Fortran/gfortran/regression/pr93524.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93524.f90 @@ -0,0 +1,17 @@ +! { dg-additional-sources pr93524.c } +! { dg-do run } +! +! Test the fix for PR93524. The main program is in pr93524.c. + +subroutine my_fortran_sub_1 (A) bind(C) + real :: A(:, :, :) + if (any (lbound(A) /= 1)) stop 1 + if (any (ubound(A) /= [21,6,8])) stop 2 + if (.not. is_contiguous (A)) stop 3 +end +subroutine my_fortran_sub_2 (A) bind(C) + real, ALLOCATABLE :: A(:, :, :) + if (any (lbound(A) /= [-10,0,3])) stop 1 + if (any (ubound(A) /= [10,5,10])) stop 2 + if (.not. is_contiguous (A)) stop 3 +end subroutine my_fortran_sub_2 Index: Fortran/gfortran/regression/pr93580.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93580.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/93580 + +program p + integer, parameter :: n = 4 + complex(n%re) :: x ! { dg-error "The RE or IM part_ref at" } + complex(n%im) :: y ! { dg-error "The RE or IM part_ref at" } + complex(n%len) :: z ! { dg-error "The LEN part_ref at" } + character(n%im) :: a ! { dg-error "The RE or IM part_ref at" } + character(n%re) :: b ! { dg-error "The RE or IM part_ref at" } + character(n%len) :: c ! { dg-error "The LEN part_ref at" } +end + Index: Fortran/gfortran/regression/pr93600_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93600_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +program p + integer, parameter :: a(0) = 0 + character(0), parameter :: b(0) = '' + a%kind = 1 ! { dg-error "Assignment to a constant expression" } + b%len = 'a' ! { dg-error "Assignment to a constant expression" } +end program + Index: Fortran/gfortran/regression/pr93600_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93600_2.f90 @@ -0,0 +1,10 @@ +! { dg-do run } + +program p + integer, parameter :: a(0) = 0 + character(0), parameter :: b(0) = '' + integer :: c + if (a%kind.ne.kind(c)) stop 1 + if (b%len.ne.0) stop 2 +end program + Index: Fortran/gfortran/regression/pr93601.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93601.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + +program p + class(*), allocatable :: z + z = z'1' ! { dg-error "BOZ literal constant at" } +end + Index: Fortran/gfortran/regression/pr93603.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93603.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + +program p + associate (y => z'1') ! { dg-error "cannot be a BOZ literal constant" } + end associate ! { dg-error "Expecting END PROGRAM" } +end + Index: Fortran/gfortran/regression/pr93604.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93604.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + +program p + type t + integer :: a + end type + type(t) :: x + data x /t(z'1')/ ! { dg-error "BOZ" } +end + Index: Fortran/gfortran/regression/pr93685_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93685_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR93685 - ICE in gfc_constructor_append_expr, at fortran/constructor.c:135 + +program p + implicit none + type t + character, pointer :: a + end type t + type u + integer, pointer :: i + end type u + type(t) :: x + type(u) :: y + character, target :: c = 'c' + integer , target :: i = 10 + data x%a /c/ + data y%i /i/ + if (x% a /= "c") stop 1 + if (y% i /= 10) stop 2 +end Index: Fortran/gfortran/regression/pr93685_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93685_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR93685 - ICE in gfc_constructor_append_expr, at fortran/constructor.c:135 + +program p + implicit none + type t + character :: a + end type t + type u + integer :: i + end type u + type(t) :: x + type(u) :: y + character, target :: c = 'c' + integer , target :: i = 10 + data x%a /c/ ! { dg-error "non-constant initialization expression" } + data y%i /i/ ! { dg-error "non-constant initialization expression" } +end Index: Fortran/gfortran/regression/pr93686_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93686_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/93686 + +program p + type t + integer :: a + end type + type(t), pointer :: x + data x /t(2)/ ! { dg-error "part-ref with pointer attribute near ... is not rightmost part-ref of data-stmt-object" } +end Index: Fortran/gfortran/regression/pr93686_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93686_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/93686 + +program p + type t + integer :: a = 1 + end type + type(t), pointer :: x + data x /t(2)/ ! { dg-error "part-ref with pointer attribute near ... is not rightmost part-ref of data-stmt-object" } +end Index: Fortran/gfortran/regression/pr93686_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93686_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/93686 + +program p + type t + end type + type(t), pointer :: x + data x /t()/ ! { dg-error "part-ref with pointer attribute near ... is not rightmost part-ref of data-stmt-object" } +end Index: Fortran/gfortran/regression/pr93686_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93686_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/93686 + +type t +end type +type(t), pointer :: x +data x / ! { dg-error "part-ref with pointer attribute near ... is not rightmost part-ref of data-stmt-object" } +end Index: Fortran/gfortran/regression/pr93714_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93714_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 93714 +! Original test case from G. Steinmetz + +program test + character((1.)) :: a + character, pointer :: b => a +end program + +! { dg-error "Scalar INTEGER expression expected" " " { target *-*-* } 6 } +! { dg-error "Different types in pointer assignment" " " { target *-*-* } 7 } Index: Fortran/gfortran/regression/pr93714_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93714_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 93714 +! Original test case from G. Steinmetz + +program test + character((9.)) :: a + character(:), pointer :: b => a +end program + +! { dg-error "Scalar INTEGER expression expected" " " { target *-*-* } 6 } +! { dg-error "Different types in pointer assignment" " " { target *-*-* } 7 } Index: Fortran/gfortran/regression/pr93792.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93792.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Original test case by Gernhard Steinmetz. + +module m + type t(n) + integer, len :: n = z'1' + end type +end +program p + use m + type(t(:)), allocatable :: z +end + +! { dg-error "Parameterized type 't' does not have a component" " " { target *-*-* } 5 } +! { dg-error "BOZ literal constant at .1. cannot appear" " " { target *-*-* } 6 } +! { dg-error "Cannot open module file" " " { target *-*-* } 10 } +! { dg-prune-output "compilation terminated" } Index: Fortran/gfortran/regression/pr93835.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr93835.f08 @@ -0,0 +1,8 @@ +! {dg-do run } +! +! PR fortran/93835 - the following code resulted in an ICE +! +program p + if (any(findloc(shape(1), 1) .ne. 0)) stop 1 +end + Index: Fortran/gfortran/regression/pr94030_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94030_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! + +subroutine f(n) + integer :: n + integer :: arr(n) + integer :: i + equivalence (i, arr(1)) +end + +! { dg-error "Array 'arr' at .1. with non-constant bounds cannot be an EQUIVALENCE object" " " { target *-*-* } 8 } Index: Fortran/gfortran/regression/pr94030_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94030_2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! Provided by Steve Kargl. + +subroutine foo(n,m) + integer, intent(in) :: n, m + integer a(n) + real b(n) + equivalence(a,b) + if (m /= 2) then + a = 1 + print *, a(1) + else + b = 42. + print *, b(1) + end if +end subroutine + +subroutine bar(m) + integer, intent(in) :: m + integer x(8) + real y(8) + equivalence(x,y) + if (m /= 2) then + x = 1 + print *, x(1) + else + y = 42. + print *, y(1) + end if +end subroutine + +! { dg-error "Array '.' at .1. with non-constant bounds cannot be an EQUIVALENCE object" " " { target *-*-* } 9 } Index: Fortran/gfortran/regression/pr94285.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94285.f90 @@ -0,0 +1,5 @@ +! PR debug/94285 +! { dg-do compile } +! { dg-options "-Os -fno-tree-dominator-opts -fno-tree-vrp -fcompare-debug" } + +include 'array_constructor_40.f90' Index: Fortran/gfortran/regression/pr94329.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94329.f90 @@ -0,0 +1,12 @@ +! PR tree-optimization/94329 +! { dg-do compile } +! { dg-options "-O1 -fno-tree-loop-optimize -fwrapv -fcompare-debug" } + +subroutine pr94329 (s, t) + real :: s, t(:,:) + do i = 1,3 + do j = 1,3 + s = t(i,j) + end do + end do +end Index: Fortran/gfortran/regression/pr94397.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94397.F90 @@ -0,0 +1,26 @@ +! { dg-do run } +! + +module m + implicit none +contains + function is_real8(a) + class(*) :: a + logical :: is_real8 + is_real8 = .false. + select type(a) + type is(real(kind(1.0_8))) + is_real8 = .true. + end select + end function is_real8 +end module m + +program test + use m + + if (is_real8(1.0_4)) stop 1 + if (.not. is_real8(1.0_8)) stop 2 +#ifdef __GFC_REAL_16__ + if (is_real8(1.0_16)) stop 3 +#endif +end program Index: Fortran/gfortran/regression/pr94708.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr94708.f90 @@ -0,0 +1,13 @@ +! { dg-do compile { target aarch64*-*-* } } +! { dg-options "-O2 -funsafe-math-optimizations -fdump-rtl-combine" } + +subroutine f(vara,varb,varc,res) + REAL, INTENT(IN) :: vara,varb,varc + REAL, INTENT(out) :: res + + res = vara + if (res .lt. varb) res = varb + if (res .gt. varc) res = varc +end subroutine + +! { dg-final { scan-rtl-dump-not "smin" "combine" } } Index: Fortran/gfortran/regression/pr95053.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95053.f @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/95053 - ICE in gfc_divide(): Bad basic type +! + 123 FORMAT ('A'/'B') + 132 FORMAT (A/ + + ' B') + END Index: Fortran/gfortran/regression/pr95053_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95053_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 95053 - make sure we do not regress on 521.wrf_r from spec2017 +! +function f (x) + real, parameter :: cldeps = 0. + f = 0. + if (cldeps > 0.) then + f = floor (x/cldeps) * cldeps + end if +end function f Index: Fortran/gfortran/regression/pr95053_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95053_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Related to PR 93499 - this used to ICE. + +program p + type t(n) + integer, kind :: n + end type t + type u(n) + integer, len :: n + end type u + type(t((0)/0)) :: x ! { dg-error "does not simplify to an INTEGER" } + type(t((0.)/0)) :: y ! { dg-error "must be of INTEGER type" } + type(u(0/(0.))) :: z ! { dg-error "must be of INTEGER type" } +end Index: Fortran/gfortran/regression/pr95088.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95088.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95088 - ICE in gfc_build_class_symbol, at fortran/class.c:653 + +module m2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 & + (n2345678901234567890123456789012345678901234567890123456789_123,& + r2345678901234567890123456789012345678901234567890123456789_123,& + k2345678901234567890123456789012345678901234567890123456789_123,& + l2345678901234567890123456789012345678901234567890123456789_123 ) + integer, kind :: n2345678901234567890123456789012345678901234567890123456789_123 + integer, kind :: r2345678901234567890123456789012345678901234567890123456789_123 + integer, kind :: k2345678901234567890123456789012345678901234567890123456789_123 + integer, len :: l2345678901234567890123456789012345678901234567890123456789_123 + complex (kind = r2345678901234567890123456789012345678901234567890123456789_123) & + :: z2345678901234567890123456789012345678901234567890123456789_123 + character(kind = k2345678901234567890123456789012345678901234567890123456789_123, & + len = l2345678901234567890123456789012345678901234567890123456789_123) & + :: c2345678901234567890123456789012345678901234567890123456789_123 + end type + type, extends (t2345678901234567890123456789012345678901234567890123456789_123) :: & + a2345678901234567890123456789012345678901234567890123456789_123 + end type + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 & + (x2345678901234567890123456789012345678901234567890123456789_123) + class(a2345678901234567890123456789012345678901234567890123456789_123(16,8,4,1234567890)) :: & + x2345678901234567890123456789012345678901234567890123456789_123 + end + end interface +end Index: Fortran/gfortran/regression/pr95089.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95089.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! PR fortran/95089 - ICE in gfc_get_derived_type, at fortran/trans-types.c:2843 + +module m23456789012345678901234567890123456789012345678901234567890123 + type t23456789012345678901234567890123456789012345678901234567890123 + type (t23456789012345678901234567890123456789012345678901234567890123), & + pointer :: z23456789012345678901234567890123456789012345678901234567890123 + end type t23456789012345678901234567890123456789012345678901234567890123 +end Index: Fortran/gfortran/regression/pr95090.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95090.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fsecond-underscore" } +! PR fortran/95090 - ICE: identifier overflow + +module m2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 & + (n2345678901234567890123456789012345678901234567890123456789_123) + integer, len :: n2345678901234567890123456789012345678901234567890123456789_123 = 8 + end type + integer :: a2345678901234567890123456789012345678901234567890123456789_123 + integer :: b2345678901234567890123456789012345678901234567890123456789_123(3)[*] + data b2345678901234567890123456789012345678901234567890123456789_123 /1,2,3/ +contains + subroutine s2345678901234567890123456789012345678901234567890123456789_123 + type(t2345678901234567890123456789012345678901234567890123456789_123 & + (n2345678901234567890123456789012345678901234567890123456789_123)) :: & + z2345678901234567890123456789012345678901234567890123456789_123 + end +end Index: Fortran/gfortran/regression/pr95091.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95091.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95091 - ICE in gfc_hash_value + +module m2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 + end type t2345678901234567890123456789012345678901234567890123456789_123 + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 & + (x2345678901234567890123456789012345678901234567890123456789_123) + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + n2345678901234567890123456789012345678901234567890123456789_123 + type, extends(t2345678901234567890123456789012345678901234567890123456789_123) :: & + u2345678901234567890123456789012345678901234567890123456789_123 + end type +end Index: Fortran/gfortran/regression/pr95104.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95104.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR libfortran/95104 - Segfault on a legal WAIT statement + +program test + wait (10, iostat=ios) + if (ios /= 0) stop 1 + close (10) +end program test Index: Fortran/gfortran/regression/pr95340.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95340.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/95340 - ICE in gfc_match_select_rank, at fortran/match.c:6690 + +program p + type t + end type t + class(t) :: z ! { dg-error "must be dummy, allocatable or pointer" } + select rank (z) ! { dg-error "must be an assumed rank variable" } + end select ! { dg-error "Expecting END PROGRAM" } +end Index: Fortran/gfortran/regression/pr95342.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95342.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/95342 - ICE in gfc_match_subroutine, at fortran/decl.c:7913 + +module m1 + interface + module subroutine s() + end + subroutine s() bind(c) ! { dg-error "EXTERNAL attribute conflicts" } + end ! { dg-error "END INTERFACE" } + end interface +end + +module m2 + interface + module function f() + end + function f() bind(c) + end ! { dg-error "Duplicate EXTERNAL attribute" } + end interface +end Index: Fortran/gfortran/regression/pr95373_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95373_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/95373 - ICE in build_reference_type, at tree.c:7942 + +subroutine s (x) + complex, parameter :: z = 3 + real(z% kind) :: x ! { dg-error "Fortran 2003: KIND part_ref" } + type t + real :: kind + logical :: re + end type t + type(t) :: b + print *, b% kind, b% re + print *, z% re ! { dg-error "Fortran 2008: RE or IM part_ref" } +end Index: Fortran/gfortran/regression/pr95373_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95373_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/95373 - ICE in build_reference_type, at tree.c:7942 + +subroutine s (x) + complex, parameter :: z = 3 + real(z% kind) :: x + type t + real :: kind + logical :: re + end type t + type(t) :: b + print *, b% kind, b% re + print *, z% re ! { dg-error "Fortran 2008: RE or IM part_ref" } +end Index: Fortran/gfortran/regression/pr95398.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95398.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } + +program test + implicit none + + type :: t1 + integer :: i + end type + + type, extends(t1) :: t2 + end type + + class(t1), allocatable :: array1(:,:) + class(t2), allocatable :: array2(:,:) + + allocate(array1(3,3)) + allocate(array2(3,3)) + + select type(b => foo(1)) + type is (t1) + b%i = 1 + type is (t2) + call sub_with_in_and_inout_param(b,b) + end select + + contains + + function foo(i) + integer :: U(2) + integer :: i + class(t1), POINTER :: foo(:) + ALLOCATE(foo(2)) + U = [ 1,2 ] + if (i>0) then + foo => array1(2,U) + else + foo => array2(2,U) + end if + end function + + subroutine sub_with_in_and_inout_param(y, z) + type(t2), INTENT(IN) :: y(:) + class(t2), INTENT(INOUT) :: z(:) + z%i = 10 + end subroutine + +end + +! { dg-error "cannot be used in a variable definition context .assignment." " " { target *-*-* } 21 } +! { dg-error "cannot be used in a variable definition context .actual argument to INTENT = OUT.INOUT." " " { target *-*-* } 23 } +! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 35 } +! { dg-error "Pointer assignment target is neither TARGET nor POINTER" " " { target *-*-* } 37 } + Index: Fortran/gfortran/regression/pr95446.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95446.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-pedantic-errors" } +! +! Contributed by Martin Diehl + +program elemental_optional + implicit none + integer :: m(5), r(5) + + m = 1 + + r = outer() + r = outer(m) + + contains + + function outer(o) result(l) + integer, intent(in), optional :: o(:) + integer :: u(5), l(5) + + l = inner(o,u) + + end function outer + + elemental function inner(a,b) result(x) + integer, intent(in), optional :: a + integer, intent(in) :: b + integer :: x + + if(present(a)) then + x = a*b + else + x = b + endif + end function inner + +end program elemental_optional + Index: Fortran/gfortran/regression/pr95500.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95500.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/95500 - ICE compiling extra interface on intrinsic + +program test_intrinsic + implicit none + intrinsic :: alog + intrinsic :: dlog + real (4), parameter :: one = 1 + + interface ln + procedure :: alog, dlog + end interface ln + + write (*,*) 'ln 1', ln (one) +end program test_intrinsic Index: Fortran/gfortran/regression/pr95502.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95502.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/95502 - ICE in gfc_check_do_variable, at fortran/parse.c:4446 + +program p + integer, pointer :: z + nullify (z%kind) ! { dg-error "in variable definition context" } + z%kind => NULL() ! { dg-error "constant expression" } +end Index: Fortran/gfortran/regression/pr95503.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95503.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/95503 - ICE in gfc_is_simply_contiguous + +program p + complex, target :: a + real, pointer, contiguous :: b => a%re ! { dg-error "not an array pointer" } +end Index: Fortran/gfortran/regression/pr95544.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95544.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494 + +program test + character(:), allocatable :: z + character(:), pointer :: p + character(1), pointer :: c + print *, adjustl (null(z)) ! { dg-error "is not permitted as actual argument" } + print *, adjustr (null(z)) ! { dg-error "is not permitted as actual argument" } + print *, len (null(p)) ! { dg-error "is not permitted as actual argument" } + print *, len (null(z)) ! { dg-error "is not permitted as actual argument" } + print *, len_trim(null(c)) ! { dg-error "is not permitted as actual argument" } + print *, len_trim(null(z)) ! { dg-error "is not permitted as actual argument" } + print *, trim (null(z)) ! { dg-error "is not permitted as actual argument" } +end Index: Fortran/gfortran/regression/pr95584.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95584.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +program p + interface s + subroutine g(x, *) + end + subroutine h(y, *) + end + end interface +end + +! { dg-warning "Obsolescent feature: Alternate-return argument" " " { target *-*-* } 5 } +! { dg-warning "Obsolescent feature: Alternate-return argument" " " { target *-*-* } 7 } +! { dg-error ".1." " " { target *-*-* } 5 } +! { dg-error "Ambiguous interfaces in generic interface" " " { target *-*-* } 7 } + Index: Fortran/gfortran/regression/pr95585.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95585.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +program test + integer, parameter :: a(2) = reshape([1, 2], a) ! { dg-error "before its definition" } +end program + Index: Fortran/gfortran/regression/pr95586_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95586_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! + +program test + implicit type(t) (1) ! { dg-error "Syntax error" } + type t + end type +end program + Index: Fortran/gfortran/regression/pr95586_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95586_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! + +program test + integer, parameter :: n1 = 1 + implicit type(t) (n1) ! { dg-error "Syntax error" } + type t + end type +end program + + Index: Fortran/gfortran/regression/pr95587.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95587.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/95587 - ICE in gfc_target_encode_expr, at fortran/target-memory.c:362 + +program p + type t + end type t + class(*), allocatable :: x, y + class(t), allocatable :: u, v + class(t), pointer :: c, d + equivalence (x, y) ! { dg-error "conflicts with ALLOCATABLE" } + equivalence (u, v) ! { dg-error "conflicts with ALLOCATABLE" } + equivalence (c, d) ! { dg-error "conflicts with POINTER" } +end Index: Fortran/gfortran/regression/pr95611.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95611.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/95611 - ICE in access_attr_decl, at fortran/decl.c:9075 + +module m + public operator (.a.) + public operator (.a.) ! { dg-error "has already been specified" } +end Index: Fortran/gfortran/regression/pr95612.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95612.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + +program p + integer, pointer :: y(:) => shape(1) ! { dg-error "Zero-sized array detected at .1. where an entity with the TARGET attribute is expected" } + integer, pointer :: z(:) => shape([1]) ! { dg-error "Pointer assignment target in initialization expression does not have the TARGET attribute at .1." } +end + Index: Fortran/gfortran/regression/pr95614_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95614_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +module m ! { dg-error ".1." } + common m ! { dg-error "cannot appear in a COMMON" } +end + Index: Fortran/gfortran/regression/pr95614_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95614_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +module m ! { dg-error ".1." } + common /xc/ m ! { dg-error "cannot appear in a COMMON" } +end + Index: Fortran/gfortran/regression/pr95614_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95614_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine s +end subroutine + +program pr95614 + common /c1/ s + s = 9.0 +end program Index: Fortran/gfortran/regression/pr95614_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95614_4.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +function f() + f = 1.0 +end function + +program pr95614 + common /c1/ f +end program Index: Fortran/gfortran/regression/pr95687.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95687.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95687 - ICE in get_unique_hashed_string, at fortran/class.c:508 + +module m2345678901234567890123456789012345678901234567890123456789_123 + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + n2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 & + (a2345678901234567890123456789012345678901234567890123456789_123) + integer, kind :: a2345678901234567890123456789012345678901234567890123456789_123 = 4 + end type + class(t2345678901234567890123456789012345678901234567890123456789_123(3)), pointer :: & + x2345678901234567890123456789012345678901234567890123456789_123 +end Index: Fortran/gfortran/regression/pr95688.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95688.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95688 - ICE in gfc_get_string, at fortran/iresolve.c:70 + +module m2345678901234567890123456789012345678901234567890123456789_123 + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + n2345678901234567890123456789012345678901234567890123456789_123 + character(:), pointer :: & + x2345678901234567890123456789012345678901234567890123456789_123 => null() +end Index: Fortran/gfortran/regression/pr95689.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95689.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95689 - ICE in check_sym_interfaces, at fortran/interface.c:2015 + +module m2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 + end type + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 & + (x2345678901234567890123456789012345678901234567890123456789_123) + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + t2345678901234567890123456789012345678901234567890123456789_123 +end Index: Fortran/gfortran/regression/pr95690.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95690.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +module m +contains + subroutine s + print *, (erfc) ! { dg-error "not a floating constant" "" { target i?86-*-* x86_64-*-* sparc*-*-* cris-*-* } } + end ! { dg-error "not a floating constant" "" { target { ! "i?86-*-* x86_64-*-* sparc*-*-* cris-*-*" } } } + function erfc() + end +end Index: Fortran/gfortran/regression/pr95707.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95707.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95707 - ICE in finish_equivalences, at fortran/trans-common.c:1319 + +module m2345678901234567890123456789012345678901234567890123456789_123 + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + n2345678901234567890123456789012345678901234567890123456789_123 + real :: a(4), u(3,2) + real :: b(4), v(4,2) + equivalence (a(1),u(1,1)), (b(1),v(1,1)) +end Index: Fortran/gfortran/regression/pr95708.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95708.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! + +program test + procedure(team_num) :: g ! { dg-error "must be explicit" } +end program Index: Fortran/gfortran/regression/pr95709.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95709.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/95709 - ICE in gfc_resolve_code, at fortran/resolve.c:11807 + +program p + integer, parameter :: i(1) = 1 + integer, parameter :: j = 1 + integer :: k(1) = 1 + goto i(1) ! { dg-error "requires a scalar INTEGER variable" } + goto j ! { dg-error "requires a scalar INTEGER variable" } + goto k(1) ! { dg-error "requires a scalar INTEGER variable" } + goto i%kind, (1) ! { dg-error "requires a scalar INTEGER variable" } +1 continue +end Index: Fortran/gfortran/regression/pr95826.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95826.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95826 - ICE in gfc_match_decl_type_spec, at fortran/decl.c:4290 + +program p + type t2345678901234567890123456789012345678901234567890123456789_123 & + (a2345678901234567890123456789012345678901234567890123456789_123, & + b2345678901234567890123456789012345678901234567890123456789_123) + integer, kind :: & + a2345678901234567890123456789012345678901234567890123456789_123 + integer, len :: & + b2345678901234567890123456789012345678901234567890123456789_123 + end type + integer, parameter :: & + n2345678901234567890123456789012345678901234567890123456789_123 = 16 + type(t2345678901234567890123456789012345678901234567890123456789_123 & + (n2345678901234567890123456789012345678901234567890123456789_123,:)), & + allocatable :: & + x2345678901234567890123456789012345678901234567890123456789_123 +end Index: Fortran/gfortran/regression/pr95827.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95827.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fsecond-underscore" } +! PR fortran/95827 - ICE in gfc_get_string, at fortran/iresolve.c:70 + +module m2345678901234567890123456789012345678901234567890123456789_123 + interface + module subroutine s2345678901234567890123456789012345678901234567890123456789_123 + end + end interface +end +submodule(m2345678901234567890123456789012345678901234567890123456789_123) & + n2345678901234567890123456789012345678901234567890123456789_123 + integer :: x2345678901234567890123456789012345678901234567890123456789_123[*] +end Index: Fortran/gfortran/regression/pr95828.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95828.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95828 - ICE in resolve_select_rank, at fortran/resolve.c:9774 + +module m2345678901234567890123456789012345678901234567890123456789_123 + type t2345678901234567890123456789012345678901234567890123456789_123 + end type +contains + subroutine s2345678901234567890123456789012345678901234567890123456789_123 & + (x2345678901234567890123456789012345678901234567890123456789_123) + type (t2345678901234567890123456789012345678901234567890123456789_123) :: & + x2345678901234567890123456789012345678901234567890123456789_123(..) + + select rank (y2345678901234567890123456789012345678901234567890123456789_123 & + => x2345678901234567890123456789012345678901234567890123456789_123) + rank (2) + rank (3) + rank default + end select + end +end Index: Fortran/gfortran/regression/pr95829.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95829.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Declaration of b used to be a bogus failure. + +subroutine s (a, b, c, d, e, f, g) + type(*) :: a + type(* ) :: b + type( *) :: c + type( * ) :: d + type(* ) :: e + type( *) :: f + type( * ) :: g +end + Index: Fortran/gfortran/regression/pr95880.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95880.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/95880 - ICE in gfc_add_type, at fortran/symbol.c:2030 + +module m +end +block data + use m + integer m ! { dg-error "cannot have a type" } +end block data Index: Fortran/gfortran/regression/pr95881.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95881.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/95881 - ICE in resolve_symbol, at fortran/resolve.c:15175 + +program p + type t + real, allocatable :: a[:] + end type t + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + allocate (x%a[*]) +end Index: Fortran/gfortran/regression/pr95882_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95882_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } + +module m + type t + character(((0)/0)) :: c ! { dg-error "Division by zero" } + end type +end + Index: Fortran/gfortran/regression/pr95882_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95882_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +module m + character(0/(0)) :: c = '123456789' ! { dg-error "Division by zero" } +end + Index: Fortran/gfortran/regression/pr95882_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95882_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +subroutine s(c) + character(((0)/0)) :: c ! { dg-error "Division by zero" } +end + Index: Fortran/gfortran/regression/pr95882_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95882_4.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + +program p + character(((0)/0)) :: c ! { dg-error "Division by zero" } + common /x/ c +end + Index: Fortran/gfortran/regression/pr95882_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95882_5.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } + +program p + character(0/(0)) :: c = '123456789' ! { dg-error "Division by zero" } + common c +end Index: Fortran/gfortran/regression/pr95978.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95978.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/95978 - ICE in gfc_match_data, at fortran/decl.c:731 + +program p + type t + integer :: a + type(t), allocatable :: b + data c /t(1)/ ! { dg-error "Unexpected DATA statement" } + end type t +end Index: Fortran/gfortran/regression/pr95980.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95980.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/95980 - ICE in get_unique_type_string, at fortran/class.c:485 + +program p + type t + end type t + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + end select +end Index: Fortran/gfortran/regression/pr95980_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95980_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/95980 - ICE in get_unique_type_string, at fortran/class.c:485 + +program p + type t + integer :: a + end type t + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + select type (y => x) + end select +end Index: Fortran/gfortran/regression/pr95981.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr95981.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +program p + type t + end type + class(t) :: x(:) ! { dg-error "must be dummy, allocatable or pointer" } + type(t) :: y(size(x,1)) ! { dg-error "must be constant of INTEGER type" } +end + Index: Fortran/gfortran/regression/pr96024.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96024.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/96024 - ICE in mio_name_expr_t +! Contributed by G.Steinmetz + +module m + implicit none + type t + character(char(1)) :: a ! { dg-error "must be of INTEGER type" } + end type + type(t) :: z = t('a') +end Index: Fortran/gfortran/regression/pr96025.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96025.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/96025 - ICE in expr_check_typed_help +! Contributed by G.Steinmetz + +program p + print *, f() +contains + character(char(1)) function f() ! { dg-error "must be of INTEGER type" } + f = 'f' + end +end Index: Fortran/gfortran/regression/pr96038.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96038.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } + +function ifoo() + parameter (n = 50) + integer n + ifoo = n +end + Index: Fortran/gfortran/regression/pr96085.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96085.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/96085 - ICE in gfc_finish_var_decl, at fortran/trans-decl.c:694 + +module m + integer, parameter :: a = 1 +contains + subroutine s + assign 2 to a ! { dg-error "requires a scalar default INTEGER variable" } +2 print *, a + end +end Index: Fortran/gfortran/regression/pr96086.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96086.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/96086 - ICE in gfc_match_select_rank, at fortran/match.c:6645 + +subroutine s + class(*) :: x(..) ! { dg-error "Assumed-rank array" } + select rank (y => x) ! { dg-error "CLASS variable" } + end select +end Index: Fortran/gfortran/regression/pr96099_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96099_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } + +program pr96099_1 + implicit class(t) (1) ! { dg-error "Syntax error in IMPLICIT" } + type t + end type +end + Index: Fortran/gfortran/regression/pr96099_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96099_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +program pr96099_2 + integer n1 + parameter (n1 = 1) + implicit class(t) (n1) ! { dg-error "Syntax error in IMPLICIT" } + type t + end type +end Index: Fortran/gfortran/regression/pr96102.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96102.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Test the fix for PR96102 in which the two lines with errors previously +! caused a segfault. +! +! Contributed by Gerhardt Steinmetz +! +! +module m + type mytype + integer :: i + end type + type(mytype) :: d = mytype (42) ! { dg-error "is host associated" } + integer :: n = 2 ! { dg-error "is host associated" } +contains + subroutine s + if ( n /= 0 ) stop 1 ! { dg-error "internal procedure of the same name" } + if ( d%i /= 0 ) stop 2 ! { dg-error "internal procedure of the same name" } + contains + integer function n() + n = 0 + end + type(mytype) function d() + d = mytype (0) + end + end +end Index: Fortran/gfortran/regression/pr96102b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96102b.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/108544 - host association +! Variation of testcase pr96102.f90 using subroutines instead of functions + +module m + type mytype + integer :: i + end type + type(mytype) :: d = mytype (42) ! { dg-error "is host associated" } + integer :: n = 2 ! { dg-error "is host associated" } +contains + subroutine s + if ( n /= 0 ) stop 1 ! { dg-error "internal procedure of the same name" } + if ( d%i /= 0 ) stop 2 ! { dg-error "internal procedure of the same name" } + contains + subroutine n() + end + subroutine d() + end + end +end + +! { dg-prune-output "Operands of comparison operator" } Index: Fortran/gfortran/regression/pr96312.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96312.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O1 -Wall" } +! +! PR fortran/96312. The line with the call to 'matmul' gave the warning +! ‘tmp.dim[0].lbound’ is used uninitialized in this function +! +! Contributed by Thomas Koenig +! +module moda +contains + PURE SUBROUTINE funca(arr, sz) + REAL, ALLOCATABLE, DIMENSION(:, :), INTENT(OUT) :: arr + integer, intent(in) :: sz + allocate(arr(sz, sz)) + arr(:, :) = 0. + END SUBROUTINE +end module + +module modc + use moda, only: funca +contains + PURE SUBROUTINE funcb(oarr) + REAL, DIMENSION(:), INTENT(OUT) :: oarr + REAL, ALLOCATABLE, DIMENSION(:, :) :: arr + real, allocatable, dimension(:) :: tmp + CALL funca(arr, ubound(oarr, 1)) + tmp = matmul(transpose(arr),oarr) + oarr = tmp*1. + END SUBROUTINE funcb +end module Index: Fortran/gfortran/regression/pr96319.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96319.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-Wconversion -Wconversion-extra" } + +program test + LOGICAL(1) :: a + logical(4) :: t = .true. + logical(4) :: b + logical(1) :: f = .false. + a = t + b = f +end program test + Index: Fortran/gfortran/regression/pr96325.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96325.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Test the fix for PR96325 in which the typebound procedure reference +! 'foo' was applied to an intrinsic type component without generating +! an error. The result of the expression was the value of the arg.. +! +! Contributed by Gerhardt Steinmetz +! + implicit none + + type t2 + integer r1 + end type + + type(t2) :: t + integer :: a + + a = t%r1%foo(1) ! { dg-error "is not an inquiry reference" } + if (a == 42) stop + + end Index: Fortran/gfortran/regression/pr96436_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f95 -pedantic" } + +character(20) :: fmt +character(9) :: buffer +fmt = "(1a1,f0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 1 +end + Index: Fortran/gfortran/regression/pr96436_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_10.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2008 -pedantic" } +! { dg-shouldfail "Zero width in format descriptor" } + +character(10) :: fmt = "(es0.2)" +print fmt, 3. +end + +! { dg-output "Fortran runtime error: Zero width in format descriptor" } + Index: Fortran/gfortran/regression/pr96436_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_2.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2003 -pedantic" } + +character(20) :: fmt +character(9) :: buffer +fmt = "(1a1,f0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 1 +end + Index: Fortran/gfortran/regression/pr96436_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=f2008 -pedantic" } + +character(20) :: fmt +character(9) :: buffer +fmt = "(1a1,f0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 1 +fmt = "(1a1,g0.2,1a1)" +write(buffer,fmt) ">", 0.3, "<" +if (buffer.ne.">0.30<") stop 2 +end + Index: Fortran/gfortran/regression/pr96436_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-std=f2018 -pedantic" } + +character(20) :: fmt +character(9) :: buffer +fmt = "(1a1,f0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 1 +fmt = "(1a1,g0.2,1a1)" +write(buffer,fmt) ">", 0.3, "<" +if (buffer.ne.">0.30<") stop 2 +fmt = "(1a1,d0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">0.30D+1<") stop 3 +fmt = "(1a1,e0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">0.30E+1<") stop 4 +fmt = "(1a1,en0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 5 +fmt = "(1a1,es0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 6 +end + Index: Fortran/gfortran/regression/pr96436_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_5.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-pedantic" } + +character(20) :: fmt +character(9) :: buffer +fmt = "(1a1,f0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 1 +fmt = "(1a1,g0.2,1a1)" +write(buffer,fmt) ">", 0.30, "<" +if (buffer.ne.">0.30<") stop 2 +fmt = "(1a1,d0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">0.30D+1<") stop 3 +fmt = "(1a1,e0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">0.30E+1<") stop 4 +fmt = "(1a1,en0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 5 +fmt = "(1a1,es0.2,1a1)" +write(buffer,fmt) ">", 3.0, "<" +if (buffer.ne.">3.00<") stop 6 +end + Index: Fortran/gfortran/regression/pr96436_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_6.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2003 -pedantic" } +! { dg-shouldfail "Zero width in format descriptor" } + +character(10) :: fmt = "(g0.2)" +print fmt, 0.3 +end + +! { dg-output "Fortran runtime error: Zero width in format descriptor" } + Index: Fortran/gfortran/regression/pr96436_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_7.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2008 -pedantic" } +! { dg-shouldfail "Zero width in format descriptor" } + +character(10) :: fmt = "(d0.2)" +print fmt, 3. +end + +! { dg-output "Fortran runtime error: Zero width in format descriptor" } + Index: Fortran/gfortran/regression/pr96436_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_8.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2008 -pedantic" } +! { dg-shouldfail "Zero width in format descriptor" } + +character(10) :: fmt = "(e0.2)" +print fmt, 3. +end + +! { dg-output "Fortran runtime error: Zero width in format descriptor" } + Index: Fortran/gfortran/regression/pr96436_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96436_9.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-std=f2008 -pedantic" } +! { dg-shouldfail "Zero width in format descriptor" } + +character(10) :: fmt = "(en0.2)" +print fmt, 3. +end + +! { dg-output "Fortran runtime error: Zero width in format descriptor" } + Index: Fortran/gfortran/regression/pr96486.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96486.f90 @@ -0,0 +1,9 @@ +! { dg-do run } + +program test + implicit none + character(0) :: value + integer :: l, stat + call get_environment_variable("PATH",value,length=l,status=stat) + if (stat.ne.-1) stop 1 +end program test Index: Fortran/gfortran/regression/pr96613.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96613.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-O2 -std=gnu" } +! PR fortran/96613 - Fix type/kind of temporaries evaluating MIN/MAX + +program test + implicit none + real :: x = 7.7643945e+09 + real :: y = 6000. + integer :: ix + + ix = min1 (5000.0, x) + if (ix /= 5000) stop 1 + ix = min1 (y, x, 5555.d0) + if (ix /= 5555) stop 2 +end program Index: Fortran/gfortran/regression/pr96711.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96711.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-require-effective-target fortran_integer_16 } +! { dg-require-effective-target fortran_real_16 } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 2 "original" } } +! +! PR fortran/96711 - ICE on NINT() Function + +program p + implicit none + real(8) :: x + real(16) :: y + ! Assume radix(x) == 2 + ! 2/epsilon(x) = 2/(radix(x)**(1-digits(x)) = 2**digits(x) with that assumption + integer(16), parameter :: k1 = nint (2 / epsilon (x), kind(k1)) + integer(16), parameter :: k2 = nint (2 / epsilon (y), kind(k2)) + integer(16), parameter :: m1 = 2_16**digits(x) ! IEEE: 2**53 + integer(16), parameter :: m2 = 2_16**digits(y) ! IEEE: 2**113 + integer(16), volatile :: m + x = 2 / epsilon (x) + y = 2 / epsilon (y) + m = nint (x, kind(m)) +! print *, m + if (k1 /= m1) stop 1 + if (m /= m1) stop 2 + m = nint (y, kind(m)) +! print *, m + if (k2 /= m2) stop 3 + if (m /= m2) stop 4 +end program Index: Fortran/gfortran/regression/pr96737.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96737.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -g" } +! +! Test the fix for PR96737 in which the 'TYPE_CANONICAL' was not campatible +! in the submodule. +! +! Contributed by Andre Vehreschild +! +module surface_packages + implicit none + + type flux_planes + integer, allocatable :: normals(:,:) + end type + + type package + integer id + type(flux_planes), allocatable :: surface_fluxes(:) + integer, allocatable :: positions(:,:,:,:) + end type + + type surfaces + type(package), allocatable :: halo_outbox(:,:,:) + contains + procedure, nopass :: set_halo_outbox + procedure, nopass :: get_surface_normal_spacing + end type + + type problem_discretization + type(surfaces) block_surfaces + end type + + interface + module subroutine set_halo_outbox(my_halo_outbox) + implicit none + type(package), intent(in) :: my_halo_outbox(:,:,:) + end subroutine + + module subroutine get_surface_normal_spacing + end subroutine + end interface + +end module + +submodule(surface_packages) implementation + implicit none + type(surfaces), save :: singleton[*] +contains + + module procedure get_surface_normal_spacing + integer i, b, d, f + + do i=1,num_images() + associate( positions => reshape(i*[5,4,3,2], [2,1,1,2]), normals => reshape(i*[6,6,6], [3,1]) ) + do b=1,size(singleton[i]%halo_outbox,1) + do d=1,size(singleton[i]%halo_outbox,2) + do f=1,size(singleton[i]%halo_outbox,3) + if ( .not. all([singleton[i]%halo_outbox(b,d,f)%positions == positions]) ) error stop "positions" + if ( .not. all([singleton[i]%halo_outbox(b,d,f)%surface_fluxes(1)%normals == normals] ) ) error stop "normals" + end do + end do + end do + end associate + end do + end procedure + + module procedure set_halo_outbox + singleton%halo_outbox = my_halo_outbox + sync all + end procedure + +end submodule + +program main + use surface_packages, only : problem_discretization, package + implicit none + type(problem_discretization) global_grid + type(package), allocatable :: bare(:,:,:) + integer i, j, k + + associate( me=>this_image() ) + + allocate( bare(me,3,2) ) + + do i=1, size(bare,1) + bare(i,:,:)%id = i + do j=1, size(bare,2) + do k=1, size(bare,3) + bare(i,j,k)%positions = reshape(me*[5,4,3,2], [2,1,1,2]) + allocate( bare(i,j,k)%surface_fluxes(1) ) + bare(i,j,k)%surface_fluxes(1)%normals = reshape(me*[6,6,6], [3,1]) + end do + end do + end do + + call global_grid%block_surfaces%set_halo_outbox(bare) + call global_grid%block_surfaces%get_surface_normal_spacing + + end associate + + sync all + if (this_image()==1) print *,"Test passed" +end program main Index: Fortran/gfortran/regression/pr96859.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr96859.f90 @@ -0,0 +1,25 @@ +! PR fortran/96859 +! { dg-do run } + +program pr96859 + if (merge_bits(32767_2, o'1234567', 32767_2).ne.32767_2) stop 1 + if (merge_bits(o'1234567', 32767_2, o'1234567').ne.32767_2) stop 2 + if (merge_bits(32767_2, o'1234567', b'010101').ne.14711_2) stop 3 + if (merge_bits(32767_2, o'1234567', z'12345678').ne.32639_2) stop 4 + if (int (o'1034567', 2).ne.14711_2) stop 5 + if (int (o'1234567', 2).ne.14711_2) stop 6 + if (int (o'1434567', 2).ne.14711_2) stop 7 + if (int (o'1634567', 2).ne.14711_2) stop 8 + if (int (o'1134567', 2).ne.-18057_2) stop 9 + if (int (o'1334567', 2).ne.-18057_2) stop 10 + if (int (o'1534567', 2).ne.-18057_2) stop 11 + if (int (o'1734567', 2).ne.-18057_2) stop 12 + if (int (o'70123456776543211234567', 8).ne.1505855851274254711_8) stop 13 + if (int (o'72123456776543211234567', 8).ne.1505855851274254711_8) stop 14 + if (int (o'74123456776543211234567', 8).ne.1505855851274254711_8) stop 15 + if (int (o'76123456776543211234567', 8).ne.1505855851274254711_8) stop 16 + if (int (o'71123456776543211234567', 8).ne.-7717516185580521097_8) stop 17 + if (int (o'73123456776543211234567', 8).ne.-7717516185580521097_8) stop 18 + if (int (o'75123456776543211234567', 8).ne.-7717516185580521097_8) stop 19 + if (int (o'77123456776543211234567', 8).ne.-7717516185580521097_8) stop 20 +end Index: Fortran/gfortran/regression/pr97036.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97036.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/97036 - [F2018] Allow ELEMENTAL RECURSIVE procedure prefix + +module m97036 + implicit none +contains + impure elemental recursive subroutine foo (n) + integer, intent(in) :: n + integer :: k(n), f(n), i + k = [ (i-1, i=1,n) ] + f = fac (k) + print *, f + end subroutine foo + elemental recursive subroutine bla () + end subroutine bla + elemental recursive function fac (k) result (f) + integer, intent(in) :: k + integer :: f + f = 1 + if (k > 1) f = k*fac (k-1) + end function fac +end module + use m97036 + implicit none + call foo ([4,5]) +end Index: Fortran/gfortran/regression/pr97095.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97095.f @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-O2 -ftree-vectorize" } + subroutine gen3delem(nel,ial,ifix,xta,xnoref,dd,jact,nelshell) + real*8 xnoref(3),xta(3,100),xn1(3,100) + if(nel.gt.0) then + do j=1,nel + enddo + do + enddo + endif + do + if(ifix.eq.0) then + do j=nelshell,nel + if(ial(j).eq.0) then + endif + enddo + endif + do j=nelshell,nel + enddo + do j=1,3 + xnoref(j)=xnoref(j)/dd + enddo + xn1(2,jact)=xnoref(3)*xta(1,jact)-xnoref(1)*xta(3,jact) + xn1(3,jact)=xnoref(1)*xta(2,jact)-xnoref(2)*xta(1,jact) + call foo(xn1) + enddo + end Index: Fortran/gfortran/regression/pr97272.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97272.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR fortran/97272 - Wrong answer from MAXLOC with character arg + +program test + implicit none + integer :: i, j, k, l = 10 + character, allocatable :: a(:) + allocate (a(l)) + a(:) = 'a' + l = l - 1 + a(l) = 'b' + i = maxloc (a, dim=1) + j = maxloc (a, dim=1, kind=2) + k = maxloc (a, dim=1, kind=8, back=.true.) +! print *, 'i = ', i, 'a(i) = ', a(i) +! print *, 'j = ', j, 'a(j) = ', a(j) +! print *, 'k = ', k, 'a(k) = ', a(k) + if (i /= l .or. j /= l .or. k /= l) stop 1 +end Index: Fortran/gfortran/regression/pr97500.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97500.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-additional-options "-ftree-vectorize -fno-guess-branch-probability" } +module testmod + implicit none + + contains + + subroutine foo(n) + integer, intent(in) :: n + real :: r(0:n,-n:n), a(0:n,-n:n), dj + integer :: k, j + + ! initialize with some dummy values + do j = -n, n + a(:, j) = j + r(:,j) = j + 1 + end do + + ! here be dragons + do k = 0, n + dj = r(k, k - 2) * a(k, k - 2) + r(k,k) = a(k, k - 1) * dj + enddo + + if (r(0,0) .ne. -2.) STOP 1 + + end subroutine + +end module + +program test + use testmod + implicit none + call foo(5) +end program Index: Fortran/gfortran/regression/pr97505.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97505.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-Os -fsanitize=signed-integer-overflow" } +! +! Test the fix for PR35824, in which the interface assignment and +! negation did not work correctly. +! +! Contributed by Rolf Roth +! +module typemodule + type alltype + double precision :: a + double precision,allocatable :: b(:) + end type + interface assignment(=) + module procedure at_from_at + end interface + interface operator(-) + module procedure neg_at + end interface +contains + subroutine at_from_at(b,a) + type(alltype), intent(in) :: a + type(alltype), intent(out) :: b + b%a=a%a + allocate(b%b(2)) + b%b=a%b + end subroutine at_from_at + function neg_at(a) result(b) + type(alltype), intent(in) :: a + type(alltype) :: b + b%a=-a%a + allocate(b%b(2)) + b%b=-a%b + end function neg_at +end module + use typemodule + type(alltype) t1,t2,t3 + allocate(t1%b(2)) + t1%a=0.5d0 + t1%b(1)=1d0 + t1%b(2)=2d0 + t2=-t1 + if (t2%a .ne. -0.5d0) STOP 1 + if (any(t2%b .ne. [-1d0, -2d0])) STOP 2 + + t1=-t1 + if (t1%a .ne. -0.5d0) STOP 3 + if (any(t1%b .ne. [-1d0, -2d0])) STOP 4 +end Index: Fortran/gfortran/regression/pr97673.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97673.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O3 -fno-early-inlining --param large-stack-frame=4000" } + +subroutine sub3noiso(a, b) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +entry sub3noisoEntry(x,y,z) + x = 'd' +end subroutine sub3noiso Index: Fortran/gfortran/regression/pr97768_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97768_1.f90 @@ -0,0 +1,25 @@ +! PR fortran/97768 +! { dg-do compile } + +module pr97768_1 + interface operator(.in.) + module procedure substr_in_str + end interface +contains + pure function to_upper (in_str) result (string) + character(len=*), intent(in) :: in_str + character(len=len(in_str)) :: string + string = in_str + end function to_upper + logical pure function substr_in_str (substring, string) + character(len=*), intent(in) :: string, substring + substr_in_str=.false. + end function +end module +function foo () + use pr97768_1, only : to_upper, operator(.in.) + logical :: foo + character(len=8) :: str + str = 'abcde' + foo = 'b' .in. to_upper (str) +end function foo Index: Fortran/gfortran/regression/pr97768_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr97768_2.f90 @@ -0,0 +1,53 @@ +! PR fortran/97768 +! { dg-do compile } + +module pr97768_2 + interface operator(.in.) + module procedure substr_in_str + end interface +contains + pure function to_upper (in_str) result (string) + character(len=*), intent(in) :: in_str + character(len=len(in_str)) :: string + string = in_str + end function to_upper + logical pure function substr_in_str (substring, string) + character(len=*), intent(in) :: string, substring + substr_in_str=.false. + end function +end module +function foo () + use pr97768_2, only : to_upper, operator(.in.) + logical :: foo + character(len=8) :: str + str = 'abcde' + foo = to_upper (str) .in. 32 ! { dg-error "are CHARACTER/INTEGER" } +end function foo +function bar (str) + use pr97768_2, only : operator(.in.) + logical :: bar + character(len=*) :: str + foo = str .in. 32 ! { dg-error "are CHARACTER\\(\\*\\)/INTEGER" } +end function bar +function baz (lenstr) + use pr97768_2, only : operator(.in.) + logical :: baz + integer :: lenstr + character(len=lenstr) :: str + str = 'abc' + foo = str .in. 32 ! { dg-error "are CHARACTER/INTEGER" } +end function baz +function qux () + use pr97768_2, only : operator(.in.) + logical :: qux + character(len=8) :: str + str = 'def' + foo = str .in. 32 ! { dg-error "are CHARACTER\\(8\\)/INTEGER" } +end function qux +function corge () + use pr97768_2, only : operator(.in.) + logical :: corge + character(len=:), allocatable :: str + str = 'ghijk' + foo = str .in. 32 ! { dg-error "are CHARACTER\\(:\\)/INTEGER" } +end function corge Index: Fortran/gfortran/regression/pr98016.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98016.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Fix for PR98016 - Used to fail with Error: Variable ‘n’ cannot appear in the +! expression at (1) for line 16. Workaround was to declare y to be real. +! +! Posted by Juergen Reuter +! +program is_it_valid + dimension y(3) + n=3 + y=func(1.0) + print *, y + stop +contains + function func(x) result (y) + dimension y(n) + y=x + end function +end Index: Fortran/gfortran/regression/pr98017.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98017.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR98017 - [8/9/10/11 Regression] Suspected regression using PACK + +program p + implicit none + character(*), parameter :: s(1) = ['abc()'] + character(*), parameter :: t(*) = s(:)(:1) + if (len (pack (s, s(:)(:1) == 'a')) /= len (s)) stop 1 + if (any (pack (s, s(:)(:1) == 'a') /= s)) stop 2 + if (len (pack (s, t == 'a')) /= len (s)) stop 3 + if (any (pack (s, t == 'a') /= s)) stop 4 + if (len (pack (s(:)(1:5), t == 'a')) /= len (s)) stop 5 + if (any (pack (s(:)(1:5), t == 'a') /= s)) stop 6 +end Index: Fortran/gfortran/regression/pr98076.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98076.f90 @@ -0,0 +1,293 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! +! Check that we can print large integer values + +program test + implicit none + ! 128-bit integer kind + integer, parameter :: k = selected_int_kind(38) + + character(len=39) :: s + character(len=100) :: buffer + integer(kind=k) :: n + integer :: i + + ! Random checks + do i = 1, 1000 + call random_digits(s) + read(s,*) n + write(buffer,'(I0.38)') n + print *, s + print *, buffer + if (adjustl(buffer) /= adjustl(s)) stop 2 + end do + + ! Systematic check + call check(0_k, "0") + call check(1_k, "1") + call check(9_k, "9") + call check(10_k, "10") + call check(11_k, "11") + call check(99_k, "99") + call check(100_k, "100") + call check(101_k, "101") + call check(999_k, "999") + call check(1000_k, "1000") + call check(1001_k, "1001") + call check(9999_k, "9999") + call check(10000_k, "10000") + call check(10001_k, "10001") + call check(99999_k, "99999") + call check(100000_k, "100000") + call check(100001_k, "100001") + call check(999999_k, "999999") + call check(1000000_k, "1000000") + call check(1000001_k, "1000001") + call check(9999999_k, "9999999") + call check(10000000_k, "10000000") + call check(10000001_k, "10000001") + call check(99999999_k, "99999999") + call check(100000000_k, "100000000") + call check(100000001_k, "100000001") + call check(999999999_k, "999999999") + call check(1000000000_k, "1000000000") + call check(1000000001_k, "1000000001") + call check(9999999999_k, "9999999999") + call check(10000000000_k, "10000000000") + call check(10000000001_k, "10000000001") + call check(99999999999_k, "99999999999") + call check(100000000000_k, "100000000000") + call check(100000000001_k, "100000000001") + call check(999999999999_k, "999999999999") + call check(1000000000000_k, "1000000000000") + call check(1000000000001_k, "1000000000001") + call check(9999999999999_k, "9999999999999") + call check(10000000000000_k, "10000000000000") + call check(10000000000001_k, "10000000000001") + call check(99999999999999_k, "99999999999999") + call check(100000000000000_k, "100000000000000") + call check(100000000000001_k, "100000000000001") + call check(999999999999999_k, "999999999999999") + call check(1000000000000000_k, "1000000000000000") + call check(1000000000000001_k, "1000000000000001") + call check(9999999999999999_k, "9999999999999999") + call check(10000000000000000_k, "10000000000000000") + call check(10000000000000001_k, "10000000000000001") + call check(99999999999999999_k, "99999999999999999") + call check(100000000000000000_k, "100000000000000000") + call check(100000000000000001_k, "100000000000000001") + call check(999999999999999999_k, "999999999999999999") + call check(1000000000000000000_k, "1000000000000000000") + call check(1000000000000000001_k, "1000000000000000001") + call check(9999999999999999999_k, "9999999999999999999") + call check(10000000000000000000_k, "10000000000000000000") + call check(10000000000000000001_k, "10000000000000000001") + call check(99999999999999999999_k, "99999999999999999999") + call check(100000000000000000000_k, "100000000000000000000") + call check(100000000000000000001_k, "100000000000000000001") + call check(999999999999999999999_k, "999999999999999999999") + call check(1000000000000000000000_k, "1000000000000000000000") + call check(1000000000000000000001_k, "1000000000000000000001") + call check(9999999999999999999999_k, "9999999999999999999999") + call check(10000000000000000000000_k, "10000000000000000000000") + call check(10000000000000000000001_k, "10000000000000000000001") + call check(99999999999999999999999_k, "99999999999999999999999") + call check(100000000000000000000000_k, "100000000000000000000000") + call check(100000000000000000000001_k, "100000000000000000000001") + call check(999999999999999999999999_k, "999999999999999999999999") + call check(1000000000000000000000000_k, "1000000000000000000000000") + call check(1000000000000000000000001_k, "1000000000000000000000001") + call check(9999999999999999999999999_k, "9999999999999999999999999") + call check(10000000000000000000000000_k, "10000000000000000000000000") + call check(10000000000000000000000001_k, "10000000000000000000000001") + call check(99999999999999999999999999_k, "99999999999999999999999999") + call check(100000000000000000000000000_k, "100000000000000000000000000") + call check(100000000000000000000000001_k, "100000000000000000000000001") + call check(999999999999999999999999999_k, "999999999999999999999999999") + call check(1000000000000000000000000000_k, "1000000000000000000000000000") + call check(1000000000000000000000000001_k, "1000000000000000000000000001") + call check(9999999999999999999999999999_k, "9999999999999999999999999999") + call check(10000000000000000000000000000_k, "10000000000000000000000000000") + call check(10000000000000000000000000001_k, "10000000000000000000000000001") + call check(99999999999999999999999999999_k, "99999999999999999999999999999") + call check(100000000000000000000000000000_k, "100000000000000000000000000000") + call check(100000000000000000000000000001_k, "100000000000000000000000000001") + call check(999999999999999999999999999999_k, "999999999999999999999999999999") + call check(1000000000000000000000000000000_k, "1000000000000000000000000000000") + call check(1000000000000000000000000000001_k, "1000000000000000000000000000001") + call check(9999999999999999999999999999999_k, "9999999999999999999999999999999") + call check(10000000000000000000000000000000_k, "10000000000000000000000000000000") + call check(10000000000000000000000000000001_k, "10000000000000000000000000000001") + call check(99999999999999999999999999999999_k, "99999999999999999999999999999999") + call check(100000000000000000000000000000000_k, "100000000000000000000000000000000") + call check(100000000000000000000000000000001_k, "100000000000000000000000000000001") + call check(999999999999999999999999999999999_k, "999999999999999999999999999999999") + call check(1000000000000000000000000000000000_k, "1000000000000000000000000000000000") + call check(1000000000000000000000000000000001_k, "1000000000000000000000000000000001") + call check(9999999999999999999999999999999999_k, "9999999999999999999999999999999999") + call check(10000000000000000000000000000000000_k, "10000000000000000000000000000000000") + call check(10000000000000000000000000000000001_k, "10000000000000000000000000000000001") + call check(99999999999999999999999999999999999_k, "99999999999999999999999999999999999") + call check(100000000000000000000000000000000000_k, "100000000000000000000000000000000000") + call check(100000000000000000000000000000000001_k, "100000000000000000000000000000000001") + call check(999999999999999999999999999999999999_k, "999999999999999999999999999999999999") + call check(1000000000000000000000000000000000000_k, "1000000000000000000000000000000000000") + call check(1000000000000000000000000000000000001_k, "1000000000000000000000000000000000001") + call check(9999999999999999999999999999999999999_k, "9999999999999999999999999999999999999") + call check(10000000000000000000000000000000000000_k, "10000000000000000000000000000000000000") + call check(10000000000000000000000000000000000001_k, "10000000000000000000000000000000000001") + call check(99999999999999999999999999999999999999_k, "99999999999999999999999999999999999999") + call check(100000000000000000000000000000000000000_k, "100000000000000000000000000000000000000") + call check(100000000000000000000000000000000000001_k, "100000000000000000000000000000000000001") + call check(109999999999999999999999999999999999999_k, "109999999999999999999999999999999999999") + + call check(-1_k, "-1") + call check(-9_k, "-9") + call check(-10_k, "-10") + call check(-11_k, "-11") + call check(-99_k, "-99") + call check(-100_k, "-100") + call check(-101_k, "-101") + call check(-999_k, "-999") + call check(-1000_k, "-1000") + call check(-1001_k, "-1001") + call check(-9999_k, "-9999") + call check(-10000_k, "-10000") + call check(-10001_k, "-10001") + call check(-99999_k, "-99999") + call check(-100000_k, "-100000") + call check(-100001_k, "-100001") + call check(-999999_k, "-999999") + call check(-1000000_k, "-1000000") + call check(-1000001_k, "-1000001") + call check(-9999999_k, "-9999999") + call check(-10000000_k, "-10000000") + call check(-10000001_k, "-10000001") + call check(-99999999_k, "-99999999") + call check(-100000000_k, "-100000000") + call check(-100000001_k, "-100000001") + call check(-999999999_k, "-999999999") + call check(-1000000000_k, "-1000000000") + call check(-1000000001_k, "-1000000001") + call check(-9999999999_k, "-9999999999") + call check(-10000000000_k, "-10000000000") + call check(-10000000001_k, "-10000000001") + call check(-99999999999_k, "-99999999999") + call check(-100000000000_k, "-100000000000") + call check(-100000000001_k, "-100000000001") + call check(-999999999999_k, "-999999999999") + call check(-1000000000000_k, "-1000000000000") + call check(-1000000000001_k, "-1000000000001") + call check(-9999999999999_k, "-9999999999999") + call check(-10000000000000_k, "-10000000000000") + call check(-10000000000001_k, "-10000000000001") + call check(-99999999999999_k, "-99999999999999") + call check(-100000000000000_k, "-100000000000000") + call check(-100000000000001_k, "-100000000000001") + call check(-999999999999999_k, "-999999999999999") + call check(-1000000000000000_k, "-1000000000000000") + call check(-1000000000000001_k, "-1000000000000001") + call check(-9999999999999999_k, "-9999999999999999") + call check(-10000000000000000_k, "-10000000000000000") + call check(-10000000000000001_k, "-10000000000000001") + call check(-99999999999999999_k, "-99999999999999999") + call check(-100000000000000000_k, "-100000000000000000") + call check(-100000000000000001_k, "-100000000000000001") + call check(-999999999999999999_k, "-999999999999999999") + call check(-1000000000000000000_k, "-1000000000000000000") + call check(-1000000000000000001_k, "-1000000000000000001") + call check(-9999999999999999999_k, "-9999999999999999999") + call check(-10000000000000000000_k, "-10000000000000000000") + call check(-10000000000000000001_k, "-10000000000000000001") + call check(-99999999999999999999_k, "-99999999999999999999") + call check(-100000000000000000000_k, "-100000000000000000000") + call check(-100000000000000000001_k, "-100000000000000000001") + call check(-999999999999999999999_k, "-999999999999999999999") + call check(-1000000000000000000000_k, "-1000000000000000000000") + call check(-1000000000000000000001_k, "-1000000000000000000001") + call check(-9999999999999999999999_k, "-9999999999999999999999") + call check(-10000000000000000000000_k, "-10000000000000000000000") + call check(-10000000000000000000001_k, "-10000000000000000000001") + call check(-99999999999999999999999_k, "-99999999999999999999999") + call check(-100000000000000000000000_k, "-100000000000000000000000") + call check(-100000000000000000000001_k, "-100000000000000000000001") + call check(-999999999999999999999999_k, "-999999999999999999999999") + call check(-1000000000000000000000000_k, "-1000000000000000000000000") + call check(-1000000000000000000000001_k, "-1000000000000000000000001") + call check(-9999999999999999999999999_k, "-9999999999999999999999999") + call check(-10000000000000000000000000_k, "-10000000000000000000000000") + call check(-10000000000000000000000001_k, "-10000000000000000000000001") + call check(-99999999999999999999999999_k, "-99999999999999999999999999") + call check(-100000000000000000000000000_k, "-100000000000000000000000000") + call check(-100000000000000000000000001_k, "-100000000000000000000000001") + call check(-999999999999999999999999999_k, "-999999999999999999999999999") + call check(-1000000000000000000000000000_k, "-1000000000000000000000000000") + call check(-1000000000000000000000000001_k, "-1000000000000000000000000001") + call check(-9999999999999999999999999999_k, "-9999999999999999999999999999") + call check(-10000000000000000000000000000_k, "-10000000000000000000000000000") + call check(-10000000000000000000000000001_k, "-10000000000000000000000000001") + call check(-99999999999999999999999999999_k, "-99999999999999999999999999999") + call check(-100000000000000000000000000000_k, "-100000000000000000000000000000") + call check(-100000000000000000000000000001_k, "-100000000000000000000000000001") + call check(-999999999999999999999999999999_k, "-999999999999999999999999999999") + call check(-1000000000000000000000000000000_k, "-1000000000000000000000000000000") + call check(-1000000000000000000000000000001_k, "-1000000000000000000000000000001") + call check(-9999999999999999999999999999999_k, "-9999999999999999999999999999999") + call check(-10000000000000000000000000000000_k, "-10000000000000000000000000000000") + call check(-10000000000000000000000000000001_k, "-10000000000000000000000000000001") + call check(-99999999999999999999999999999999_k, "-99999999999999999999999999999999") + call check(-100000000000000000000000000000000_k, "-100000000000000000000000000000000") + call check(-100000000000000000000000000000001_k, "-100000000000000000000000000000001") + call check(-999999999999999999999999999999999_k, "-999999999999999999999999999999999") + call check(-1000000000000000000000000000000000_k, "-1000000000000000000000000000000000") + call check(-1000000000000000000000000000000001_k, "-1000000000000000000000000000000001") + call check(-9999999999999999999999999999999999_k, "-9999999999999999999999999999999999") + call check(-10000000000000000000000000000000000_k, "-10000000000000000000000000000000000") + call check(-10000000000000000000000000000000001_k, "-10000000000000000000000000000000001") + call check(-99999999999999999999999999999999999_k, "-99999999999999999999999999999999999") + call check(-100000000000000000000000000000000000_k, "-100000000000000000000000000000000000") + call check(-100000000000000000000000000000000001_k, "-100000000000000000000000000000000001") + call check(-999999999999999999999999999999999999_k, "-999999999999999999999999999999999999") + call check(-1000000000000000000000000000000000000_k, "-1000000000000000000000000000000000000") + call check(-1000000000000000000000000000000000001_k, "-1000000000000000000000000000000000001") + call check(-9999999999999999999999999999999999999_k, "-9999999999999999999999999999999999999") + call check(-10000000000000000000000000000000000000_k, "-10000000000000000000000000000000000000") + call check(-10000000000000000000000000000000000001_k, "-10000000000000000000000000000000000001") + call check(-99999999999999999999999999999999999999_k, "-99999999999999999999999999999999999999") + call check(-100000000000000000000000000000000000000_k, "-100000000000000000000000000000000000000") + call check(-100000000000000000000000000000000000001_k, "-100000000000000000000000000000000000001") + call check(-109999999999999999999999999999999999999_k, "-109999999999999999999999999999999999999") + +contains + + subroutine check (i, str) + implicit none + integer(kind=k), intent(in), value :: i + character(len=*), intent(in) :: str + + character(len=100) :: buffer + write(buffer,*) i + if (adjustl(buffer) /= adjustl(str)) stop 1 + end subroutine + + subroutine random_digits (str) + implicit none + integer, parameter :: l = 38 + character(len=l+1) :: str + real :: r + integer :: i, d + + str = "" + do i = 2, l+1 + call random_number(r) + d = floor(r * 10) + str(i:i) = achar(48 + d) + end do + + call random_number(r) + if (r > 0.5) then + str(1:1) = '-' + end if + end subroutine +end Index: Fortran/gfortran/regression/pr98284.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98284.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/98284 - ICE in get_array_index + +program p + implicit none + type t + integer, allocatable :: h(:) + end type t + type(t) :: u + integer :: i + data (u% h(i),i=1,8) /8*1/ ! { dg-error "cannot have the ALLOCATABLE attribute" } +end Index: Fortran/gfortran/regression/pr98411.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98411.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2008 -Wall -fautomatic -fmax-stack-var-size=100" } +! PR fortran/98411 - Pointless warning for static variables + +module try + implicit none + integer, save :: a(1000) +contains + subroutine initmodule + real, save :: b(1000) + logical :: c(1000) ! { dg-warning "moved from stack to static storage" } + integer :: e(1000) = 1 + a(1) = 42 + b(2) = 3.14 + c(3) = .true. + e(5) = -1 + end subroutine initmodule +end module try Index: Fortran/gfortran/regression/pr98661.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98661.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/98661 - valgrind issues with error recovery +! +! Test issues related to former testcase charlen_03.f90 +program p + implicit none + type t + character(:), pointer :: c(n) ! { dg-error "must have a deferred shape" } + real, allocatable :: x(n) ! { dg-error "must have a deferred shape" } + end type +end + +subroutine s +! no 'implicit none' + type u + character(:), pointer :: c(n) ! { dg-error "must have a deferred shape" } + real, allocatable :: x(n) ! { dg-error "must have a deferred shape" } + end type +end Index: Fortran/gfortran/regression/pr98974.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr98974.F90 @@ -0,0 +1,21 @@ +! PR middle-end/98974 +! { dg-do compile } +! { dg-options "-Ofast" } +! { dg-additional-options "-mcpu=neoverse-v1" { target aarch64*-*-* } } + +module module_foobar + integer,parameter :: fp_kind = selected_real_kind(15) +contains + subroutine foobar( foo, ix ,jx ,kx,iy,ky) + real, dimension( ix, kx, jx ) :: foo + real(fp_kind), dimension( iy, ky, 3 ) :: bar, baz + do k=1,ky + do i=1,iy + if ( baz(i,k,1) > 0. ) then + bar(i,k,1) = 0 + endif + foo(i,nk,j) = baz0 * bar(i,k,1) + enddo + enddo + end +end Index: Fortran/gfortran/regression/pr99060.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99060.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test the fix for PR99060 in which the expression caused an ICE after the error. +! +! Contributed by Gerhard Steinmetz +! +program p + real :: a + print *, a%kind%n ! { dg-error "not an inquiry reference" } +end Index: Fortran/gfortran/regression/pr99112.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99112.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! PR99112 - ICE with runtime diagnostics for SIZE intrinsic function + +module m + type t + end type +contains + function f (x, y) result(z) + class(t) :: x(:) + class(t) :: y(size(x)) + type(t) :: z(size(x)) + end + function g (x) result(z) + class(*) :: x(:) + type(t) :: z(size(x)) + end + subroutine s () + class(t), allocatable :: a(:), b(:), c(:), d(:) + class(t), pointer :: p(:) + c = f (a, b) + d = g (p) + end +end +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 3 "original" } } +! { dg-final { scan-tree-dump-times "Allocatable actual argument" 2 "original" } } +! { dg-final { scan-tree-dump-times "Pointer actual argument" 1 "original" } } Index: Fortran/gfortran/regression/pr99204.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99204.f90 @@ -0,0 +1,10 @@ +! PR tree-optimization/99204 +! { dg-do compile } +! { dg-options "-O2 -w" } + +program pr99204 + character :: c + integer :: i = -12345678 + c = 'abc'(i:i) + print *, c +end Index: Fortran/gfortran/regression/pr99349.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99349.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/99349 - ICE in match_data_constant +! Contributed by G.Steinmetz + +function f() + logical, parameter :: a((1.)/0) = .true. ! { dg-error "Parameter array" } + integer :: b + data b /a%kind/ ! { dg-error "Syntax error" } +end Index: Fortran/gfortran/regression/pr99545.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99545.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-fcheck=mem" } +! +! Test the fix for PR99545, in which the allocate statements caused an ICE. +! +! Contributed by Juergen Reuter +! +module commands + implicit none + private + + type, abstract :: range_t + integer :: step_mode = 0 + integer :: n_step = 0 + end type range_t + + type, extends (range_t) :: range_int_t + integer :: i_step = 0 + end type range_int_t + + type, extends (range_t) :: range_real_t + real :: lr_step = 0 +end type range_real_t + + type :: cmd_scan_t + private + class(range_t), dimension(:), allocatable :: range + contains + procedure :: compile => cmd_scan_compile + end type cmd_scan_t + +contains + + subroutine cmd_scan_compile (cmd) + class(cmd_scan_t), intent(inout) :: cmd + allocate (range_int_t :: cmd%range (3)) + allocate (range_real_t :: cmd%range (3)) + end subroutine cmd_scan_compile + +end module commands Index: Fortran/gfortran/regression/pr99602.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99602.f90 @@ -0,0 +1,94 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! +! Test fix of PR99602, where a spurious runtime error was introduced +! by PR99112. This is the testcase in comment #6 of the PR. +! PR99602a.f90 turns on the runtime errors by eliminating the pointer +! attribute from the formal arguments in the abstract interface and +! prepare_whizard_m2. +! +! Contributed by Jeurgen Reuter +! +module m + implicit none + private + public :: m_t + type :: m_t + private + end type m_t +end module m + +module m2_testbed + use m + implicit none + private + public :: prepare_m2 + procedure (prepare_m2_proc), pointer :: prepare_m2 => null () + + abstract interface + subroutine prepare_m2_proc (m2) + import + class(m_t), intent(inout), pointer :: m2 + end subroutine prepare_m2_proc + end interface + +end module m2_testbed + +module a + use m + use m2_testbed, only: prepare_m2 + implicit none + private + public :: a_1 + +contains + + subroutine a_1 () + class(m_t), pointer :: mm + mm => null () + call prepare_m2 (mm) ! Runtime error triggered here + end subroutine a_1 + +end module a + + +module m2 + use m + implicit none + private + public :: m2_t + + type, extends (m_t) :: m2_t + private + contains + procedure :: read => m2_read + end type m2_t +contains + + subroutine m2_read (mm) + class(m2_t), intent(out), target :: mm + end subroutine m2_read +end module m2 + +program main + use m2_testbed + use a, only: a_1 + implicit none + prepare_m2 => prepare_whizard_m2 + call a_1 () + +contains + + subroutine prepare_whizard_m2 (mm) + use m + use m2 + class(m_t), intent(inout), pointer :: mm + if (.not. associated (mm)) allocate (m2_t :: mm) + select type (mm) + type is (m2_t) +! call mm%read () ! Since mm is passed to non-pointer, this generates the error code. + end select + end subroutine prepare_whizard_m2 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 0 "original" } } +! { dg-final { scan-tree-dump-times "Pointer actual argument" 0 "original" } } Index: Fortran/gfortran/regression/pr99602a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99602a.f90 @@ -0,0 +1,93 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! +! Test fix of PR99602, where a spurious runtime error was introduced +! by PR99112. This is the testcase in comment #6 of the PR. +! This version of PR99602.f90 turns on the runtime errors by eliminating +! the pointer attribute from the formal arguments in the abstract interface +! and prepare_whizard_m2. +! +! Contributed by Jeurgen Reuter +! +module m + implicit none + private + public :: m_t + type :: m_t + private + end type m_t +end module m + +module m2_testbed + use m + implicit none + private + public :: prepare_m2 + procedure (prepare_m2_proc), pointer :: prepare_m2 => null () + + abstract interface + subroutine prepare_m2_proc (m2) + import + class(m_t), intent(inout) :: m2 + end subroutine prepare_m2_proc + end interface + +end module m2_testbed + +module a + use m + use m2_testbed, only: prepare_m2 + implicit none + private + public :: a_1 + +contains + + subroutine a_1 () + class(m_t), pointer :: mm + mm => null () + call prepare_m2 (mm) ! Runtime error triggered here + end subroutine a_1 + +end module a + + +module m2 + use m + implicit none + private + public :: m2_t + + type, extends (m_t) :: m2_t + private + contains + procedure :: read => m2_read + end type m2_t +contains + + subroutine m2_read (mm) + class(m2_t), intent(out), target :: mm + end subroutine m2_read +end module m2 + +program main + use m2_testbed + use a, only: a_1 + implicit none + prepare_m2 => prepare_whizard_m2 + call a_1 () + +contains + + subroutine prepare_whizard_m2 (mm) + use m + use m2 + class(m_t), intent(inout) :: mm + select type (mm) + type is (m2_t) + call mm%read () + end select + end subroutine prepare_whizard_m2 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 1 "original" } } +! { dg-final { scan-tree-dump-times "Pointer actual argument" 1 "original" } } Index: Fortran/gfortran/regression/pr99602b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99602b.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-fcheck=pointer" } +! +! Test the fix for PR99602 in which the runtime error, +! "Proc-pointer actual argument 'model' is not associated" was triggered +! by the NULL result from model%get_par_data_ptr ("tea ") +! +! Contributed by Juergen Reuter +! +module model_data + type :: model_data_t + type(modelpar_real_t), dimension(:), pointer :: par_real => null () + contains + procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name + procedure :: set => field_data_set + end type model_data_t + + type :: modelpar_real_t + character (4) :: name + real(4) :: value + end type modelpar_real_t + + type(modelpar_real_t), target :: names(2) = [modelpar_real_t("foo ", 1.0), & + modelpar_real_t("bar ", 2.0)] + integer :: return_value = 0 + +contains + + function model_data_get_par_data_ptr_name (model, name) result (ptr) + class(model_data_t), intent(in) :: model + character (*), intent(in) :: name + class(modelpar_real_t), pointer :: ptr + integer :: i + ptr => null () + do i = 1, size (model%par_real) + if (model%par_real(i)%name == name) ptr => model%par_real(i) + end do + end function model_data_get_par_data_ptr_name + + subroutine field_data_set (this, ptr) + class(model_data_t), intent(inout) :: this + class(modelpar_real_t), intent(in), pointer :: ptr + if (associated (ptr)) then + return_value = int (ptr%value) + else + return_value = -1 + end if + end subroutine + +end module model_data + + use model_data + class(model_data_t), allocatable :: model + class(modelpar_real_t), pointer :: name_ptr + + allocate (model_data_t :: model) + model%par_real => names + + call model%set (model%get_par_data_ptr ("bar ")) + if (return_value .ne. 2) stop 1 + call model%set (model%get_par_data_ptr ("tea ")) ! Triggered runtime error + if (return_value .ne. -1) stop 2 +end + Index: Fortran/gfortran/regression/pr99602c.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99602c.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! +! PR fortran/99602 +! + +module m + implicit none +contains + subroutine wr(y) + class(*), pointer :: y + if (associated (y)) stop 1 + end +end module m + +use m +implicit none +class(*), pointer :: cptr + +nullify (cptr) +call wr(cptr) +end + +! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } } +! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } } Index: Fortran/gfortran/regression/pr99602d.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99602d.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fcheck=pointer -fdump-tree-original" } +! +! PR fortran/99602 +! + +module m + implicit none +contains + subroutine wr(y) + class(*), pointer :: y + if (associated (y)) stop 1 + end +end module m + +use m +implicit none +class(*), pointer :: cptr + +nullify (cptr) +call wr(cptr) +end + +! { dg-final { scan-tree-dump-not "_gfortran_runtime_error_at" "original" } } +! { dg-final { scan-tree-dump-not "Pointer actual argument" "original" } } Index: Fortran/gfortran/regression/pr99853.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99853.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/99853 + +subroutine s1 () + select case (.true.) ! { dg-error "Cannot convert" } + case (1_8) ! { dg-error "must be of type LOGICAL" } + end select +end + +subroutine s2 () + select case (.false._1) ! { dg-error "Cannot convert" } + case (2:3) ! { dg-error "must be of type LOGICAL" } + end select +end + +subroutine s3 () + select case (3_2) ! { dg-error "Cannot convert" } + case (.false.) ! { dg-error "must be of type INTEGER" } + end select +end + +subroutine s4 (i) + select case (i) ! { dg-error "Cannot convert" } + case (.true._8) ! { dg-error "must be of type INTEGER" } + end select +end + +! { dg-prune-output "Cannot convert" } Index: Fortran/gfortran/regression/pr99956.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pr99956.f @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -floop-interchange -fdump-tree-linterchange-details" } + + subroutine mat_times_vec(y,x,a,axp,ayp,azp,axm,aym,azm, + $ nb,nx,ny,nz) + implicit none + integer nb,nx,ny,nz,i,j,k,m,l,kit,im1,ip1,jm1,jp1,km1,kp1 + + real*8 y(nb,nx,ny,nz),x(nb,nx,ny,nz),tem + + real*8 a(nb,nb,nx,ny,nz), + 1 axp(nb,nb,nx,ny,nz),ayp(nb,nb,nx,ny,nz),azp(nb,nb,nx,ny,nz), + 2 axm(nb,nb,nx,ny,nz),aym(nb,nb,nx,ny,nz),azm(nb,nb,nx,ny,nz) + + + do k=1,nz + km1=mod(k+nz-2,nz)+1 + kp1=mod(k,nz)+1 + do j=1,ny + jm1=mod(j+ny-2,ny)+1 + jp1=mod(j,ny)+1 + do i=1,nx + im1=mod(i+nx-2,nx)+1 + ip1=mod(i,nx)+1 + do l=1,nb + tem=0.0 + do m=1,nb + tem=tem+ + 1 a(l,m,i,j,k)*x(m,i,j,k)+ + 2 axp(l,m,i,j,k)*x(m,ip1,j,k)+ + 3 ayp(l,m,i,j,k)*x(m,i,jp1,k)+ + 4 azp(l,m,i,j,k)*x(m,i,j,kp1)+ + 5 axm(l,m,i,j,k)*x(m,im1,j,k)+ + 6 aym(l,m,i,j,k)*x(m,i,jm1,k)+ + 7 azm(l,m,i,j,k)*x(m,i,j,km1) + enddo + y(l,i,j,k)=tem + enddo + enddo + enddo + enddo + return + end + +! { dg-final { scan-tree-dump-times "is interchanged" 1 "linterchange" } } Index: Fortran/gfortran/regression/predcom-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/predcom-1.f @@ -0,0 +1,16 @@ +! PR 32160, complex temporary variables were not marked as gimple registers +! { dg-do compile } +! { dg-options "-O3" } + + REAL FUNCTION CLANHT( N, E ) + INTEGER N + COMPLEX E( * ) + INTEGER I + REAL ANORM + INTRINSIC ABS + DO 20 I = 2, N + ANORM = ANORM +ABS( E( I ) )+ ABS( E( I-1 ) ) + 20 CONTINUE + CLANHT = ANORM + RETURN + END Index: Fortran/gfortran/regression/predcom-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/predcom-2.f @@ -0,0 +1,20 @@ +! PR 32220, ICE when the loop is not unrolled enough to eliminate all +! register copies +! { dg-do compile } +! { dg-options "-O3 -std=legacy" } + + subroutine derv (b,cosxy,thick) +c + common /shell4/xji(3,3) +c + dimension cosxy(6,*), + 1 thick(*),b(*) +c + + do 125 i=1,3 + b(k2+i)=xji(i,1) + xji(i,2) + xji(i,3) + 125 b(k3+i)=cosxy(i+3,kk) + cosxy(i,kk) +c +c + return + end Index: Fortran/gfortran/regression/predict-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/predict-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-profile_estimate" } + +subroutine test(block, array) +integer :: i, block(9), array(2) + +do i = array(1), array(2), 2 + block(i) = i +end do + +do i = array(1), array(2), -2 + block(i) = block(i) + i +end do + +end subroutine test + +! { dg-final { scan-tree-dump-times "Fortran loop preheader heuristics of edge\[^:\]*: 1.00%" 2 "profile_estimate" } } Index: Fortran/gfortran/regression/predict-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/predict-2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-profile_estimate" } + +subroutine test(block, array) +integer :: i,j, block(9), array(4) + +do i = array(1), array(2), 2 + do j = array(3), array(4), 3 + block(i) = j + end do +end do +end subroutine test + +! { dg-final { scan-tree-dump-times "Fortran loop preheader heuristics of edge" 2 "profile_estimate" } } +! { dg-final { scan-tree-dump-times "loop guard" 0 "profile_estimate" } } Index: Fortran/gfortran/regression/predict-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/predict-3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-fno-tree-fre -fno-tree-ccp -Og" } + +program simplify_transfer + call pr30881 () +contains + subroutine pr18769 () + type t + end type t + end subroutine pr18769 + subroutine pr30881 () + INTEGER, PARAMETER :: K=1 + I=TRANSFER(.TRUE.,K) + SELECT CASE(I) + CASE(TRANSFER(.TRUE.,K)) + CASE(TRANSFER(.FALSE.,K)) + STOP 2 + CASE DEFAULT + STOP 3 + END SELECT + END subroutine pr30881 + subroutine pr31194 () + end subroutine pr31194 + subroutine pr31216 () + END subroutine pr31216 + subroutine pr31427 () + END subroutine pr31427 +end program simplify_transfer Index: Fortran/gfortran/regression/present_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/present_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Test the fix for PR25097, in which subobjects of the optional dummy argument +! could appear as argument A of the PRESENT intrinsic. +! +! Contributed by Joost VandeVondele +! + MODULE M1 + TYPE T1 + INTEGER :: I + END TYPE T1 + CONTAINS + SUBROUTINE S1(D1) + TYPE(T1), OPTIONAL :: D1(4) + write(6,*) PRESENT(D1%I) ! { dg-error "must not be a subobject" } + write(6,*) PRESENT(D1(1)) ! { dg-error "must not be a subobject" } + write(6,*) PRESENT(D1) + END SUBROUTINE S1 + END MODULE + END Index: Fortran/gfortran/regression/print_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/29403 +program p + character(len=10) a, b, c + integer i + i = 1 + print ('(I0)'), i + a = '(I0,' + b = 'I2,' + c = 'I4)' + call prn(a, b, c, i) + print (1,*), i ! { dg-error "in PRINT statement" } +end program p + +subroutine prn(a, b, c, i) + integer i + character(len=*) a, b, c + print (a//(b//c)), i, i, i + print trim(a//trim(b//c)), i, i, i +end subroutine prn Index: Fortran/gfortran/regression/print_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR52564 Accepts invalid: Missing I/O list after comma +program printbug + print *, 'hello world' +! the following line should not compile: + print *, ! { dg-error "not allowed" } +end program Index: Fortran/gfortran/regression/print_c_kinds.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_c_kinds.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +program print_c_kinds + use, intrinsic :: iso_c_binding + implicit none + + print *, 'c_short is: ', c_short + print *, 'c_int is: ', c_int + print *, 'c_long is: ', c_long + print *, 'c_long_long is: ', c_long_long + print * + print *, 'c_int8_t is: ', c_int8_t + print *, 'c_int_least8_t is: ', c_int_least8_t + print *, 'c_int_fast8_t is: ', c_int_fast8_t + print * + print *, 'c_int16_t is: ', c_int16_t + print *, 'c_int_least16_t is: ', c_int_least16_t + print *, 'c_int_fast16_t is: ', c_int_fast16_t + print * + print *, 'c_int32_t is: ', c_int32_t + print *, 'c_int_least32_t is: ', c_int_least32_t + print *, 'c_int_fast32_t is: ', c_int_fast32_t + print * + print *, 'c_int64_t is: ', c_int64_t + print *, 'c_int_least64_t is: ', c_int_least64_t + print *, 'c_int_fast64_t is: ', c_int_fast64_t + print * + print *, 'c_intmax_t is: ', c_intmax_t + print *, 'c_intptr_t is: ', c_intptr_t + print * + print *, 'c_float is: ', c_float + print *, 'c_double is: ', c_double + print *, 'c_long_double is: ', c_long_double + print * + print *, 'c_char is: ', c_char +end program print_c_kinds Index: Fortran/gfortran/regression/print_fmt_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_fmt_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR 23661 +! PRINT with a character format was broken +character(5) :: f = "(a)" +! { dg-output "check" } +print f, "check" +end Index: Fortran/gfortran/regression/print_fmt_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_fmt_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 23661 Make sure space between PRINT and variable name is enforced in +! free form. +! Also tests the namelist case +character(5) :: f = "(a)" +real x +namelist /mynml/ x +printf, "check" ! { dg-error "Unclassifiable" } +x = 1 +printmynml +end Index: Fortran/gfortran/regression/print_fmt_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_fmt_3.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 23661 Make sure space between PRINT and variable name is not enforced in +! fixed form. +! Also tests the namelist case + character(5) :: f = "(a)" + real x + namelist /mynml/ x + printf, "check" + x = 1 + printmynml ! { dg-warning "extension" } + end Index: Fortran/gfortran/regression/print_fmt_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_fmt_4.f @@ -0,0 +1,3 @@ +! { dg-do compile } + print precision(1.) ! { dg-error "must be of type default CHARACTER" } + end Index: Fortran/gfortran/regression/print_fmt_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_fmt_5.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! print_fmt_5.f90 +! Test of fix for PR28237 and the last bit of PR23420. See +! below for the description of the problem. +! +program r + character(12) :: for = '(i5)', left = '(i', right = ')' + integer :: i, j + integer :: h(4) & + = (/1h(, 1hi, 1h5, 1h)/)! { dg-warning "HOLLERITH|Hollerith" } + namelist /mynml/ i + i = fact () +! +! All these are "legal" things to do; note however the warnings +! for extensions or obsolete features! +! + print *, fact() + print 100, fact() + print '(i5)', fact() + print mynml ! { dg-warning "is an extension" } + do i = 1, 5 + print trim(left)//char(iachar('0') + i)//trim(right), i + end do + assign 100 to i ! { dg-warning "ASSIGN statement" } + print i, fact() ! { dg-warning "ASSIGNED variable" } + print h, fact () ! { dg-warning "Non-character in FORMAT" } +! +! These are not and caused a segfault in trans-io:560 +! +! PR28237 + print fact() ! { dg-error "not an ASSIGNED variable" } +! original PR23420 + print precision(1.2_8) ! { dg-error "type default CHARACTER" } +! PR23420 points 4 and 5 + print j + j ! { dg-error "not an ASSIGNED variable" } +! An extension of the above, encountered in writing the fix + write (*, fact())! { dg-error "not an ASSIGNED variable" } + 100 format (i5) +contains + function fact() + integer :: fact + fact = 1 + end function fact +end + Index: Fortran/gfortran/regression/print_parentheses_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_parentheses_1.f @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! + program main + character*80 line + print (line,'(A)'), 'hello' ! { dg-error "Syntax error" } + end Index: Fortran/gfortran/regression/print_parentheses_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/print_parentheses_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +program main + character*80 line + print (line,'(A)'), 'hello' ! { dg-error "Syntax error" } +end program main Index: Fortran/gfortran/regression/private_type_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR21986 - test based on original example. +! A public subroutine must not have private-type, dummy arguments. +! Contributed by Paul Thomas +module modboom + implicit none + private + public:: dummysub + type:: intwrapper + integer n + end type intwrapper +contains + subroutine dummysub(size, arg_array) ! { dg-error "PRIVATE type and cannot be a dummy argument" } + type(intwrapper) :: size + real, dimension(size%n) :: arg_array + real :: local_array(4) + end subroutine dummysub +end module modboom Index: Fortran/gfortran/regression/private_type_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_10.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/34438 +! +! Check that error is not issued for local, non-module +! variables. +! +! Contributed by Sven Buijssen +! +module demo + implicit none + private + type myint + integer :: bar = 42 + end type myint + public :: func +contains + subroutine func() + type(myint) :: foo + end subroutine func +end module demo + +module demo2 + implicit none + private + type myint + integer :: bar = 42 + end type myint + type(myint), save :: foo2 ! { dg-error "of PRIVATE derived type" } + public :: foo2 +end module demo2 Index: Fortran/gfortran/regression/private_type_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_11.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/38065 +! +! Reported by Norman S. Clerman +! and reduced by Joost VandeVondele +! +MODULE M1 + IMPLICIT NONE + PRIVATE + TYPE T1 + INTEGER :: I1 + END TYPE T1 + PUBLIC :: S1,F2 +CONTAINS + SUBROUTINE S1 + CONTAINS + TYPE(T1) FUNCTION F1() + END FUNCTION F1 + END SUBROUTINE S1 + TYPE(T1) FUNCTION F2() + END FUNCTION F2 +END MODULE M1 Index: Fortran/gfortran/regression/private_type_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_12.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/38065 +! +! Reported by Norman S. Clerman +! and reduced by Joost VandeVondele +! +MODULE M1 + IMPLICIT NONE + PRIVATE + TYPE T1 + INTEGER :: I1 + END TYPE T1 + PUBLIC :: S1,F2 +CONTAINS + SUBROUTINE S1 + CONTAINS + TYPE(T1) FUNCTION F1() + END FUNCTION F1 + END SUBROUTINE S1 + TYPE(T1) FUNCTION F2() ! { dg-error "Fortran 2003: PUBLIC variable 'f2'" } + END FUNCTION F2 +END MODULE M1 Index: Fortran/gfortran/regression/private_type_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_13.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Test fix for F95 part of PR39800, in which the host association of the type 't1' +! generated an error. +! +! Reported to clf by Alexei Matveev and reported by +! Tobias Burnus +! +module m + implicit none + private + + type :: t1 + integer :: i + end type + + type :: t2 + type(t1) :: j + end type + + contains + + subroutine sub() + implicit none + + type :: t3 + type(t1) :: j + end type + + end subroutine + +end module Index: Fortran/gfortran/regression/private_type_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_14.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR fortran/51378 +! +! Allow constructor to nonprivate parent compoents, +! even if the extension specified PRIVATE for its own components +! +! Contributed by Reinhold Bader +! +module type_ext + type :: vec + real, dimension(3) :: comp + integer :: len + end type vec + type, extends(vec) :: l_vec + private + character(len=20) :: label = '01234567890123456789' + end type l_vec +end module type_ext +program test_ext + use type_ext + implicit none + type(vec) :: o_vec, oo_vec + type(l_vec) :: o_l_vec + integer :: i +! + o_vec = vec((/1.0, 2.0, 3.0/),3) +! write(*,*) o_vec%comp, o_vec%len + o_l_vec = l_vec(comp=(/1.0, 2.0, 3.0/),len=3) +! partial constr. not accepted by ifort 11.1, fixed in 12.0 (issue 562240) +! write(*,*) o_l_vec%comp, o_l_vec%len +! write(*,*) o_l_vec%vec + oo_vec = o_l_vec%vec + do i=1, 3 + if (abs(oo_vec%comp(i) - o_vec%comp(i)) > 1.0E-5) then + write(*, *) 'FAIL' + stop + end if + end do + write(*, *) 'OK' +end program Index: Fortran/gfortran/regression/private_type_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR16404 test 6 - If a component of a derived type is of a type declared to +! be private, either the derived type definition must contain the PRIVATE +! statement, or the derived type must be private. +! Modified on 20051105 to test PR24534. +! Modified on 20090419 to use -std=f95, since F2003 allows public types +! with private components. +! +! Contributed by Joost VandeVondele +MODULE TEST + PRIVATE + TYPE :: info_type + INTEGER :: value + END TYPE info_type + TYPE :: all_type! { dg-error "PRIVATE type and cannot be a component" } + TYPE(info_type) :: info + END TYPE + TYPE :: any_type! This is OK because of the PRIVATE statement. + PRIVATE + TYPE(info_type) :: info + END TYPE + public all_type, any_type +END MODULE +END Index: Fortran/gfortran/regression/private_type_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_3.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-O0" } +! { dg-require-visibility "" } +! Tests the fix for PR24207 and the problems associated +! with the fix for PR21986. In two cases, use associated +! public symbols were taking on the default private access +! attribute of the local namespace. In the third, a private +! symbol was not available to a namelist in contained +! procedure in the same module. +! +! Based on the example in PR24207. +! +module a + implicit none + real b + type :: mytype + integer :: c + end type mytype +end module a +module c + use a + implicit none + public d + private + real x + contains + subroutine d (arg_t) ! This would cause an error + type (mytype) :: arg_t + namelist /e/ b, x ! .... as would this. + read(5,e) + arg_t%c = 42 + end subroutine d +end module c Index: Fortran/gfortran/regression/private_type_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_4.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR 25093: Check that a PUBLIC function can't be of PRIVATE type +! in Fortran 95; in Fortran 2003 it is allowed (cf. PR fortran/38065) +! +module m1 + + type :: t1 + integer :: i + end type t1 + + private :: t1 + public :: f1 + +contains + + type(t1) function f1() ! { dg-error "of PRIVATE derived type" } + end function + +end module Index: Fortran/gfortran/regression/private_type_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_5.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! Tests the fix for PR26779, where an error would occur because +! init was detected to be public with a private type dummy argument. +! +! Contributed by Paul Thomas +! +module test + public sub + type, private :: t + integer :: i + end type t +contains + subroutine sub (arg) + integer arg + type(t) :: root + call init(root, arg) + contains + subroutine init(ir, i) + integer i + type(t) :: ir + ir%i = i + end subroutine init + end subroutine sub +end module test Index: Fortran/gfortran/regression/private_type_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR fortran/32460 +! +module foomod + implicit none + type :: footype + private + integer :: dummy + end type footype + TYPE :: bartype + integer :: dummy + integer, private :: dummy2 + end type bartype +end module foomod + +program foo_test + USE foomod + implicit none + TYPE(footype) :: foo + TYPE(bartype) :: foo2 + foo = footype(1) ! { dg-error "is a PRIVATE component" } + foo2 = bartype(1,2) ! { dg-error "is a PRIVATE component" } + foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" } +end program foo_test Index: Fortran/gfortran/regression/private_type_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_7.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! PR32760 Error defining subroutine named PRINT +! Test case derived from original PR. + +module gfcbug68 + implicit none + private :: write + +contains + + function foo (i) + integer, intent(in) :: i + integer foo + + write (*,*) i + call write(i) + foo = i + end function foo + + subroutine write (m) + integer, intent(in) :: m + print *, m*m*m + end subroutine write + +end module gfcbug68 + +program testit + use gfcbug68 + integer :: i = 27 + integer :: k + + k = foo(i) + print *, "in the main:", k +end program testit Index: Fortran/gfortran/regression/private_type_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_8.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! A public subroutine can have private-type, dummy arguments +! in Fortran 2003 (but not in Fortran 95). +! See private_type_1.f90 for the F95 test. +! +module modboom + implicit none + private + public:: dummysub + type:: intwrapper + integer n + end type intwrapper +contains + subroutine dummysub(size, arg_array) + type(intwrapper) :: size + real, dimension(size%n) :: arg_array + real :: local_array(4) + end subroutine dummysub +end module modboom Index: Fortran/gfortran/regression/private_type_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/private_type_9.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/33106 +! +module m1 + implicit none + type, private :: t + integer :: i + end type t + type(t), public :: one ! { dg-error "PRIVATE derived type" } + type(t), public, parameter :: two = t(2) ! { dg-error "PRIVATE derived type" } +end module m1 + +module m2 + implicit none + private + type t + integer :: i + end type t + type(t), public :: one ! { dg-error "PRIVATE derived type" } + type(t), public, parameter :: two = t(2) ! { dg-error "PRIVATE derived type" } +end module m2 + +module m3 + implicit none + type t + integer :: i + end type t +end module m3 + +module m4 + use m3!, only: t + implicit none + private + private :: t + type(t), public :: one + type(t), public, parameter :: two = t(2) +end module m4 + +end Index: Fortran/gfortran/regression/proc_assign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_assign_1.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! This tests the patch for PR26787 in which it was found that setting +! the result of one module procedure from within another produced an +! ICE rather than an error. +! +! This is an "elaborated" version of the original testcase from +! Joshua Cogliati +! +function ext1 () + integer ext1, ext2, arg + ext1 = 1 + entry ext2 (arg) + ext2 = arg +contains + subroutine int_1 () + ext1 = arg * arg ! OK - host associated. + end subroutine int_1 +end function ext1 + +module simple + implicit none +contains + integer function foo () + foo = 10 ! OK - function result + call foobar () + contains + subroutine foobar () + integer z + foo = 20 ! OK - host associated. + end subroutine foobar + end function foo + subroutine bar() ! This was the original bug. + foo = 10 ! { dg-error "is not a variable" } + end subroutine bar + integer function oh_no () + oh_no = 1 + foo = 5 ! { dg-error "is not a variable" } + end function oh_no +end module simple + +module simpler + implicit none +contains + integer function foo_er () + foo_er = 10 ! OK - function result + end function foo_er +end module simpler + + use simpler + real w, stmt_fcn + interface + function ext1 () + integer ext1 + end function ext1 + function ext2 (arg) + integer ext2, arg + end function ext2 + end interface + stmt_fcn (w) = sin (w) + call x (y ()) + x = 10 ! { dg-error "is not a variable" } + y = 20 ! { dg-error "is not a variable" } + foo_er = 8 ! { dg-error "is not a variable" } + ext1 = 99 ! { dg-error "is not a variable" } + ext2 = 99 ! { dg-error "is not a variable" } + stmt_fcn = 1.0 ! { dg-error "is not a variable" } + w = stmt_fcn (1.0) +contains + subroutine x (i) + integer i + y = i ! { dg-error "is not a variable" } + end subroutine x + function y () + integer y + y = 2 ! OK - function result + end function y +end Index: Fortran/gfortran/regression/proc_assign_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_assign_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! This checks the fix for PR34910, in which the invalid reference +! below caused an ICE. +! +! Contributed by Daniel Franke +! +MODULE foo +CONTAINS + INTEGER FUNCTION f() + f = 42 + CONTAINS + LOGICAL FUNCTION f1() + f1 = .TRUE. + END FUNCTION + + LOGICAL FUNCTION f2() + f1 = .FALSE. ! { dg-error "is not a variable" } + END FUNCTION + END FUNCTION +END MODULE Index: Fortran/gfortran/regression/proc_decl_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_1.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! This tests various error messages for PROCEDURE declarations. +! Contributed by Janus Weil + +module m + + abstract interface + subroutine sub() + end subroutine + subroutine sub2() bind(c) + end subroutine + end interface + + procedure(), public, private :: a ! { dg-error "was already specified" } + procedure(sub),bind(C) :: a2 ! { dg-error "requires an interface with BIND.C." } + procedure(sub2), public, bind(c, name="myEF") :: e, f ! { dg-error "Multiple identifiers provided with single NAME= specifier" } + procedure(sub2), bind(C, name=""), pointer :: g ! { dg-error "may not have POINTER attribute" } + + public:: h + procedure(),public:: h ! { dg-error "was already specified" } + +contains + + subroutine abc + procedure() :: abc2 + entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" } + real x + end subroutine + +end module m + +program prog + + interface z + subroutine z1() + end subroutine + subroutine z2(a) + integer :: a + end subroutine + end interface + + procedure(z) :: bar ! { dg-error "may not be generic" } + + procedure(), allocatable:: b ! { dg-error "PROCEDURE attribute conflicts with ALLOCATABLE attribute" } + procedure(), save:: c ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" } + + procedure(dcos) :: my1 + procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" } + + real f, x + f(x) = sin(x**2) + external oo + + procedure(f) :: q ! { dg-error "may not be a statement function" } + procedure(oo) :: p ! { dg-error "must be explicit" } + + procedure ( ) :: r + procedure ( up ) :: s ! { dg-error "must be explicit" } + + procedure(t) :: t ! { dg-error "may not be used as its own interface" } + + call s + +contains + + subroutine foo(a,c) ! { dg-error "PROCEDURE attribute conflicts with INTENT attribute" } + abstract interface + subroutine b() bind(C) + end subroutine b + end interface + procedure(b), bind(c,name="hjj") :: a ! { dg-error "may not have BIND.C. attribute with NAME" } + procedure(b),intent(in):: c + end subroutine foo + +end program Index: Fortran/gfortran/regression/proc_decl_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_10.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none + interface + double precision function my1(x) + double precision, intent(in) :: x + end function my1 + end interface + interface + real(kind=4) function my2(x) + real, intent(in) :: x + end function my2 + end interface + interface + real function my3(x, y) + real, intent(in) :: x, y + end function my3 + end interface +end module + +program test +use m +implicit none +procedure(dcos):: my1 ! { dg-error "Cannot change attributes" } +procedure(cos) :: my2 ! { dg-error "Cannot change attributes" } +procedure(dprod) :: my3 ! { dg-error "Cannot change attributes" } + +end program test Index: Fortran/gfortran/regression/proc_decl_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_11.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! PR fortran/33917 +! +! Depending, in which order the symbol tree +! was walked in resolve, gfortran resolved +! p6 before p4; thus there was no explicit +! interface available for p4 and an error +! was printed. (This is a variant of proc_decl_2.f90) +! +! Additionally, the following contrain was not honoured: +! "C1212 (R1215) [...] If name is declared by a procedure-declaration-stmt +! it shall be previously declared." ("name" = interface-name) +! +program s + implicit none + procedure() :: q2 + procedure() :: q3 + procedure() :: q5 + procedure(sub) :: p4 + procedure(p4) :: p6 +contains + subroutine sub + end subroutine +end program s + +subroutine test + implicit none + abstract interface + subroutine sub() + end subroutine sub + end interface + procedure(p4) :: p6 ! { dg-error "declared in a later PROCEDURE statement" } + procedure(sub) :: p4 +end subroutine test Index: Fortran/gfortran/regression/proc_decl_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_12.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! This tests the (partial) fix for PR35830, i.e. handling array arguments +! with the PROCEDURE statement. +! +! Contributed by Janus Weil + +module m +contains + subroutine one(a) + integer a(1:3) + if (any(a /= [1,2,3])) STOP 1 + end subroutine one +end module m + +program test + use m + implicit none + call foo(one) +contains + subroutine foo(f) + procedure(one) :: f + call f([1,2,3]) + end subroutine foo +end program test Index: Fortran/gfortran/regression/proc_decl_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_13.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR fortran/35830 +! +module m +contains + subroutine one(a) + integer a(:) + print *, lbound(a), ubound(a), size(a) + if ((lbound(a,dim=1) /= 1) .or. (ubound(a,dim=1) /= 3)) & + STOP 1 + print *, a + if (any(a /= [1,2,3])) STOP 2 + end subroutine one +end module m + +program test + use m + implicit none + call foo1(one) + call foo2(one) +contains + subroutine foo1(f) + ! The following interface block is needed + ! for NAG f95 as it wrongly does not like + ! use-associated interfaces for PROCEDURE + ! (It is not needed for gfortran) + interface + subroutine bar(a) + integer a(:) + end subroutine + end interface + procedure(bar) :: f + call f([1,2,3]) ! Was failing before + end subroutine foo1 + subroutine foo2(f) + interface + subroutine f(a) + integer a(:) + end subroutine + end interface + call f([1,2,3]) ! Works + end subroutine foo2 +end program test Index: Fortran/gfortran/regression/proc_decl_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_14.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/35830 +! +abstract interface + function ptrfunc() + integer, pointer :: ptrfunc + end function ptrfunc + elemental subroutine elem(a) + integer,intent(in) :: a + end subroutine elem + function dims() + integer :: dims(3) + end function dims +end interface + +procedure(ptrfunc) :: func_a +procedure(elem) :: func_b +procedure(dims) :: func_c + +integer, pointer :: ptr +integer :: array(3) + +ptr => func_a() +call func_b([1,2,3]) +array = func_c() +end Index: Fortran/gfortran/regression/proc_decl_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_15.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR fortran/35830 +! +function f() + real, allocatable :: f(:) + allocate(f(1:3)) + f(1:3)= (/9,8,7/) +end function + +program test + implicit none + abstract interface + function ai() + real, allocatable :: ai(:) + end function + end interface + procedure(ai) :: f + if(any(f() /= [9,8,7])) STOP 1 + if(size(f()) /= 3) STOP 2 +end Index: Fortran/gfortran/regression/proc_decl_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_16.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR fortran/36459 +! +abstract interface + function dim() + integer :: dim + end function dim +end interface +procedure(dim) :: f + +interface + integer function tan() + end function +end interface +procedure(tan) :: g + +print *, f() + +print *, tan() + +end Index: Fortran/gfortran/regression/proc_decl_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_17.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! +! PR 36322/36463 +! +! Original code by James Van Buskirk. +! Modified by Janus Weil + +module m + + use ISO_C_BINDING + + character, allocatable, save :: my_message(:) + + abstract interface + function abs_fun(x) + use ISO_C_BINDING + import my_message + integer(C_INT) x(:) + character(size(my_message),C_CHAR) abs_fun(size(x)) + end function abs_fun + end interface + +contains + + function foo(y) + implicit none + integer(C_INT) :: y(:) + character(size(my_message),C_CHAR) :: foo(size(y)) + integer i,j + do i=1,size(y) + do j=1,size(my_message) + foo(i)(j:j) = achar(iachar(my_message(j))+y(i)) + end do + end do + end function + + subroutine check(p,a) + use ISO_C_BINDING + integer(C_INT) a(:) + procedure(abs_fun) :: p + character(size(my_message),C_CHAR) :: c(size(a)) + integer k,l,m + c = p(a) + m=iachar('a') + do k=1,size(a) + do l=1,size(my_message) + if (c(k)(l:l) /= achar(m)) STOP 1 + m = m + 1 + end do + end do + end subroutine + +end module + +program prog + +use m + +integer(C_INT) :: i(4) = (/0,6,12,18/) + +allocate(my_message(1:6)) + +my_message = (/'a','b','c','d','e','f'/) + +call check(foo,i) + +end program Index: Fortran/gfortran/regression/proc_decl_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_18.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! +! PR 36322/36463 +! +! Contributed by Janus Weil + +module m + +contains + + pure integer function mysize(a) + integer,intent(in) :: a(:) + mysize = size(a) + end function + +end module + + +program prog + +use m +implicit none + +abstract interface + function abs_fun(x,sz) + integer,intent(in) :: x(:) + interface + pure integer function sz(b) + integer,intent(in) :: b(:) + end function + end interface + integer :: abs_fun(sz(x)) + end function +end interface + +procedure(abs_fun) :: p + +integer :: k,j(3),i(3) = (/1,2,3/) + +j = p(i,mysize) + +do k=1,mysize(i) + if (j(k) /= 2*i(k)) STOP 1 +end do + +end + + function p(y,asz) + implicit none + integer,intent(in) :: y(:) + interface + pure integer function asz(c) + integer,intent(in) :: c(:) + end function + end interface + integer :: p(asz(y)) + integer l + do l=1,asz(y) + p(l) = y(l)*2 + end do + end function Index: Fortran/gfortran/regression/proc_decl_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_19.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 36426 +! +! Contributed by Tobias Burnus + +abstract interface + function foo(x) + character(len=*) :: x + character(len=len(x)) :: foo + end function foo +end interface +procedure(foo) :: bar + +abstract interface + character function abs_fun() + end function +end interface +procedure(abs_fun):: x + +character(len=20) :: str +str = bar("Hello") +end Index: Fortran/gfortran/regression/proc_decl_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_2.f90 @@ -0,0 +1,148 @@ +! { dg-do run } +! Various runtime tests of PROCEDURE declarations. +! Contributed by Janus Weil + +module m + + use ISO_C_BINDING + + abstract interface + subroutine csub() bind(c) + end subroutine csub + end interface + + integer, parameter :: ckind = C_FLOAT_COMPLEX + abstract interface + function stub() bind(C) + import ckind + complex(ckind) stub + end function + end interface + + procedure():: mp1 + procedure(real), private:: mp2 + procedure(mfun), public:: mp3 + procedure(csub), public, bind(c) :: c, d + procedure(csub), public, bind(c, name="myB") :: b + procedure(stub), bind(C) :: e + +contains + + real function mfun(x,y) + real x,y + mfun=4.2 + end function + + subroutine bar(a,b) + implicit none + interface + subroutine a() + end subroutine a + end interface + optional :: a + procedure(a), optional :: b + end subroutine bar + + subroutine bar2(x) + abstract interface + character function abs_fun() + end function + end interface + procedure(abs_fun):: x + end subroutine + + +end module + + +program p + implicit none + + abstract interface + subroutine abssub(x) + real x + end subroutine + end interface + + integer i + real r + + procedure(integer):: p1 + procedure(fun):: p2 + procedure(abssub):: p3 + procedure(sub):: p4 + procedure():: p5 + procedure(p4):: p6 + procedure(integer) :: p7 + + i=p1() + if (i /= 5) STOP 1 + i=p2(3.1) + if (i /= 3) STOP 2 + r=4.2 + call p3(r) + if (abs(r-5.2)>1e-6) STOP 3 + call p4(r) + if (abs(r-3.7)>1e-6) STOP 4 + call p5() + call p6(r) + if (abs(r-7.4)>1e-6) STOP 5 + i=p7(4) + if (i /= -8) STOP 6 + r=dummytest(p3) + if (abs(r-2.1)>1e-6) STOP 7 + +contains + + integer function fun(x) + real x + fun=7 + end function + + subroutine sub(x) + real x + end subroutine + + real function dummytest(dp) + procedure(abssub):: dp + real y + y=1.1 + call dp(y) + dummytest=y + end function + +end program p + + +integer function p1() + p1 = 5 +end function + +integer function p2(x) + real x + p2 = int(x) +end function + +subroutine p3(x) + real :: x + x=x+1.0 +end subroutine + +subroutine p4(x) + real :: x + x=x-1.5 +end subroutine + +subroutine p5() +end subroutine + +subroutine p6(x) + real :: x + x=x*2. +end subroutine + +function p7(x) + implicit none + integer :: x, p7 + p7 = x*(-2) +end function Index: Fortran/gfortran/regression/proc_decl_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_20.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/36463 +! Gfortran used to fail on this testcase with: +! gfc_get_default_type(): Bad symbol '@0' +! +! Original program by James Van Buskirk +! Reduced by Janus Weil + +module other_fun + interface + function abstract_fun(x) + integer x + integer abstract_fun(x) + end function abstract_fun + end interface +end module other_fun + + program fptr + use other_fun + procedure(abstract_fun) :: fun + end program fptr Index: Fortran/gfortran/regression/proc_decl_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_21.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR fortran/39414: PROCEDURE statement double declaration bug +! +! Discovered by Paul Thomas +! Modified by Janus Weil + + +! forbidden + +procedure(integer) :: a +integer :: a ! { dg-error "already has basic type of" } + +integer :: b +procedure(integer) :: b ! { dg-error "already has basic type of" } + +procedure(iabs) :: c +integer :: c ! { dg-error "may not have basic type of" } + +integer :: d +procedure(iabs) :: d ! { dg-error "already has basic type of" } + +! allowed + +integer :: e +procedure() :: e + +procedure() :: f +integer :: f + +end + Index: Fortran/gfortran/regression/proc_decl_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_22.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 37254: Reject valid PROCEDURE statement with implicit interface +! +! Original test case by Dominique d'Humieres +! Modified by Janus Weil + + real function proc3( arg1 ) + integer :: arg1 + proc3 = arg1+7 + end function proc3 + +program myProg + PROCEDURE () :: proc3 + call proc4( proc3 ) + +contains + + subroutine proc4( arg1 ) + PROCEDURE(real) :: arg1 + print*, 'the func: ', arg1(0) + end subroutine proc4 + +end program myProg + Index: Fortran/gfortran/regression/proc_decl_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_23.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! Test the fix for PR43227, in which the lines below would segfault. +! +! Dominique d'Humieres +! +function char1 (s) result(res) + character, dimension(:), intent(in) :: s + character(len=size(s)) :: res + do i = 1, size(s) + res(i:i) = s(i) + end do +end function char1 + +module m_string + + procedure(string_to_char) :: char1 ! segfault + procedure(string_to_char), pointer :: char2 ! segfault + type t_string + procedure(string_to_char), pointer, nopass :: char3 ! segfault + end type t_string + +contains + + function string_to_char (s) result(res) + character, dimension(:), intent(in) :: s + character(len=size(s)) :: res + do i = 1, size(s) + res(i:i) = s(i) + end do + end function string_to_char + +end module m_string + + use m_string + type(t_string) :: t + print *, string_to_char (["a","b","c"]) + char2 => string_to_char + print *, char2 (["d","e","f"]) + t%char3 => string_to_char + print *, t%char3 (["g","h","i"]) + print *, char1 (["j","k","l"]) +end Index: Fortran/gfortran/regression/proc_decl_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_24.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! Contributed by James van Buskirk +! +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/44d572766bce0e6f/ + + use iso_c_binding + implicit none + + abstract interface + subroutine all_subs(x,y) bind(C) + use iso_c_binding + real(c_float) :: x,y + end subroutine all_subs + end interface + + procedure(all_subs) :: sub + type(C_FUNPTR) :: s + + s = c_funloc (sub) + +end Index: Fortran/gfortran/regression/proc_decl_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_25.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 47352: [F03] ICE with proc-pointers in generic procedures +! +! Contributed by James van Buskirk +! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/bbaf59ffd7c372e9 + + implicit none + + abstract interface + real function f() + end function f + end interface + + procedure(f) :: f1 + + interface gen + procedure f1 + end interface gen + + write(*,*) gen() +end Index: Fortran/gfortran/regression/proc_decl_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_26.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Tobias Burnus + +program test + + implicit none + + interface + subroutine one(a) + integer a(:) + end subroutine + subroutine two(a) + integer a(2) + end subroutine + end interface + + call foo(two) ! { dg-error "Shape mismatch in argument" } + call bar(two) ! { dg-error "Shape mismatch in argument" } + +contains + + subroutine foo(f1) + procedure(one) :: f1 + end subroutine foo + + subroutine bar(f2) + interface + subroutine f2(a) + integer a(:) + end subroutine + end interface + end subroutine bar + +end program Index: Fortran/gfortran/regression/proc_decl_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_27.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 50659: [4.5/4.6/4.7 Regression] [F03] ICE on invalid with procedure interface +! +! Contributed by Andrew Benson + +module m1 + integer :: arrSize +end module + +module m2 +contains + function Proc (arg) + use m1 + double precision, dimension(arrSize) :: proc + double precision :: arg + end function +end + + use m2 + implicit none + procedure(Proc) :: Proc_Get +end Index: Fortran/gfortran/regression/proc_decl_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_28.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 53956: [F03] PROCEDURE w/ interface: Bogus "EXTERNAL attribute conflicts with FUNCTION attribute" +! +! Contributed by James van Buskirk + + interface + subroutine sub (a) + integer, external :: a + end subroutine + end interface + + procedure(sub) :: proc + +end Index: Fortran/gfortran/regression/proc_decl_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_29.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 42418: PROCEDURE: Rejects interface which is both specific and generic procedure +! +! Contributed by Tobias Burnus + + interface gen + procedure gen + end interface + + procedure(gen) :: p1 + procedure(gen2) :: p2 ! { dg-error "may not be generic" } + procedure(sf) :: p3 ! { dg-error "may not be a statement function" } + procedure(char) :: p4 + + interface gen2 + procedure char + end interface + + sf(x) = x**2 ! { dg-warning "Obsolescent feature" } + +contains + + subroutine gen + end subroutine + + subroutine char + end subroutine + +end Index: Fortran/gfortran/regression/proc_decl_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_3.f90 @@ -0,0 +1,75 @@ +! { dg-do compile } +! Some tests for PROCEDURE declarations inside of interfaces. +! Contributed by Janus Weil + +module m + + interface + subroutine a() + end subroutine a + end interface + + procedure(c) :: f + + interface bar + procedure a,d + end interface bar + + interface foo + procedure c + end interface foo + + abstract interface + procedure f ! { dg-error "must be in a generic interface" } + end interface + + interface + function opfoo(a) + integer,intent(in) :: a + integer :: opfoo + end function opfoo + end interface + + interface operator(.op.) + procedure opfoo + end interface + + external ex ! { dg-error "has no explicit interface" } + procedure():: ip ! { dg-error "has no explicit interface" } + procedure(real):: pip ! { dg-error "has no explicit interface" } + + interface nn1 + procedure ex + procedure a, a ! { dg-error "already present in the interface" } + end interface + + interface nn2 + procedure ip + end interface + + interface nn3 + procedure pip + end interface + +contains + + subroutine d(x) + + interface + subroutine x() + end subroutine x + end interface + + interface gen + procedure x + end interface + + end subroutine d + + function c(x) + integer :: x + real :: c + c = 3.4*x + end function c + +end module m Index: Fortran/gfortran/regression/proc_decl_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Test for PROCEDURE statements with the -std=f95 flag. +! Contributed by Janus Weil + +program p + +procedure():: proc ! { dg-error "Fortran 2003: PROCEDURE statement" } + +end program Index: Fortran/gfortran/regression/proc_decl_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_5.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! PR fortran/33945 +! +! PROCEDURE in the interface was wrongly rejected +module modproc + implicit none + interface bar + procedure x + end interface bar + procedure(sub) :: x + interface + integer function sub() + end function sub + end interface +end module modproc + +integer function x() + implicit none + x = -5 +end function x + +program test + use modproc + implicit none + if(x() /= -5) STOP 1 +end program test Index: Fortran/gfortran/regression/proc_decl_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_6.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/33945 +! +! MODULE PROCEDURE in the interface was wrongly accepted +module modproc2 + implicit none + interface + subroutine x + end subroutine x + end interface + procedure(x) :: y + interface bar + module procedure y ! { dg-error "not a module procedure" } + end interface bar +end module modproc2 + +end Index: Fortran/gfortran/regression/proc_decl_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_7.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none +contains + subroutine sub(a) + interface + function a() + real :: a + end function a + end interface + print *, a() + end subroutine sub +end module m +use m +implicit none +intrinsic cos +call sub(cos) ! { dg-error "wrong number of arguments" } +end Index: Fortran/gfortran/regression/proc_decl_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +module m +implicit none +contains + subroutine sub(a) + interface + function a(x) + real :: a, x + intent(in) :: x + end function a + end interface + print *, a(4.0) + end subroutine sub + +end module m + +use m +implicit none +EXTERNAL foo ! interface is undefined +procedure(cos) :: foo ! { dg-error "Duplicate EXTERNAL attribute specified" } +call sub(foo) ! { dg-error "is not a function" } +end Index: Fortran/gfortran/regression/proc_decl_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_decl_9.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR33162 INTRINSIC functions as ACTUAL argument +! Test case adapted from PR by Jerry DeLisle +elemental real function t(x) + real, intent(in) ::x + t = x +end function + +program p + implicit none + intrinsic sin + procedure(sin) :: t + if (t(1.0) /= 1.0) STOP 1 +end program Index: Fortran/gfortran/regression/proc_ptr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_1.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! basic tests of PROCEDURE POINTERS +! +! Contributed by Janus Weil + +module m +contains + subroutine proc1(arg) + character (5) :: arg + arg = "proc1" + end subroutine + integer function proc2(arg) + integer, intent(in) :: arg + proc2 = arg**2 + end function + complex function proc3(re, im) + real, intent(in) :: re, im + proc3 = complex (re, im) + end function +end module + +subroutine foo1 +end subroutine + +real function foo2() + foo2=6.3 +end function + +program procPtrTest + use m, only: proc1, proc2, proc3 + character (5) :: str + PROCEDURE(proc1), POINTER :: ptr1 + PROCEDURE(proc2), POINTER :: ptr2 + PROCEDURE(proc3), POINTER :: ptr3 => NULL() + PROCEDURE(REAL), SAVE, POINTER :: ptr4 + PROCEDURE(), POINTER :: ptr5,ptr6 + + EXTERNAL :: foo1,foo2 + real :: foo2 + + if(ASSOCIATED(ptr3)) STOP 1 + + NULLIFY(ptr1) + if (ASSOCIATED(ptr1)) STOP 2 + ptr1 => proc1 + if (.not. ASSOCIATED(ptr1)) STOP 3 + call ptr1 (str) + if (str .ne. "proc1") STOP 4 + + ptr2 => NULL() + if (ASSOCIATED(ptr2)) STOP 5 + ptr2 => proc2 + if (.not. ASSOCIATED(ptr2,proc2)) STOP 6 + if (10*ptr2 (10) .ne. 1000) STOP 7 + + ptr3 => NULL (ptr3) + if (ASSOCIATED(ptr3)) STOP 8 + ptr3 => proc3 + if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) STOP 9 + + ptr4 => cos + if (ptr4(0.0)/=1.0) STOP 10 + + ptr5 => foo1 + call ptr5() + + ptr6 => foo2 + if (ptr6()/=6.3) STOP 11 + +end program Index: Fortran/gfortran/regression/proc_ptr_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_10.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/37253 +! +! Contributed by Dominique d'Humieres + +module myMod + + CONTAINS + + real function proc3( arg1 ) + integer :: arg1 + proc3 = arg1+7 + end function proc3 + + subroutine proc4( arg1 ) + procedure(real), pointer :: arg1 + if (arg1(0)/=7) STOP 1 + end subroutine proc4 + +end module myMod + +program myProg + use myMod + PROCEDURE (real), POINTER :: p => NULL() + p => proc3 + call proc4( p ) +end program myProg + Index: Fortran/gfortran/regression/proc_ptr_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_11.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! +! PR 38290: Procedure pointer assignment checking. +! +! Test case found at http://de.wikibooks.org/wiki/Fortran:_Fortran_2003:_Zeiger +! Adapted by Janus Weil + +program bsp + implicit none + intrinsic :: isign, iabs + abstract interface + subroutine up() + end subroutine up + ! As intrinsics but not elemental + pure integer function isign_interf(a, b) + integer, intent(in) :: a, b + end function isign_interf + pure integer function iabs_interf(x) + integer, intent(in) :: x + end function iabs_interf + end interface + + procedure( up ) , pointer :: pptr + procedure(isign_interf), pointer :: q + + procedure(iabs_interf),pointer :: p1 + procedure(f), pointer :: p2 + + pointer :: p3 + interface + function p3(x) + real(8) :: p3,x + intent(in) :: x + end function p3 + end interface + + pptr => add ! { dg-error "is not a subroutine" } + + q => add + + print *, pptr() ! { dg-error "is not a function" } + + p1 => iabs + p2 => iabs + p1 => f + p2 => f + p2 => p1 + p1 => p2 + + p1 => abs ! { dg-error "Type mismatch in function result" } + p2 => abs ! { dg-error "Type mismatch in function result" } + + p3 => dsin + p3 => sin ! { dg-error "Type mismatch in function result" } + + contains + + pure function add( a, b ) + integer :: add + integer, intent( in ) :: a, b + add = a + b + end function add + + pure integer function f(x) + integer,intent(in) :: x + f = 317 + x + end function + +end program bsp Index: Fortran/gfortran/regression/proc_ptr_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_12.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +procedure(integer),pointer :: p +p => foo() +if (p(-1)/=1) STOP 1 +contains + function foo() result(bar) + procedure(integer),pointer :: bar + bar => iabs + end function +end Index: Fortran/gfortran/regression/proc_ptr_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_13.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-g" } +! +! PR 38152: Procedure pointers as module variables. +! +! Contributed by Daniel Kraft + +MODULE myfortran_binding + + IMPLICIT NONE + PROCEDURE(error_stop), POINTER :: error_handler + +CONTAINS + + LOGICAL FUNCTION myfortran_shutdown () + CALL error_handler () + END FUNCTION myfortran_shutdown + + SUBROUTINE error_stop () + END SUBROUTINE error_stop + +END MODULE myfortran_binding + + +use myfortran_binding +error_handler => error_stop +end Index: Fortran/gfortran/regression/proc_ptr_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_14.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR 39692: f95: conflict between EXTERNAL and POINTER +! +! Test for Procedure Pointers (without PROCEDURE statements) with the -std=f95 flag. +! +! Contributed by Janus Weil + +pointer :: f +external :: f ! { dg-error "Fortran 2003: Procedure pointer" } + +external :: g +pointer :: g ! { dg-error "Fortran 2003: Procedure pointer" } + +real, pointer, external :: h ! { dg-error "Fortran 2003: Procedure pointer" } + +interface + subroutine i + end subroutine i +end interface +pointer :: i ! { dg-error "Fortran 2003: Procedure pointer" } + +pointer :: j +interface + real function j() + end function j ! { dg-error "Fortran 2003: Procedure pointer" } +end interface + +contains + + function k() ! { dg-error "attribute conflicts with" } + intrinsic sin + external k + pointer k ! { dg-error "Fortran 2003: Procedure pointer" } + real k + end function k + +end + Index: Fortran/gfortran/regression/proc_ptr_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_15.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 39735: procedure pointer assignments: return value is not checked +! +! Contributed by Janus Weil + +implicit none +procedure(real(4)), pointer :: p1 +procedure(integer), pointer :: p2 +procedure(sub), pointer :: p3 +procedure(), pointer :: p4 +procedure(real(8)),pointer :: p5 +real(4), external, pointer :: p6 + +! valid +p2 => iabs +p3 => sub +p4 => p3 +p6 => p1 + +! invalid +p1 => iabs ! { dg-error "Type mismatch in function result" } +p1 => p2 ! { dg-error "Type mismatch in function result" } +p1 => p5 ! { dg-error "Type mismatch in function result" } +p6 => iabs ! { dg-error "Type mismatch in function result" } +p4 => p2 ! { dg-error "is not a subroutine" } + +contains + + subroutine sub(i) + integer :: i + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_16.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 39946: PROCEDURE statements: interface with RESULT variable +! +! Original test case by Juergen Reuter +! Modified by Janus Weil + + procedure(prc_is_allowed), pointer :: fptr + + interface + function prc_is_allowed (flv, hel, col) result (is_allowed) + logical :: is_allowed + integer, intent(in) :: flv, hel, col + end function prc_is_allowed + end interface + + fptr => prc_is_allowed + +end + Index: Fortran/gfortran/regression/proc_ptr_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_17.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR39998: Procedure Pointer Assignments: Statement Functions & Internal Functions. +! +! Contributed by Tobias Burnus + + procedure(), pointer :: p + f(x) = x**2 ! { dg-warning "Obsolescent feature" } + p => f ! { dg-error "invalid in procedure pointer assignment" } + p => sub ! { dg-error "invalid in procedure pointer assignment" } +contains + subroutine sub + end subroutine sub +end + Index: Fortran/gfortran/regression/proc_ptr_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_18.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + PROCEDURE(triple), POINTER :: f + + f => triple + if (sum(f(2.,4.)-triple(2.,4.))>1E-3) STOP 1 + +CONTAINS + + FUNCTION triple(a,b) RESULT(tre) + REAL, INTENT(in) :: a, b + REAL :: tre(2) + tre(1) = 3.*a + tre(2) = 3.*b + END FUNCTION triple + +END PROGRAM test_prog + Index: Fortran/gfortran/regression/proc_ptr_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_19.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! This example tests for a bug in procedure pointer assignments, +! where the rhs is a dummy. +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + PROCEDURE(add), POINTER :: forig, fset + + forig => add + + CALL set_ptr(forig,fset) + + if (forig(1,2) /= fset(1,2)) STOP 1 + +CONTAINS + + SUBROUTINE set_ptr(f1,f2) + PROCEDURE(add), POINTER :: f1, f2 + f2 => f1 + END SUBROUTINE set_ptr + + FUNCTION add(a,b) + INTEGER :: a,b,add + add = a+b + + END FUNCTION add + +END PROGRAM test_prog + Index: Fortran/gfortran/regression/proc_ptr_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! checking invalid code for PROCEDURE POINTERS +! +! Contributed by Janus Weil + +PROCEDURE(REAL), POINTER :: ptr +PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" } +REAL :: x + + abstract interface + subroutine bar(a) + integer :: a + end subroutine bar + end interface + +ptr => cos(4.0) ! { dg-error "Invalid procedure pointer assignment" } +ptr => x ! { dg-error "Invalid procedure pointer assignment" } +ptr => sin(x) ! { dg-error "Invalid procedure pointer assignment" } + +ptr => bar ! { dg-error "is invalid in procedure pointer assignment" } + +ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" } + +end Index: Fortran/gfortran/regression/proc_ptr_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_20.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR 40450: [F03] procedure pointer as actual argument +! +! Contributed by John McFarland + +MODULE m + ABSTRACT INTERFACE + SUBROUTINE sub() + END SUBROUTINE sub + END INTERFACE + +CONTAINS + + SUBROUTINE passf(f2) + PROCEDURE(sub), POINTER:: f2 + CALL callf(f2) + END SUBROUTINE passf + + SUBROUTINE callf(f3) + PROCEDURE(sub), POINTER :: f3 + PRINT*, 'calling f' + CALL f3() + END SUBROUTINE callf +END MODULE m + + +PROGRAM prog + USE m + PROCEDURE(sub), POINTER :: f1 + f1 => s + CALL passf(f1) + +CONTAINS + + SUBROUTINE s + PRINT*, 'sub' + END SUBROUTINE s +END PROGRAM prog Index: Fortran/gfortran/regression/proc_ptr_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_21.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Tests the fix for PR40591 in which the interface 'sub2' +! for 'pptr2' was not resolved. +! +! Contributed by Tobias Burnus +! +program main + call test +contains + subroutine sub1(arg) + integer arg + arg = arg + 1 + end subroutine sub1 + subroutine test() + procedure(sub1), pointer :: pptr1 + procedure(sub2), pointer :: pptr2 + integer i + i = 0 + pptr1 => sub1 + call pptr1 (i) + pptr1 => sub2 + call pptr1 (i) + pptr2 => sub1 + call pptr2 (i) + pptr2 => sub2 + call pptr2 (i) + if (i .ne. 22) STOP 1 + end subroutine test + subroutine sub2(arg) + integer arg + arg = arg + 10 + end subroutine sub2 +end program main Index: Fortran/gfortran/regression/proc_ptr_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_22.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR 40646: [F03] array-valued procedure pointer components +! +! Original test case by Charlie Sharpsteen +! Modified by Janus Weil + +module bugTestMod + implicit none + procedure(returnMat), pointer :: pp2 +contains + function returnMat( a, b ) result( mat ) + integer:: a, b + double precision, dimension(a,b):: mat + mat = 1d0 + end function returnMat +end module bugTestMod + +program bugTest + use bugTestMod + implicit none + procedure(returnMat), pointer :: pp + pp => returnMat + if (sum(pp(2,2))/=4) STOP 1 + pp2 => returnMat + if (sum(pp2(3,2))/=6) STOP 2 +end program bugTest Index: Fortran/gfortran/regression/proc_ptr_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_23.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! +! PR 41106: [F03] Procedure Pointers with CHARACTER results +! +! Contributed by Janus Weil + +character(len=5) :: str +procedure(character(len=5)), pointer :: pp +pp => abc +print *,pp() +str = pp() +if (str/='abcde') STOP 1 +contains + function abc() + character(len=5) :: abc + abc = 'abcde' + end function abc +end + Index: Fortran/gfortran/regression/proc_ptr_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_24.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! +! Code was posted to comp.lang.fortran by Richard Maine. +! http://groups.google.com/group/comp.lang.fortran/browse_frm/thread/fff9b3426211c018# +! +module m + type :: foo + real, pointer :: array(:) + procedure (), pointer, nopass :: f ! { dg-error "Procedure pointer component" } + end type +contains + elemental subroutine fooAssgn (a1, a2) + type(foo), intent(out) :: a1 + type(foo), intent(in) :: a2 + allocate (a1%array(size(a2%array))) + + a1%array = a2%array + a1%f => a2%f ! { dg-error "not a member of the" } + end subroutine +end module m Index: Fortran/gfortran/regression/proc_ptr_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_25.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test + + PROCEDURE(add), POINTER :: f + logical :: g + + ! Passing the function works + g=greater(4.,add(1.,2.)) + if (.not. g) STOP 1 + + ! Passing the procedure pointer fails + f => add + g=greater(4.,f(1.,2.)) + if (.not. g) STOP 2 + +CONTAINS + + REAL FUNCTION add(x,y) + REAL, INTENT(in) :: x,y + print *,"add:",x,y + add = x+y + END FUNCTION add + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test + Index: Fortran/gfortran/regression/proc_ptr_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_26.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/42597 +! +! Contributed by mrestelli@gmail.com +! + +module mod_a + implicit none + + abstract interface + pure function intf(x) result(y) + real, intent(in) :: x(:,:) + real :: y(size(x,1),size(x,1),size(x,2)) + end function intf + end interface + + procedure(intf), pointer :: p_fun => null() +end module mod_a + +program main + use mod_a + implicit none + + procedure(intf), pointer :: p_fun2 => null() + + if (associated(p_fun) .or. associated(p_fun2)) & + STOP 1 +end program main Index: Fortran/gfortran/regression/proc_ptr_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_27.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/44446 +! +! Contributed by Marco Restelli. +! +! Procedure pointer with PROTECTED was wrongly rejected. +! +module m + implicit none + abstract interface + pure function i_f(x) result(y) + real, intent(in) :: x + real :: y + end function i_f + end interface + procedure(i_f), pointer, protected :: p_f => null() +end module m Index: Fortran/gfortran/regression/proc_ptr_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_28.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 44718: Procedure-pointer name is wrongly regarded as "external procedure" +! +! Contributed by John McFarland + +MODULE m + + IMPLICIT NONE + +CONTAINS + + FUNCTION func(x) RESULT(y) + INTEGER :: x,y + y = x *2 + END FUNCTION func + + SUBROUTINE sub(x) + INTEGER :: x + PRINT*, x + END SUBROUTINE sub + + + SUBROUTINE use_func() + PROCEDURE(func), POINTER :: f + INTEGER :: y + f => func + y = f(2) + END SUBROUTINE use_func + + SUBROUTINE use_sub() + PROCEDURE(sub), POINTER :: f + f => sub + CALL f(2) + END SUBROUTINE use_sub + +END MODULE m Index: Fortran/gfortran/regression/proc_ptr_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_29.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 45366: Problem with procedure pointer dummy in PURE function +! +! Contributed by Marco Restelli + +module m1 + implicit none + abstract interface + pure function i_f(x) result(y) + real, intent(in) :: x + real :: y + end function i_f + end interface +end module m1 + +module m2 + use m1, only: i_f + implicit none +contains + pure function i_g(x,p) result(y) + real, intent(in) :: x + procedure(i_f), pointer, intent(in) :: p + real :: y + y = p(x) + end function i_g +end module m2 Index: Fortran/gfortran/regression/proc_ptr_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_3.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! PROCEDURE POINTERS without the PROCEDURE statement +! +! Contributed by Janus Weil + +real function e1(x) + real :: x + e1 = x * 3.0 +end function + +subroutine e2(a,b) + real, intent(inout) :: a + real, intent(in) :: b + a = a + b +end subroutine + +program proc_ptr_3 + +real, external, pointer :: fp + +pointer :: sp +interface + subroutine sp(a,b) + real, intent(inout) :: a + real, intent(in) :: b + end subroutine sp +end interface + +real, external :: e1 + +interface + subroutine e2(a,b) + real, intent(inout) :: a + real, intent(in) :: b + end subroutine e2 +end interface + +real :: c = 1.2 + +fp => e1 + +if (abs(fp(2.5)-7.5)>0.01) STOP 1 + +sp => e2 + +call sp(c,3.4) + +if (abs(c-4.6)>0.01) STOP 2 + +end Index: Fortran/gfortran/regression/proc_ptr_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_30.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 46067: [F03] invalid procedure pointer assignment not detected +! +! Contributed by Stephen J. Bespalko + + implicit none + + type test_type + integer :: id = 1 + end type + + abstract interface + real function fun_interface(t,x) + import :: test_type + real, intent(in) :: x + class(test_type) :: t + end function + end interface + + type(test_type) :: funs + real :: r + procedure(fun_interface), pointer :: pp + + pp => fun1 ! { dg-error "Interface mismatch in procedure pointer assignment" } + r = pp(funs,0.) + print *, " pp(0) ", r + +contains + + real function fun1 (t,x) + real, intent(in) :: x + type(test_type) :: t + print *," id = ", t%id + fun1 = cos(x) + end function + +end Index: Fortran/gfortran/regression/proc_ptr_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_31.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 49400: [F08] Proc-pointer declaration in BLOCK construct +! +! Contributed by Tobias Burnus + + block + procedure(real),pointer :: p + end block +end Index: Fortran/gfortran/regression/proc_ptr_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_32.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-procedure +! +! Contributed by James Van Buskirk + + implicit none + procedure(my_dcos), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" } + f => my_dcos ! { dg-error "Nonintrinsic elemental procedure 'my_dcos' is invalid in procedure pointer assignment" } +contains + real elemental function my_dcos(x) + real, intent(in) :: x + my_dcos = cos(x) + end function +end Index: Fortran/gfortran/regression/proc_ptr_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_33.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-procedure +! +! Contributed by James Van Buskirk + +module funcs + implicit none + abstract interface + real elemental function fun(x) + real, intent(in) :: x + end function + end interface +contains + function my_dcos(x) + real, intent(in) :: x + real :: my_dcos + my_dcos = cos(x) + end function +end module + +program start + use funcs + implicit none + procedure(fun), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" } + real x(3) + x = [1,2,3] + f => my_dcos ! { dg-error "Mismatch in PURE attribute" } + write(*,*) f(x) +end program start Index: Fortran/gfortran/regression/proc_ptr_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_34.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! +! PR fortran/52469 +! +! This was failing as the DECL of the proc pointer "func" +! was used for the interface of the proc-pointer component "my_f_ptr" +! rather than the decl of the proc-pointer target +! +! Contributed by palott@gmail.com +! + +module ExampleFuncs + implicit none + + ! NOTE: "func" is a procedure pointer! + pointer :: func + interface + function func (z) + real :: func + real, intent (in) :: z + end function func + end interface + + type Contains_f_ptr + procedure (func), pointer, nopass :: my_f_ptr + end type Contains_f_ptr +contains + +function f1 (x) + real :: f1 + real, intent (in) :: x + + f1 = 2.0 * x + + return +end function f1 + +function f2 (x) + real :: f2 + real, intent (in) :: x + + f2 = 3.0 * x**2 + + return +end function f2 + +function fancy (func, x) + real :: fancy + real, intent (in) :: x + + interface AFunc + function func (y) + real :: func + real, intent (in) ::y + end function func + end interface AFunc + + fancy = func (x) + 3.3 * x +end function fancy + +end module ExampleFuncs + + +program test_proc_ptr + use ExampleFuncs + implicit none + + type (Contains_f_ptr), dimension (2) :: NewType + + !NewType(1) % my_f_ptr => f1 + NewType(2) % my_f_ptr => f2 + + !write (*, *) NewType(1) % my_f_ptr (3.0), NewType(2) % my_f_ptr (3.0) + write (6, *) NewType(2) % my_f_ptr (3.0) ! < Shall print '27.0' + + stop +end program test_proc_ptr Index: Fortran/gfortran/regression/proc_ptr_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_35.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/52542 +! +! Ensure that the procedure myproc is Bind(C). +! +! Contributed by Mat Cross of NAG +! +interface + subroutine s() bind(c) + end subroutine s +end interface +procedure(s) :: myproc +call myproc() +end +! { dg-final { scan-assembler-not "myproc_" } } Index: Fortran/gfortran/regression/proc_ptr_36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_36.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR fortran/52585 +! +! Test proc-pointer dummies with ASSOCIATE +! +! Contributed by Mat Cross of NAG +! +module m0 + abstract interface + subroutine sub + end subroutine sub + end interface + interface + subroutine s(ss, isassoc) + import sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + end subroutine s + end interface +end module m0 + +use m0, only : sub, s +procedure(sub) :: sub2, pp +pointer :: pp +pp => sub2 +if (.not. associated(pp)) STOP 1 +if (.not. associated(pp,sub2)) STOP 2 +call s(pp, .true.) +pp => null() +if (associated(pp)) STOP 3 +if (associated(pp,sub2)) STOP 4 +call s(pp, .false.) +end + +subroutine s(ss, isassoc) + use m0, only : sub + logical :: isassoc + procedure(sub), pointer, intent(in) :: ss + procedure(sub) :: sub2 + if (isassoc .neqv. associated(ss)) STOP 5 + if (isassoc .neqv. associated(ss,sub2)) STOP 6 +end subroutine s + +subroutine sub2 +end subroutine sub2 Index: Fortran/gfortran/regression/proc_ptr_37.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_37.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 51081: [F03] Proc-pointer assignment: Rejects valid internal proc +! +! Contributed by Tobias Burnus + +procedure(), pointer :: p1 +procedure(real), pointer :: p2 +p1 => int2 +p2 => scale ! { dg-error "is invalid in procedure pointer assignment" } +contains + subroutine int2() + print *,"..." + end subroutine +end Index: Fortran/gfortran/regression/proc_ptr_38.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_38.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 54387: [F03] Wrongly accepts non-proc result variable on the RHS of a proc-pointer assignment +! +! Contributed by James Van Buskirk + +integer function foo() + procedure(), pointer :: i + i => foo ! { dg-error "is invalid as proc-target in procedure pointer assignment" } +end + +recursive function bar() result (res) + integer :: res + procedure(), pointer :: j + j => bar +end Index: Fortran/gfortran/regression/proc_ptr_39.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_39.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! PR 52909: [F03] Procedure pointers not private to modules +! +! Contributed by Andrew Benson + +module Module1 + procedure(), pointer, private :: procPtr => null() +end module + +module Module2 + procedure(), pointer, private :: procPtr => null() +end module + +program Test + use Module1 + use Module2 +end program Index: Fortran/gfortran/regression/proc_ptr_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_4.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! PROCEDURE POINTERS & pointer-valued functions +! +! Contributed by Janus Weil + +interface + integer function f1() + end function +end interface + +interface + function f2() + integer, pointer :: f2 + end function +end interface + +interface + function pp1() + integer :: pp1 + end function +end interface +pointer :: pp1 + +pointer :: pp2 +interface + function pp2() + integer :: pp2 + end function +end interface + +pointer :: pp3 +interface + function pp3() + integer, pointer :: pp3 + end function +end interface + +interface + function pp4() + integer, pointer :: pp4 + end function +end interface +pointer :: pp4 + + +pp1 => f1 + +pp2 => pp1 + +f2 => f1 ! { dg-error "is not a variable" } + +pp3 => f2 + +pp4 => pp3 + +end \ No newline at end of file Index: Fortran/gfortran/regression/proc_ptr_40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_40.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 56261: [OOP] seg fault call procedure pointer on polymorphic array +! +! Contributed by Andrew Benson + + implicit none + type :: nc + end type + external :: qq + procedure( ), pointer :: f1 + procedure(ff), pointer :: f2 + + f1 => ff ! { dg-error "Explicit interface required" } + f2 => qq ! { dg-error "Explicit interface required" } + +contains + + subroutine ff (self) + class(nc) :: self + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_41.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 56968: [4.7/4.8/4.9 Regression] [F03] Issue with a procedure defined with a generic name returning procedure pointer +! +! Contributed by Samuel Debionne + +module test + + interface generic_name_get_proc_ptr + module procedure specific_name_get_proc_ptr + end interface + + abstract interface + double precision function foo(arg1) + real, intent(in) :: arg1 + end function + end interface + +contains + + function specific_name_get_proc_ptr() result(res) + procedure(foo), pointer :: res + end function + +end module test + +program crash_test + use :: test + + procedure(foo), pointer :: ptr + + ptr => specific_name_get_proc_ptr() + ptr => generic_name_get_proc_ptr() + +end program Index: Fortran/gfortran/regression/proc_ptr_42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_42.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 56814: [4.8/4.9 Regression] Bogus Interface mismatch in dummy procedure +! +! Contributed by Marco Restelli + +module m1 + abstract interface + pure function i_f(x) result(d) + real, intent(in) :: x(:,:) + real :: d(size(x,1),size(x,2)) + end function + end interface + + procedure(i_f), pointer :: f => null() +end module + +module m2 +contains + pure subroutine ns_dirdata(fun) + interface + pure function fun(x) result(d) + real, intent(in) :: x(:,:) + real :: d(size(x,1),size(x,2)) + end function + end interface + end subroutine +end module + +program p + use m1 + use m2 + call ns_dirdata(f) +end Index: Fortran/gfortran/regression/proc_ptr_43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_43.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 58099: [4.8/4.9 Regression] [F03] over-zealous procedure-pointer error checking +! +! Contributed by Daniel Price + + implicit none + procedure(real), pointer :: wfunc + + wfunc => w_cubic + +contains + + pure real function w_cubic(q2) + real, intent(in) :: q2 + w_cubic = 0. + end function + +end Index: Fortran/gfortran/regression/proc_ptr_44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_44.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 54949: [F03] abstract procedure pointers not rejected +! +! Contributed by Janus Weil + + implicit none + + abstract interface + subroutine abssub1 + end subroutine + end interface + pointer :: abssub1 ! { dg-error "PROCEDURE POINTER attribute conflicts with ABSTRACT attribute" } + + pointer :: abssub2 + abstract interface + subroutine abssub2 ! { dg-error "PROCEDURE POINTER attribute conflicts with ABSTRACT attribute" } + end subroutine + end interface + + abssub1 => sub ! { dg-error "is not a variable" } + abssub2 => sub + +contains + + subroutine sub + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_45.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/49397 +! +! Valid per IR F08/0060 and F2008Corr2, C729 +! +Program m5 + Print *,f() +Contains + Subroutine s + Procedure(Real),Pointer :: p + Print *,g() + p => f ! (1) + Print *,p() + p => g ! (2) + Print *,p() + End Subroutine +End Program +Function f() + f = 1 +End Function +Function g() + g = 2 +End Function Index: Fortran/gfortran/regression/proc_ptr_46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_46.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/49397 +! +! Invalid per IR F08/0060 and F2008Corr2, C729 +! + +! Print *,f() ! << Valid when uncommented +Contains + Subroutine s + Procedure(Real),Pointer :: p + p => f ! { dg-error "Procedure pointer target 'f' at .1. must be either an intrinsic, host or use associated, referenced or have the EXTERNAL attribute" } + End Subroutine +End Index: Fortran/gfortran/regression/proc_ptr_47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_47.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Tests the fix for PR68196 +! +! Contributed by Damian Rouson +! + type AA + integer :: i + procedure(foo), pointer :: funct + end type + class(AA), allocatable :: my_AA + type(AA) :: res + + allocate (my_AA, source = AA (1, foo)) + + res = my_AA%funct () + + if (res%i .ne. 3) STOP 1 + if (.not.associated (res%funct)) STOP 2 + if (my_AA%i .ne. 4) STOP 3 + if (associated (my_AA%funct)) STOP 4 + +contains + function foo(A) + class(AA) :: A + type(AA) foo + + select type (A) + type is (AA) + foo = AA (3, foo) + A = AA (4, NULL ()) + end select + end function +end Index: Fortran/gfortran/regression/proc_ptr_48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_48.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Checks the fix for PR68196, comment #8 +! +! Contributed by Damian Rouson +! + type Bug ! Failed at trans--array.c:8269 + real, allocatable :: scalar + procedure(boogInterface),pointer :: boog + end type + interface + function boogInterface(A) result(C) + import Bug + class(Bug) A + type(Bug) C + end function + end interface + + real, parameter :: ninetynine = 99.0 + real, parameter :: onenineeight = 198.0 + + type(bug) :: actual, res + + actual%scalar = ninetynine + actual%boog => boogImplementation + + res = actual%boog () ! Failed on bug in expr.c:3933 + if (res%scalar .ne. onenineeight) STOP 1 + +! Make sure that the procedure pointer is assigned correctly + if (actual%scalar .ne. ninetynine) STOP 2 + actual = res%boog () + if (actual%scalar .ne. onenineeight) STOP 3 + +! Deallocate so that we can use valgrind to check for memory leaks + deallocate (res%scalar, actual%scalar) + +contains + function boogImplementation(A) result(C) ! Failed at trans--array.c:8078 + class(Bug) A + type(Bug) C + select type (A) + type is (bug) + C = A + C%scalar = onenineeight + class default + STOP 4 + end select + end function +end Index: Fortran/gfortran/regression/proc_ptr_49.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_49.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! Tests the fix for PRs 78013 and 61420, both of which gave a +! no IMPLICIT type message for the procedure pointer at assignment. +! +module m + + implicit none + + abstract interface + function I_f() result( r ) + real :: r + end function I_f + end interface + + type, abstract :: a_t + private + procedure(I_f), nopass, pointer :: m_f => null() + contains + private + procedure, pass(this), public :: f => get_f + end type a_t + +contains + + function get_f( this ) result( f_ptr ) ! Error message here. + class(a_t), intent(in) :: this + procedure(I_f), pointer :: f_ptr + f_ptr => this%m_f ! Error here :-) + end function get_f + +end module m + +module test + implicit none + + type functions + contains + procedure, nopass :: get_pf => get_it ! Error here + end type + + class(functions), allocatable :: f + +contains + + function get_it() ! Error message here. + procedure (real), pointer :: get_it + end function + +end module Index: Fortran/gfortran/regression/proc_ptr_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_5.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! NULL() initialization for PROCEDURE POINTERS +! +! Contributed by Tobias Burnus + +program main +implicit none +call test(.true.) +call test(.false.) + +contains + +integer function hello() + hello = 42 +end function hello + +subroutine test(first) + logical :: first + integer :: i + procedure(integer), pointer :: x => null() + + if(first) then + if(associated(x)) STOP 1 + x => hello + else + if(.not. associated(x)) STOP 2 + i = x() + if(i /= 42) STOP 3 + end if + end subroutine test + +end program main Index: Fortran/gfortran/regression/proc_ptr_50.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_50.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! +! Test the fix for PR86242, in which the procedure pointer in 'tester' +! was being copied as if it were an allocatable class component. +! +! Contributed by +! +module test + + implicit none + + private + public :: tester + + type :: wrapper + integer(4) :: n + end type wrapper + + type :: output + real(8) :: dummy + end type output + + type :: tester + class(wrapper), allocatable :: wrap + procedure(proc1), pointer :: ptr => null() + end type tester + + abstract interface + function proc1(self) result(uc) + import :: tester, output + class(tester), intent(in) :: self + class(output), allocatable :: uc + end function proc1 + end interface + +end module test + +! Comment #2 from Janus Weil +module test1 + + implicit none + + type :: output + end type + + type :: tester + integer, allocatable :: wrap + procedure(proc1), pointer, nopass :: ptr + end type + + interface ! Originally abstract + function proc1() result(uc) + import :: output + class(output), allocatable :: uc ! Works if a pointer + end function + end interface + +! PR82969 from Gerhard Steinmetz + type t + real, allocatable :: x(:) + procedure(f), nopass, pointer :: g + end type +contains + function f() result(z) + class(t), allocatable :: z + end + +end module test1 Index: Fortran/gfortran/regression/proc_ptr_51.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_51.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR90786. +! +! Contributed by Andrew benson +! +module f +procedure(c), pointer :: c_ + + type :: s + integer :: i = 42 + end type s + class(s), pointer :: res, tgt + +contains + + function c() + implicit none + class(s), pointer :: c + c => tgt + return + end function c + + subroutine fs() + implicit none + c_ => c ! This used to ICE + return + end subroutine fs + +end module f + + use f + allocate (tgt, source = s(99)) + call fs() + res => c_() + if (res%i .ne. 99) stop 1 + deallocate (tgt) +end Index: Fortran/gfortran/regression/proc_ptr_52.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_52.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! +! Test the fix for PRs93924 & 93925. +! +! Contributed by Martin Stein +! +module cs + +implicit none + +integer, target :: integer_target + +abstract interface + function classStar_map_ifc(x) result(y) + class(*), pointer :: y + class(*), target, intent(in) :: x + end function classStar_map_ifc +end interface + +contains + + function fun(x) result(y) + class(*), pointer :: y + class(*), target, intent(in) :: x + select type (x) + type is (integer) + integer_target = x ! Deals with dangling target. + y => integer_target + class default + y => null() + end select + end function fun + + function apply(f, x) result(y) + procedure(classStar_map_ifc) :: f + integer, intent(in) :: x + integer :: y + class(*), pointer :: p + y = 0 ! Get rid of 'y' undefined warning + p => f (x) + select type (p) + type is (integer) + y = p + end select + end function apply + + function selector() result(f) + procedure(classStar_map_ifc), pointer :: f + f => fun + end function selector + +end module cs + + +program classStar_map + +use cs +implicit none + +integer :: x, y +procedure(classStar_map_ifc), pointer :: f + +x = 123654 +f => selector () ! Fixed by second chunk in patch +y = apply (f, x) ! Fixed by first chunk in patch +if (x .ne. y) stop 1 + +x = 2 * x +y = apply (fun, x) ! PR93925; fixed as above +if (x .ne. y) stop 2 + +end program classStar_map Index: Fortran/gfortran/regression/proc_ptr_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_6.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PROCEDURE POINTERS as actual/formal arguments +! +! Contributed by Janus Weil + +subroutine foo(j) + INTEGER, INTENT(OUT) :: j + j = 6 +end subroutine + +program proc_ptr_6 + +PROCEDURE(),POINTER :: ptr1 +PROCEDURE(REAL),POINTER :: ptr2 +EXTERNAL foo +INTEGER :: k = 0 + +ptr1 => foo +call s_in(ptr1,k) +if (k /= 6) STOP 1 + +call s_out(ptr2) +if (ptr2(-3.0) /= 3.0) STOP 2 + +contains + +subroutine s_in(p,i) + PROCEDURE(),POINTER,INTENT(IN) :: p + INTEGER, INTENT(OUT) :: i + call p(i) +end subroutine + +subroutine s_out(p) + PROCEDURE(REAL),POINTER,INTENT(OUT) :: p + p => abs +end subroutine + +end program Index: Fortran/gfortran/regression/proc_ptr_7.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_7.c @@ -0,0 +1,10 @@ +/* Procedure pointer test. Used by proc_ptr_7.f90. + PR fortran/32580. */ + +int f(void) { + return 42; +} + +void assignf_(int(**ptr)(void)) { + *ptr = f; +} Index: Fortran/gfortran/regression/proc_ptr_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_7.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-additional-sources proc_ptr_7.c } +! +! PR fortran/32580 +! Procedure pointer test +! +! Contributed by Tobias Burnus + +program proc_pointer_test + use iso_c_binding, only: c_int + implicit none + + interface + subroutine assignF(f) + import c_int + procedure(Integer(c_int)), pointer :: f + end subroutine + end interface + + procedure(Integer(c_int)), pointer :: ptr + + call assignF(ptr) + if(ptr() /= 42) STOP 1 + + ptr => f55 + if(ptr() /= 55) STOP 2 + + call foo(ptr) + if(ptr() /= 65) STOP 3 + +contains + + subroutine foo(a) + procedure(integer(c_int)), pointer :: a + if(a() /= 55) STOP 4 + a => f65 + if(a() /= 65) STOP 5 + end subroutine foo + + integer(c_int) function f55() + f55 = 55 + end function f55 + + integer(c_int) function f65() + f65 = 65 + end function f65 +end program proc_pointer_test Index: Fortran/gfortran/regression/proc_ptr_8.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_8.c @@ -0,0 +1,14 @@ +/* Used by proc_ptr_8.f90. + PR fortran/32580. */ + +int (*funpointer)(int); + +int f(int t) +{ + return t*3; +} + +void init() +{ + funpointer=f; +} Index: Fortran/gfortran/regression/proc_ptr_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_8.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-additional-sources proc_ptr_8.c } +! +! PR fortran/32580 +! Original test case +! +! Contributed by Joost VandeVondele + +MODULE X + + USE ISO_C_BINDING + INTERFACE + INTEGER(KIND=C_INT) FUNCTION mytype( a ) BIND(C) + USE ISO_C_BINDING + INTEGER(KIND=C_INT), VALUE :: a + END FUNCTION + SUBROUTINE init() BIND(C,name="init") + END SUBROUTINE + END INTERFACE + + TYPE(C_FUNPTR), BIND(C,name="funpointer") :: funpointer + +END MODULE X + +USE X +PROCEDURE(mytype), POINTER :: ptype,ptype2 + +CALL init() +CALL C_F_PROCPOINTER(funpointer,ptype) +if (ptype(3_c_int) /= 9) STOP 1 + +! the stuff below was added with PR 42072 +call setpointer(ptype2) +if (ptype2(4_c_int) /= 12) STOP 2 + +contains + + subroutine setpointer (p) + PROCEDURE(mytype), POINTER :: p + CALL C_F_PROCPOINTER(funpointer,p) + end subroutine + +END Index: Fortran/gfortran/regression/proc_ptr_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_9.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/36705 +! +! Contributed by Tobias Burnus + +save :: p +procedure() :: p +pointer :: p + +contains + +subroutine bar(x) + procedure(), intent(in) :: x + pointer :: x +end subroutine bar + +end Index: Fortran/gfortran/regression/proc_ptr_common_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_common_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-std=f2003" } +! +! PR fortran/36592 +! +! Procedure Pointers inside COMMON blocks. +! (Allowed in F03, but forbidden in F08.) +! +! Contributed by Janus Weil . + +subroutine one() + implicit none + procedure(real), pointer :: p1,p2 + integer :: a,b + common /com/ p1,p2,a,b + if (a/=5 .or. b/=-9 .or. p1(0.0)/=1.0 .or. p2(0.0)/=0.0) STOP 1 +end subroutine one + +program main + implicit none + integer :: x,y + intrinsic sin,cos + procedure(real), pointer :: func1 + real, external :: func2 + pointer func2 + common /com/ func1,func2,x,y + x = 5 + y = -9 + func1 => cos + func2 => sin + call one() +end program main + Index: Fortran/gfortran/regression/proc_ptr_common_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_common_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +! PR fortran/36592 +! +! Procedure Pointers inside COMMON blocks. +! +! Contributed by Tobias Burnus . + +abstract interface + subroutine foo() bind(C) + end subroutine foo +end interface + +procedure(foo), pointer, bind(C) :: proc +common /com/ proc,r ! { dg-error "PROCEDURE attribute conflicts with COMMON attribute" } + +common s +call s() ! { dg-error "PROCEDURE attribute conflicts with COMMON attribute" } + +end Index: Fortran/gfortran/regression/proc_ptr_comp_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_1.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! Basic test for PPCs with SUBROUTINE interface and NOPASS. +! +! Contributed by Janus Weil + + type t + integer :: i + procedure(sub), pointer, nopass :: ppc + procedure(), pointer, nopass :: proc + end type + + type, extends(t) :: t2 + procedure(), pointer, nopass :: proc2 + end type t2 + + type(t) :: x + type(t2) :: x2 + + procedure(sub),pointer :: pp + integer :: sum = 0 + + x%i = 1 + x%ppc => sub + pp => x%ppc + + call sub(1) + if (sum/=1) STOP 1 + call pp(2) + if (sum/=3) STOP 2 + call x%ppc(3) + if (sum/=6) STOP 3 + + ! calling object as argument + x%proc => sub2 + call x%proc(x) + if (x%i/=7) STOP 4 + + ! type extension + x%proc => sub + call x%proc(4) + if (sum/=10) STOP 5 + x2%proc => sub + call x2%proc(5) + if (sum/=15) STOP 6 + x2%proc2 => sub + call x2%proc2(6) + if (sum/=21) STOP 7 + +contains + + subroutine sub(y) + integer, intent(in) :: y + sum = sum + y + end subroutine + + subroutine sub2(arg) + type(t),intent(inout) :: arg + arg%i = arg%i + sum + end subroutine + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_10.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Contributed by Janus Weil + +module m + +abstract interface + function ai() + real, dimension(3) :: ai + end function +end interface + +type t + procedure(ai), pointer, nopass :: ppc +end type + +procedure(ai), pointer :: pp + +end module + +program test +use m +type(t) :: obj +obj%ppc => pp +pp => obj%ppc +end Index: Fortran/gfortran/regression/proc_ptr_comp_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_11.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR 40427: Procedure Pointer Components with OPTIONAL arguments +! +! Original test case by John McFarland +! Modified by Janus Weil + +PROGRAM prog + + ABSTRACT INTERFACE + SUBROUTINE sub_template(i,j,o) + INTEGER, INTENT(in) :: i + INTEGER, INTENT(in), OPTIONAL :: j, o + END SUBROUTINE sub_template + END INTERFACE + + TYPE container + PROCEDURE(sub_template), POINTER, NOPASS :: s + END TYPE container + + PROCEDURE(sub_template), POINTER :: f + TYPE (container) :: c + + c%s => sub + f => sub + + CALL f(2,o=4) + CALL c%s(3,o=6) + +CONTAINS + + SUBROUTINE sub(i,arg2,arg3) + INTEGER, INTENT(in) :: i + INTEGER, INTENT(in), OPTIONAL :: arg2, arg3 + if (present(arg2)) STOP 1 + if (.not. present(arg3)) STOP 2 + if (2*i/=arg3) STOP 3 + END SUBROUTINE sub + +END PROGRAM prog + Index: Fortran/gfortran/regression/proc_ptr_comp_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_12.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR 40646: [F03] array-valued procedure pointer components +! +! Original test case by Charlie Sharpsteen +! Modified by Janus Weil + +module bugTestMod + implicit none + type:: boundTest + procedure(returnMat), pointer, nopass:: test + end type boundTest +contains + function returnMat( a, b ) result( mat ) + integer:: a, b + double precision, dimension(a,b):: mat + mat = 1d0 + end function returnMat +end module bugTestMod + +program bugTest + use bugTestMod + implicit none + type( boundTest ):: testObj + double precision, dimension(2,2):: testCatch + testObj%test => returnMat + testCatch = testObj%test(2,2) + print *,testCatch + if (sum(testCatch)/=4) STOP 1 + print *,testObj%test(3,3) + if (sum(testObj%test(3,3))/=9) STOP 2 +end program bugTest Index: Fortran/gfortran/regression/proc_ptr_comp_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_13.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR 40882: [F03] infinite recursion in gfc_get_derived_type with PPC returning derived type. +! At the same time, check that a formal argument does not cause infinite recursion (PR 40870). +! +! Contributed by Janus Weil + +implicit none + +type :: t + integer :: data + procedure(foo), pointer, nopass :: ppc + procedure(type(t)), pointer, nopass :: ppc2 +end type + +type(t) :: o,o2 + +o%data = 1 +o%ppc => foo + +o2 = o%ppc(o) + +if (o%data /= 1) STOP 1 +if (o2%data /= 5) STOP 2 +if (.not. associated(o%ppc)) STOP 3 +if (associated(o2%ppc)) STOP 4 + +contains + + function foo(arg) + type(t) :: foo, arg + foo%data = arg%data * 5 + foo%ppc => NULL() + end function + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_14.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR 41022: [F03] procedure pointer components as actual arguments +! +! Contributed by Juergen Reuter + +program foo + + type :: container_t + procedure(proc), nopass, pointer :: proc => null () + end type container_t + + type(container_t), target :: obj1 + type(container_t) :: obj2 + + obj1%proc => proc + call transfer_proc_ptr (obj2, obj1) + + if (obj2%proc()/=7) STOP 1 + +contains + + subroutine transfer_proc_ptr (obj2, obj1) + type(container_t), intent(out) :: obj2 + type(container_t), intent(in), target :: obj1 + call assign_proc_ptr (obj2%proc, obj1) + end subroutine transfer_proc_ptr + + subroutine assign_proc_ptr (ptr, obj1) + procedure(proc), pointer :: ptr + type(container_t), intent(in), target :: obj1 + ptr => obj1%proc + end subroutine assign_proc_ptr + + integer function proc () + proc = 7 + end function + +end program foo + Index: Fortran/gfortran/regression/proc_ptr_comp_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_15.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 41106: [F03] Procedure Pointers with CHARACTER results +! +! Contributed by Tobias Burnus + +module m + type :: t + procedure(character(len=5)), pointer, nopass :: ptr + end type +contains + function abc() + character(len=5) :: abc + abc = 'abcde' + end function abc +end module m + +use m + type(t) :: x + character(len=5) :: str + x%ptr => abc + print *,x%ptr() + str = x%ptr() + if (str/='abcde') STOP 1 +end Index: Fortran/gfortran/regression/proc_ptr_comp_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_16.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR 41106: [F03] Procedure Pointers with CHARACTER results +! +! Contributed by Janus Weil + +module m + type :: t + procedure(abc), pointer, nopass :: ptr + end type +contains + function abc(i) + integer :: i + character(len=i) :: abc + abc = 'abcde' + end function abc +end module m + +use m + type(t) :: x + character(len=4) :: str + x%ptr => abc + print *,x%ptr(4) + if (x%ptr(4)/='abcd') STOP 1 + str = x%ptr(3) + if (str/='abc') STOP 1 +end Index: Fortran/gfortran/regression/proc_ptr_comp_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_17.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR 41106: [F03] Procedure Pointers with CHARACTER results +! +! Contributed by Janus Weil + +module m + type :: t + procedure(abc), pointer, nopass :: ptr + end type +contains + function abc(arg) + character(len=5),pointer :: abc + character(len=5),target :: arg + abc => arg + end function abc +end module m + +use m + type(t) :: x + character(len=5) :: str = 'abcde' + character(len=5), pointer :: strptr + x%ptr => abc + print *,x%ptr(str) + strptr => x%ptr(str) + if (strptr/='abcde') STOP 1 + str = 'fghij' + if (strptr/='fghij') STOP 2 +end Index: Fortran/gfortran/regression/proc_ptr_comp_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_18.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Contributed by Janus Weil + +PROGRAM test + + type :: t + PROCEDURE(add), POINTER, nopass :: f + end type + type(t) :: o + logical :: g + + o%f => add + g=greater(4.,o%f(1.,2.)) + if (.not. g) STOP 1 + +CONTAINS + + REAL FUNCTION add(x,y) + REAL, INTENT(in) :: x,y + add = x+y + END FUNCTION add + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + print *,"greater:",x,y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test + Index: Fortran/gfortran/regression/proc_ptr_comp_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_19.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Contributed by Janus Weil + +PROGRAM test + + type :: t + PROCEDURE(three), POINTER, nopass :: f + end type + type(t) :: o + logical :: g + + o%f => three + g=greater(4.,o%f()) + if (.not. g) STOP 1 + +CONTAINS + + REAL FUNCTION three() + three = 3. + END FUNCTION + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + print *,"greater:",x,y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test + Index: Fortran/gfortran/regression/proc_ptr_comp_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_2.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! Basic test for PPCs with FUNCTION interface and NOPASS. +! +! Contributed by Janus Weil + + type t + procedure(fcn), pointer, nopass :: ppc + procedure(abstr), pointer, nopass :: ppc1 + integer :: i + end type + + abstract interface + integer function abstr(x) + integer, intent(in) :: x + end function + end interface + + type(t) :: obj + procedure(fcn), pointer :: f + integer :: base + + intrinsic :: iabs + +! Check with interface from contained function + obj%ppc => fcn + base=obj%ppc(2) + if (base/=4) STOP 1 + call foo (obj%ppc,3) + +! Check with abstract interface + obj%ppc1 => obj%ppc + base=obj%ppc1(4) + if (base/=8) STOP 1 + call foo (obj%ppc1,5) + +! Check compatibility components with non-components + f => obj%ppc + base=f(6) + if (base/=12) STOP 1 + call foo (f,7) + +contains + + integer function fcn(x) + integer, intent(in) :: x + fcn = 2 * x + end function + + subroutine foo (arg, i) + procedure (fcn), pointer :: arg + integer :: i + if (arg(i)/=2*i) STOP 1 + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_comp_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_20.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR 40869: [F03] PPC assignment checking +! +! Contributed by Janus Weil + +implicit none + +interface func + procedure f1,f2 +end interface + +interface operator(.op.) + procedure f1,f2 +end interface + +type :: t1 + procedure(integer), pointer, nopass :: ppc +end type + +type :: t2 + procedure(real), pointer, nopass :: ppc +end type + +type(t1) :: o1 +type(t2) :: o2 +procedure(logical),pointer :: pp1 +procedure(complex),pointer :: pp2 + +pp1 => pp2 ! { dg-error "Type mismatch in function result" } +pp2 => o2%ppc ! { dg-error "Type mismatch in function result" } + +o1%ppc => pp1 ! { dg-error "Type mismatch in function result" } +o1%ppc => o2%ppc ! { dg-error "Type mismatch in function result" } + +contains + + real function f1(a,b) ! { dg-error "Ambiguous interfaces" } + real,intent(in) :: a,b + f1 = a + b + end function + + integer function f2(a,b) ! { dg-error "Ambiguous interfaces" } + real,intent(in) :: a,b + f2 = a - b + end function + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_21.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 41242: [4.5 Regression] PPC call rejected (related to user-defined assignment?) +! +! Original test case by Juergen Reuter +! Modified by Janus Weil + + type :: nf_t + procedure(integer), nopass, pointer :: get_n_in + end type + + interface assignment(=) + procedure op_assign + end interface + + type(nf_t) :: prc_lib + prc_lib = "foobar" + print *, prc_lib%get_n_in() + +contains + + elemental subroutine op_assign (str, ch) + type(nf_t), intent(out) :: str + character(len=*), intent(in) :: ch + end subroutine + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_22.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 41978: [F03] ICE in gfc_conv_expr_descriptor for array PPC assignment +! +! Contributed by Daniel Kraft + +MODULE m + IMPLICIT NONE + + TYPE t + PROCEDURE(myproc), POINTER, PASS :: myproc + END TYPE t + +CONTAINS + + INTEGER FUNCTION myproc (me) + CLASS(t), INTENT(IN) :: me + myproc = 42 + END FUNCTION myproc + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(t) :: arr(2) + arr%myproc => myproc ! { dg-error "must not have the POINTER attribute" } +END PROGRAM main + Index: Fortran/gfortran/regression/proc_ptr_comp_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_23.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! Tests the fix for PR42104 in which the call to the procedure pointer +! component caused an ICE because the "always_implicit flag was not used +! to force the passing of a descriptor for the array argument. +! +! Contributed by Martien Hulsen +! +module poisson_functions_m + + implicit none + +contains + + function func ( nr, x ) + integer, intent(in) :: nr + real, intent(in), dimension(:) :: x + real :: func + + real :: pi + + pi = 4 * atan(1.) + + select case(nr) + case(1) + func = 0 + case(2) + func = 1 + case(3) + func = 1 + cos(pi*x(1))*cos(pi*x(2)) + case default + write(*,'(/a,i0/)') 'Error func: wrong function number: ', nr + stop + end select + + end function func + +end module poisson_functions_m + +module element_defs_m + + implicit none + + abstract interface + function dummyfunc ( nr, x ) + integer, intent(in) :: nr + real, intent(in), dimension(:) :: x + real :: dummyfunc + end function dummyfunc + end interface + + type function_p + procedure(dummyfunc), nopass, pointer :: p => null() + end type function_p + +end module element_defs_m + +program t + +use poisson_functions_m +use element_defs_m + +procedure(dummyfunc), pointer :: p => null() +type(function_p) :: funcp + +p => func +funcp%p => func + +print *, func(nr=3,x=(/0.1,0.1/)) +print *, p(nr=3,x=(/0.1,0.1/)) +print *, funcp%p(nr=3,x=(/0.1,0.1/)) + +end program t Index: Fortran/gfortran/regression/proc_ptr_comp_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_24.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR42045: [F03] passing a procedure pointer component to a procedure pointer dummy +! +! Contributed by John McFarland + +PROGRAM prog + TYPE object + PROCEDURE(), POINTER, NOPASS :: f + END TYPE object + TYPE container + TYPE (object), POINTER :: o(:) + END TYPE container + TYPE (container) :: c + TYPE (object) :: o1, o2 + PROCEDURE(), POINTER :: f => NULL() + o1%f => f + CALL set_func(o2,f) + CALL set_func(o2,o1%f) + ALLOCATE( c%o(5) ) + c%o(5)%f => f + CALL set_func(o2,c%o(5)%f) +CONTAINS + SUBROUTINE set_func(o,f) + TYPE (object) :: o + PROCEDURE(), POINTER :: f + o%f => f + END SUBROUTINE set_func +END PROGRAM prog Index: Fortran/gfortran/regression/proc_ptr_comp_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_25.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 46060: [F03] procedure pointer component referenced without argument list +! +! Contributed by Stephen J. Bespalko + +implicit none + +abstract interface + function name_func (ivar) result (res) + integer, intent(in) :: ivar + character(len=8) :: res + end function name_func +end interface + +type var_type + procedure(name_func), nopass, pointer :: name +end type var_type + +type(var_type) :: vars +character(len=8) name + +name = vars%name ! { dg-error "requires an argument list" } + +end Index: Fortran/gfortran/regression/proc_ptr_comp_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_26.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 46841: [F03] ICE on allocating array of procedure pointers +! +! Contributed by Martien Hulsen + + type vfunc_p + procedure (dum_vfunc), pointer, nopass :: p => null() + end type vfunc_p + + type(vfunc_p), allocatable, dimension(:) :: vfunc1 + + allocate(vfunc1(10)) + +contains + + function dum_vfunc () + real, dimension(2) :: dum_vfunc + dum_vfunc = 0 + end function dum_vfunc + +end Index: Fortran/gfortran/regression/proc_ptr_comp_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_27.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 46201: [F03] ICE on procedure pointer component call +! +! Contributed by Stephen J. Bespalko + +type t + procedure(character), nopass, pointer :: ppc +end type +type(t),dimension(1) :: v +print *,v(1)%ppc() +end Index: Fortran/gfortran/regression/proc_ptr_comp_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_28.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 47224: [F03] ICE with procedure pointer component +! +! Contributed by Martien Hulsen + + type coefficients_t + procedure (real), pointer, nopass :: vfunc + end type + + type(coefficients_t) :: coeff + real, dimension(3) :: x + + print *, abs ( coeff%vfunc ( x(:) ) ) + +end Index: Fortran/gfortran/regression/proc_ptr_comp_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_29.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 47240: [F03] segfault with procedure pointer component +! +! Contributed by Martien Hulsen + + type t + procedure (fun), pointer, nopass :: p + end type + type(t) :: x + real, dimension(2) :: r + x%p => fun + r = evaluate (x%p) + if (r(1) /= 5 .and. r(2) /= 6) STOP 1 +contains + function fun () + real, dimension(2) :: fun + fun = (/ 5, 6 /) + end function + function evaluate ( dummy ) + real, dimension(2) :: evaluate + procedure(fun) :: dummy + evaluate = dummy () + end function +end Index: Fortran/gfortran/regression/proc_ptr_comp_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_3.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! Probing some error messages. +! +! Contributed by Janus Weil + +implicit none + +interface + subroutine sub + end subroutine +end interface + +external :: aaargh + +type :: t + procedure(), pointer, nopass :: ptr1 + procedure(real), pointer, nopass :: ptr2 + procedure(sub), pointer, nopass :: ptr3 + procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" } + procedure(), pointer, nopass, pointer :: ptr5 ! { dg-error "Duplicate" } + procedure, pointer, nopass :: ptr6 ! { dg-error "Syntax error" } + procedure(), nopass :: ptr8 ! { dg-error "POINTER attribute is required" } + procedure(pp), pointer, nopass :: ptr9 ! { dg-error "declared in a later PROCEDURE statement" } + real :: y +end type t + +type :: t2 + procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" } +end type + +type,bind(c) :: bct ! { dg-error "BIND.C. derived type" } + procedure(), pointer,nopass :: ptr ! { dg-error "cannot be a member of|may not be C interoperable" } +end type bct + +procedure(sub), pointer :: pp + +type(t) :: x + +x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" } + +x => x%ptr2 ! { dg-error "Non-POINTER in pointer association context" } + +print *, x%ptr1() ! { dg-error "attribute conflicts with" } +call x%ptr2() ! { dg-error "attribute conflicts with" } +print *,x%ptr3() ! { dg-error "attribute conflicts with" } + +call x%y ! { dg-error "Expected type-bound procedure or procedure pointer component" } + +end Index: Fortran/gfortran/regression/proc_ptr_comp_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_30.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 47768: ICE: printing a derived-type variable with proc-pointer components +! +! Contributed by Janus Weil + +type :: t + integer :: i = 3 + procedure(type(t)), pointer, nopass :: ppc +end type + +type(t) :: x + +print *,x ! { dg-error "cannot have procedure pointer components" } +end Index: Fortran/gfortran/regression/proc_ptr_comp_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_31.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 47768: printing a derived-type variable with proc-pointer components +! +! Contributed by Arjen Markus + +module proc_pointers + implicit none + type :: rectangle + real :: width, height + procedure(real), pointer, nopass :: get_special_area + end type +end module + +program test_objects + use proc_pointers + implicit none + type(rectangle) :: rect + write(*,*) rect ! { dg-error "cannot have procedure pointer components" } +end program Index: Fortran/gfortran/regression/proc_ptr_comp_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_32.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected +! +! Contributed by Arjen Markus + +module m + + implicit none + + type :: rectangle + procedure(get_area), pointer :: get_special_area + end type rectangle + + abstract interface + real function get_area( this ) + import :: rectangle + class(rectangle), intent(in) :: this + end function get_area + end interface + +contains + + real function get_my_area( this ) + type(rectangle), intent(in) :: this + get_my_area = 3.0 + end function get_my_area + +end module + + +use m +type(rectangle) :: rect +rect%get_special_area => get_my_area ! { dg-error "Interface mismatch in procedure pointer assignment" } +end Index: Fortran/gfortran/regression/proc_ptr_comp_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_33.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! +! PR 48095: [OOP] Invalid assignment to procedure pointer component not rejected +! +! Original test case by Arjen Markus +! Modified by Janus Weil + +module m + + implicit none + + type :: rectangle + real :: width, height + procedure(get_area_ai), pointer :: get_area => get_my_area ! { dg-error "Type mismatch in argument" } + end type rectangle + + abstract interface + real function get_area_ai( this ) + import :: rectangle + class(rectangle), intent(in) :: this + end function get_area_ai + end interface + +contains + + real function get_my_area( this ) + type(rectangle), intent(in) :: this + get_my_area = 3.0 * this%width * this%height + end function get_my_area + +end + +!------------------------------------------------------------------------------- + +program p + + implicit none + + type :: rectangle + real :: width, height + procedure(get_area_ai), pointer :: get_area + end type rectangle + + abstract interface + real function get_area_ai (this) + import :: rectangle + class(rectangle), intent(in) :: this + end function get_area_ai + end interface + + type(rectangle) :: rect + + rect = rectangle (1.0, 2.0, get1) + rect = rectangle (3.0, 4.0, get2) ! { dg-error "Type mismatch in argument" } + +contains + + real function get1 (this) + class(rectangle), intent(in) :: this + get1 = 1.0 * this%width * this%height + end function get1 + + real function get2 (this) + type(rectangle), intent(in) :: this + get2 = 2.0 * this%width * this%height + end function get2 + +end Index: Fortran/gfortran/regression/proc_ptr_comp_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_34.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR 51082: [F03] Wrong result for a pointer to a proc-pointer component +! +! Contributed by Tobias Burnus + +program ala + implicit none + + type process_list + procedure(ala1), pointer, nopass :: process + end type + + type(process_list), target :: p_list + type(process_list), pointer :: p + + p_list%process => ala1 + p => p_list + + write(*,*) p_list%process(1.0) + write(*,*) p%process(1.0) !!!! failed + +contains + + real function ala1(x) + real, intent(in) :: x + ala1 = x + end function + +end program Index: Fortran/gfortran/regression/proc_ptr_comp_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_35.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 54147: [F03] Interface checks for PPCs & deferred TBPs +! +! Contributed by Janus Weil + + interface gen + procedure gen + end interface + + type t1 + procedure(gen),pointer,nopass :: p1 + procedure(gen2),pointer,nopass :: p2 ! { dg-error "may not be generic" } + end type + + type t2 + procedure(sf),pointer,nopass :: p3 ! { dg-error "may not be a statement function" } + end type + + type t3 + procedure(char),pointer,nopass :: p4 ! { dg-error "Intrinsic procedure" } + end type + + interface gen2 + procedure gen + end interface + + sf(x) = x**2 ! { dg-warning "Obsolescent feature" } + +contains + + subroutine gen + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_comp_36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_36.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 54107: [4.8 Regression] Memory hog with abstract interface +! +! Contributed by Arjen Markus + + implicit none + type computation_method + character(len=40) :: name + procedure(compute_routine), pointer, nopass :: compute + end type + abstract interface + subroutine compute_routine( param_value, zfunc, probability ) + real, dimension(:), intent(in) :: param_value + procedure(compute_routine) :: zfunc + real, intent(in) :: probability + end subroutine + end interface +end Index: Fortran/gfortran/regression/proc_ptr_comp_37.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_37.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 56385: [4.6/4.7/4.8 Regression] [OOP] ICE with allocatable function result in a procedure-pointer component +! +! Contributed by Vladimir Fuka + + implicit none + + type :: TGeometricShape + end type + + type :: TVolumeSourceBody + class(TGeometricShape), allocatable :: GeometricShape + procedure(scalar_flux_interface), pointer :: get_scalar_flux + end type + + abstract interface + function scalar_flux_interface(self) result(res) + import + real, allocatable :: res(:) + class(TVolumeSourceBody), intent(in) :: self + end function + end interface + +end Index: Fortran/gfortran/regression/proc_ptr_comp_38.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_38.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/58803 +! +! Contributed by Vittorio Zecca +! +! Was before ICEing due to a double free +! + type t + procedure(real), pointer, nopass :: f1, f2 + end type + end Index: Fortran/gfortran/regression/proc_ptr_comp_39.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_39.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 63674: [F03] procedure pointer and non/pure procedure +! +! Contributed by Valery Weber + +program prog + interface + integer function nf() + end function + pure integer function pf() + end function + subroutine ns() + end subroutine + pure subroutine ps() + end subroutine + end interface + type :: t + procedure(nf), nopass, pointer :: nf => NULL() ! non-pure function + procedure(pf), nopass, pointer :: pf => NULL() ! pure function + procedure(ns), nopass, pointer :: ns => NULL() ! non-pure subroutine + procedure(ps), nopass, pointer :: ps => NULL() ! pure subroutine + end type +contains + pure integer function eval(a) + type(t), intent(in) :: a + eval = a%pf() + eval = a%nf() ! { dg-error "Reference to impure function" } + call a%ps() + call a%ns() ! { dg-error "is not PURE" } + end function +end Index: Fortran/gfortran/regression/proc_ptr_comp_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_4.f90 @@ -0,0 +1,117 @@ +! { dg-do compile } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! Original code by Juergen Reuter +! +! Adapted by Janus Weil + + +! Test for infinte recursion in trans-types.c when a PPC interface +! refers to the original type. + +module expressions + + type :: eval_node_t + logical, pointer :: lval => null () + type(eval_node_t), pointer :: arg1 => null () + procedure(unary_log), nopass, pointer :: op1_log => null () + end type eval_node_t + + abstract interface + logical function unary_log (arg) + import eval_node_t + type(eval_node_t), intent(in) :: arg + end function unary_log + end interface + +contains + + subroutine eval_node_set_op1_log (en, op) + type(eval_node_t), intent(inout) :: en + procedure(unary_log) :: op + en%op1_log => op + end subroutine eval_node_set_op1_log + + subroutine eval_node_evaluate (en) + type(eval_node_t), intent(inout) :: en + en%lval = en%op1_log (en%arg1) + end subroutine + +end module + + +! Test for C_F_PROCPOINTER and pointers to derived types + +module process_libraries + + implicit none + + type :: process_library_t + procedure(), nopass, pointer :: write_list + end type process_library_t + +contains + + subroutine process_library_load (prc_lib) + use iso_c_binding + type(process_library_t) :: prc_lib + type(c_funptr) :: c_fptr + call c_f_procpointer (c_fptr, prc_lib%write_list) + end subroutine process_library_load + + subroutine process_libraries_test () + type(process_library_t), pointer :: prc_lib + call prc_lib%write_list () + end subroutine process_libraries_test + +end module process_libraries + + +! Test for argument resolution + +module hard_interactions + + implicit none + + type :: hard_interaction_t + procedure(), nopass, pointer :: new_event + end type hard_interaction_t + + interface afv + module procedure afv_1 + end interface + +contains + + function afv_1 () result (a) + real, dimension(0:3) :: a + end function + + subroutine hard_interaction_evaluate (hi) + type(hard_interaction_t) :: hi + call hi%new_event (afv ()) + end subroutine + +end module hard_interactions + + +! Test for derived types with PPC working properly as function result. + + implicit none + + type :: var_entry_t + procedure(), nopass, pointer :: obs1_int + end type var_entry_t + + type(var_entry_t), pointer :: var + + var => var_list_get_var_ptr () + +contains + + function var_list_get_var_ptr () + type(var_entry_t), pointer :: var_list_get_var_ptr + end function var_list_get_var_ptr + +end Index: Fortran/gfortran/regression/proc_ptr_comp_40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_40.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 64173: [F03] ICE involving procedure pointer component +! +! Contributed by Rich Townsend + + implicit none + + type :: r_magnus_ivp_t + integer, allocatable :: jc + procedure(abscissa_), nopass, pointer :: abscissa_p + end type + + abstract interface + function abscissa_ () result (x) + real, allocatable :: x(:) + end function + end interface + +contains + + function doinit () result (iv) + type(r_magnus_ivp_t) :: iv + end function + +end Index: Fortran/gfortran/regression/proc_ptr_comp_41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_41.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 64508: [F03] interface check missing for procedure pointer component as actual argument +! +! Contributed by Janus Weil + + TYPE :: parent + END TYPE + + TYPE, EXTENDS(parent) :: extension + procedure(extension_proc), pointer :: ppc + END TYPE + + CLASS(extension), ALLOCATABLE :: x + CALL some_proc(x%ppc) ! { dg-error "Interface mismatch in dummy procedure" } + +contains + + SUBROUTINE parent_proc(arg) + CLASS(parent), INTENT(IN) :: arg + END SUBROUTINE + + SUBROUTINE extension_proc(arg) + CLASS(extension), INTENT(IN) :: arg + END SUBROUTINE + + + SUBROUTINE some_proc(proc) + PROCEDURE(parent_proc) :: proc + TYPE(Parent) :: a + CALL proc(a) + END SUBROUTINE + +end Index: Fortran/gfortran/regression/proc_ptr_comp_42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_42.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 58023: [F03] ICE on invalid with bad PPC declaration +! +! Contributed by Andrew Benson + + implicit none + + type :: sfd + procedure(mr), pointer :: mr2 ! { dg-error "must be explicit" } + end type + + type(sfd):: d + print *, d%mr2() + +end Index: Fortran/gfortran/regression/proc_ptr_comp_43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_43.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 58023: [F03] ICE on invalid with bad PPC declaration +! +! Contributed by Andrew Benson + +module m + implicit none + + abstract interface + double precision function mr() + end function mr + end interface + + type :: sfd + procedure(mr), pointer :: mr1 ! { dg-error "must have at least one argument" } + procedure(mr), pointer :: mr2 ! { dg-error "must have at least one argument" } + end type sfd + +contains + + subroutine go() + implicit none + type(sfd):: d + + write (0,*) d%mr2() + return + end subroutine go + +end module m Index: Fortran/gfortran/regression/proc_ptr_comp_44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_44.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! Test the fix for PR59198, where the field for the component 'term' in +! the derived type 'decay_gen_t' was not being built. +! +! Contributed by Juergen Reuter +! +module decays + abstract interface + function obs_unary_int () + end function obs_unary_int + end interface + + type, abstract :: any_config_t + contains + procedure (any_config_final), deferred :: final + end type any_config_t + + type :: decay_term_t + type(unstable_t), dimension(:), pointer :: unstable_product => null () + end type decay_term_t + + type, abstract :: decay_gen_t + type(decay_term_t), dimension(:), allocatable :: term + procedure(obs_unary_int), nopass, pointer :: obs1_int => null () + end type decay_gen_t + + type, extends (decay_gen_t) :: decay_root_t + contains + procedure :: final => decay_root_final + end type decay_root_t + + type, abstract :: rng_t + end type rng_t + + type, extends (decay_gen_t) :: decay_t + class(rng_t), allocatable :: rng + contains + procedure :: final => decay_final + end type decay_t + + type, extends (any_config_t) :: unstable_config_t + contains + procedure :: final => unstable_config_final + end type unstable_config_t + + type :: unstable_t + type(unstable_config_t), pointer :: config => null () + type(decay_t), dimension(:), allocatable :: decay + end type unstable_t + + interface + subroutine any_config_final (object) + import + class(any_config_t), intent(inout) :: object + end subroutine any_config_final + end interface + +contains + subroutine decay_root_final (object) + class(decay_root_t), intent(inout) :: object + end subroutine decay_root_final + + recursive subroutine decay_final (object) + class(decay_t), intent(inout) :: object + end subroutine decay_final + + recursive subroutine unstable_config_final (object) + class(unstable_config_t), intent(inout) :: object + end subroutine unstable_config_final + +end module decays Index: Fortran/gfortran/regression/proc_ptr_comp_45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_45.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Test the fix for PR59198, where the field for the component 'term' in +! the derived type 'decay_gen_t' was not being built. +! +! Contributed by Paul Thomas and based on the original testcase by +! Juergen Reuter +! +module decays + + implicit none + + interface + real elemental function iface (arg) + real, intent(in) :: arg + end function + end interface + + type :: decay_term_t + type(decay_t), pointer :: unstable_product + integer :: i + end type + + type :: decay_gen_t + procedure(iface), nopass, pointer :: obs1_int + type(decay_term_t), allocatable :: term + end type + + type :: rng_t + integer :: i + end type + + type, extends (decay_gen_t) :: decay_t + class(rng_t), allocatable :: rng + end type + + class(decay_t), allocatable :: object + +end + + use decays + type(decay_t), pointer :: template + real, parameter :: arg = 1.570796327 + allocate (template) + allocate (template%rng) + template%obs1_int => cos + if (abs (template%obs1_int (arg) - cos (arg)) .gt. 1e-4) STOP 1 + allocate (object, source = template) + if (abs (object%obs1_int (arg) - cos (arg)) .gt. 1e-4) STOP 2 +end Index: Fortran/gfortran/regression/proc_ptr_comp_46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_46.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 77596: [F03] procedure pointer component with implicit interface can point to a function +! +! Contributed by toK + +program xxx + implicit none + + type tf + procedure(), nopass, pointer :: fp + end type tf + + call ass() + +contains + + integer function ff(x) + integer, intent(in) :: x + ff = x + 1 + end function ff + + subroutine ass() + type(tf) :: p + p%fp=>ff ! { dg-error "is not a subroutine" } + call p%fp(3) + end subroutine ass + +end Index: Fortran/gfortran/regression/proc_ptr_comp_47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_47.f90 @@ -0,0 +1,40 @@ +! { dg-do run } + +MODULE distribution_types + ABSTRACT INTERFACE + FUNCTION dist_map_blk_to_proc_func ( row, col, nrow_tot, ncol_tot, proc_grid ) RESULT( reslt ) + INTEGER, INTENT( IN ) :: row, col, nrow_tot, ncol_tot + INTEGER, DIMENSION( : ), INTENT( IN ) :: proc_grid + INTEGER, DIMENSION( : ), ALLOCATABLE :: reslt + END FUNCTION dist_map_blk_to_proc_func + END INTERFACE + TYPE, PUBLIC :: dist_type + INTEGER, DIMENSION( : ), ALLOCATABLE :: task_coords + PROCEDURE( dist_map_blk_to_proc_func ), NOPASS, POINTER :: map_blk_to_proc => NULL( ) + END TYPE dist_type +END MODULE distribution_types + +MODULE sparse_matrix_types + USE distribution_types, ONLY : dist_type + TYPE, PUBLIC :: sm_type + TYPE( dist_type ) :: dist + END TYPE sm_type +END MODULE sparse_matrix_types + +PROGRAM comp_proc_ptr_test + USE sparse_matrix_types, ONLY : sm_type + + call sm_multiply_a () +CONTAINS + SUBROUTINE sm_multiply_a ( ) + INTEGER :: n_push_tot, istat + TYPE( sm_type ), DIMENSION( : ), ALLOCATABLE :: matrices_a, matrices_b + n_push_tot =2 + ALLOCATE( matrices_a( n_push_tot + 1 ), matrices_b( n_push_tot + 1), STAT=istat ) + if (istat /= 0) STOP 1 + if (.not. allocated(matrices_a)) STOP 2 + if (.not. allocated(matrices_b)) STOP 3 + if (associated(matrices_a(1)%dist%map_blk_to_proc)) STOP 4 + END SUBROUTINE sm_multiply_a +END PROGRAM comp_proc_ptr_test + Index: Fortran/gfortran/regression/proc_ptr_comp_48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_48.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR 80046: [F03] Explicit interface required: pointer argument +! +! Contributed by Joachim Herb + +program p + implicit none + + type :: Node_t + procedure(NodeCloner), nopass, pointer :: cloneProc => NULL() + procedure(), nopass, pointer :: noIfc => NULL() + end type + + interface + subroutine NodeCloner( tgt, src ) + import Node_t + type(Node_t), pointer, intent(out) :: tgt + type(Node_t), intent(in) :: src + end subroutine + end interface + + type(Node_t) :: node + procedure(NodeCloner), pointer :: cloneNode + procedure(), pointer :: noIfc + + cloneNode => node%noIfc ! { dg-error "Explicit interface required" } + node%noIfc => cloneNode ! { dg-error "Explicit interface required" } + + noIfc => node%cloneProc ! { dg-error "Explicit interface required" } + node%cloneProc => noIfc ! { dg-error "Explicit interface required" } + + node%cloneProc => node%noIfc ! { dg-error "Explicit interface required" } + node%noIfc => node%cloneProc ! { dg-error "Explicit interface required" } + + ! the following cases are legal + + node%noIfc => node%noIfc + node%cloneProc => node%cloneProc + + cloneNode => node%cloneProc + node%cloneProc => cloneNode + + noIfc => node%noIfc + node%noIfc => noIfc + +end Index: Fortran/gfortran/regression/proc_ptr_comp_49.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_49.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 80392: [5/6/7 Regression] [OOP] ICE with allocatable polymorphic function result in a procedure pointer component +! +! Contributed by + +module mwe + + implicit none + + type :: MyType + procedure(my_op), nopass, pointer :: op + end type + +contains + + function my_op() result(foo) + class(MyType), allocatable :: foo + end function + +end module Index: Fortran/gfortran/regression/proc_ptr_comp_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_5.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! Nested types / double component references. +! +! Contributed by Janus Weil + +abstract interface + subroutine as + end subroutine + integer function af() + end function +end interface + +type :: t1 + procedure(as), pointer, nopass :: s + procedure(af), pointer, nopass :: f +end type + +type :: t2 + type(t1) :: c +end type + +type(t2) :: x +integer :: j = 0 + +x%c%s => is +call x%c%s +if (j/=5) STOP 1 + +x%c%f => if +j=x%c%f() +if (j/=42) STOP 2 + +contains + +subroutine is + j = 5 +end subroutine + +integer function if() + if = 42 +end function + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_50.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_50.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 70601: [5/6/7 Regression] [OOP] ICE on procedure pointer component call +! +! Contributed by zmi + +program test + implicit none + + type :: concrete_type + procedure (run_concrete_type), pointer :: run + end type + + type(concrete_type), allocatable :: concrete + + allocate(concrete) + concrete % run => run_concrete_type + call concrete % run() + +contains + + subroutine run_concrete_type(this) + class(concrete_type) :: this + end subroutine + +end Index: Fortran/gfortran/regression/proc_ptr_comp_51.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_51.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 80983: [F03] memory leak when calling procedure-pointer component with allocatable result +! +! Contributed by Janus Weil + +program test + implicit none + + type :: concrete_type + procedure (alloc_integer), pointer, nopass :: alloc + end type + + procedure (alloc_integer), pointer :: pp + + type(concrete_type) :: concrete + + print *, alloc_integer() ! case #1: plain function + + pp => alloc_integer + print *, pp() ! case #2: procedure pointer + + concrete % alloc => alloc_integer + print *, concrete % alloc() ! case #3: procedure-pointer component + +contains + + function alloc_integer() result(res) + integer, allocatable :: res + allocate(res, source=13) + end function + +end + +! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } Index: Fortran/gfortran/regression/proc_ptr_comp_52.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_52.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 85395: [F03] private clause contained in derived type acquires spurious scope +! +! Contributed by + +module defs + implicit none + + type :: base + contains + private + end type + + type :: options + procedure(), pointer, nopass :: ptr + end type + + type :: t + private + procedure(), pointer, nopass, public :: ptr + end type +end module + + +program p + use defs + implicit none + type(options) :: self + type(t) :: dt + self%ptr => null() + dt%ptr => null() +end Index: Fortran/gfortran/regression/proc_ptr_comp_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_6.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! +! PR39630: Fortran 2003: Procedure pointer components. +! +! test case taken from: +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742?#884b9eca6d7e6742 +! http://fortranwiki.org/fortran/show/proc_component_example + +module proc_component_example + + type t + real :: a + procedure(print_int), pointer, & + nopass :: proc + end type t + + abstract interface + subroutine print_int (arg, lun) + import + type(t), intent(in) :: arg + integer, intent(in) :: lun + end subroutine print_int + end interface + + integer :: calls = 0 + +contains + + subroutine print_me (arg, lun) + type(t), intent(in) :: arg + integer, intent(in) :: lun + write (lun,*) arg%a + calls = calls + 1 + end subroutine print_me + + subroutine print_my_square (arg, lun) + type(t), intent(in) :: arg + integer, intent(in) :: lun + write (lun,*) arg%a**2 + calls = calls + 1 + end subroutine print_my_square + +end module proc_component_example + +program main + + use proc_component_example + use iso_fortran_env, only : output_unit + + type(t) :: x + + x%a = 2.71828 + + x%proc => print_me + call x%proc(x, output_unit) + x%proc => print_my_square + call x%proc(x, output_unit) + + if (calls/=2) STOP 1 + +end program main Index: Fortran/gfortran/regression/proc_ptr_comp_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_7.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 40089: Public type with public component which has a private type +! +! Original test case by Juergen Reuter +! Adapted by Janus Weil + +module m + + implicit none + private + + public :: public_t + + type :: private_t + integer :: i + end type + + type :: public_t + type(private_t), pointer :: public_comp_with_private_type + procedure(ifc) , nopass, pointer :: ppc + end type + + abstract interface + integer function ifc () + end function + end interface + +end module m + +program test +use m +implicit none +type(public_t) :: x +integer :: j +j = x%ppc() +end Index: Fortran/gfortran/regression/proc_ptr_comp_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_8.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! PR 40164: Fortran 2003: "Arrays of procedure pointers" (using PPCs) +! +! Original test case by Barron Bichon +! Adapted by Janus Weil + +PROGRAM test_prog + + ABSTRACT INTERFACE + FUNCTION fn_template(n,x) RESULT(y) + INTEGER, INTENT(in) :: n + REAL, INTENT(in) :: x(n) + REAL :: y(n) + END FUNCTION fn_template + END INTERFACE + + TYPE PPA + PROCEDURE(fn_template), POINTER, NOPASS :: f + END TYPE PPA + + TYPE ProcPointerArray + PROCEDURE(add), POINTER, NOPASS :: f + END TYPE ProcPointerArray + + TYPE (ProcPointerArray) :: f_array(3) + PROCEDURE(add), POINTER :: f + real :: r + + f_array(1)%f => add + f => f_array(1)%f + f_array(2)%f => sub + f_array(3)%f => f_array(1)%f + + r = f(1.,2.) + if (abs(r-3.)>1E-3) STOP 1 + r = f_array(1)%f(4.,2.) + if (abs(r-6.)>1E-3) STOP 2 + r = f_array(2)%f(5.,3.) + if (abs(r-2.)>1E-3) STOP 3 + if (abs(f_array(1)%f(1.,3.)-f_array(3)%f(2.,2.))>1E-3) STOP 4 + +CONTAINS + + FUNCTION add(a,b) RESULT(sum) + REAL, INTENT(in) :: a, b + REAL :: sum + sum = a + b + END FUNCTION add + + FUNCTION sub(a,b) RESULT(diff) + REAL, INTENT(in) :: a, b + REAL :: diff + diff = a - b + END FUNCTION sub + +END PROGRAM test_prog + Index: Fortran/gfortran/regression/proc_ptr_comp_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_9.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + TYPE ProcPointerType + PROCEDURE(triple), POINTER, NOPASS :: f + END TYPE ProcPointerType + + TYPE (ProcPointerType) :: ppt + PROCEDURE(triple), POINTER :: f + REAL :: tres(2) + + ppt%f => triple + f => ppt%f + tres = f(2,[2.,4.]) + if (abs(tres(1)-6.)>1E-3) STOP 1 + if (abs(tres(2)-12.)>1E-3) STOP 2 + tres = ppt%f(2,[3.,5.]) + if (abs(tres(1)-9.)>1E-3) STOP 3 + if (abs(tres(2)-15.)>1E-3) STOP 4 + +CONTAINS + + FUNCTION triple(n,x) RESULT(tre) + INTEGER, INTENT(in) :: n + REAL, INTENT(in) :: x(2) + REAL :: tre(2) + tre = 3.*x + END FUNCTION triple + +END PROGRAM test_prog + Index: Fortran/gfortran/regression/proc_ptr_comp_pass_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_1.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742 + +module mymod + + type :: mytype + integer :: i + procedure(set_int_value), pointer :: seti + end type + + abstract interface + subroutine set_int_value(this,i) + import + class(mytype), intent(inout) :: this + integer, intent(in) :: i + end subroutine set_int_value + end interface + + contains + + subroutine seti_proc(this,i) + class(mytype), intent(inout) :: this + integer, intent(in) :: i + this%i=i + end subroutine seti_proc + +end module mymod + +program Test_03 + use mymod + implicit none + + type(mytype) :: m + + m%i = 44 + m%seti => seti_proc + + call m%seti(6) + + if (m%i/=6) STOP 1 + +end program Test_03 Index: Fortran/gfortran/regression/proc_ptr_comp_pass_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! taken from "The Fortran 2003 Handbook" (Adams et al., 2009) + +module passed_object_example + + type t + real :: a + procedure(print_me), pointer, pass(arg) :: proc + end type t + +contains + + subroutine print_me (arg, lun) + class(t), intent(in) :: arg + integer, intent(in) :: lun + if (abs(arg%a-2.718)>1E-6) STOP 1 + write (lun,*) arg%a + end subroutine print_me + + subroutine print_my_square (arg, lun) + class(t), intent(in) :: arg + integer, intent(in) :: lun + if (abs(arg%a-2.718)>1E-6) STOP 2 + write (lun,*) arg%a**2 + end subroutine print_my_square + +end module passed_object_example + + +program main + use passed_object_example + use iso_fortran_env, only: output_unit + + type(t) :: x + + x%a = 2.718 + x%proc => print_me + call x%proc (output_unit) + x%proc => print_my_square + call x%proc (output_unit) + +end program main Index: Fortran/gfortran/regression/proc_ptr_comp_pass_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004) + +type t + procedure(obp), pointer, pass(x) :: p + character(100) :: name +end type + +abstract interface + subroutine obp(w,x) + import :: t + integer :: w + class(t) :: x + end subroutine +end interface + +type(t) :: a +a%p => my_obp_sub +a%name = "doodoo" + +call a%p(32) + +contains + + subroutine my_obp_sub(w,x) + integer :: w + class(t) :: x + if (x%name/="doodoo") STOP 1 + if (w/=32) STOP 2 + end subroutine + +end + Index: Fortran/gfortran/regression/proc_ptr_comp_pass_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_4.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Janus Weil + +module m + + type :: t0 + procedure() :: p0 ! { dg-error "POINTER attribute is required for procedure pointer component" } + end type + + type :: t1 + integer :: i + procedure(foo1), pointer :: f1 ! { dg-error "must be scalar" } + end type + + type :: t2 + integer :: i + procedure(foo2), pointer :: f2 ! { dg-error "may not have the POINTER attribute" } + end type + + type :: t3 + integer :: i + procedure(foo3), pointer :: f3 ! { dg-error "may not be ALLOCATABLE" } + end type + + type :: t4 + procedure(), pass(x), pointer :: f4 ! { dg-error "NOPASS or explicit interface required" } + procedure(real), pass(y), pointer :: f5 ! { dg-error "NOPASS or explicit interface required" } + procedure(foo6), pass(c), pointer :: f6 ! { dg-error "has no argument" } + end type + + type :: t7 + procedure(foo7), pass, pointer :: f7 ! { dg-error "must have at least one argument" } + end type + + type :: t8 + procedure(foo8), pass, pointer :: f8 ! { dg-error "must be of the derived type" } + procedure(foo9), pass, pointer :: f9 ! { dg-error "Non-polymorphic passed-object dummy argument" } + end type + +contains + + subroutine foo1 (x1,y1) + class(t1) :: x1(:) + type(t1) :: y1 + end subroutine + + subroutine foo2 (x2,y2) + class(t2),pointer :: x2 + type(t2) :: y2 + end subroutine + + subroutine foo3 (x3,y3) + class(t3),allocatable :: x3 + type(t3) :: y3 + end subroutine + + real function foo6 (a,b) + real :: a,b + foo6 = 1. + end function + + integer function foo7 () + foo7 = 2 + end function + + character function foo8 (i) + integer :: i + end function + + subroutine foo9(x) + type(t8) :: x + end subroutine + +end module m Index: Fortran/gfortran/regression/proc_ptr_comp_pass_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_5.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Tobias Burnus + +module m + type :: t + sequence + integer :: i + procedure(foo), pointer,pass(y) :: foo + end type t +contains + subroutine foo(x,y) + type(t),optional :: x + type(t) :: y + if(present(x)) then + print *, 'foo', x%i, y%i + if (mod(x%i+y%i,3)/=2) STOP 1 + else + print *, 'foo', y%i + if (mod(y%i,3)/=1) STOP 2 + end if + end subroutine foo +end module m + +use m +type(t) :: t1, t2 +t1%i = 4 +t2%i = 7 +t1%foo => foo +t2%foo => t1%foo +call t1%foo() +call t2%foo() +call t2%foo(t1) +end Index: Fortran/gfortran/regression/proc_ptr_comp_pass_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_6.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fcheck=bounds" } +! +! PR 42804: ICE with -fcheck=bounds and type bound procedure call on array element +! +! Contributed by Ian Harvey + +MODULE ModA + IMPLICIT NONE + TYPE, PUBLIC :: A + PROCEDURE(a_proc),pointer :: Proc + END TYPE A +CONTAINS + SUBROUTINE a_proc(this, stat) + CLASS(A), INTENT(INOUT) :: this + INTEGER, INTENT(OUT) :: stat + WRITE (*, *) 'a_proc' + stat = 0 + END SUBROUTINE a_proc +END MODULE ModA + +PROGRAM ProgA + USE ModA + IMPLICIT NONE + INTEGER :: ierr + INTEGER :: i + TYPE(A), ALLOCATABLE :: arr(:) + ALLOCATE(arr(2)) + DO i = 1, 2 + arr(i)%proc => a_proc + CALL arr(i)%Proc(ierr) + END DO +END PROGRAM ProgA Index: Fortran/gfortran/regression/proc_ptr_comp_pass_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_comp_pass_7.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! +! PR 46662: [OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()" +! +! Contributed by Wolfgang Kilian +! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/a0857fa4a692d518 + +module types + implicit none + + type, abstract :: base_t + integer :: i = 0 + procedure(base_write_i), pointer :: write_procptr + contains + procedure :: write_i => base_write_i + end type base_t + + type, extends (base_t) :: t + end type t + +contains + + subroutine base_write_i (obj) + class (base_t), intent(in) :: obj + print *, obj%i + end subroutine base_write_i + +end module types + + +program main + use types + implicit none + + type(t) :: obj + + print *, "Direct printing" + obj%i = 1 + print *, obj%i + + print *, "Direct printing via parent" + obj%base_t%i = 2 + print *, obj%base_t%i + + print *, "Printing via TBP" + obj%i = 3 + call obj%write_i + + print *, "Printing via parent TBP" + obj%base_t%i = 4 + call obj%base_t%write_i ! { dg-error "is of ABSTRACT type" } + + print *, "Printing via OBP" + obj%i = 5 + obj%write_procptr => base_write_i + call obj%write_procptr + + print *, "Printing via parent OBP" + obj%base_t%i = 6 + obj%base_t%write_procptr => base_write_i + call obj%base_t%write_procptr ! { dg-error "is of ABSTRACT type" } + +end program main Index: Fortran/gfortran/regression/proc_ptr_result_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_1.f90 @@ -0,0 +1,186 @@ +! { dg-do run } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +module mo +contains + + function j() + implicit none + procedure(integer),pointer :: j + intrinsic iabs + j => iabs + end function + + subroutine sub(y) + integer,intent(inout) :: y + y = y**2 + end subroutine + +end module + + +program proc_ptr_14 +use mo +implicit none +intrinsic :: iabs +integer :: x +procedure(integer),pointer :: p,p2 +procedure(sub),pointer :: ps + +p => a() +if (p(-1)/=1) STOP 1 +p => b() +if (p(-2)/=2) STOP 2 +p => c() +if (p(-3)/=3) STOP 3 + +ps => d() +x = 4 +call ps(x) +if (x/=16) STOP 4 + +p => dd() +if (p(-4)/=4) STOP 5 + +ps => e(sub) +x = 5 +call ps(x) +if (x/=25) STOP 6 + +p => ee() +if (p(-5)/=5) STOP 7 +p => f() +if (p(-6)/=6) STOP 8 +p => g() +if (p(-7)/=7) STOP 9 + +ps => h(sub) +x = 2 +call ps(x) +if (x/=4) STOP 10 + +p => i() +if (p(-8)/=8) STOP 11 +p => j() +if (p(-9)/=9) STOP 12 + +p => k(p2) +if (p(-10)/=p2(-10)) STOP 13 + +p => l() +if (p(-11)/=11) STOP 14 + +contains + + function a() + procedure(integer),pointer :: a + a => iabs + end function + + function b() + procedure(integer) :: b + pointer :: b + b => iabs + end function + + function c() + pointer :: c + procedure(integer) :: c + c => iabs + end function + + function d() + pointer :: d + external d + d => sub + end function + + function dd() + pointer :: dd + external :: dd + integer :: dd + dd => iabs + end function + + function e(arg) + external :: e,arg + pointer :: e + e => arg + end function + + function ee() + integer :: ee + external :: ee + pointer :: ee + ee => iabs + end function + + function f() + pointer :: f + interface + integer function f(x) + integer,intent(in) :: x + end function + end interface + f => iabs + end function + + function g() + interface + integer function g(x) + integer,intent(in) :: x + end function g + end interface + pointer :: g + g => iabs + end function + + function h(arg) + interface + subroutine arg(b) + integer,intent(inout) :: b + end subroutine arg + end interface + pointer :: h + interface + subroutine h(a) + integer,intent(inout) :: a + end subroutine h + end interface + h => arg + end function + + function i() + pointer :: i + interface + function i(x) + integer :: i,x + intent(in) :: x + end function i + end interface + i => iabs + end function + + function k(arg) + procedure(integer),pointer :: k,arg + k => iabs + arg => k + end function + + function l() + ! we cannot use iabs directly as it is elemental + abstract interface + pure function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs + end interface + procedure(interf_iabs),pointer :: l + integer :: i + l => iabs + if (l(-11)/=11) STOP 15 + end function + +end Index: Fortran/gfortran/regression/proc_ptr_result_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_2.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +module proc_ptr_15 + + interface + function e(x) + real :: x + procedure(), pointer :: e + end function e + end interface + + interface + function f(x) + real :: x + external :: f + pointer :: f + end function + end interface + + interface + function g(x) + real :: x + pointer :: g + external :: g + end function + end interface + +contains + + subroutine point_fun() + call set_fun(aux) + end subroutine + + subroutine set_fun(y) + external :: y + end subroutine + + function aux() + external aux + pointer aux + intrinsic sin + aux => sin + end function + + function foo(x) + real :: x + interface + subroutine foo(i) ! { dg-error "attribute conflicts with" } + integer :: i + end subroutine + end interface + !pointer :: foo + end function + +end Index: Fortran/gfortran/regression/proc_ptr_result_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_3.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! PR 36704: Procedure pointer as function result +! +! Original test case from James Van Buskirk. +! +! Adapted by Janus Weil + +module store_subroutine + implicit none + + abstract interface + subroutine sub(i) + integer, intent(inout) :: i + end subroutine sub + end interface + + procedure(sub), pointer, private :: psub => NULL() + +contains + + subroutine set_sub(x) + procedure(sub) x + psub => x + end subroutine set_sub + + function get_sub() + procedure(sub), pointer :: get_sub + get_sub => psub + end function get_sub + +end module store_subroutine + +program test + use store_subroutine + implicit none + procedure(sub), pointer :: qsub + integer :: k = 1 + + call my_sub(k) + if (k/=3) STOP 1 + qsub => get_sub() + call qsub(k) + if (k/=9) STOP 2 +end program test + +recursive subroutine my_sub(j) + use store_subroutine + implicit none + integer, intent(inout) :: j + j = j*3 + call set_sub(my_sub) +end subroutine my_sub Index: Fortran/gfortran/regression/proc_ptr_result_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 40451: [F03] procedure pointer assignment rejected +! +! Contributed by Tobias Burnus + +contains + + function f() + intrinsic :: sin + abstract interface + pure real function sin_interf(x) + real, intent(in) :: x + end function sin_interf + end interface + ! We cannot use "sin" directly as it is ELEMENTAL + procedure(sin_interf), pointer :: f + f => sin + end function f + +end + Index: Fortran/gfortran/regression/proc_ptr_result_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_5.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 40541: Assignment checking for proc-pointer => proc-ptr-returning-function() +! +! Contributed by Tobias Burnus + +program test + procedure(real), pointer :: p + p => f() ! { dg-error "Type mismatch in function result" } +contains + function f() + pointer :: f + interface + logical(1) function f() + end function + end interface + f = .true._1 ! { dg-error "Illegal assignment" } + end function f +end program test Index: Fortran/gfortran/regression/proc_ptr_result_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_6.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! PR 40593: Proc-pointer returning function as actual argument +! +! Original test case by Tobias Burnus +! Modified by Janus Weil + +module m +contains + subroutine sub(a) + integer :: a + a = 42 + end subroutine + integer function func() + func = 42 + end function +end module m + +program test + use m + implicit none + call caller1(getPtr1()) + call caller2(getPtr2()) + call caller3(getPtr2()) +contains + subroutine caller1(s) + procedure(sub) :: s + integer :: b + call s(b) + if (b /= 42) STOP 1 + end subroutine + subroutine caller2(f) + procedure(integer) :: f + if (f() /= 42) STOP 2 + end subroutine + subroutine caller3(f) + procedure(func),pointer :: f + if (f() /= 42) STOP 3 + end subroutine + function getPtr1() + procedure(sub), pointer :: getPtr1 + getPtr1 => sub + end function + function getPtr2() + procedure(func), pointer :: getPtr2 + getPtr2 => func + end function +end program test Index: Fortran/gfortran/regression/proc_ptr_result_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_7.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 54285: [F03] Calling a PPC with proc-ptr result +! +! Contributed by Janus Weil + +type :: t + procedure(a), pointer, nopass :: p +end type + +type(t) :: x + +! We cannot use "iabs" directly as it is elemental. +abstract interface + pure integer function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs +end interface +procedure(interf_iabs), pointer :: pp + +x%p => a + +pp => x%p() + +if (pp(-3) /= 3) STOP 1 + +contains + + function a() result (b) + procedure(interf_iabs), pointer :: b + b => iabs + end function + +end Index: Fortran/gfortran/regression/proc_ptr_result_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/proc_ptr_result_8.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! Test fix for PR54286. +! +! Contributed by Janus Weil +! Module 'm' added later because original fix missed possibility of +! null interfaces - thanks to Dominique Dhumieres +! +module m + type :: foobar + real, pointer :: array(:) + procedure (), pointer, nopass :: f + end type +contains + elemental subroutine fooAssgn (a1, a2) + type(foobar), intent(out) :: a1 + type(foobar), intent(in) :: a2 + allocate (a1%array(size(a2%array))) + a1%array = a2%array + a1%f => a2%f + end subroutine +end module m + +implicit integer (a) +type :: t + procedure(a), pointer, nopass :: p +end type +type(t) :: x + +! We cannot use iabs directly as it is elemental +abstract interface + integer pure function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs +end interface + +procedure(interf_iabs), pointer :: pp +procedure(foo), pointer :: pp1 + +x%p => a ! ok +if (x%p(0) .ne. loc(foo)) STOP 1 +if (x%p(1) .ne. loc(iabs)) STOP 2 + +x%p => a(1) ! { dg-error "PROCEDURE POINTER mismatch in function result" } + +pp => a(1) ! ok +if (pp(-99) .ne. iabs(-99)) STOP 3 + +pp1 => a(2) ! ok +if (pp1(-99) .ne. -iabs(-99)) STOP 4 + +pp => a ! { dg-error "PROCEDURE POINTER mismatch in function result" } + +contains + + function a (c) result (b) + integer, intent(in) :: c + procedure(interf_iabs), pointer :: b + if (c .eq. 1) then + b => iabs + else + b => foo + end if + end function + + pure integer function foo (arg) + integer, intent (in) :: arg + foo = -iabs(arg) + end function +end Index: Fortran/gfortran/regression/procedure_lvalue.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/procedure_lvalue.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Tests the fix for PR17911, where a USE associated l-value +! would cause an ICE in gfc_conv_variable. +! Test contributed by Tobias Schlueter +module t + interface a + module procedure b + end interface +contains + integer function b(x) + b = x + end function b +end module t + +subroutine r + use t + b = 1. ! { dg-error "is not a variable" } + y = a(1.) +end subroutine r Index: Fortran/gfortran/regression/product_init_expr.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/product_init_expr.f03 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options "-fno-inline" } +! +! PRODUCT as initialization expression. +! +! This test compares results of simplifier of PRODUCT +! with the corresponding inlined or library routine(s). +! + + IMPLICIT NONE + + INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] ) + INTEGER, PARAMETER :: imatrix_prod = PRODUCT (imatrix) + INTEGER, PARAMETER :: imatrix_prod_d1(4) = PRODUCT (imatrix, dim=1) + INTEGER, PARAMETER :: imatrix_prod_d2(2) = PRODUCT (imatrix, dim=2) + LOGICAL, PARAMETER :: i_equal_prod = ALL ([PRODUCT( imatrix_prod_d1 ) == PRODUCT ( imatrix_prod_d2 ), & + PRODUCT( imatrix_prod_d1 ) == imatrix_prod]) + LOGICAL, PARAMETER :: i_empty_prod = PRODUCT(imatrix, mask=.FALSE.) == 1 + + REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0 ], [2, 4] ) + REAL, PARAMETER :: rmatrix_prod = PRODUCT (rmatrix) + REAL, PARAMETER :: rmatrix_prod_d1(4) = PRODUCT (rmatrix, dim=1) + REAL, PARAMETER :: rmatrix_prod_d2(2) = PRODUCT (rmatrix, dim=2) + LOGICAL, PARAMETER :: r_equal_prod = ALL ([PRODUCT( rmatrix_prod_d1 ) == PRODUCT ( rmatrix_prod_d2 ), & + PRODUCT( rmatrix_prod_d1 ) == rmatrix_prod]) + LOGICAL, PARAMETER :: r_empty_prod = PRODUCT(rmatrix, mask=.FALSE.) == 1.0 + + IF (.NOT. ALL ([i_equal_prod, i_empty_prod])) STOP 1 + IF (.NOT. ALL ([r_equal_prod, r_empty_prod])) STOP 2 + + CALL ilib (imatrix, imatrix_prod) + CALL ilib_with_dim (imatrix, 1, imatrix_prod_d1) + CALL ilib_with_dim (imatrix, 2, imatrix_prod_d2) + CALL rlib (rmatrix, rmatrix_prod) + CALL rlib_with_dim (rmatrix, 1, rmatrix_prod_d1) + CALL rlib_with_dim (rmatrix, 2, rmatrix_prod_d2) + +CONTAINS + SUBROUTINE ilib (array, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(in) :: result + IF (PRODUCT(array) /= result) STOP 3 + END SUBROUTINE + + SUBROUTINE ilib_with_dim (array, dim, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + INTEGER, DIMENSION(:), INTENT(in) :: result + IF (ANY (PRODUCT (array, dim=dim) /= result)) STOP 4 + END SUBROUTINE + + SUBROUTINE rlib (array, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + REAL, INTENT(in) :: result + IF (ABS(PRODUCT(array) - result) > 2e-6) STOP 5 + END SUBROUTINE + + SUBROUTINE rlib_with_dim (array, dim, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(iN) :: dim + REAL, DIMENSION(:), INTENT(in) :: result + IF (ANY (ABS(PRODUCT (array, dim=dim) - result) > 2e-6)) STOP 6 + END SUBROUTINE +END + + Index: Fortran/gfortran/regression/product_sum_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/product_sum_bounds_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +program main + real, dimension(4,3) :: a + real, dimension(2) :: b + a = 21. + b = product(a,dim=1) ! { dg-error "Different shape" } + b = sum(a,dim=2) ! { dg-error "Different shape" } +end program main Index: Fortran/gfortran/regression/program_name_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/program_name_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PR28762 in which the program name would cause +! the compiler to test the write statement as a variable thereby generating +! an "Expecting VARIABLE" error. +! +! Contributed by David Ham +! +program write + integer :: debuglevel = 1 + if (0 < debuglevel) write (*,*) "Hello World" +end program write Index: Fortran/gfortran/regression/promotion.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/promotion.f90 @@ -0,0 +1,13 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-require-effective-target ilp32 } +! { dg-options "-fdefault-integer-8 -fdefault-real-8 -fdefault-double-8" } +program a + logical l + integer i + real x + double precision d + if (kind(l) /= 8) STOP 1 + if (kind(i) /= 8) STOP 2 + if (kind(x) /= 8) STOP 3 + if (kind(d) /= 8) STOP 4 +end program a Index: Fortran/gfortran/regression/promotion_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/promotion_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fdefault-real-8 -fexternal-blas -fblas-matmul-limit=1 -fdump-tree-original -finline-matmul-limit=0" } +! +! PR fortran/54463 +! +! Contributed by Simon Reinhardt +! +program test + implicit none + real, dimension(3,3) :: A + call random_number(a) + A = matmul(A,A) +end program test + +! { dg-final { scan-tree-dump-times "sgemm" 0 "original" } } +! { dg-final { scan-tree-dump-times "dgemm" 1 "original" } } Index: Fortran/gfortran/regression/promotion_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/promotion_3.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fdefault-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR 82143: add a -fdefault-real-16 flag +! +! Contributed by Janus Weil + +real :: r +real(kind=4) :: r4 +real(kind=8) :: r8 +double precision :: d +if (kind(r4) /= 4) STOP 1 +if (kind(r8) /= 8) STOP 2 +if (kind(r) /= 16) STOP 3 +if (kind(d) /= 16) STOP 4 +end Index: Fortran/gfortran/regression/promotion_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/promotion_4.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fdefault-real-10" } +! { dg-require-effective-target fortran_real_10 } +! +! PR 82143: add a -fdefault-real-16 flag +! +! Contributed by Janus Weil + +real :: r +real(kind=4) :: r4 +real(kind=8) :: r8 +double precision :: d +if (kind(r4) /= 4) STOP 1 +if (kind(r8) /= 8) STOP 2 +if (kind(r) /= 10) STOP 3 +if (kind(d) < 10) STOP 4 +end Index: Fortran/gfortran/regression/protected_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_1.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a valid code + +module protmod + implicit none + integer :: a,b + integer, target :: at,bt + integer, pointer :: ap,bp + protected :: a, at + protected :: ap +contains + subroutine setValue() + a = 43 + ap => null() + nullify(ap) + ap => at + ap = 3 + allocate(ap) + ap = 73 + call increment(a,ap,at) + if(a /= 44 .or. ap /= 74 .or. at /= 4) STOP 1 + end subroutine setValue + subroutine increment(a1,a2,a3) + integer, intent(inout) :: a1, a2, a3 + a1 = a1 + 1 + a2 = a2 + 1 + a3 = a3 + 1 + end subroutine increment +end module protmod + +program main + use protmod + implicit none + b = 5 + bp => bt + bp = 4 + bt = 7 + call setValue() + if(a /= 44 .or. ap /= 74 .or. at /= 4) STOP 2 + call plus5(ap) + if(a /= 44 .or. ap /= 79 .or. at /= 4) STOP 3 + call checkVal(a,ap,at) +contains + subroutine plus5(j) + integer, intent(inout) :: j + j = j + 5 + end subroutine plus5 + subroutine checkVal(x,y,z) + integer, intent(in) :: x, y, z + if(a /= 44 .or. ap /= 79 .or. at /= 4) STOP 4 + end subroutine +end program main Index: Fortran/gfortran/regression/protected_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_2.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a valid code + +module protmod + implicit none + integer, protected :: a + integer, protected, target :: at + integer, protected, pointer :: ap +contains + subroutine setValue() + a = 43 + ap => null() + nullify(ap) + ap => at + ap = 3 + allocate(ap) + ap = 73 + call increment(a,ap,at) + if(a /= 44 .or. ap /= 74 .or. at /= 4) STOP 1 + end subroutine setValue + subroutine increment(a1,a2,a3) + integer, intent(inout) :: a1, a2, a3 + a1 = a1 + 1 + a2 = a2 + 1 + a3 = a3 + 1 + end subroutine increment +end module protmod + +program main + use protmod + implicit none + call setValue() + if(a /= 44 .or. ap /= 74 .or. at /= 4) STOP 2 + call plus5(ap) + if(a /= 44 .or. ap /= 79 .or. at /= 4) STOP 3 + call checkVal(a,ap,at) +contains + subroutine plus5(j) + integer, intent(inout) :: j + j = j + 5 + end subroutine plus5 + subroutine checkVal(x,y,z) + integer, intent(in) :: x, y, z + if(a /= 44 .or. ap /= 79 .or. at /= 4) STOP 4 + end subroutine +end program main Index: Fortran/gfortran/regression/protected_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_3.f90 @@ -0,0 +1,23 @@ +! { dg-options "-std=f95" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Reject in Fortran 95 + +module protmod + implicit none + integer :: a + integer, target :: at + integer, pointer :: ap + protected :: a, at, ap ! { dg-error "Fortran 2003: PROTECTED statement" } +end module protmod + +module protmod2 + implicit none + integer, protected :: a ! { dg-error "Fortran 2003: PROTECTED attribute" } + integer, protected, target :: at ! { dg-error "Fortran 2003: PROTECTED attribute" } + integer, protected, pointer :: ap ! { dg-error "Fortran 2003: PROTECTED attribute" } +end module protmod2 Index: Fortran/gfortran/regression/protected_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_4.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module protmod + implicit none + integer :: a + integer, target :: at + integer, pointer :: ap + protected :: a, at, ap +end module protmod + +program main + use protmod + implicit none + integer :: j + logical :: asgnd + protected :: j ! { dg-error "only allowed in specification part of a module" } + a = 43 ! { dg-error "variable definition context" } + ap => null() ! { dg-error "pointer association context" } + nullify(ap) ! { dg-error "pointer association context" } + ap => & ! { dg-error "pointer association context" } + & at ! { dg-error "Pointer assignment target has PROTECTED attribute" } + ap = 3 ! OK + allocate(ap) ! { dg-error "pointer association context" } + ap = 73 ! OK + call increment(a,at) ! { dg-error "variable definition context" } + call pointer_assignments(ap) ! { dg-error "pointer association context" } + asgnd = pointer_check(ap) +contains + subroutine increment(a1,a3) + integer, intent(inout) :: a1, a3 + a1 = a1 + 1 + a3 = a3 + 1 + end subroutine increment + subroutine pointer_assignments(p) + integer, pointer,intent(out) :: p + p => null() + end subroutine pointer_assignments + function pointer_check(p) + integer, pointer,intent(in) :: p + logical :: pointer_check + pointer_check = associated(p) + end function pointer_check +end program main + +module test + real :: a + protected :: test ! { dg-error "MODULE attribute conflicts with PROTECTED" } +end module test Index: Fortran/gfortran/regression/protected_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_5.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module good1 + implicit none + integer :: a + integer :: b,c + protected :: c + equivalence (a,c) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" } +end module good1 + + +module bad1 + implicit none + integer, protected :: a + integer :: b,c + protected :: c + equivalence (a,b) ! { dg-error "Either all or none of the objects in the EQUIVALENCE" } +end module bad1 + +module bad2 + implicit none + integer, protected :: a + integer :: b,c,d + protected :: c + common /one/ a,b ! { dg-error "PROTECTED attribute conflicts with COMMON" } + common /two/ c,d ! { dg-error "PROTECTED attribute conflicts with COMMON" } +end module bad2 + +module good2 + implicit none + type myT + integer :: j + integer, pointer :: p + real, allocatable, dimension(:) :: array + end type myT + type(myT), save :: t + protected :: t +end module good2 + +program main + use good2 + implicit none + t%j = 15 ! { dg-error "variable definition context" } + nullify(t%p) ! { dg-error "pointer association context" } + allocate(t%array(15))! { dg-error "variable definition context" } +end program main Index: Fortran/gfortran/regression/protected_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_6.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-shouldfail "Invalid Fortran 2003 code" } +! { dg-options "-std=f2003" } +! PR fortran/23994 +! +! Test PROTECTED attribute. Within the module everything is allowed. +! Outside (use-associated): For pointers, their association status +! may not be changed. For nonpointers, their value may not be changed. +! +! Test of a invalid code + +module protmod + implicit none + integer, Protected :: a + integer, protected, target :: at + integer, protected, pointer :: ap +end module protmod + +program main + use protmod + implicit none + a = 43 ! { dg-error "variable definition context" } + ap => null() ! { dg-error "pointer association context" } + nullify(ap) ! { dg-error "pointer association context" } + ap => & ! { dg-error "pointer association context" } + & at ! { dg-error "Pointer assignment target has PROTECTED attribute" } + ap = 3 ! OK + allocate(ap) ! { dg-error "pointer association context" } + ap = 73 ! OK + call increment(a,at) ! { dg-error "variable definition context" } + call pointer_assignments(ap) ! { dg-error "pointer association context" } +contains + subroutine increment(a1,a3) + integer, intent(inout) :: a1, a3 + a1 = a1 + 1 + a3 = a3 + 1 + end subroutine increment + subroutine pointer_assignments(p) + integer, pointer,intent (inout) :: p + p => null() + end subroutine pointer_assignments +end program main + +module prot2 + implicit none +contains + subroutine bar + real, protected :: b ! { dg-error "only allowed in specification part of a module" } + end subroutine bar +end module prot2 Index: Fortran/gfortran/regression/protected_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_7.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/37504 +! +module m + implicit none + integer, pointer, protected :: protected_pointer + integer, target, protected :: protected_target +end module m + +program p + use m + implicit none + integer, pointer :: unprotected_pointer + ! The next two lines should be rejected; see PR 37513 why + ! we get such a strange error message. + protected_pointer => unprotected_pointer ! { dg-error "pointer association context" } + protected_pointer = unprotected_pointer ! OK + unprotected_pointer => protected_target ! { dg-error "target has PROTECTED attribute" } + unprotected_pointer => protected_pointer ! OK +end program p Index: Fortran/gfortran/regression/protected_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_8.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/46122 +! +! PROTECT check +! +! Contributed by Jared Ahern +! + +MODULE amod + IMPLICIT NONE + TYPE foo + INTEGER :: i = 4 + INTEGER, POINTER :: j => NULL() + END TYPE foo + TYPE(foo), SAVE, PROTECTED :: a + TYPE(foo), SAVE, PROTECTED, POINTER :: b + INTEGER, SAVE, PROTECTED :: i = 5 + INTEGER, SAVE, PROTECTED, POINTER :: j => NULL() +contains + subroutine alloc() + allocate(b,j) + end subroutine alloc +END MODULE amod + +PROGRAM test + USE amod + IMPLICIT NONE + INTEGER, TARGET :: k + TYPE(foo), TARGET :: c + k = 2 ! local + c%i = 9 ! local + + call alloc() + + i = k ! { dg-error "is PROTECTED" } + j => k ! { dg-error "is PROTECTED" } + j = 3 ! OK 1 + a = c ! { dg-error "is PROTECTED" } + a%i = k ! { dg-error "is PROTECTED" } + a%j => k ! { dg-error "is PROTECTED" } + a%j = 5 ! OK 2 + b => c ! { dg-error "is PROTECTED" } + b%i = k ! OK 3 + b%j => k ! OK 4 + b%j = 5 ! OK 5 + +END PROGRAM test Index: Fortran/gfortran/regression/protected_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/protected_9.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/66052 +! +! +! Original code from Gerhard Steinmetz +! +module a + contains + protected x ! { dg-error "only allowed in specification part" } +end module a + +program p + contains + protected x ! { dg-error "only allowed in specification part" } +end Index: Fortran/gfortran/regression/ptr-func-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr-func-1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2008 " } +! +! PR fortran/46100 +! +! Pointer function as definable actual argument +! - a Fortran 2008 feature +! +integer, target :: tgt +call one (two ()) +if (tgt /= 774) STOP 1 +contains + subroutine one (x) + integer, intent(inout) :: x + if (x /= 34) STOP 2 + x = 774 + end subroutine one + function two () + integer, pointer :: two + two => tgt + two = 34 + end function two +end + Index: Fortran/gfortran/regression/ptr-func-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr-func-2.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003 " } +! +! PR fortran/46100 +! +! Pointer function as definable actual argument +! - a Fortran 2008 feature +! +integer, target :: tgt +call one (two ()) ! { dg-error "Fortran 2008: Pointer functions" } +if (tgt /= 774) STOP 1 +contains + subroutine one (x) + integer, intent(inout) :: x + if (x /= 34) STOP 2 + x = 774 + end subroutine one + function two () + integer, pointer :: two + two => tgt + two = 34 + end function two +end + Index: Fortran/gfortran/regression/ptr-func-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr-func-3.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! PR fortran/96896 + +call test1 +call reshape_test +end + +subroutine test1 +implicit none +integer, target :: B +integer, pointer :: A(:) +allocate(A(5)) +A = 1 +B = 10 +get_A() = get_B() +if (any (A /= 10)) stop 1 +get_A() = get_A() +if (any (A /= 10)) stop 2 +deallocate(A) +contains + function get_A() + integer, pointer :: get_A(:) + get_A => A + end + function get_B() + integer, pointer :: get_B + get_B => B + end +end + +subroutine reshape_test + implicit none + real, target, dimension (1:9) :: b + integer :: i + b = 1.0 + myshape(b) = 3.0 + do i = 1, 3 + myfunc (b,i,2) = b(i) + i + b(i) = b(i) + 2.0 + end do + if (any (b /= [real::5,5,5,4,5,6,3,3,3])) stop 3 +contains + function myfunc(b,i,j) + real, target, dimension (1:9) :: b + real, pointer :: myfunc + real, pointer :: p(:,:) + integer :: i,j + p => myshape(b) + myfunc => p(i,j) + end function myfunc + function myshape(b) + real, target, dimension (1:9) :: b + real, pointer :: myshape(:,:) + myshape(1:3,1:3) => b + end function myshape +end subroutine reshape_test Index: Fortran/gfortran/regression/ptr-func-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr-func-4.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-O2 -std=f2008" } +! PR fortran/100218 - target of pointer from evaluation of function-reference + +program p + implicit none + integer, target :: z = 0 + call g (f ()) + if (z /= 1) stop 1 +contains + function f () result (r) + integer, pointer :: r + r => z + end function f + subroutine g (x) + integer, intent(out) :: x + x = 1 + end subroutine g +end program p Index: Fortran/gfortran/regression/ptr_func_assign_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr_func_assign_1.f08 @@ -0,0 +1,112 @@ +! { dg-do run } +! +! Tests implementation of F2008 feature: pointer function assignments. +! +! Contributed by Paul Thomas +! +module fcn_bar +contains + function bar (arg, idx) result (res) + integer, pointer :: res + integer, target :: arg(:) + integer :: idx + res => arg (idx) + res = 99 + end function +end module + +module fcn_mydt + type mydt + integer, allocatable, dimension (:) :: i + contains + procedure, pass :: create + procedure, pass :: delete + procedure, pass :: fill + procedure, pass :: elem_fill + end type +contains + subroutine create (this, sz) + class(mydt) :: this + integer :: sz + if (allocated (this%i)) deallocate (this%i) + allocate (this%i(sz)) + this%i = 0 + end subroutine + subroutine delete (this) + class(mydt) :: this + if (allocated (this%i)) deallocate (this%i) + end subroutine + function fill (this, idx) result (res) + integer, pointer :: res(:) + integer :: lb, ub + class(mydt), target :: this + integer :: idx + lb = idx + ub = lb + size(this%i) - 1 + res => this%i(lb:ub) + end function + function elem_fill (this, idx) result (res) + integer, pointer :: res + class(mydt), target :: this + integer :: idx + res => this%i(idx) + end function +end module + + use fcn_bar + use fcn_mydt + integer, target :: a(3) = [1,2,3] + integer, pointer :: b + integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2] + type(mydt) :: dt + foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" } + if (any (a .ne. [1,2,3])) STOP 1 + +! Assignment to pointer result is after procedure call. + foo (a) = 77 + +! Assignment within procedure applies. + b => foo (a) + if (b .ne. 99) STOP 2 + +! Use of index for assignment. + bar (a, 2) = 99 + if (any (a .ne. [99,99,3])) STOP 3 + +! Make sure that statement function still works! + if (foobar (10) .ne. 100) STOP 4 + + bar (a, 3) = foobar (9) + if (any (a .ne. [99,99,81])) STOP 5 + +! Try typebound procedure + call dt%create (6) + dt%elem_fill (3) = 42 + if (dt%i(3) .ne. 42) STOP 6 + dt%elem_fill (3) = 42 + dt%elem_fill (3) ! PR63921 style assignment + if (dt%i(3) .ne. 84) STOP 7 + dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3) + if (dt%i(3) .ne. 0) STOP 8 +! Array is now reset + dt%fill (3) = ifill ! Check with array variable rhs + dt%fill (1) = [2,1] ! Check with array constructor rhs + if (any (dt%i .ne. [2,1,ifill])) STOP 9 + dt%fill (1) = footoo (size (dt%i, 1)) ! Check with array function rhs + if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10 + dt%fill (3) = ifill + dt%fill (3) ! Array version of PR63921 assignment + if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11 + call dt%delete + +contains + function foo (arg) + integer, pointer :: foo + integer, target :: arg(:) + foo => arg (1) + foo = 99 + end function + function footoo (arg) result(res) + integer :: arg + integer :: res(arg) + res = [(arg - i, i = 0, arg - 1)] + end function +end Index: Fortran/gfortran/regression/ptr_func_assign_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr_func_assign_2.f08 @@ -0,0 +1,113 @@ +! { dg-do compile } +! { dg-options -std=f2003 } +! +! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard. +! +! Contributed by Paul Thomas +! +module fcn_bar +contains + function bar (arg, idx) result (res) + integer, pointer :: res + integer, target :: arg(:) + integer :: idx + res => arg (idx) + res = 99 + end function +end module + +module fcn_mydt + type mydt + integer, allocatable, dimension (:) :: i + contains + procedure, pass :: create + procedure, pass :: delete + procedure, pass :: fill + procedure, pass :: elem_fill + end type +contains + subroutine create (this, sz) + class(mydt) :: this + integer :: sz + if (allocated (this%i)) deallocate (this%i) + allocate (this%i(sz)) + this%i = 0 + end subroutine + subroutine delete (this) + class(mydt) :: this + if (allocated (this%i)) deallocate (this%i) + end subroutine + function fill (this, idx) result (res) + integer, pointer :: res(:) + integer :: lb, ub + class(mydt), target :: this + integer :: idx + lb = idx + ub = lb + size(this%i) - 1 + res => this%i(lb:ub) + end function + function elem_fill (this, idx) result (res) + integer, pointer :: res + class(mydt), target :: this + integer :: idx + res => this%i(idx) + end function +end module + + use fcn_bar + use fcn_mydt + integer, target :: a(3) = [1,2,3] + integer, pointer :: b + integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2] + type(mydt) :: dt + foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" } + if (any (a .ne. [1,2,3])) STOP 1 + +! Assignment to pointer result is after procedure call. + foo (a) = 77 ! { dg-error "Pointer procedure assignment" } + +! Assignment within procedure applies. + b => foo (a) + if (b .ne. 99) STOP 2 + +! Use of index for assignment. + bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" } + if (any (a .ne. [99,99,3])) STOP 3 + +! Make sure that statement function still works! + if (foobar (10) .ne. 100) STOP 4 + + bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" } + if (any (a .ne. [99,99,81])) STOP 5 + +! Try typebound procedure + call dt%create (6) + dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" } + if (dt%i(3) .ne. 42) STOP 6 + dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" } + if (dt%i(3) .ne. 84) STOP 7 + dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" } + if (dt%i(3) .ne. 0) STOP 8 +! Array is now reset + dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" } + dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" } + if (any (dt%i .ne. [2,1,ifill])) STOP 9 + dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" } + if (any (dt%i .ne. [6,5,4,3,2,1])) STOP 10 + dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" } + if (any (dt%i .ne. [6,5,6,10,21,62])) STOP 11 + call dt%delete + +contains + function foo (arg) + integer, pointer :: foo + integer, target :: arg(:) + foo => arg (1) + foo = 99 + end function + function footoo (arg) result(res) + integer :: arg + integer :: res(arg) + res = [(arg - i, i = 0, arg - 1)] + end function +end Index: Fortran/gfortran/regression/ptr_func_assign_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr_func_assign_3.f08 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Tests corrections to implementation of pointer function assignments. +! +! Contributed by Mikael Morin +! +module m + implicit none + type dt + integer :: data + contains + procedure assign_dt + generic :: assignment(=) => assign_dt + end type +contains + subroutine assign_dt(too, from) + class(dt), intent(out) :: too + type(dt), intent(in) :: from + too%data = from%data + 1 + end subroutine +end module m + +program p + use m + integer, parameter :: b = 3 + integer, target :: a = 2 + type(dt), target :: tdt + type(dt) :: sdt = dt(1) + + func (arg=b) = 1 ! This was rejected as an unclassifiable statement + if (a /= 1) STOP 1 + + func (b + b - 3) = -1 + if (a /= -1) STOP 2 + + dtfunc () = sdt ! Check that defined assignment is resolved + if (tdt%data /= 2) STOP 3 +contains + function func(arg) result(r) + integer, pointer :: r + integer :: arg + if (arg == 3) then + r => a + else + r => null() + end if + end function func + function dtfunc() result (r) + type(dt), pointer :: r + r => tdt + end function +end program p Index: Fortran/gfortran/regression/ptr_func_assign_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr_func_assign_4.f08 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Tests correction to implementation of pointer function assignments. +! +! Contributed by Mikael Morin +! +program p + integer, target :: a(3) = 2 + integer :: b(3, 3) = 1 + integer :: c + + c = 3 + func (b(2, 2)) = b ! { dg-error "Incompatible ranks 1 and 2 in assignment" } + func (c) = b ! { dg-error "Incompatible ranks 1 and 2 in assignment" } + +contains + function func(arg) result(r) + integer, pointer :: r(:) + integer :: arg + + if (arg == 1) then + r => a + else + r => null() + end if + end function func +end program p Index: Fortran/gfortran/regression/ptr_func_assign_5.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ptr_func_assign_5.f08 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! Test the fix for PR77703, in which calls of the pointer function +! caused an ICE in 'gfc_trans_auto_character_variable'. +! +! Contributed by Gerhard Steinmetz +! +module m + implicit none + private + integer, parameter, public :: n = 2 + integer, parameter :: ell = 6 + + character(len=n*ell), target, public :: s + + public :: t +contains + function t( idx ) result( substr ) + integer, intent(in) :: idx + character(len=ell), pointer :: substr + + if ( (idx < 0).or.(idx > n) ) then + error stop + end if + substr => s((idx-1)*ell+1:idx*ell) + end function t +end module m + +program p + use m, only : s, t, n + integer :: i + + ! Define 's' + s = "123456789012" + + ! Then perform operations involving 't' + if (t(1) .ne. "123456") stop 1 + if (t(2) .ne. "789012") stop 2 + + ! Do the pointer function assignments + t(1) = "Hello " + if (s .ne. "Hello 789012") Stop 3 + t(2) = "World!" + if (s .ne. "Hello World!") Stop 4 +end program p Index: Fortran/gfortran/regression/public_private_module.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! See PR fortran/36251. +module a + implicit none + integer :: i = 42 +end module a + +module b + use a + implicit none + public a ! { dg-error "attribute applied to" } +end module b + +module d + use a + implicit none + private a ! { dg-error "attribute applied to" } +end module d Index: Fortran/gfortran/regression/public_private_module_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_10.f90 @@ -0,0 +1,16 @@ +! PR 87734 +module m_vstring + implicit none + + public :: vstring_length + +contains + + subroutine vstring_cast() + character ( len = vstring_length() ) :: char_string + end subroutine + + pure integer function vstring_length () + end function + +end module Index: Fortran/gfortran/regression/public_private_module_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_2.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-options "-O2" } +! { dg-require-visibility "" } +! +! PR fortran/52751 (top, "module mod") +! PR fortran/40973 (bottom, "module m") +! +! Ensure that (only) those module variables and procedures which are PRIVATE +! and have no C-binding label are optimized away. +! + module mod + integer :: aa + integer, private :: iii + integer, private, bind(C) :: jj ! { dg-warning "PRIVATE but has been given the binding label" } + integer, private, bind(C,name='lll') :: kk ! { dg-warning "PRIVATE but has been given the binding label" } + integer, private, bind(C,name='') :: mmmm + integer, bind(C) :: nnn + integer, bind(C,name='oo') :: pp + integer, bind(C,name='') :: qq + end module mod + +! The two xfails below have appeared with the introduction of submodules. 'iii' and +! 'mmm' now are TREE_PUBLIC but has DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN set. + + ! { dg-final { scan-assembler "__mod_MOD_aa" } } + ! { dg-final { scan-assembler-not "iii" { xfail *-*-* } } } + ! { dg-final { scan-assembler "jj" } } + ! { dg-final { scan-assembler "lll" } } + ! { dg-final { scan-assembler-not "kk" } } + ! { dg-final { scan-assembler-not "mmmm" { xfail *-*-* } } } + ! { dg-final { scan-assembler "nnn" } } + ! { dg-final { scan-assembler "oo" } } + ! { dg-final { scan-assembler "__mod_MOD_qq" } } + +MODULE M + PRIVATE :: two, three, four, six + PUBLIC :: one, seven, eight, ten +CONTAINS + SUBROUTINE one(a) + integer :: a + a = two() + END SUBROUTINE one + integer FUNCTION two() + two = 42 + END FUNCTION two + integer FUNCTION three() bind(C) ! { dg-warning "PRIVATE but has been given the binding label" } + three = 43 + END FUNCTION three + integer FUNCTION four() bind(C, name='five') ! { dg-warning "PRIVATE but has been given the binding label" } + four = 44 + END FUNCTION four + integer FUNCTION six() bind(C, name='') + six = 46 + END FUNCTION six + integer FUNCTION seven() bind(C) + seven = 46 + END FUNCTION seven + integer FUNCTION eight() bind(C, name='nine') + eight = 48 + END FUNCTION eight + integer FUNCTION ten() bind(C, name='') + ten = 48 + END FUNCTION ten +END MODULE + +! { dg-final { scan-assembler "__m_MOD_one" } } +! { dg-final { scan-assembler-not "two" } } +! { dg-final { scan-assembler "three" } } +! { dg-final { scan-assembler-not "four" } } +! { dg-final { scan-assembler "five" } } +! { dg-final { scan-assembler-not "six" } } +! { dg-final { scan-assembler "seven" } } +! { dg-final { scan-assembler "nine" } } +! { dg-final { scan-assembler "__m_MOD_ten" } } Index: Fortran/gfortran/regression/public_private_module_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_3.f90 @@ -0,0 +1,59 @@ +! { dg-do link } +! { dg-additional-sources public_private_module_4.f90 } +! +! PR fortran/52916 +! Cf. PR fortran/40973 +! +! Ensure that PRIVATE specific functions do not get +! marked as TREE_PUBLIC() = 0, if the generic name is +! PUBLIC. +! +module m + interface gen + module procedure bar + end interface gen + + type t + end type t + + interface operator(.myop.) + module procedure my_op + end interface + + interface operator(+) + module procedure my_plus + end interface + + interface assignment(=) + module procedure my_assign + end interface + + private :: bar, my_op, my_plus, my_assign +contains + subroutine bar() + print *, "bar" + end subroutine bar + function my_op(op1, op2) result(res) + type(t) :: res + type(t), intent(in) :: op1, op2 + end function my_op + function my_plus(op1, op2) result(res) + type(t) :: res + type(t), intent(in) :: op1, op2 + end function my_plus + subroutine my_assign(lhs, rhs) + type(t), intent(out) :: lhs + type(t), intent(in) :: rhs + end subroutine my_assign +end module m + +module m2 + type t2 + contains + procedure, nopass :: func => foo + end type t2 + private :: foo +contains + subroutine foo() + end subroutine foo +end module m2 Index: Fortran/gfortran/regression/public_private_module_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_4.f90 @@ -0,0 +1,23 @@ +! { dg-do compile { target skip-all-targets } } +! +! To be used by public_private_module_3.f90 +! +! PR fortran/52916 +! Cf. PR fortran/40973 +! +! Ensure that PRIVATE specific functions do not get +! marked as TREE_PUBLIC() = 0, if the generic name is +! PUBLIC. +! +use m +use m2 +implicit none + +type(t) :: a, b, c +type(t2) :: x + +call gen() +a = b + (c .myop. a) + +call x%func() +end Index: Fortran/gfortran/regression/public_private_module_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_5.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-O3" } +! +! PR fortran/53175 +! + +MODULE ENERGY_FUNCTION + IMPLICIT NONE + + TYPE PARAM + PRIVATE + INTEGER :: WHICH_VECTOR + END TYPE PARAM + + INTEGER, PRIVATE :: DIM2 + INTEGER, PRIVATE :: DIM5 + + private :: specific + interface gen + module procedure specific + end interface gen + + CONTAINS + + FUNCTION ENERGY_FUNCTION_CURRENT_ARGS() + INTEGER, DIMENSION(DIM2) :: ENERGY_FUNCTION_CURRENT_ARGS + END FUNCTION ENERGY_FUNCTION_CURRENT_ARGS + + FUNCTION ENERGY_FUNCTION_GET_PARAMS() + TYPE(PARAM), DIMENSION(DIM2) :: ENERGY_FUNCTION_GET_PARAMS + END FUNCTION ENERGY_FUNCTION_GET_PARAMS + + function specific() + character(len=dim5) :: specific + end function specific +END MODULE ENERGY_FUNCTION + +! { dg-final { scan-assembler "__energy_function_MOD_dim2" } } +! { dg-final { scan-assembler "__energy_function_MOD_dim5" } } + Index: Fortran/gfortran/regression/public_private_module_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_6.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O1" } +! { dg-require-visibility "" } +! +! PR fortran/54221 +! +! Check that the unused PRIVATE "aaaa" variable is optimized away +! + +module m + private + integer, save :: aaaa +end module m + +! The xfail below has appeared with the introduction of submodules. 'aaaa' +! now is TREE_PUBLIC but has DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN set. + +! { dg-final { scan-assembler-not "aaaa" { xfail *-*-* } } } Index: Fortran/gfortran/regression/public_private_module_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_7.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-O2" } +! +! PR fortran/54884 +! +! Check that get_key_len is not optimized away as it +! is used in a publicly visible specification expression. +! +module m_common_attrs + private + !... + public :: get_key +contains + pure function get_key_len() result(n) + n = 5 + end function get_key_len + pure function other() result(n) + n = 5 + end function other + ! ... + function get_key() result(key) + ! ... + character(len=get_key_len()) :: key + key = '' + end function get_key +end module m_common_attrs + +! { dg-final { scan-assembler-not "__m_common_attrs_MOD_other" } } +! { dg-final { scan-assembler "__m_common_attrs_MOD_get_key_len" } } Index: Fortran/gfortran/regression/public_private_module_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/public_private_module_8.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-O2" } +! +! PR fortran/54884 +! +! Check that get_key_len is not optimized away as it +! is used in a publicly visible specification expression. +! + +module m + private + public :: foo + interface foo + module procedure bar + end interface foo +contains + pure function mylen() + integer :: mylen + mylen = 42 + end function mylen + pure function myotherlen() + integer :: myotherlen + myotherlen = 99 + end function myotherlen + subroutine bar(x) + character(len=mylen()) :: x + character :: z2(myotherlen()) + call internal(x) + block + character(len=myotherlen()) :: z + z = "abc" + x(1:5) = z + end block + x(6:10) = intern_func() + contains + function intern_func() + character(len=myotherlen()) :: intern_func + intern_func = "zuzu" + end function intern_func + subroutine internal(y) + character(len=myotherlen()) :: y + y = "abc" + end subroutine internal + end subroutine bar +end module m + +! { dg-final { scan-assembler-not "__m_MOD_myotherlen" } } +! { dg-final { scan-assembler "__m_MOD_bar" } } +! { dg-final { scan-assembler "__m_MOD_mylen" } } Index: Fortran/gfortran/regression/pure_byref_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_byref_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR 22607: PURE/ELEMENTAL return-by-reference functions +program main + implicit none + character(2), dimension(2) :: a, b + a = 'ok' + b = fun(a) + if (.not.all(b == 'ok')) STOP 1 +contains + elemental function fun(a) + character(*), intent(in) :: a + character(len(a)) :: fun + fun = a + end function fun +end program main Index: Fortran/gfortran/regression/pure_byref_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_byref_2.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR 22607: PURE return-by-reference functions +program main + implicit none + integer, dimension(2) :: b + b = fun(size(b)) + if (b(1) /= 1 .or. b(2) /= 2) STOP 1 +contains + pure function fun(n) + integer, intent(in) :: n + integer :: fun(n) + integer :: i + do i = 1, n + fun(i) = i + end do + end function fun +end program main Index: Fortran/gfortran/regression/pure_byref_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_byref_3.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR 22607: External/module pure return-by-reference functions + +pure function hoj() + integer :: hoj(3) + hoj = (/1, 2, 3/) +end function hoj + +module huj_mod +contains + pure function huj() + integer :: huj(3) + huj = (/1, 2, 3/) + end function huj +end module huj_mod + +program pure_byref_3 + use huj_mod + implicit none + + interface + pure function hoj() + integer :: hoj(3) + end function hoj + end interface + integer :: a(3) + + a = huj() + if (.not. all(a == (/1, 2, 3/))) STOP 1 + + a = hoj() + if (.not. all(a == (/1, 2, 3/))) STOP 2 +end program pure_byref_3 Index: Fortran/gfortran/regression/pure_dummy_length_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_dummy_length_1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Tests fix for PR26107 in which an ICE would occur after the second +! error message below. This resulted from a spurious attempt to +! produce the third error message, without the name of the function. +! +! This is an expanded version of the testcase in the PR. +! + pure function equals(self, & ! { dg-error "must be INTENT" } + string, ignore_case) result(same) + character(*), intent(in) :: string + integer(4), intent(in) :: ignore_case + integer(4) :: same + if (len (self) < 1) return ! { dg-error "must be CHARACTER" } + same = 1 + end function + + function impure(self) result(ival) + character(*), intent(in) :: self + ival = 1 + end function + + pure function purity(self, string, ignore_case) result(same) + character(*), intent(in) :: self + character(*), intent(in) :: string + integer(4), intent(in) :: ignore_case + integer i + if (end > impure (self)) & ! { dg-error "impure function" } + return + end function Index: Fortran/gfortran/regression/pure_formal_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/47507 +! +! PURE procedures: Allow arguments w/o INTENT if they are VALUE +! + +pure function f(x) + real, VALUE :: x + real :: f + f = sin(x) +end function f + +pure subroutine sub(x) + real, VALUE :: x +end subroutine sub Index: Fortran/gfortran/regression/pure_formal_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/47550 +! Follow up to: PR fortran/47507 +! +! PURE procedures: Allow arguments w/o INTENT if they are VALUE +! + +pure function f(x) ! { dg-error "Fortran 2008: Argument 'x' of pure function" } + real, VALUE :: x + real :: f + f = sin(x) +end function f + +pure subroutine sub(x) ! { dg-error "Fortran 2008: Argument 'x' of pure subroutine" } + real, VALUE :: x +end subroutine sub Index: Fortran/gfortran/regression/pure_formal_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Clean up, made when working on PR fortran/52864 +! +! Test some PURE and intent checks - related to pointers. +module m + type t + end type t + integer, pointer :: x + class(t), pointer :: y +end module m + +pure subroutine foo() + use m + call bar(x) ! { dg-error "cannot appear in a variable definition context" } + call bar2(x) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" } + call bb(y) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" } +contains + pure subroutine bar(x) + integer, pointer, intent(inout) :: x + end subroutine + pure subroutine bar2(x) + integer, pointer :: x + end subroutine + pure subroutine bb(x) + class(t), pointer, intent(in) :: x + end subroutine +end subroutine Index: Fortran/gfortran/regression/pure_formal_proc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_proc_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Test fix for PR30034 in which the legal, pure procedure formal +! argument was rejected as an error. +! +! Contgributed by Troban Trumsko +! + pure subroutine s_one ( anum, afun ) + integer, intent(in) :: anum + interface + pure function afun (k) result (l) + implicit none + integer, intent(in) :: k + integer :: l + end function afun + end interface +end subroutine s_one Index: Fortran/gfortran/regression/pure_formal_proc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_proc_2.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Tests the fix for PR36526, in which the call to getStrLen would +! generate an error due to the use of a wrong symbol in interface.c +! +! Contributed by Bálint Aradi +! +module TestPure + implicit none + + type T1 + character(10) :: str + end type T1 + +contains + + pure function getT1Len(self) result(t1len) + type(T1), pointer :: self + integer :: t1len + + t1len = getStrLen(self%str) + + end function getT1Len + + + pure function getStrLen(str) result(length) + character(*), intent(in) :: str + integer :: length + + length = len_trim(str) + + end function getStrLen + +end module TestPure + + +program Test + use TestPure + implicit none + + type(T1), pointer :: pT1 + + allocate(pT1) + pT1%str = "test" + write (*,*) getT1Len(pT1) + deallocate(pT1) + +end program Test Index: Fortran/gfortran/regression/pure_formal_proc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_formal_proc_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 50547: dummy procedure argument of PURE shall be PURE +! +! Contributed by Vittorio Zecca + +pure function f(proc) + interface + function proc() ! { dg-error "must also be PURE" } + end + end interface +end Index: Fortran/gfortran/regression/pure_initializer_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_initializer_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for PR32881, in which the initialization +! of 'p' generated an error because the pureness of 'bar' +! escaped. +! +! Contributed by Janne Blomqvist +! +subroutine foo () + integer, pointer :: p => NULL() +contains + pure function bar (a) + integer, intent(in) :: a + integer :: bar + bar = a + end function bar +end subroutine foo + Index: Fortran/gfortran/regression/pure_initializer_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_initializer_2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! PR42008 Wrongly rejected derived types with default initializers +! in PURE procedures +module mod_xyz + implicit none +contains + pure subroutine psub() + type ilist + type(ilist), pointer :: next => null() ! Valid + integer :: i + end type ilist + end subroutine psub +end module mod_xyz + +module mod_xyz2 + implicit none +contains + pure subroutine psub() + type ilist + type(ilist), pointer :: next + integer, pointer :: p => null() ! Valid + integer :: i + end type ilist + type(ilist) :: var ! Valid + var%next => null() + end subroutine psub +end module mod_xyz2 + +module mod_xyz3 + implicit none + type ilist + type(ilist), pointer :: next => null() ! Valid + integer :: i + end type ilist +contains + pure subroutine psub() + type(ilist) :: var ! Valid + end subroutine psub +end module mod_xyz3 + +pure function test() + integer,pointer :: p => null() !{ dg-error "not allowed in a PURE procedure" } + integer :: test + test = p +end function test Index: Fortran/gfortran/regression/pure_initializer_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/pure_initializer_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/42922 +! +! Contributed by mrestelli@gmail.com +! +pure subroutine psub() + implicit none + type ilist + integer :: i = 0 + end type ilist + type(ilist) :: x + x%i = 1 +end subroutine psub Index: Fortran/gfortran/regression/quad_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/quad_1.f90 @@ -0,0 +1,37 @@ +! { dg-do link } +! +! This test checks whether the largest possible +! floating-point number works. That's usually +! REAL(16) -- either because the hardware supports it or +! because of libquadmath. However, it can also be +! REAL(10) or REAL(8) +! +program test_qp + use iso_fortran_env, only: real_kinds + implicit none + integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1)) + real(QP), parameter :: Z1 = 1,HALF_PI = asin(Z1),PI = HALF_PI+HALF_PI + real(QP) :: x = 0.124_QP + complex(QP) :: z = 0.124_QP + print *, 'kind = ', qp + print *, x + print *, PI + print *, 16*atan(0.2_QP)-4*atan(Z1/239) + print *, sin(PI) + print *, cos(HALF_PI) + print *, asinh(PI) + print *, erfc(Z1) + print *, epsilon(x) + print *, precision(x) + print *, digits(x) + + print *, z + print *, PI*cmplx(0.0_qp, 1.0_qp) +! Disable the complex functions as not all "long-double" systems have +! a libm with those C99 functions. (libquadmath had), cf. PR 46584 +! print *, 16*atan(0.2_QP)-4*atan(Z1/239) +! print *, sin(z) +! print *, cos(z) +! print *, sinh(z) ! asinh not implemented in libquadmath, cf. PR 46416 + print *, precision(z) +end program test_qp Index: Fortran/gfortran/regression/quad_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/quad_2.f90 @@ -0,0 +1,79 @@ +! { dg-do run { xfail hppa*-*-hpux* } } +! { dg-require-effective-target fortran_largest_fp_has_sqrt } +! +! This test checks whether the largest possible +! floating-point number works. +! +! This is a run-time check. Depending on the architecture, +! this tests REAL(8), REAL(10) or REAL(16) and REAL(16) +! might be a hardware or libquadmath 128bit number. +! +program test_qp + use iso_fortran_env, only: real_kinds + implicit none + integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1)) + real(qp) :: fp1, fp2, fp3, fp4 + character(len=80) :: str1, str2, str3, str4 + fp1 = 1 + fp2 = sqrt (2.0_qp) + write (str1,*) fp1 + write (str2,'(g0)') fp1 + write (str3,*) fp2 + write (str4,'(g0)') fp2 + +! print '(3a)', '>',trim(str1),'<' +! print '(3a)', '>',trim(str2),'<' +! print '(3a)', '>',trim(str3),'<' +! print '(3a)', '>',trim(str4),'<' + + read (str1, *) fp3 + if (fp1 /= fp3) STOP 1 + read (str2, *) fp3 + if (fp1 /= fp3) STOP 2 + read (str3, *) fp4 + if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 3 + read (str4, *) fp4 + if (abs (fp2 - fp4)/fp2 > epsilon(fp2)) STOP 4 + + select case (qp) + case (8) + if (str1 /= " 1.0000000000000000") STOP 5 + if (str2 /= "1.0000000000000000") STOP 6 + if (str3 /= " 1.4142135623730951") STOP 7 + if (str4 /= "1.4142135623730951") STOP 8 + + case (10) + if (str1 /= " 1.00000000000000000000") STOP 9 + if (str2 /= "1.00000000000000000000") STOP 10 + if (str3 /= " 1.41421356237309504876") STOP 11 + if (str4 /= "1.41421356237309504876") STOP 12 + + case (16) + if (digits(1.0_qp) == 113) then + ! IEEE 754 binary 128 format + ! e.g. libquadmath/__float128 on i686/x86_64/ia64 + if (str1 /= " 1.00000000000000000000000000000000000") STOP 13 + if (str2 /= "1.00000000000000000000000000000000000") STOP 14 + if (str3 /= " 1.41421356237309504880168872420969798") STOP 15 + if (str4 /= "1.41421356237309504880168872420969798") STOP 16 + else if (digits(1.0_qp) == 106) then + ! IBM binary 128 format + if (str1 /= " 1.0000000000000000000000000000000") STOP 17 + if (str2 /= "1.0000000000000000000000000000000") STOP 18 + if (str3(1:37) /= " 1.4142135623730950488016887242097") STOP 19 + if (str4(1:34) /= "1.4142135623730950488016887242097") STOP 20 + end if + + ! Do a libm run-time test + block + real(qp), volatile :: fp2a + fp2a = 2.0_qp + fp2a = sqrt (fp2a) + if (abs (fp2a - fp2) > sqrt(2.0_qp)-nearest(sqrt(2.0_qp),-1.0_qp)) STOP 21 + end block + + case default + STOP 22 + end select + +end program test_qp Index: Fortran/gfortran/regression/quad_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/quad_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! I/O test for REAL(16) +! +! Contributed by Dominique d'Humieres +! +program test_qp + use iso_fortran_env, only: real_kinds + implicit none + integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1)) + real(kind=qp) :: a,b(2), c + integer :: exponent, i + character(len=180) :: tmp + + ! Run this only with libquadmath; assume that all those systems + ! have also kind=10. + if (size (real_kinds) >= 4 .and. qp == 16) then + i = 3 + if (real_kinds(i) /= 10) stop + + exponent = 4000 + b(:) = huge (1.0_qp)/10.0_qp**exponent +! print *, 'real(16) big value: ', b(1) + write (tmp, *) b + read (tmp, *) a, c +! print *, 'same value read again: ', a, c +! print *, 'difference: looks OK now ', a-b(1) + if (abs (a-b(1))/a > epsilon(0.0_qp) & + .or. abs (c-b(1))/c > epsilon (0.0_qp)) STOP 1 + end if +end program test_qp Index: Fortran/gfortran/regression/random_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Check that the random_seed for real(10) exists and that +! real(8) and real(10) random number generators +! return the same sequence of values. +! Mostly copied from random_2.f90 +program random_3 + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + + integer, dimension(:), allocatable :: seed + real(kind=8), dimension(10) :: r8 + real(kind=k), dimension(10) :: r10 + real, parameter :: delta = 1.d-10 + integer n + + ! Run the test only if real(10) is available. With the current + ! xorshift1024* PRNG the real(16) generator uses two uint64_t values + ! for every real(16) value generated, and hence the sequences won't + ! be the same as with real(4,8,10). + if (k == 10) then + call random_seed (size=n) + allocate (seed(n)) + call random_seed (get=seed) + ! Test both array valued and scalar routines. + call random_number(r8) + call random_number (r8(10)) + + ! Reset the seed and get the real(8) values. + call random_seed (put=seed) + call random_number(r10) + call random_number (r10(10)) + + if (any ((r8 - r10) .gt. delta)) STOP 1 + end if +end program random_3 Index: Fortran/gfortran/regression/random_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +program trs + implicit none + integer :: size, ierr + integer, allocatable, dimension(:) :: seed, check + call test_random_seed(size) + allocate(seed(size),check(size)) + seed = 42 + call test_random_seed(put=seed) + call test_random_seed(get=check) + ! With xorshift1024* the last seed value is special + seed(size) = check(size) + if (any (seed /= check)) STOP 1 +contains + subroutine test_random_seed(size, put, get) + integer, optional :: size + integer, dimension(:), optional :: put + integer, dimension(:), optional :: get + call random_seed(size, put, get) + end subroutine test_random_seed +end program trs Index: Fortran/gfortran/regression/random_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-shouldfail "" } +! +program trs + implicit none + integer :: size + integer :: seed(50) + call test_random_seed(size,seed) +contains + subroutine test_random_seed(size, put, get) + integer, optional :: size + integer, dimension(:), optional :: put + integer, dimension(:), optional :: get + call random_seed(size, put, get) + end subroutine test_random_seed +end program trs +! { dg-output "Fortran runtime error: RANDOM_SEED should have at most one argument present.*" } Index: Fortran/gfortran/regression/random_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +subroutine test1 (size, put, get) + integer :: size + integer, dimension(:), optional :: put + integer, dimension(:), optional :: get + call random_seed(size, put, get) +end + +subroutine test2 (size, put, get) + integer, optional :: size + integer, dimension(:) :: put + integer, dimension(:) :: get + call random_seed(size, put, get) ! { dg-error "Too many arguments" } +end Index: Fortran/gfortran/regression/random_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_7.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! +program trs + implicit none + integer :: size, ierr + integer, allocatable, dimension(:) :: seed, check + call test_random_seed(size) + allocate(seed(size),check(size)) + seed(:) = huge(seed) / 17 + call test_random_seed(put=seed) + call test_random_seed(get=check) + ! In the current xorshift1024* implementation the last seed value is + ! special + seed(size) = check(size) + if (any (seed /= check)) STOP 1 +contains + subroutine test_random_seed(size, put, get) + integer, optional :: size + integer, dimension(:), optional :: put + integer, dimension(:), optional :: get + call random_seed(size, put, get) + end subroutine test_random_seed +end program trs Index: Fortran/gfortran/regression/random_init_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +program foo + logical a(2) + real x + call random_init(1., .false.) ! { dg-error "must be LOGICAL" } + call random_init(.true., 1) ! { dg-error "must be LOGICAL" } + call random_number(x) + a = .true. + call random_init(a, .false.) ! { dg-error "must be a scalar" } + call random_init(.false., a) ! { dg-error "must be a scalar" } +end program foo Index: Fortran/gfortran/regression/random_init_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_2.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +program foo + + real x(2), y(2) + + call random_init(.false., .false.) + call random_number(x) +! print *, x + x = int(1e6*x) + + call random_init(.false., .false.) + call random_number(y) +! print *, y + y = int(1e6*y) + + if (any(x == y)) call abort + + call random_init(.true., .false.) + call random_number(x) +! print *, x + x = int(1e6*x) + + call random_init(.true., .false.) + call random_number(y) +! print *, y + y = int(1e6*y) + + if (any(x /= y)) call abort + +end program foo Index: Fortran/gfortran/regression/random_init_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_3.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +program rantest + + implicit none + + logical, parameter :: debug = .false. + character(len=20) name + integer fd, i, n + integer, allocatable :: n1(:), n2(:), n3(:) + real x(4), y(4), z(4) + + if (debug) then + write(name,'(A,I0)') 'dat', this_image() + open(newunit=fd, file=name) + end if + + call random_seed(size=n) + allocate(n1(n), n2(n), n3(n)) + ! + ! Setup repeatable sequences (if co-arrays the seeds should be distinct + ! are different). Get the seeds. + ! + call random_init(.true., .true.) + call random_seed(get=n1) + call random_number(x) ! This changes internal state. + if (debug) then + write(fd,'(A,4F12.6)') 'x = ', x + end if + + call random_seed(get=n2) ! Grab current state. + ! + ! Use the gotten seed to reseed PRNG and grab sequence. + ! It should be the same sequence. + ! + call random_seed(put=n1) + call random_number(y) + if (debug) then + write(fd,'(A,4F12.6)') 'y = ', y + end if + ! + ! Setup repeatable sequences (if co-arrays the seeds should be distinct + ! are different). Get the seeds. It should be the same sequence. + ! + call random_init(.true., .true.) + call random_seed(get=n3) + call random_number(z) + if (debug) then + write(fd,'(A,4F12.6)') 'z = ', z + end if + + x = int(1e6*x) ! Convert to integer with at most 6 digits. + y = int(1e6*y) ! Convert to integer with at most 6 digits. + z = int(1e6*z) ! Convert to integer with at most 6 digits. + + if (any(x /= y)) call abort + if (any(x /= z)) call abort + + if (debug) then + write(fd,*) + do i = 1, n + if (n1(i) - n2(i) /= 0) then + write(fd,*) 'n1 /= n2', i, n1(i), n2(i) + end if + end do + write(fd,*) + do i = 1, n + if (n1(i) - n3(i) /= 0) then + write(fd,*) 'n1 /= n3', i, n1(i), n3(i) + end if + end do + end if + +end program rantest Index: Fortran/gfortran/regression/random_init_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +program rantest + + implicit none + + logical, parameter :: debug = .false. + character(len=20) name + integer fd, i, n + integer, allocatable :: n1(:), n2(:), n3(:) + real x(4), y(4), z(4) + + if (debug) then + write(name,'(A,I0)') 'dat', this_image() + open(newunit=fd, file=name) + end if + + call random_seed(size=n) + allocate(n1(n), n2(n), n3(n)) + + call random_init(.true., .false.) + call random_seed(get=n1) + call random_number(x) + + call random_init(.true., .false.) + call random_seed(get=n2) + call random_number(y) + + call random_init(.true., .false.) + call random_seed(get=n3) + call random_number(z) + + if (debug) then + write(fd,'(A,4F12.6)') 'x = ', x + write(fd,'(A,4F12.6)') 'y = ', y + write(fd,'(A,4F12.6)') 'z = ', z + write(fd,*) + do i = 1, 5 + write(fd,'(I2,4I13)') i, n1(i), n2(i), n3(i) + end do + end if + +end program rantest Index: Fortran/gfortran/regression/random_init_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_5.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +program rantest + + implicit none + + logical, parameter :: debug = .false. + character(len=20) name + integer fd, i, n + integer, allocatable :: n1(:), n2(:), n3(:) + real x(4), y(4), z(4) + + if (debug) then + write(name,'(A,I0)') 'dat', this_image() + open(newunit=fd, file=name) + end if + + call random_seed(size=n) + allocate(n1(n), n2(n), n3(n)) + + call random_init(.false., .false.) + call random_seed(get=n1) + call random_number(x) + + call random_init(.false., .false.) + call random_seed(get=n2) + call random_number(y) + + call random_init(.false., .false.) + call random_seed(get=n3) + call random_number(z) + + if (debug) then + write(fd,'(A,4F12.6)') 'x = ', x + write(fd,'(A,4F12.6)') 'y = ', y + write(fd,'(A,4F12.6)') 'z = ', z + write(fd,*) + do i = 1, 5 + write(fd,'(I2,4I13)') i, n1(i), n2(i), n3(i) + end do + end if + +end program rantest Index: Fortran/gfortran/regression/random_init_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_init_6.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +program rantest + + implicit none + + logical, parameter :: debug = .false. + character(len=20) name + integer fd, i, n + integer, allocatable :: n1(:), n2(:), n3(:) + real x(4), y(4), z(4) + + if (debug) then + write(name,'(A,I0)') 'dat', this_image() + open(newunit=fd, file=name) + end if + + call random_seed(size=n) + allocate(n1(n), n2(n), n3(n)) + + call random_init(.false., .true.) + call random_seed(get=n1) + call random_number(x) + + call random_init(.false., .true.) + call random_seed(get=n2) + call random_number(y) + + call random_init(.false., .true.) + call random_seed(get=n3) + call random_number(z) + + if (debug) then + write(fd,'(A,4F12.6)') 'x = ', x + write(fd,'(A,4F12.6)') 'y = ', y + write(fd,'(A,4F12.6)') 'z = ', z + write(fd,*) + do i = 1, 5 + write(fd,'(I2,4I13)') i, n1(i), n2(i), n3(i) + end do + end if + +end program rantest Index: Fortran/gfortran/regression/random_seed_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_seed_1.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } + +! Emit a diagnostic for too small PUT array at compile time +! See PR fortran/37159 + +! Updated to check for arrays of unexpected size, +! this also works for -fdefault-integer-8. +! + +PROGRAM random_seed_1 + IMPLICIT NONE + + ! Should match sizeof(master_state) in + ! libgfortran/intrinsics/random.c + INTEGER, PARAMETER :: nbytes = 32 + + ! '+1' to avoid out-of-bounds warnings + INTEGER, PARAMETER :: n = nbytes / KIND(n) + 1 + INTEGER, DIMENSION(n) :: seed + + ! Get seed, array too small + CALL RANDOM_SEED(GET=seed(1:(n-2))) ! { dg-error "too small" } + + ! Get seed, array bigger than necessary + CALL RANDOM_SEED(GET=seed(1:n)) + + ! Get seed, proper size + CALL RANDOM_SEED(GET=seed(1:(n-1))) + + ! Put too few bytes + CALL RANDOM_SEED(PUT=seed(1:(n-2))) ! { dg-error "too small" } + + ! Put too many bytes + CALL RANDOM_SEED(PUT=seed(1:n)) + + ! Put the right amount of bytes + CALL RANDOM_SEED(PUT=seed(1:(n-1))) +END PROGRAM random_seed_1 Index: Fortran/gfortran/regression/random_seed_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_seed_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 44595: INTENT of arguments to intrinsic procedures not checked +! +! Contributed by Steve Kargl + +subroutine reset_seed(iseed) + implicit none + integer, intent(in) :: iseed + call random_seed(iseed) ! { dg-error "cannot be INTENT.IN." } +end subroutine reset_seed Index: Fortran/gfortran/regression/random_seed_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_seed_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Check that array constructors using non-compile-time +! iterators are handled correctly. +program main + implicit none + call init_random_seed +contains + SUBROUTINE init_random_seed() + INTEGER :: i, n, clock + INTEGER, DIMENSION(:), ALLOCATABLE :: seed + + CALL RANDOM_SEED(size = n) + ALLOCATE(seed(n)) + + CALL SYSTEM_CLOCK(COUNT=clock) + + seed = clock + 37 * (/ (i - 1, i = 1, n) /) + CALL RANDOM_SEED(PUT = seed) + + DEALLOCATE(seed) + END SUBROUTINE init_random_seed +end program main Index: Fortran/gfortran/regression/random_seed_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/random_seed_4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/95037 +! This led to a segfault or a confusing error message. Original +! test case by Bill Long. + +subroutine my_random_seed_v (size, put, get) +integer, optional :: size +integer, optional :: put(1) +integer, optional :: get(1) +call random_seed (size, get=get) ! { dg-error "too small" } +call random_seed (size, put=put) ! { dg-error "too small" } +call random_seed (size, get=get, put=put) ! { dg-error "too small" } +end subroutine my_random_seed_v + Index: Fortran/gfortran/regression/rank_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rank_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Fortran < 2008 allows 7 dimensions +! Fortran 2008 allows 15 dimensions (including co-array ranks) +! +integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) +integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 15 dimensions" } +end Index: Fortran/gfortran/regression/rank_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rank_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Fortran < 2008 allows 7 dimensions +! Fortran 2008 allows 15 dimensions (including co-array ranks) +! +integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) ! { dg-error "more than 7 dimensions" } + +! PR fortran/36825: +integer,parameter :: N=10 +complex,dimension(-N:N,-N:N,0:1,0:1,-N:N,-N:N,0:1,0:1) :: P ! { dg-error "more than 7 dimensions" } +end Index: Fortran/gfortran/regression/rank_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rank_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48820 +! +intrinsic :: rank ! { dg-error "new in Fortran 2018" } +end Index: Fortran/gfortran/regression/rank_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rank_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts -fdump-tree-original" } +! +! PR fortran/48820 +! + +program test_rank + implicit none + intrinsic :: rank + + integer :: a + real, allocatable :: b(:,:) + + if (rank(a) /= 0) call not_existing() + if (rank (b) /= 2) call not_existing() +end program test_rank + +! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } } Index: Fortran/gfortran/regression/read_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! Cf. PR fortran/33232 +program test + implicit none + integer :: a + READ *, a + READ '(i3)', a +end program test Index: Fortran/gfortran/regression/read_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! +! PR fortran/34404 +! +! Contributed by Joost VandeVondele. +! +implicit none +complex :: x +character(len=80) :: t="(1.0E-7,4.0E-3)" +read(t,*) x +if (real(x) /= 1.0e-7 .or. aimag(x)/=4.0e-3) STOP 1 +END Index: Fortran/gfortran/regression/read_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR80727 Crash of runtime gfortran library during integer transformation +! Note: before the patch this was giving an incorrect EOR error on READ. +program gfortran_710_io_bug + character str*4 + integer(4) :: i4 + str ='' + i = 256 + write(str,fmt='(a)') i + i = 0 + read ( unit=str(1:4), fmt='(a)' ) i4 + if (i4.ne.256) STOP 1 +end program gfortran_710_io_bug Index: Fortran/gfortran/regression/read_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_4.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR80741 wrong code causes incorrect behaviour of namelist READ +program p + use, intrinsic :: iso_fortran_env, only: iostat_end + implicit none + integer :: x, y, ios, io + character(10) :: line + namelist /test/ x, y + + x = 10 + y = 10 + ios = 0 + io = 10 + open(unit=io, status='scratch') + write(io, test) + write(io, *) 'done' + rewind(io) + x = 0 + y = 0 + read(io, test) + if (x.ne.10 .or. y.ne.10) STOP 1 + ! + read(io, *) line + if (line.ne.'done') STOP 2 + ! + read(io, *, iostat=ios) line + if (ios/=iostat_end) STOP 3 + rewind(io) + x = 0 + y = 0 + read(io, test) + if (x.ne.10 .or. y.ne.10) STOP 4 + read(io, *, iostat=ios) line + if (line.ne.'done') STOP 5 +end Index: Fortran/gfortran/regression/read_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_5.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR53029 Missed optimization, this test case took several seconds to + program internalread + implicit none + integer m + parameter(m=1000000) + character value*10 + character(80) :: result + integer i,j,intvalues(m) + real :: start, finish + intvalues = 33 + call cpu_time(start) + do j=1,100 + write(value,'(i3,a5)') j," 5 69" + read(value,*,end=20) intvalues + 20 write(result,*) (intvalues(i),i=2,4) + if (result.ne.(' 5 69 33')) STOP 1 + call cpu_time(finish) + if ((finish-start).gt. 0.5) STOP 2 + enddo + end program internalread Index: Fortran/gfortran/regression/read_bad_advance.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_bad_advance.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR27138 Failure to advance line on bad list directed read. +! Submitted by Jerry DeLisle + program test + implicit none + integer :: ntype = 55 + real :: rtype + complex :: ctype + logical :: ltype + OPEN (10, status="scratch") + write(10,*) "aaaa aaaa aaaa aaaa" + write(10,*) "bbbb bbbb bbbb bbbb" + write(10,*) "cccc cccc cccc cccc" + write(10,*) "dddd dddd dddd dddd" + write(10,*) " " + write(10,*) "1234 5678 9012 3456" + rewind(10) + READ (10,*,END=77,ERR=77) ntype + goto 99 + 77 READ (10,*,END=78,ERR=78) rtype + goto 99 + 78 READ (10,*,END=79,ERR=79) ctype + goto 99 + 79 READ (10,*,END=80,ERR=80) ltype + goto 99 + 80 READ (10,*,END=99,ERR=99) ntype + if (ntype.ne.1234) goto 99 + close(10) + stop + 99 close(10) + STOP 1 + end program test Index: Fortran/gfortran/regression/read_bang.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_bang.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! PR69651 Usage of unitialized pointer io/list_read.c +! Note: The uninitialized pointer was not the cause of the problem +! observed with this test case. The problem was mishandling '!' +! See also test case read_bang4.f90. +program test + implicit none + integer :: i, j, ios + real :: r, s + complex :: c, d + character(20) :: str1, str2 + + i = -5 + j = -6 + r = -3.14 + s = -2.71 + c = (-1.1,-2.2) + d = (-3.3,-4.4) + str1 = "candy" + str2 = "peppermint" + open(15, status='scratch') + write(15,*) "10 1!2" + write(15,*) " 23.5! 34.5" + write(15,*) " (67.50,69.25) (51.25,87.75)!" + write(15,*) " 'abcdefgh!' ' !klmnopq!'" + rewind(15) + read(15,*,iostat=ios) i, j + if (ios.ne.5010) STOP 1 + read(15,*,iostat=ios) r, s + if (ios.ne.5010) STOP 2 + read(15,*,iostat=ios) c, d + if (ios.ne.5010) STOP 3 + read(15,*,iostat=ios) str1, str2 + if (ios.ne.0) STOP 4 + if (str1.ne."abcdefgh!") print *, str1 + if (str2.ne." !klmnopq!") print *, str2 + close(15) +end program Index: Fortran/gfortran/regression/read_bang4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_bang4.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR69651 Usage of unitialized pointer io/list_read.c +! Note: The uninitialized pointer was not the cause of the problem +! observed with this test case. This tests the case with UTF-8 +! files. The large string test the realloc use in push_char4 of +! list_read.c +program test + implicit none + integer :: i, j, k, ios + integer, parameter :: big = 600 + real :: r, s + complex :: c, d + character(kind=4,len=big) :: str1, str2, str3 + + do i=1,big, 10 + do j = 0, 9 + k = i + j + str2(k:k) = char(65+j) + end do + end do + i = -5 + j = -6 + r = -3.14 + s = -2.71 + c = (-1.1,-2.2) + d = (-3.3,-4.4) + str3 = str2 + open(15, status='scratch', encoding="utf-8") + write(15,*) "10 1!2" + write(15,*) " 23.5! 34.5" + write(15,*) " (67.50,69.25) (51.25,87.75)!" + write(15,*) " 'abcdefgh!'", " ", str2 + rewind(15) + str1 = 4_"candy" + str2 = 4_"peppermint" + read(15,*,iostat=ios) i, j + if (ios.ne.5010) STOP 1 + read(15,*,iostat=ios) r, s + if (ios.ne.5010) STOP 2 + read(15,*,iostat=ios) c, d + if (ios.ne.5010) STOP 3 + read(15,*,iostat=ios) str1, str2 + if (ios.ne.0) STOP 4 + if (str1.ne.4_"abcdefgh!") STOP 5 + if (str2.ne.str3) STOP 6 + close(15) +end program Index: Fortran/gfortran/regression/read_comma.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_comma.f @@ -0,0 +1,26 @@ +! { dg-do run { target fd_truncate } } +! PR25039 This test checks that commas in input fields for formatted sequential +! reads are interpreted as the read completion. If no comma is encountered the +! normal field width determines the end of the read. The test case also checks +! that default blanks are interpreted as NULL in numerics. +! Test case derived from sample provided in PR by Iwan Kawrakow. +! Contributed by Jerry DeLisle +! + program pr25039 + implicit none + integer :: i1, i2, i3 + character(10) :: a1 + open(10, status="scratch") + write(10,'(a)') "1, 235" + rewind(10) + read(10,'(3i2)') i1,i2,i3 + if(i1.ne.1) STOP 1 + if(i2.ne.2) STOP 2 + if(i3.ne.35) STOP 3 + rewind(10) +! Make sure commas are read in character strings. + write(10,'(a)') "1234,6789," + rewind(10) + read(10,'(a10)') a1 + if(a1.ne."1234,6789,") STOP 4 + end Index: Fortran/gfortran/regression/read_dir-aux.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_dir-aux.c @@ -0,0 +1,68 @@ +#if defined(__WIN32__) && !defined(__CYGWIN__) + /* Mostly skip on Windows, cf. main file why. */ + +int expect_open_to_fail () { return 1; } + +void my_verify_not_exists (const char *dir) { } +void my_mkdir (const char *dir) { } +void my_rmdir (const char *dir) { } + +#else + +#include /* For mkdir + permission bits. */ +#include /* For rmdir. */ +#include /* For errno. */ +#include /* For perror. */ +#include /* For abort. */ + + +int expect_open_to_fail () { return 0; } + +void +my_verify_not_exists (const char *dir) +{ + struct stat path_stat; + int err = stat (dir, &path_stat); + if (err && errno == ENOENT) + return; /* OK */ + if (err) + perror ("my_verify_not_exists"); + else + printf ("my_verify_not_exists: pathname %s still exists\n", dir); + abort (); + } + +void +my_mkdir (const char *dir) +{ + int err; + struct stat path_stat; + + /* Check whether 'dir' exists and is a directory. */ + err = stat (dir, &path_stat); + if (err && errno != ENOENT) + { + perror ("my_mkdir: failed to call stat for directory"); + abort (); + } + if (err == 0 && !S_ISDIR (path_stat.st_mode)) + { + printf ("my_mkdir: pathname %s is not a directory\n", dir); + abort (); + } + + err = mkdir (dir, S_IRWXU | S_IRGRP | S_IXGRP | S_IROTH | S_IXOTH); + if (err != 0) + { + perror ("my_mkdir: failed to create directory"); + abort (); + } +} + +void +my_rmdir (const char *dir) +{ + rmdir (dir); +} + +#endif /* !defined(__WIN32__) || defined(__CYGWIN__) */ Index: Fortran/gfortran/regression/read_dir.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_dir.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-additional-sources read_dir-aux.c } +! +! PR67367 + +program bug + use iso_c_binding + implicit none + + interface + integer(c_int) function expect_open_to_fail () bind(C) + import + end + subroutine my_verify_not_exists(s) bind(C) + ! Aborts if the passed pathname (still) exists + import + character(len=1,kind=c_char) :: s(*) + end subroutine + subroutine my_mkdir(s) bind(C) + ! Call POSIX's mkdir - and ignore fails due to + ! existing directories but fail otherwise + import + character(len=1,kind=c_char) :: s(*) + end subroutine + subroutine my_rmdir(s) bind(C) + ! Call POSIX's rmdir - and ignore fails + import + character(len=1,kind=c_char) :: s(*) + end subroutine + end interface + + character(len=*), parameter :: sdir = "junko.dir" + character(len=*,kind=c_char), parameter :: c_sdir = sdir // c_null_char + + character(len=1) :: c + integer ios + + if (expect_open_to_fail () /= 0) then + ! Windows is documented to fail with EACCESS when trying to open a + ! directory. However, target macros such as __WIN32__ are not defined + ! in Fortran; hence, we use a detour via this C function. + ! Check for '.' which is a known-to-exist directory: + open(unit=10, file='.',iostat=ios,action='read',access='stream') + if (ios == 0) & + stop 3 ! Error: open to fail (EACCESS) + stop 0 ! OK + endif + + call my_mkdir(c_sdir) + open(unit=10, file=sdir,iostat=ios,action='read',access='stream') + + if (ios.ne.0) then + call my_rmdir(c_sdir) + STOP 1 + end if + read(10, iostat=ios) c + if (ios.ne.21.and.ios.ne.0) then ! EISDIR has often the value 21 + close(10, status='delete') + call my_verify_not_exists(c_sdir) + STOP 2 + end if + close(10, status='delete') + call my_verify_not_exists(c_sdir) +end program bug Index: Fortran/gfortran/regression/read_empty_file.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_empty_file.f @@ -0,0 +1,7 @@ +! { dg-do run } +! PR43320 Missing EOF on read from empty file. + open(8,status='scratch',form='formatted') ! Create empty file + read(8,'(a80)', end=123) ! Reading from an empty file should be an EOF + STOP 1 +123 continue + end Index: Fortran/gfortran/regression/read_eof_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run { target fd_truncate } } +! PR25697 Check that reading from a file that is at end-of-file does not +! segfault or give error. Test case derived from example in PR from Dale Ranta. +! Contributed by Jerry DeLisle + integer data(9) + do i = 1,9 + data(i)=-3 + enddo + open(unit=11,status='scratch',form='unformatted') + write(11)data + read(11,end= 1000 )data + STOP 1 + 1000 continue + backspace 11 + backspace 11 + write(11)data + rewind 11 + data = 0 + read(11,end= 1001 )data + 1001 continue + read(11,end= 1002 )data + STOP 1 + 1002 continue + if (.not. all(data == -3)) STOP 2 + close(11) + end + Index: Fortran/gfortran/regression/read_eof_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_2.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR25835 Check that reading from a file that is at end-of-file does not +! segfault or give error. Test case derived from example in PR from Dale Ranta. +! Contributed by Jerry DeLisle + integer data(2045) ! Exceed internal buffer size + data=-1 + open(unit=11,status='scratch', form='unformatted') + write(11)data + read(11,end= 1000 )data + STOP 1 + 1000 continue + backspace 11 + backspace 11 + data = 0 + read(11)data + if (.not. all(data == -1)) STOP 2 + read(11,end= 1002 )data + STOP 3 + 1002 continue + close(11) + end Index: Fortran/gfortran/regression/read_eof_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run { target fd_truncate } } +! PR25835 Check that reading from a file that is at end-of-file does not +! segfault or give error. Test case derived from example in PR from Dale Ranta. +! Contributed by Jerry DeLisle + integer data(5000) + data=-256 + open(unit=11,status='scratch', form='unformatted') + write(11)data + write(11)data + read(11,end= 1000 )data + STOP 1 + 1000 continue + backspace 11 + rewind 11 + write(11)data + read(11,end= 1001 )data + STOP 2 + 1001 continue + data = 0 + backspace 11 + rewind 11 + read(11,end= 1002 )data + if (.not. all(data == -256)) STOP 3 + 1002 continue + read(11,end= 1003 )data + STOP 4 + 1003 continue + close(11) + end + + Index: Fortran/gfortran/regression/read_eof_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR 27575 and PR 30009: This test checks the error checking for end +! of file condition. +! Derived from test case in PR. +! Submitted by Jerry DeLisle , modified by +! Thomas Koenig + + program test + integer i1,i2,i3 + open(unit=11,form='unformatted') + write (11) 1, 2 + write (11) 3, 4 + close(11,status='keep') + + open(unit=11,form='unformatted') + + read(11, ERR=100) i1, i2, i3 + STOP 1 + 100 continue + if (i1 /= 1 .or. i2 /= 2) STOP 1 + + read(11, ERR=110) i1, i2, i3 + STOP 2 + 110 continue + if (i1 /= 3 .or. i2 /= 4) STOP 2 + + read(11, end=120) i3 + STOP 3 + 120 close(11,status='delete') + end Index: Fortran/gfortran/regression/read_eof_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_5.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR34560 I/O internal read: END expected, but no failure +program main + character(len=2) :: line + character(len=1) :: a(3) + a = "x" + line = 'ab' + read (line,'(A)',END=99) a + STOP 1 + 99 continue + if (any(a /= ['a','x','x'])) STOP 2 +end program main Index: Fortran/gfortran/regression/read_eof_6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_6.f @@ -0,0 +1,7 @@ +! { dg-do run } +! PR43320 Missing EOF on read from empty file. + open(8,status='scratch',form='formatted') ! Create empty file + read(8,'(a80)', end=123) ! Reading from an empty file should be an EOF + STOP 1 +123 continue + end Index: Fortran/gfortran/regression/read_eof_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_7.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR43517 Spurious EOF condition when namelist read follows formatted read +! Test case from the problem reporter - Michael Richmond +program main + namelist /name/ j + open (10,status='scratch',form='formatted') + write(10,'(a)') "999999" + write(10,'(a)') " $name" + write(10,'(a)') " j=73," + write(10,'(a)') " /" + rewind(10) + i = 54321 + idum = 6789 + read (10,'(2i5,4x)') i, idum ! Trailing 4x was setting EOF condition + if (i /= 99999 .and. idum /= 9) STOP 1 + j = 12345 + read (10,name) ! EOF condition tripped here. + if (j /= 73) STOP 2 +end program main + Index: Fortran/gfortran/regression/read_eof_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_8.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR43265: See comment #26 in the PR. Before patch, +! the test case would fail to read the last line of the file. +! Thanks to Jean-Baptiste Faure for providing the initial test case. +program test + character (len=6) :: line + integer :: n, k=0 + open(unit=25,file="test.dat",status="replace", & + & form="unformatted", access="stream") + write(25) "Line 1" // char(10) + write(25) "Line 2" // char(10) + write(25) "Line 3" // char(10) + write(25) "Line 4" // char(10) + write(25) "Line 5" ! No EOR marker on the last line. + close(25, status="keep") + open(25, file="test.dat", status="old") + do n=1,10 + read(25,'(a)',end=100,err=101) line + k = k+1 + enddo + STOP 1 +100 if (k /= 5) STOP 2 + close(25, status="delete") + stop +101 STOP 3 +end program test + Index: Fortran/gfortran/regression/read_eof_all.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eof_all.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! PR43265 Followup patch for miscellaneous EOF conditions. +! Eaxamples from Tobius Burnus + use iso_fortran_env + character(len=2) :: str, str2(2) + integer :: a, b, c, ios + str = '' + str2 = '' + + open(99,file='test.dat',access='stream',form='unformatted', status='replace') + write(99) ' ' + close(99) + + open(99,file='test.dat') + read(99, '(T7,i2)') i + close(99, status="delete") + if (i /= 0) STOP 1 + + read(str(1:0), '(T7,i1)') i + if (i /= 0) STOP 2 + + read(str,'(i2,/,i2)',end=111) a, b + STOP 3!stop 'ERROR: Expected EOF error (1)' + 111 continue + + read(str2,'(i2,/,i2)',end=112) a, b + + read(str2,'(i2,/,i2,/,i2)',end=113) a, b, c + STOP 4!stop 'ERROR: Expected EOF error (2)' + + 112 STOP 5!stop 'ERROR: Unexpected EOF (3)' + + 113 continue + read(str,'(i2,/,i2)',end=121,pad='no') a, b + STOP 6!stop 'ERROR: Expected EOF error (1)' + 121 continue + + read(str2(:),'(i2,/,i2)', end=122, pad='no') a, b + goto 125 + 122 STOP 7!stop 'ERROR: Expected no EOF error (2)' + 125 continue + + read(str2(:),'(i2,/,i2,/,i2)',end=123,pad='no') a, b, c + STOP 8!stop 'ERROR: Expected EOF error (3)' + 123 continue + + read(str(2:1),'(i2,/,i2)',end=131, pad='no') a, b + STOP 9!stop 'ERROR: Expected EOF error (1)' + 131 continue + + read(str2(:)(2:1),'(i2,/,i2)',end=132, pad='no') a, b + STOP 10!stop 'ERROR: Expected EOF error (2)' + 132 continue + + read(str2(:)(2:1),'(i2,/,i2,/,i2)',end=133,pad='no') a, b, c + STOP 11!stop 'ERROR: Expected EOF error (3)' + 133 continue + + read(str(2:1),'(i2,/,i2)',iostat=ios, pad='no') a, b + if (ios /= IOSTAT_END) STOP 12!stop 'ERROR: expected iostat /= 0 (1)' + + read(str2(:)(2:1),'(i2,/,i2)',iostat=ios, pad='no') a, b + if (ios /= IOSTAT_END) STOP 13!stop 'ERROR: expected iostat /= 0 (2)' + + read(str2(:)(2:1),'(i2,/,i2,/,i2)',iostat=ios,pad='no') a, b, c + if (ios /= IOSTAT_END) STOP 14!stop 'ERROR: expected iostat /= 0 (2)' + + ! print *, "success" + end + + Index: Fortran/gfortran/regression/read_eor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_eor.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR24489 Assure that read does not go past the end of record. The width of +! the format specifier is 8, but the internal unit record length is 4 so only +! the first 4 characters should be read. +! Contributed by Jerry DeLisle . +program pr24489 + character*4, dimension(8) :: abuf = (/"0123","4567","89AB","CDEF", & + "0123","4567","89AB","CDEF"/) + character*4, dimension(2,4) :: buf + character*8 :: a + equivalence (buf,abuf) + read(buf, '(a8)') a + if (a.ne.'0123') STOP 1 +end program pr24489 Index: Fortran/gfortran/regression/read_float_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_float_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR18218 +! The IO library has an algorithm that involved repeated multiplication by 10, +! resulting in introducing large cumulative floating point errors. +program foo + character*20 s + real(kind=8) d + s = "-.18774312893273 " + read(unit=s, fmt='(g20.14)') d + if (d + 0.18774312893273d0 .gt. 1d-13) STOP 1 +end program + Index: Fortran/gfortran/regression/read_float_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_float_2.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! Contributed by Dominique Dhumieres + +character(15) :: str="+ .339 567+2" +real, parameter :: should_be = .339567e2 +real, parameter :: eps = 10 * epsilon (should_be) +real :: x, y + +read(str,'(BN,F15.6)') x +print *, x +read(str,'(G15.7)') y +print *, y + +if (abs (x - should_be) > eps .or. abs (y - should_be) > eps) then + STOP 1 +end if + +end Index: Fortran/gfortran/regression/read_float_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_float_3.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Contributed by Dominique Dhumieres + +character(100) :: str1 = & + "123.00456.88 0.123E+01 +0.987+1 -0.2345+02 -0.6879E+2+0.7E+03 0.4E+03" +character(100), parameter :: should_be = & + "123.00456.88 0.123E+01 0.987E+01-0.2345E+02-0.6879E+02 0.7E+03 0.4E+03" +character(100) :: output +complex :: c1, c2, c3, c4 + +100 format ( 2F6.2, 2E10.3, 2E11.4, 2E8.1) +read (str1,100) c1, c2, c3, c4 +write (output, 100) c1, c2, c3, c4 + +print *, output +if (output /= should_be) then + print *, should_be + STOP 1 +end if + +end Index: Fortran/gfortran/regression/read_float_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_float_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR libgfortran/53051 +! +! Check that reading "4.0q0" works, i.e. floating-point +! numbers which use "q" to indicate the exponential. +! (Which is a vendor extension.) +! + character(len=20) :: str + real :: r + integer :: i + + r = 0 + str = '1.0q0' + read(str, *, iostat=i) r + if (r /= 1.0 .or. i /= 0) STOP 1 + !print *, r + end Index: Fortran/gfortran/regression/read_infnan_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_infnan_1.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-add-options ieee } + +! PR43298 Fortran library does not read in NaN, NaN(), -Inf, or Inf + +! Formatted READ part of PR fortran/43298 + +! Test case prepared by Jerry DeLisle +program pr43298 + real(4) :: x4(7) + real(8) :: x8(7) + character(80) :: output + +open(10, status='scratch') +! 0123456789012345678901234567890123456789012345678901234567890123456789 +write(10,'(a)') "inf nan infinity NaN(dx) -INf NAN InFiNiTy" +rewind(10) +x4 = 0.0_4 +x8 = 0.0_8 +read(10,'(7f10.3)') x4 +rewind(10) +read(10,'(7f10.3)') x8 +write (output, '("x4 =",7G6.0)') x4 +if (output.ne."x4 = Inf NaN Inf NaN -Inf NaN Inf") STOP 1 +write (output, '("x8 =",7G6.0)') x8 +if (output.ne."x8 = Inf NaN Inf NaN -Inf NaN Inf") STOP 2 +!print '("x4 =",7G6.0)', x4 +!print '("x8 =",7G6.0)', x8 +end program pr43298 + Index: Fortran/gfortran/regression/read_legacy_comma.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_legacy_comma.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! PR78351 +program read_csv + implicit none + integer, parameter :: dbl = selected_real_kind(p=14, r=99) + + call checkit("101,1.,2.,3.,7,7") + call checkit ("102,1.,,3.,,7") + call checkit (",1.,,3.,, ") + +contains + +subroutine checkit (text) + character(*) :: text + integer :: I1, I2, I3 + real(dbl) :: R1, R2, R3 + 10 format (I8,3ES16.8,2I8) + + I1=-99; I2=-99; I3=-99 + R1=-99._DBL; R2=-99._DBL; R3=-99._DBL + read(text,10) I1, R1, R2, R3, I2, I3 + if (I1 == -99) stop 1 + if (I2 == -99) stop 2 + if (I3 == -99) stop 3 + if (R1 == -99._DBL) stop 4 + if (R2 == -99._DBL) stop 5 + if (R3 == -99._DBL) stop 6 +end subroutine + +end program Index: Fortran/gfortran/regression/read_list_eof_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_list_eof_1.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! PR 49296 List formatted read of file without EOR marker (\n). +program read_list_eof_1 + implicit none + character(len=100) :: s + integer :: ii + real :: rr + logical :: ll + + call genfil ('a') + open (unit=20, file='read.dat', form='FORMATTED', action='READ', & + status='OLD') + read (20, fmt=*) s + close (20, status='delete') + if (trim(s) /= "a") then + STOP 1 + end if + + call genfil ('1') + open (unit=20, file='read.dat', form='FORMATTED', action='READ', & + status='OLD') + read (20, fmt=*) ii + close (20, status='delete') + if (ii /= 1) then + STOP 2 + end if + + call genfil ('1.5') + open (unit=20, file='read.dat', form='FORMATTED', action='READ', & + status='OLD') + read (20, fmt=*) rr + close (20, status='delete') + if (rr /= 1.5) then + STOP 3 + end if + + call genfil ('T') + open (unit=20, file='read.dat', form='FORMATTED', action='READ', & + status='OLD') + read (20, fmt=*) ll + close (20, status='delete') + if (.not. ll) then + STOP 4 + end if + +contains + subroutine genfil(str) + character(len=*), intent(in) :: str + open(10, file='read.dat', form='unformatted', action='write', & + status='replace', access='stream') + write(10) str + close(10) + end subroutine genfil +end program read_list_eof_1 Index: Fortran/gfortran/regression/read_logical.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_logical.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 26554 : Test logical read from string. Test case derived from PR. +! Submitted by Jerry DeLisle . +program bug + implicit none + character*30 :: strg + logical l + l = .true. + strg = "false" + read (strg,*) l + if (l) STOP 1 + strg = "true" + read (strg,*) l + if (.not.l) STOP 2 + end + Index: Fortran/gfortran/regression/read_many_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_many_1.f @@ -0,0 +1,24 @@ +!{ dg-do run } +! PR26423 Large file I/O error related to buffering +! Test case derived from case by Dale Ranta. +! Submitted by Jerry DeLisle + integer :: a(3000) , b(2048) + a=3 + b=5 + a(1) = 1 + a(3000)=1234 + write(2) a + b(1) = 2 + b(2048) = 5678 + write(2) b + rewind 2 + read(2) a + read(2) b + if (a(1).ne.1) STOP 1 + if (a(2).ne.3) STOP 2 + if (b(1).ne.2) STOP 3 + if (b(2).ne.5) STOP 4 + if (a(3000).ne.1234) STOP 5 + if (b(2048).ne.5678) STOP 6 + close(2, status='delete') + end Index: Fortran/gfortran/regression/read_no_eor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_no_eor.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! Handle eor and eof conditions with missing eor in file. +! Test case modified from case presented by Ian Harvey on clf. +program eieio_stat + use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor + implicit none + integer, parameter :: unit=10 + integer :: ios1, ios2, ios3 + character(25) :: buffer + character(100) :: themessage + !**** + open(10,file="eieio", form="unformatted", access="stream", status="replace") + write(10) "Line-1" // char(10) + write(10) "Line-2" + close(10) + + open(10,file="eieio") + + buffer = 'abcdefg' + read (unit,"(a)",advance="no",iostat=ios1, pad="yes") buffer + if (ios1 /= iostat_eor .and. buffer /= "Line-1") STOP 1 + + buffer = '<' + read (unit,"(a)",advance="no",iostat=ios2,pad="yes") buffer + if (ios2 /= iostat_eor .and. buffer /= "Line-2") STOP 2 + + buffer = '5678' + read (unit,"(a)",advance="no",iostat=ios3, iomsg=themessage) buffer + if (ios3 /= iostat_end .and. buffer /= "5678") STOP 3 + + rewind(10) + + buffer = "abcdefg" + read (unit,"(a)",advance="no",iostat=ios1, pad="no") buffer + if (ios1 /= iostat_eor .and. buffer /= "abcdefg") STOP 4 + + buffer = '<' + read (unit,"(a)",advance="no",iostat=ios2,pad="no") buffer + if (ios2 /= iostat_eor .and. buffer /= "<") STOP 5 + + buffer = '1234' + read (unit,"(a)",advance="no",iostat=ios3, iomsg=themessage) buffer + if (ios3 <= 0 .and. buffer /= "1234") STOP 6 + + close(unit, status="delete") +end program eieio_stat Index: Fortran/gfortran/regression/read_noadvance.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_noadvance.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! pr24719, non-advancing read should read more than one line +! test contributed by jerry delisle + implicit none + character(1) :: chr + character(20) :: correct = 'foo: bar 123abc' + integer :: i + open(unit = 11, status = "scratch", action="readwrite") + write(11,'(a)') "foo: bar" + write(11,'(a)') "123abc" + rewind(11) + i = 0 + do + i = i + 1 +10 read(unit = 11, fmt = '(a)', advance = 'no', end = 99, eor = 11) chr + if (chr.ne.correct(i:i)) STOP 1 + cycle +11 continue + end do +99 close(11) + end Index: Fortran/gfortran/regression/read_repeat.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_repeat.f90 @@ -0,0 +1,25 @@ +! { 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 + + open(10, status="scratch") + 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)) STOP 1 + if (any(iarr(3:5).ne.2)) STOP 2 + if (any(iarr(6:7).ne.0)) STOP 3 + if (ia .ne. 12 .or. ib .ne. 13) STOP 4 + + close(10) +end program rread Index: Fortran/gfortran/regression/read_repeat_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_repeat_2.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! +! PR fortran/56810 +! +! Contributed by Jonathan Hogg +! +program test + implicit none + + integer :: i + complex :: a(4) + + open (99, status='scratch') + write (99, *) '4*(1.0,2.0)' + rewind (99) + read (99,*) a(:) + close (99) + if (any (a /= cmplx (1.0,2.0))) STOP 1 +end program test Index: Fortran/gfortran/regression/read_size_noadvance.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_size_noadvance.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR26890 Test for use of SIZE variable in IO list. +! Test case from Paul Thomas. +! Submitted by Jerry DeLisle + + character(80) :: buffer, line + integer :: nchars + line = "The quick brown fox jumps over the lazy dog." + open (10, status="scratch") + write (10, '(a)') trim(line) + rewind (10) + read (10, '(a)', advance = 'no', size = nchars, eor = 998) buffer + STOP 1 +998 if (nchars.ne.44) STOP 2 + rewind (10) + buffer = "how about some random text here just to be sure on this one." + nchars = 80 + read (10, '(a)', advance = 'no', size = nchars, eor = 999) buffer(:nchars) +999 if (nchars.ne.44) STOP 3 + if (buffer.ne.line) STOP 4 + close (10) +end + Index: Fortran/gfortran/regression/read_x_eof.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_x_eof.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR43265 No EOF condition if reading with '(x)' from an empty file +! Test case from the reporter. +program pr43265 +implicit none +integer::i +open(23,status="scratch") +write(23,'(a)') "Line 1" +write(23,'(a)') "Line 2" +write(23,'(a)') "Line 3" +rewind(23) +do i=1,10 + read(23,'(1x)',end=12) +enddo +12 if (i.ne.4) STOP 1 +end Index: Fortran/gfortran/regression/read_x_eor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_x_eor.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-output "^" } +! +! Test fix for pr24785 - EOR used to scrub the 2X. +! Reduced from PR example submitted by Harald Anlauf +! + program x_with_advance_bug + write (*,'(A,2X)', advance="no") "<" + write (*,'(A)') ">" ! { dg-output "< >" } + end Index: Fortran/gfortran/regression/read_x_past.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/read_x_past.f @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options -w } +! PR 26661 : Test reading X's past file end with no LF or CR. +! PR 26880 : Tests that rewind clears the gfc_unit read_bad flag. +! PR 43265 : Tests that no error occurs with or without X at end. +! Contributed by Jerry DeLisle . + implicit none + character(3) a(4) + integer i + open (10, status="scratch") + 10 format(A,$) ! This is not pedantic + write(10,10)' abc def ghi jkl' + rewind(10) + + a = "" + read(10,20)(a(i),i=1,4) + if (a(4).ne."jkl") STOP 1 + + rewind(10) + + a = "" + read(10,30)(a(i),i=1,4) + if (a(4).ne."jkl") STOP 2 + + 20 format(1x,a3,1x,a3,1x,a3,1x,a3,10x) + 30 format(1x,a3,1x,a3,1x,a3,1x,a3) + close(10) + end Index: Fortran/gfortran/regression/readwrite_unf_direct_eor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/readwrite_unf_direct_eor_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 30056 - exceeding the record length was misrepresented as an EOF +! on read and ignored on write + program main + integer i,j + open (10, form="unformatted", access="direct", recl=4) + write (10, rec=1, err=10) 1,2 + STOP 1 + 10 continue + read (10, rec=1, err=20) i, j + STOP 2 + 20 continue + close (10, status="delete") + end Index: Fortran/gfortran/regression/real4-10-real8-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-10-real8-10.f90 @@ -0,0 +1,25 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-10 -freal-8-real-10" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 10)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 10)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-10-real8-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-10-real8-16.f90 @@ -0,0 +1,26 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-10 -freal-8-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 10)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 16)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-10-real8-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-10-real8-4.f90 @@ -0,0 +1,25 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-10 -freal-8-real-4" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 ! << this is ambiguous: kind=8 → 4 → 10 or 8 → 4; thus,excluded below + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 10)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d5)] /= 4)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-10.f90 @@ -0,0 +1,25 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-10" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 10)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 8)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-16-real8-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-16-real8-10.f90 @@ -0,0 +1,26 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-16 -freal-8-real-10" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 16)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 10)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-16-real8-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-16-real8-16.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-16 -freal-8-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 16)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 16)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-16-real8-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-16-real8-4.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-16 -freal-8-real-4" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 ! << this is ambiguous: kind=8 → 4 → 16 or 8 → 4; thus,excluded below + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 16)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d5)] /= 4)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-16.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 16)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 8)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-8-real8-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-8-real8-10.f90 @@ -0,0 +1,25 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-4-real-8 -freal-8-real-10" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(r1), kind(1.0_4), kind(1.0_k4), kind(r2), kind(r3), kind(r4)] /= 8)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 10)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-8-real8-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-8-real8-16.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-8 -freal-8-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 8)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 16)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-8-real8-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-8-real8-4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-8 -freal-8-real-4" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 ! << this is ambiguous: kind=8 → 4 → 8 or 8 → 4; thus,excluded below + real(selected_real_kind(p=15)) :: d5 + + print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 8)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d5)] /= 4)) stop 2 +end program test Index: Fortran/gfortran/regression/real4-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real4-8.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-4-real-8" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 8)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 8)) stop 2 +end program test Index: Fortran/gfortran/regression/real8-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real8-10.f90 @@ -0,0 +1,25 @@ +! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-w -freal-8-real-10" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 4)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 10)) stop 2 +end program test Index: Fortran/gfortran/regression/real8-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real8-16.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-8-real-16" } +! { dg-require-effective-target fortran_real_16 } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 4)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 16)) stop 2 +end program test Index: Fortran/gfortran/regression/real8-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real8-4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-w -freal-8-real-4" } +! +! PR fortran/99355 +! PR fortran/99355 comment 10 to 13 + PR fortran/57871 +! + +program test + real :: r1 + real*4:: r2 + real(4) :: r3 + real(selected_real_kind(p=6)) :: r4 + integer, parameter :: k4 = 4, k8 = 8 + + double precision :: d1 + real*8 :: d2 + real(8) :: d3 + real(kind(1.d0)) :: d4 + real(selected_real_kind(p=15)) :: d5 + + !print '(tr3,a10,10(tr1,i2))', 'single', kind(r1), kind(r2), kind(r3), kind(r4) + !print '(tr3,a10,10(tr1,i2))', 'double', kind(d1), kind(d2), kind(d3), kind(d4), kind(d5) + if (any ([kind(1.0), kind(1.0_4), kind(1.0_k4), kind(r1), kind(r2), kind(r3), kind(r4)] /= 4)) stop 1 + if (any ([kind(1.d0), kind(1.0_8), kind(1.0_k8), kind(d1), kind(d2), kind(d3), kind(d4), kind(d5)] /= 4)) stop 2 +end program test Index: Fortran/gfortran/regression/real_compare_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_compare_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-Wcompare-reals" } +program main + real :: a + complex :: c + read (*,*) a + read (*,*) c + if (a .eq. 3.14) print *,"foo" ! { dg-warning "Equality comparison for REAL" } + if (3.14 == a) print *,"foo" ! { dg-warning "Equality comparison for REAL" } + if (a .eq. 3) print *,"foo" ! { dg-warning "Equality comparison for REAL" } + if (3. == a) print *,"foo" ! { dg-warning "Equality comparison for REAL" } + if (a .ne. 4.14) print *,"foo" ! { dg-warning "Inequality comparison for REAL" } + if (4.14 /= a) print *,"foo" ! { dg-warning "Inequality comparison for REAL" } + if (a .ne. 4) print *,"foo" ! { dg-warning "Inequality comparison for REAL" } + if (4 /= a) print *,"foo" ! { dg-warning "Inequality comparison for REAL" } + + if (c .eq. (3.14, 2.11)) print *,"foo" ! { dg-warning "Equality comparison for COMPLEX" } + if ((3.14, 2.11) == a) print *,"foo" ! { dg-warning "Equality comparison for COMPLEX" } + if (c .ne. (3.14, 2.11)) print *,"foo" ! { dg-warning "Inequality comparison for COMPLEX" } + if ((3.14, 2.11) /= a) print *,"foo" ! { dg-warning "Inequality comparison for COMPLEX" } +end program main Index: Fortran/gfortran/regression/real_const_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_const_1.f @@ -0,0 +1,24 @@ +c { dg-do run } +c +c Fixed form test program for PR 17941 (signed constants with spaces) +c + program real_const_1 + complex c0, c1, c2, c3, c4 + real rp(4), rn(4) + parameter (c0 = (-0.5, - 0.5)) + parameter (c1 = (- 0.5, + 0.5)) + parameter (c2 = (- 0.5E2, +0.5)) + parameter (c3 = (-0.5, + 0.5E-2)) + parameter (c4 = (- 1, + 1)) + data rn /- 1.0, - 1d0, - 1.d0, - 10.d-1/ + data rp /+ 1.0, + 1d0, + 1.d0, + 10.d-1/ + real, parameter :: del = 1.e-5 + + if (abs(c0 - cmplx(-0.5,-0.5)) > del) STOP 1 + if (abs(c1 - cmplx(-0.5,+0.5)) > del) STOP 2 + if (abs(c2 - cmplx(-0.5E2,+0.5)) > del) STOP 3 + if (abs(c3 - cmplx(-0.5,+0.5E-2)) > del) STOP 4 + if (abs(c4 - cmplx(-1.0,+1.0)) > del) STOP 5 + if (any (abs (rp - 1.0) > del)) STOP 6 + if (any (abs (rn + 1.0) > del)) STOP 7 + end program Index: Fortran/gfortran/regression/real_const_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_const_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! Free form test program for PR 17941 (signed constants with spaces) +! +program real_const_2 + complex c0, c1, c2, c3, c4 + real rp(4), rn(4) + parameter (c0 = (-0.5, - 0.5)) + parameter (c1 = (- 0.5, + 0.5)) + parameter (c2 = (- 0.5E2, +0.5)) + parameter (c3 = (-0.5, + 0.5E-2)) + parameter (c4 = (- 1, + 1)) + data rn /- 1.0, - 1d0, - 1.d0, - 10.d-1/ + data rp /+ 1.0, + 1d0, + 1.d0, + 10.d-1/ + real, parameter :: del = 1.e-5 + + if (abs(c0 - cmplx(-0.5,-0.5)) > del) STOP 1 + if (abs(c1 - cmplx(-0.5,+0.5)) > del) STOP 2 + if (abs(c2 - cmplx(-0.5E2,+0.5)) > del) STOP 3 + if (abs(c3 - cmplx(-0.5,+0.5E-2)) > del) STOP 4 + if (abs(c4 - cmplx(-1.0,+1.0)) > del) STOP 5 + if (any (abs (rp - 1.0) > del)) STOP 6 + if (any (abs (rn + 1.0) > del)) STOP 7 +end program Index: Fortran/gfortran/regression/real_const_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_const_3.f90 @@ -0,0 +1,54 @@ +!{ dg-do run } +!{ dg-options "-fno-range-check" } +!{ dg-add-options ieee } +! PR19310 and PR19904, allow disabling range check during compile. +! Contributed by Jerry DeLisle +program main + character(len=80) str + real, parameter :: zero=0, nan=0/zero + complex :: z = (-0.1,-2.2)/(0.0,0.0) + complex :: z2 = (0.1,1)/0 + complex :: z3 = (1e35, -2e3)/1.234e-37 + complex :: z4 = (1e-35, -2e-35)/1234e34 + real :: a + a = exp(1000.0) + b = 1/exp(1000.0) + + write(str,*) a + if (trim(adjustl(str)) .ne. 'Infinity') STOP 1 + + if (b .ne. 0.) STOP 2 + + write(str,*) -1.0/b + if (trim(adjustl(str)) .ne. '-Infinity') STOP 3 + + write(str,*) b/0.0 + if (trim(adjustl(str)) .ne. 'NaN') STOP 4 + + write(str,*) 0.0/0.0 + if (trim(adjustl(str)) .ne. 'NaN') STOP 5 + + write(str,*) 1.0/(-0.) + if (trim(adjustl(str)) .ne. '-Infinity') STOP 6 + + write(str,*) -2.0/0. + if (trim(adjustl(str)) .ne. '-Infinity') STOP 7 + + write(str,*) 3.0/0. + if (trim(adjustl(str)) .ne. 'Infinity') STOP 8 + + write(str,*) nan + if (trim(adjustl(str)) .ne. 'NaN') STOP 9 + + write(str,*) z + if (trim(adjustl(str)) .ne. '(NaN,NaN)') STOP 10 + + write(str,*) z2 + if (trim(adjustl(str)) .ne. '(NaN,NaN)') STOP 11 + + write(str,*) z3 + if (trim(adjustl(str)) .ne. '(Inf,-Inf)') STOP 12 + + write(str,*) z4 + if (trim(adjustl(str)) .ne. '(0.00000000,-0.00000000)') STOP 13 +end program main Index: Fortran/gfortran/regression/real_dimension_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_dimension_1.f @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 34305 - Test for specifying a real as dimension + program test + real , parameter :: dsize = 1000 + dimension idata (dsize) ! { dg-error "scalar INTEGER expression" } + idata (1) = -1 ! { dg-error "must have the pointer attribute" } + end Index: Fortran/gfortran/regression/real_do_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_do_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-warning "Loop variable" "Loop" { target *-*-* } 13 } +! { dg-warning "Start expression" "Start" { target *-*-* } 13 } +! { dg-warning "End expression" "End" { target *-*-* } 13 } +! { dg-warning "Step expression" "Step" { target *-*-* } 13 } +! Test REAL type iterators in DO loops +program real_do_1 + real x, y + integer n + + n = 0 + y = 1.0 + do x = 1.0, 2.05, 0.1 + call check (x, y) + y = y + 0.1 + n = n + 1 + end do + if (n .ne. 11) STOP 1 +contains +subroutine check (a, b) + real, intent(in) :: a, b + + if (abs (a - b) .gt. 0.00001) STOP 2 +end subroutine +end program Index: Fortran/gfortran/regression/real_index_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/real_index_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! PR 16907 : We didn't support REAL array indices as an extension + integer I, A(10) + A = 2 + I=A(1.0) ! { dg-warning "Extension" } + if (i/=2) STOP 1 + end Index: Fortran/gfortran/regression/realloc_on_assign_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_1.f03 @@ -0,0 +1,80 @@ +! { dg-do run } +! Tests the patch that implements F2003 automatic allocation and +! reallocation of allocatable arrays on assignment. +! +! Contributed by Paul Thomas +! + integer(4), allocatable :: a(:), b(:), c(:,:) + integer(4) :: j + integer(4) :: src(2:5) = [11,12,13,14] + integer(4) :: mat(2:3,5:6) + character(4), allocatable :: chr1(:) + character(4) :: chr2(2) = ["abcd", "wxyz"] + + allocate(a(1)) + mat = reshape (src, [2,2]) + + a = [4,3,2,1] + if (size(a, 1) .ne. 4) STOP 1 + if (any (a .ne. [4,3,2,1])) STOP 2 + + a = [((42 - i), i = 1, 10)] + if (size(a, 1) .ne. 10) STOP 3 + if (any (a .ne. [((42 - i), i = 1, 10)])) STOP 4 + + b = a + if (size(b, 1) .ne. 10) STOP 5 + if (any (b .ne. a)) STOP 6 + + a = [4,3,2,1] + if (size(a, 1) .ne. 4) STOP 7 + if (any (a .ne. [4,3,2,1])) STOP 8 + + a = b + if (size(a, 1) .ne. 10) STOP 9 + if (any (a .ne. [((42 - i), i = 1, 10)])) STOP 10 + + j = 20 + a = [(i, i = 1, j)] + if (size(a, 1) .ne. j) STOP 11 + if (any (a .ne. [(i, i = 1, j)])) STOP 12 + + a = foo (15) + if (size(a, 1) .ne. 15) STOP 13 + if (any (a .ne. [((i + 15), i = 1, 15)])) STOP 14 + + a = src + if (lbound(a, 1) .ne. lbound(src, 1)) STOP 15 + if (ubound(a, 1) .ne. ubound(src, 1)) STOP 16 + if (any (a .ne. [11,12,13,14])) STOP 17 + + k = 7 + a = b(k:8) + if (lbound(a, 1) .ne. lbound (b(k:8), 1)) STOP 18 + if (ubound(a, 1) .ne. ubound (b(k:8), 1)) STOP 19 + if (any (a .ne. [35,34])) STOP 20 + + c = mat + if (any (lbound (c) .ne. lbound (mat))) STOP 21 + if (any (ubound (c) .ne. ubound (mat))) STOP 22 + if (any (c .ne. mat)) STOP 23 + + deallocate (c) + c = mat(2:,:) + if (any (lbound (c) .ne. lbound (mat(2:,:)))) STOP 24 + + chr1 = chr2(2:1:-1) + if (lbound(chr1, 1) .ne. 1) STOP 25 + if (any (chr1 .ne. chr2(2:1:-1))) STOP 26 + + b = c(1, :) + c(2, :) + if (lbound(b, 1) .ne. lbound (c(1, :) + c(2, :), 1)) STOP 27 + if (any (b .ne. c(1, :) + c(2, :))) STOP 28 +contains + function foo (n) result(res) + integer(4), allocatable, dimension(:) :: res + integer(4) :: n + allocate (res(n)) + res = [((i + 15), i = 1, n)] + end function foo +end Index: Fortran/gfortran/regression/realloc_on_assign_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_10.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR52012 - with realloc_lhs active(ie. default condition) the +! offset was wrongly calculated for a, after assignment. +! +! Reported by Reinhold Bader and Tobias Burnus +! +program gf + implicit none + real, allocatable :: a(:,:,:) + real, parameter :: zero = 0.0, one = 1.0 + real :: b(3,4,5) = zero + b(1,2,3) = one + allocate (a(size (b, 3), size (b, 2), size (b, 1))) + a = reshape (b, shape (a), order = [3, 2, 1]) + if (any (a(:, 2, 1) .ne. [zero, zero, one, zero, zero])) STOP 1 + if (a(3, 2, 1) /= one) STOP 1 + if (sum (abs (a)) /= one) STOP 2 +end program Index: Fortran/gfortran/regression/realloc_on_assign_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_11.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR52012 - tests of automatic reallocation on assignment for variable = array_intrinsic +! +! Contributed by Tobias Burnus and Dominique Dhumieres +! + integer, allocatable :: a(:), b(:), e(:,:) + integer :: c(1:5,1:5), d(1:5,1:5) + allocate(b(3)) + b = [1,2,3] + +! Shape conforms so bounds follow allocation. + allocate (a(7:9)) + a = reshape( b, shape=[size(b)]) + if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [7,9,3,3])) STOP 1 + + deallocate (a) +! 'a' not allocated so lbound defaults to 1. + a = reshape( b, shape=[size(b)]) + if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [1,3,3,3])) STOP 2 + + deallocate (a) +! Shape conforms so bounds follow allocation. + allocate (a(0:0)) + a(0) = 1 + if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [0,0,1,1])) STOP 3 + +! 'a' not allocated so lbound defaults to 1. + e = matmul (c(2:5,:), d(:, 3:4)) + if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [1,1,4,2,8,4,2])) STOP 4 + deallocate (e) + +! Shape conforms so bounds follow allocation. + allocate (e(4:7, 11:12)) + e = matmul (c(2:5,:), d(:, 3:4)) + if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [4,11,7,12,8,4,2])) STOP 5 +end Index: Fortran/gfortran/regression/realloc_on_assign_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_12.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! +! PR fortran/52151 +! +! Check that the bounds/shape/strides are correctly set +! for (re)alloc on assignment, if the LHS is either not +! allocated or has the wrong shape. This test is for +! code which is only invoked for libgfortran intrinsic +! such as RESHAPE. +! +! Based on the example of PR 52117 by Steven Hirshman +! + PROGRAM RESHAPEIT + call unalloc () + call wrong_shape () + contains + subroutine unalloc () + INTEGER, PARAMETER :: n1=2, n2=2, n3=2 + INTEGER :: m1, m2, m3, lc + REAL, ALLOCATABLE :: A(:,:), B(:,:,:) + REAL :: val + + ALLOCATE (A(n1,n2*n3)) +! << B is not allocated + + val = 0 + lc = 0 + DO m3=1,n3 + DO m2=1,n2 + lc = lc+1 + DO m1=1,n1 + val = val+1 + A(m1, lc) = val + END DO + END DO + END DO + + B = RESHAPE(A, [n1,n2,n3]) + + if (any (shape (B) /= [n1,n2,n3])) STOP 1 + if (any (ubound (B) /= [n1,n2,n3])) STOP 2 + if (any (lbound (B) /= [1,1,1])) STOP 3 + + lc = 0 + DO m3=1,n3 + DO m2=1,n2 + lc = lc+1 + DO m1=1,n1 +! PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3) + if (A(m1,lc) /= B(m1,m2,m3)) STOP 4 + END DO + END DO + END DO + DEALLOCATE(A, B) + end subroutine unalloc + + subroutine wrong_shape () + INTEGER, PARAMETER :: n1=2, n2=2, n3=2 + INTEGER :: m1, m2, m3, lc + REAL, ALLOCATABLE :: A(:,:), B(:,:,:) + REAL :: val + + ALLOCATE (A(n1,n2*n3)) + ALLOCATE (B(1,1,1)) ! << shape differs from RHS + + val = 0 + lc = 0 + DO m3=1,n3 + DO m2=1,n2 + lc = lc+1 + DO m1=1,n1 + val = val+1 + A(m1, lc) = val + END DO + END DO + END DO + + B = RESHAPE(A, [n1,n2,n3]) + + if (any (shape (B) /= [n1,n2,n3])) STOP 5 + if (any (ubound (B) /= [n1,n2,n3])) STOP 6 + if (any (lbound (B) /= [1,1,1])) STOP 7 + + lc = 0 + DO m3=1,n3 + DO m2=1,n2 + lc = lc+1 + DO m1=1,n1 +! PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3) + if (A(m1,lc) /= B(m1,m2,m3)) STOP 8 + END DO + END DO + END DO + DEALLOCATE(A, B) + end subroutine wrong_shape + END PROGRAM RESHAPEIT Index: Fortran/gfortran/regression/realloc_on_assign_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_13.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Test the fix for PR52386. +! +! Contributed by Juergen Reuter +! +module cascades + implicit none + private +contains + function reduced (array) + integer, dimension(:), allocatable :: reduced + integer, dimension(:), intent(in) :: array + logical, dimension(size(array)) :: mask + mask = .true. + allocate (reduced (count (mask))) + reduced = pack (array, mask) + end function reduced +end module cascades Index: Fortran/gfortran/regression/realloc_on_assign_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_14.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-Wrealloc-lhs-all -Wrealloc-lhs" } +! +! PR fortran/52196 +! +implicit none +type t + integer :: x +end type t +integer, allocatable :: a(:), b +real, allocatable :: r(:) +type(t), allocatable :: c(:) +character(len=:), allocatable :: str +character(len=:), allocatable :: astr(:) + +allocate(a(2), b, c(1)) +b = 4 ! { dg-warning "Code for reallocating the allocatable variable" } +a = [b,b] ! { dg-warning "Code for reallocating the allocatable array" } +c = [t(4)] ! { dg-warning "Code for reallocating the allocatable variable" } +a = 5 ! no realloc +c = t(5) ! no realloc +str = 'abc' ! { dg-warning "Code for reallocating the allocatable variable" } +astr = 'abc' ! no realloc +astr = ['abc'] ! { dg-warning "Code for reallocating the allocatable array" } +a = reshape(a,shape(a)) ! { dg-warning "Code for reallocating the allocatable array" } +r = sin(r) +r = sin(r(1)) ! no realloc +b = sin(r(1)) ! { dg-warning "Code for reallocating the allocatable variable" } + +a = nar() ! { dg-warning "Code for reallocating the allocatable array" } +a = nar2() ! { dg-warning "Code for reallocating the allocatable array" } +contains + function nar() + integer,allocatable :: nar(:) + end function + function nar2() + integer :: nar2(8) + end function +end Index: Fortran/gfortran/regression/realloc_on_assign_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_15.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/53389 +! +! The program was leaking memory before due to +! realloc on assignment and nested functions. +! +module foo + implicit none + contains + + function filler(array, val) + real, dimension(:), intent(in):: array + real, dimension(size(array)):: filler + real, intent(in):: val + + filler=val + + end function filler +end module + +program test + use foo + implicit none + + real, dimension(:), allocatable:: x, y + integer, parameter:: N=1000 !*1000 + integer:: i + +! allocate( x(N) ) + allocate( y(N) ) + y=0.0 + + do i=1, N +! print *,i + x=filler(filler(y, real(2*i)), real(i)) + y=y+x + end do + +end program test Index: Fortran/gfortran/regression/realloc_on_assign_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_16.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Test the fix for PR56008 +! +! Contributed by Stefan Mauerberger +! +PROGRAM main + !USE MPI + + TYPE :: test_typ + REAL, ALLOCATABLE :: a(:) + END TYPE + + TYPE(test_typ) :: xx, yy + TYPE(test_typ), ALLOCATABLE :: conc(:) + + !CALL MPI_INIT(i) + + xx = test_typ( [1.0,2.0] ) + yy = test_typ( [4.0,4.9] ) + + conc = [ xx, yy ] + + if (any (int (10.0*conc(1)%a) .ne. [10,20])) STOP 1 + if (any (int (10.0*conc(2)%a) .ne. [40,49])) STOP 2 + + !CALL MPI_FINALIZE(i) + +END PROGRAM main Index: Fortran/gfortran/regression/realloc_on_assign_16a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_16a.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-Ofast -fno-tree-forwprop" } +! Test that PR 82976 is fixed, this used to ICE. +! +! Contributed by Stefan Mauerberger +! +PROGRAM main + !USE MPI + + TYPE :: test_typ + REAL, ALLOCATABLE :: a(:) + END TYPE + + TYPE(test_typ) :: xx, yy + TYPE(test_typ), ALLOCATABLE :: conc(:) + + !CALL MPI_INIT(i) + + xx = test_typ( [1.0,2.0] ) + yy = test_typ( [4.0,4.9] ) + + conc = [ xx, yy ] + + if (any (int (10.0*conc(1)%a) .ne. [10,20])) STOP 1 + if (any (int (10.0*conc(2)%a) .ne. [40,49])) STOP 2 + + !CALL MPI_FINALIZE(i) + +END PROGRAM main Index: Fortran/gfortran/regression/realloc_on_assign_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_17.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Test the fix for PR47517 +! +! Reported by Tobias Burnus +! from a testcase by James Van Buskirk +module mytypes + implicit none + type label + integer, allocatable :: parts(:) + end type label + type table + type(label), allocatable :: headers(:) + end type table +end module mytypes + +program allocate_assign + use mytypes + implicit none + integer, parameter :: ik8 = selected_int_kind(18) + type(table) x1(2) + type(table) x2(3) + type(table), allocatable :: x(:) + integer i, j, k + integer(ik8) s + call foo + s = 0 + do k = 1, 10000 + x = x1 + s = s+x(2)%headers(2)%parts(2) + x = x2 + s = s+x(2)%headers(2)%parts(2) + end do + if (s .ne. 40000) STOP 1 +contains +! +! TODO - these assignments lose 1872 bytes on x86_64/FC17 +! This is PR38319 +! + subroutine foo + x1 = [table([(label([(j,j=1,3)]),i=1,3)]), & + table([(label([(j,j=1,4)]),i=1,4)])] + + x2 = [table([(label([(j,j=1,4)]),i=1,4)]), & + table([(label([(j,j=1,5)]),i=1,5)]), & + table([(label([(j,j=1,6)]),i=1,6)])] + end subroutine +end program allocate_assign Index: Fortran/gfortran/regression/realloc_on_assign_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_18.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Ensure that for zero-sized array, nonzero memory is allocated +! +type t +end type t + +type(t), allocatable :: x, y(:) + +x = t() +y = [ t :: ] + +if (.not. allocated (x)) STOP 1 +if (.not. allocated (y)) STOP 2 +end + +! { dg-final { scan-tree-dump "x = \\(struct t .\\) __builtin_malloc \\(1\\);" "original" } } +! { dg-final { scan-tree-dump "y.data = \\(void . restrict\\) __builtin_malloc \\(1\\);" "original" } } Index: Fortran/gfortran/regression/realloc_on_assign_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_19.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR 52243 - avoid check for reallocation when doing simple +! assignments with the same variable on both sides. +module foo +contains + elemental function ele(a) + real, intent(in) :: a + real :: ele + ele = 1./(2+a) + end function ele + + subroutine bar(a) + real, dimension(:), allocatable :: a + a = a * 2.0 + a = sin(a-0.3) + a = ele(a) + end subroutine bar +end module foo +! { dg-final { scan-tree-dump-times "alloc" 0 "original" } } Index: Fortran/gfortran/regression/realloc_on_assign_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_2.f03 @@ -0,0 +1,152 @@ +! { dg-do run } +! Tests the patch that implements F2003 automatic allocation and +! reallocation of allocatable arrays on assignment. The tests +! below were generated in the final stages of the development of +! this patch. +! test1 has been corrected for PR47051 +! +! Contributed by Dominique Dhumieres +! and Tobias Burnus +! + integer :: nglobal + call test1 + call test2 + call test3 + call test4 + call test5 + call test6 + call test7 + call test8 +contains + subroutine test1 +! +! Check that the bounds are set correctly, when assigning +! to an array that already has the correct shape. +! + real :: a(10) = 1, b(51:60) = 2 + real, allocatable :: c(:), d(:) + c=a + if (lbound (c, 1) .ne. lbound(a, 1)) STOP 1 + if (ubound (c, 1) .ne. ubound(a, 1)) STOP 2 + c=b +! 7.4.1.3 "If variable is an allocated allocatable variable, it is +! deallocated if expr is an array of different shape or any of the +! corresponding length type parameter values of variable and expr +! differ." Here the shape is the same so the deallocation does not +! occur and the bounds are not recalculated. This was corrected +! for the fix of PR47051. + if (lbound (c, 1) .ne. lbound(a, 1)) STOP 3 + if (ubound (c, 1) .ne. ubound(a, 1)) STOP 4 + d=b + if (lbound (d, 1) .ne. lbound(b, 1)) STOP 5 + if (ubound (d, 1) .ne. ubound(b, 1)) STOP 6 + d=a +! The other PR47051 correction. + if (lbound (d, 1) .ne. lbound(b, 1)) STOP 7 + if (ubound (d, 1) .ne. ubound(b, 1)) STOP 8 + end subroutine + subroutine test2 +! +! Check that the bounds are set correctly, when making an +! assignment with an implicit conversion. First with a +! non-descriptor variable.... +! + integer(4), allocatable :: a(:) + integer(8) :: b(5:6) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) STOP 9 + if (ubound (a, 1) .ne. ubound(b, 1)) STOP 10 + end subroutine + subroutine test3 +! +! ...and now a descriptor variable. +! + integer(4), allocatable :: a(:) + integer(8), allocatable :: b(:) + allocate (b(7:11)) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) STOP 11 + if (ubound (a, 1) .ne. ubound(b, 1)) STOP 12 + end subroutine + subroutine test4 +! +! Check assignments of the kind a = f(...) +! + integer, allocatable :: a(:) + integer, allocatable :: c(:) + a = f() + if (any (a .ne. [1, 2, 3, 4])) STOP 13 + c = a + 8 + a = f (c) + if (any ((a - 8) .ne. [1, 2, 3, 4])) STOP 14 + deallocate (c) + a = f (c) + if (any ((a - 4) .ne. [1, 2, 3, 4])) STOP 15 + end subroutine + function f(b) + integer, allocatable, optional :: b(:) + integer :: f(4) + if (.not.present (b)) then + f = [1,2,3,4] + elseif (.not.allocated (b)) then + f = [5,6,7,8] + else + f = b + end if + end function f + + subroutine test5 +! +! Extracted from rnflow.f90, Polyhedron benchmark suite, +! http://www.polyhedron.com +! + integer, parameter :: ncls = 233, ival = 16, ipic = 17 + real, allocatable, dimension (:,:) :: utrsft + real, allocatable, dimension (:,:) :: dtrsft + real, allocatable, dimension (:,:) :: xwrkt + allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls)) + nglobal = 0 + xwrkt = trs2a2 (ival, ipic, ncls) + if (any (shape (xwrkt) .ne. [ncls, ncls])) STOP 16 + xwrkt = invima (xwrkt, ival, ipic, ncls) + if (nglobal .ne. 1) STOP 17 + if (sum(xwrkt) .ne. xwrkt(ival, ival)) STOP 18 + end subroutine + function trs2a2 (j, k, m) + real, dimension (1:m,1:m) :: trs2a2 + integer, intent (in) :: j, k, m + nglobal = nglobal + 1 + trs2a2 = 0.0 + end function trs2a2 + function invima (a, j, k, m) + real, dimension (1:m,1:m) :: invima + real, dimension (1:m,1:m), intent (in) :: a + integer, intent (in) :: j, k + invima = 0.0 + invima (j, j) = 1.0 / (1.0 - a (j, j)) + end function invima + subroutine test6 + character(kind=1, len=100), allocatable, dimension(:) :: str + str = [ "abc" ] + if (TRIM(str(1)) .ne. "abc") STOP 19 + if (len(str) .ne. 100) STOP 20 + end subroutine + subroutine test7 + character(kind=4, len=100), allocatable, dimension(:) :: str + character(kind=4, len=3) :: test = "abc" + str = [ "abc" ] + if (TRIM(str(1)) .ne. test) STOP 21 + if (len(str) .ne. 100) STOP 22 + end subroutine + subroutine test8 + type t + integer, allocatable :: a(:) + end type t + type(t) :: x + x%a= [1,2,3] + if (any (x%a .ne. [1,2,3])) STOP 23 + x%a = [4] + if (any (x%a .ne. [4])) STOP 24 + end subroutine +end + Index: Fortran/gfortran/regression/realloc_on_assign_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_20.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/43366 +! +! Invalid assignment to an allocatable polymorphic var. +! +type t +end type t +class(t), allocatable :: var + +var = t() ! { dg-error "Fortran 2008: Assignment to an allocatable polymorphic variable" } +end Index: Fortran/gfortran/regression/realloc_on_assign_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_21.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fno-realloc-lhs" } +! +! PR fortran/43366 +! +! Invalid assignment to an allocatable polymorphic var. +! +type t +end type t +class(t), allocatable :: var + +var = t() ! { dg-error "Assignment to an allocatable polymorphic variable at .1. requires '-frealloc-lhs'" } +end Index: Fortran/gfortran/regression/realloc_on_assign_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_22.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/43366 +! +! Invalid assignment to an allocatable polymorphic var. +! +type t +end type t +class(t), allocatable :: caf[:] + +caf = t() ! { dg-error "Assignment to polymorphic coarray at .1. is not permitted" } +end Index: Fortran/gfortran/regression/realloc_on_assign_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_23.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR fortran/57354 +! +! Contributed by Vladimir Fuka +! + type t + integer,allocatable :: i + end type + + type(t) :: e + type(t), allocatable :: a(:) + integer :: chksum = 0 + + do i=1,3 ! Was 100 in original + e%i = i + chksum = chksum + i + if (.not.allocated(a)) then + a = [e] + else + call foo + end if + end do + + if (sum ([(a(i)%i, i=1,size(a))]) .ne. chksum) STOP 1 +contains + subroutine foo + a = [a, e] + end subroutine +end Index: Fortran/gfortran/regression/realloc_on_assign_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_24.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 62142 - this used to segfault +! Original test case by Ondřej Čertík . +program test_segfault + implicit none + real, allocatable :: X(:) + allocate (x(1)) + x = 1. + X = floor(X) +end program Index: Fortran/gfortran/regression/realloc_on_assign_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_25.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR 47674 - this would segfault if MALLOC_PERTURB is set. +! This checks a code path where it is not possible to determine +! the length of the string at compile time. +! +program main + implicit none + character(:), allocatable :: a + integer :: m, n + a = 'a' + if (a .ne. 'a') STOP 1 + a = a // 'x' + if (a .ne. 'ax') STOP 2 + if (len (a) .ne. 2) STOP 3 + n = 2 + m = 2 + a = a(m:n) + if (a .ne. 'x') STOP 4 + if (len (a) .ne. 1) STOP 5 +end program main Index: Fortran/gfortran/regression/realloc_on_assign_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_26.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 68147 - no temprorary within the IF statement. +! Original test case by Martin Reinecke. +program test + implicit none + character(len=:),allocatable ::name + name="./a.out" + if (index(name,"/") /= 0) THEN + name=name(3:) + if (name .ne. "a.out") STOP 1 + endif +end program Index: Fortran/gfortran/regression/realloc_on_assign_27.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_27.f08 @@ -0,0 +1,23 @@ +! { dg-do run } + + type :: t + integer :: i + end type + + type, extends(t) :: r + real :: r + end type + + class(t), allocatable :: x + type(r) :: y = r (3, 42) + + x = y + if (x%i /= 3) STOP 1 + select type(x) + class is (r) + if (x%r /= 42.0) STOP 2 + class default + STOP 3 + end select +end + Index: Fortran/gfortran/regression/realloc_on_assign_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_28.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/66102 +! +! Contributed by Vladimir Fuka +! + type t + integer,allocatable :: i + end type + + type(t) :: e + type(t), allocatable, dimension(:) :: a, b + integer :: chksum = 0 + + do i=1,3 ! Was 100 in original + e%i = i + chksum = chksum + i + if (.not.allocated(a)) then + a = [e] + b = first_arg([e], [e]) + else + call foo + end if + end do + + if (sum ([(a(i)%i, i=1,size(a))]) .ne. chksum) STOP 1 + if (any([(a(i)%i, i=1,size(a))] /= [(i, i=1,size(a))])) STOP 2 + if (size(a) /= size(b)) STOP 3 + if (any([(b(i)%i, i=1,size(b))] /= [(i, i=1,size(b))])) STOP 4 +contains + subroutine foo + b = first_arg([b, e], [a, e]) + a = [a, e] + end subroutine + elemental function first_arg(arg1, arg2) + type(t), intent(in) :: arg1, arg2 + type(t) :: first_arg + first_arg = arg1 + end function first_arg +end Index: Fortran/gfortran/regression/realloc_on_assign_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_29.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR fortran/81116 +! The assignment was broken due to a missing temporary. +! Original test case by Clive Page. + +program test10 + implicit none + character(:), allocatable :: string + ! + string = '1234567890' + string = string(1:5) // string(7:) + if (string /= '123457890') STOP 1 +end program test10 Index: Fortran/gfortran/regression/realloc_on_assign_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_3.f03 @@ -0,0 +1,88 @@ +! { dg-do run } +! Test (re)allocation on assignment of scalars +! +! Contributed by Paul Thomas +! + call test_real + call test_derived + call test_char1 + call test_char4 + call test_deferred_char1 + call test_deferred_char4 +contains + subroutine test_real + real, allocatable :: x + real :: y = 42 + x = 42.0 + if (x .ne. y) STOP 1 + deallocate (x) + x = y + if (x .ne. y) STOP 2 + end subroutine + subroutine test_derived + type :: mytype + real :: x + character(4) :: c + end type + type (mytype), allocatable :: t + t = mytype (99.0, "abcd") + if (t%c .ne. "abcd") STOP 3 + end subroutine + subroutine test_char1 + character(len = 8), allocatable :: c1 + character(len = 8) :: c2 = "abcd1234" + c1 = "abcd1234" + if (c1 .ne. c2) STOP 4 + deallocate (c1) + c1 = c2 + if (c1 .ne. c2) STOP 5 + end subroutine + subroutine test_char4 + character(len = 8, kind = 4), allocatable :: c1 + character(len = 8, kind = 4) :: c2 = 4_"abcd1234" + c1 = 4_"abcd1234" + if (c1 .ne. c2) STOP 6 + deallocate (c1) + c1 = c2 + if (c1 .ne. c2) STOP 7 + end subroutine + subroutine test_deferred_char1 + character(:), allocatable :: c + c = "Hello" + if (c .ne. "Hello") STOP 8 + if (len(c) .ne. 5) STOP 9 + c = "Goodbye" + if (c .ne. "Goodbye") STOP 10 + if (len(c) .ne. 7) STOP 11 +! Check that the hidden LEN dummy is passed by reference + call test_pass_c1 (c) + if (c .ne. "Made in test!") print *, c + if (len(c) .ne. 13) STOP 12 + end subroutine + subroutine test_pass_c1 (carg) + character(:), allocatable :: carg + if (carg .ne. "Goodbye") STOP 13 + if (len(carg) .ne. 7) STOP 14 + carg = "Made in test!" + end subroutine + subroutine test_deferred_char4 + character(:, kind = 4), allocatable :: c + c = 4_"Hello" + if (c .ne. 4_"Hello") STOP 15 + if (len(c) .ne. 5) STOP 16 + c = 4_"Goodbye" + if (c .ne. 4_"Goodbye") STOP 17 + if (len(c) .ne. 7) STOP 18 +! Check that the hidden LEN dummy is passed by reference + call test_pass_c4 (c) + if (c .ne. 4_"Made in test!") print *, c + if (len(c) .ne. 13) STOP 19 + end subroutine + subroutine test_pass_c4 (carg) + character(:, kind = 4), allocatable :: carg + if (carg .ne. 4_"Goodbye") STOP 20 + if (len(carg) .ne. 7) STOP 21 + carg = 4_"Made in test!" + end subroutine +end + Index: Fortran/gfortran/regression/realloc_on_assign_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_30.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 85641 - this used to ICE due do infinite recursion. +! Test case by Antony Lewis. +program tester +character(LEN=:), allocatable :: fields +integer j +character(LEN=4), parameter :: CMB_CL_Fields = 'TEBP' + +fields = '' +j=1 +fields = fields // CMB_CL_Fields(j:j) + +end program tester Index: Fortran/gfortran/regression/realloc_on_assign_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_31.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/87625 +! +! Ensure that "var" gets allocated. +! +! Contributed by Tobias Burnus +! +program test + implicit none + type t + integer :: i + end type t + class(t), allocatable :: var(:) + call poly_init() + print *, var(:)%i + if (lbound(var, 1) /= 1 .and. ubound(var, 1) /= 2) call abort() + if (var(1)%i /= 11 .or. var(2)%i /= 12) call abort() + call poly_init2() + !print *, var(:)%i + if (lbound(var, 1) /= 1 .and. ubound(var, 1) /= 3) call abort() + if (var(1)%i /= 11 .or. var(2)%i /= 12 .or. var(3)%i /= 13) call abort() +contains + subroutine poly_init() + !allocate(var(2)) + var = [t :: t(11), t(12)] + end subroutine poly_init + subroutine poly_init2() + var = [t :: t(11), t(12), t(13)] + end subroutine poly_init2 + end program test Index: Fortran/gfortran/regression/realloc_on_assign_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_32.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Test the fix for PR88980 in which the 'span' field if the descriptor +! for 'Items' was not set, causing the assignment to segfault. +! +! Contributed by Antony Lewis +! +program tester + call gbug +contains + subroutine gbug + type TNameValue + character(LEN=:), allocatable :: Name + end type TNameValue + + type TNameValue_pointer + Type(TNameValue), allocatable :: P + end type TNameValue_pointer + + Type TType + type(TNameValue_pointer), dimension(:), allocatable :: Items + end type TType + Type(TType) T + + allocate(T%Items(2)) + allocate(T%Items(2)%P) + T%Items(2)%P%Name = 'test' + if (T%Items(2)%P%Name .ne. 'test') stop 1 + + end subroutine gbug +end program tester Index: Fortran/gfortran/regression/realloc_on_assign_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_4.f03 @@ -0,0 +1,48 @@ +! { dg-do run } +! Tests function return of deferred length scalars. +! +! Contributed by Paul Thomas +! +module m +contains + function mfoo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(2:4) + end function + function mbar (carg) + character (:), allocatable :: mbar + character (*) :: carg + mbar = carg(2:13) + end function +end module + + use m + character (:), allocatable :: lhs + lhs = foo ("foo calling ") + if (lhs .ne. "foo") STOP 1 + if (len (lhs) .ne. 3) STOP 2 + deallocate (lhs) + lhs = bar ("bar calling - baaaa!") + if (lhs .ne. "bar calling") STOP 3 + if (len (lhs) .ne. 12) STOP 4 + deallocate (lhs) + lhs = mfoo ("mfoo calling ") + if (lhs .ne. "foo") STOP 5 + if (len (lhs) .ne. 3) STOP 6 + deallocate (lhs) + lhs = mbar ("mbar calling - baaaa!") + if (lhs .ne. "bar calling") STOP 7 + if (len (lhs) .ne. 12) STOP 8 +contains + function foo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(1:3) + end function + function bar (carg) + character (:), allocatable :: bar + character (*) :: carg + bar = carg(1:12) + end function +end Index: Fortran/gfortran/regression/realloc_on_assign_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_5.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! Test the fix for PR47523 in which concatenations did not work +! correctly with assignments to deferred character length scalars. +! +! Contributed by Thomas Koenig +! +program main + implicit none + character(:), allocatable :: a, b + a = 'a' + if (a .ne. 'a') STOP 1 + a = a // 'x' + if (a .ne. 'ax') STOP 2 + if (len (a) .ne. 2) STOP 3 + a = (a(2:2)) + if (a .ne. 'x') STOP 4 + if (len (a) .ne. 1) STOP 5 +end program main Index: Fortran/gfortran/regression/realloc_on_assign_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_6.f03 @@ -0,0 +1,126 @@ +! { dg-do compile } +! Test the fix for PR48456 and PR48360 in which the backend +! declarations for components were not located in the automatic +! reallocation on assignments, thereby causing ICEs. +! +! Contributed by Keith Refson +! and Douglas Foulds +! +! This is PR48360 + +module m + type mm + real, dimension(3,3) :: h0 + end type mm +end module m + +module gf33 + + real, allocatable, save, dimension(:,:) :: hmat + +contains + subroutine assignit + + use m + implicit none + + type(mm) :: mmv + + hmat = mmv%h0 + end subroutine assignit +end module gf33 + +! This is PR48456 + +module custom_type + +integer, parameter :: dp = kind(0.d0) + +type :: my_type_sub + real(dp), dimension(5) :: some_vector +end type my_type_sub + +type :: my_type + type(my_type_sub) :: some_element +end type my_type + +end module custom_type + +module custom_interfaces + +interface + subroutine store_data_subroutine(vec_size) + implicit none + integer, intent(in) :: vec_size + integer :: k + end subroutine store_data_subroutine +end interface + +end module custom_interfaces + +module store_data_test + +use custom_type + +save +type(my_type), dimension(:), allocatable :: some_type_to_save + +end module store_data_test + +program test + +use store_data_test + +integer :: vec_size + +vec_size = 2 + +call store_data_subroutine(vec_size) +call print_after_transfer() + +end program test + +subroutine store_data_subroutine(vec_size) + +use custom_type +use store_data_test + +implicit none + +integer, intent(in) :: vec_size +integer :: k + +allocate(some_type_to_save(vec_size)) + +do k = 1,vec_size + + some_type_to_save(k)%some_element%some_vector(1) = 1.0_dp + some_type_to_save(k)%some_element%some_vector(2) = 2.0_dp + some_type_to_save(k)%some_element%some_vector(3) = 3.0_dp + some_type_to_save(k)%some_element%some_vector(4) = 4.0_dp + some_type_to_save(k)%some_element%some_vector(5) = 5.0_dp + +end do + +end subroutine store_data_subroutine + +subroutine print_after_transfer() + +use custom_type +use store_data_test + +implicit none + +real(dp), dimension(:), allocatable :: C_vec +integer :: k + +allocate(C_vec(5)) + +do k = 1,size(some_type_to_save) + + C_vec = some_type_to_save(k)%some_element%some_vector + print *, "C_vec", C_vec + +end do + +end subroutine print_after_transfer Index: Fortran/gfortran/regression/realloc_on_assign_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_7.f03 @@ -0,0 +1,84 @@ +! { dg-do run } +! Check the fix for PR48462 in which the assignments involving matmul +! seg faulted because a was automatically freed before the assignment. +! Since it is related, the test for the fix of PR48746 has been added +! as a subroutine by that name. +! +! Contributed by John Nedney +! +program main + implicit none + integer, parameter :: dp = kind(0.0d0) + real(kind=dp), allocatable :: delta(:,:) + real(kind=dp), allocatable, target :: a(:,:) + real(kind=dp), pointer :: aptr(:,:) + + allocate(a(3,3)) + aptr => a + + call foo + if (.not. associated (aptr, a)) STOP 1 ! reallocated to same size - remains associated + call bar + if (.not. associated (aptr, a)) STOP 2 ! reallocated to smaller size - remains associated + call foobar + if (associated (aptr, a)) STOP 3 ! reallocated to larger size - disassociates + + call pr48746 +contains +! +! Original reduced version from comment #2 + subroutine foo + implicit none + real(kind=dp), allocatable :: b(:,:) + + allocate(b(3,3)) + allocate(delta(3,3)) + + a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) + b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3]) + + a = matmul( matmul( a, b ), b ) + delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2 + if (any (delta > 1d-12)) STOP 1 + if (any (lbound (a) .ne. [1, 1])) STOP 2 + end subroutine +! +! Check that all is well when the shape of 'a' changes. + subroutine bar + implicit none + real(kind=dp), allocatable :: a(:,:) + real(kind=dp), allocatable :: b(:,:) + + b = reshape ([1d0, 1d0, 1d0], [3,1]) + a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) + + a = matmul( a, matmul( a, b ) ) + + delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2 + if (any (delta > 1d-12)) STOP 3 + if (any (lbound (a) .ne. [1, 1])) STOP 4 + end subroutine + subroutine foobar + integer :: i + a = reshape ([(real(i, dp), i = 1, 100)],[10,10]) + end subroutine + subroutine pr48746 +! This is a further wrinkle on the original problem and came about +! because the dtype field of the result argument, passed to matmul, +! was not being set. This is needed by matmul for the rank. +! +! Contributed by Thomas Koenig +! + implicit none + integer, parameter :: m=10, n=12, count=4 + real :: optmatmul(m, n) + real :: a(m, count), b(count, n), c(m, n) + real, dimension(:,:), allocatable :: tmp + call random_number(a) + call random_number(b) + tmp = matmul(a,b) + if (any (lbound (tmp) .ne. [1,1])) STOP 5 + if (any (ubound (tmp) .ne. [10,12])) STOP 6 + end subroutine +end program main + Index: Fortran/gfortran/regression/realloc_on_assign_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_8.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/51448 +! +! Contribued by François Willot +! + PROGRAM MAIN + IMPLICIT NONE + TYPE mytype + REAL b(2) + END TYPE mytype + TYPE(mytype) a + DOUBLE PRECISION, ALLOCATABLE :: x(:) + ALLOCATE(x(2)) + a%b=0.0E0 + x=a%b + END Index: Fortran/gfortran/regression/realloc_on_assign_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/realloc_on_assign_9.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR fortran/51869 +! +module soop_stars_class + implicit none + type soop_stars + real ,dimension(:,:) ,allocatable :: position + end type + type show + type(soop_stars) :: rocket + end type +contains + function new_show(boom) + type(soop_stars) ,intent(in) :: boom + type(show) :: new_show + new_show%rocket = boom + end function +end module + +program main + use soop_stars_class + implicit none + + type(soop_stars) :: fireworks + type(show), allocatable :: july4 + + allocate (fireworks%position(2,2)) + fireworks%position = 33.0 + + july4 = new_show(boom=fireworks) +end program Index: Fortran/gfortran/regression/reassoc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -fdump-tree-optimized" } + +function test(b) + real a + a = (b + 5.) - 5. + test = a +end + +! We need an explicit +5 and -5, and an intermediate ((bla)) expression +! (the reassoc barrier). Make use of "." matching lineends. +! { dg-final { scan-tree-dump "\\\+ 5.*\\\)\\\).* - 5" "optimized" } } Index: Fortran/gfortran/regression/reassoc_10.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_10.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -ffp-contract=off -fdump-tree-optimized" } + + SUBROUTINE S55199(P,Q,Dvdph) + implicit none + real(8) :: c1,c2,c3,P,Q,Dvdph + c1=0.1d0 + c2=0.2d0 + c3=0.3d0 + Dvdph = c1 + 2.*P*c2 + 3.*P**2*Q**3*c3 + END + +! There should be five multiplies following un-distribution +! and power expansion. + +! { dg-final { scan-tree-dump-times " \\\* " 5 "optimized" } } Index: Fortran/gfortran/regression/reassoc_11.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_11.f @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } + +! This tests only for compile-time failure, which formerly occurred +! when a __builtin_powi was introduced by reassociation in a bad place. + + SUBROUTINE GRDURBAN(URBWSTR, ZIURB, GRIDHT) + + IMPLICIT NONE + INTEGER :: I + REAL :: SW2, URBWSTR, ZIURB, GRIDHT(87) + + SAVE + + SW2 = 1.6*(GRIDHT(I)/ZIURB)**0.667*URBWSTR**2 + + END Index: Fortran/gfortran/regression/reassoc_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_12.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-options "-O2 -ffast-math" } +! PR middle-end/57370 + + SUBROUTINE xb88_lr_adiabatic_lda_calc(e_ndrho_ndrho_ndrho, & + grad_deriv,npoints, sx) + IMPLICIT REAL*8 (t) + INTEGER, PARAMETER :: dp=8 + REAL(kind=dp), DIMENSION(1:npoints) :: e_ndrho_ndrho_ndrho, & + e_ndrho_ndrho_rho + DO ii=1,npoints + IF( grad_deriv >= 2 .OR. grad_deriv == -2 ) THEN + t1425 = t233 * t557 + t1429 = beta * t225 + t1622 = t327 * t1621 + t1626 = t327 * t1625 + t1632 = t327 * t1631 + t1685 = t105 * t1684 + t2057 = t1636 + t8 * (t2635 + t3288) + END IF + IF( grad_deriv >= 3 .OR. grad_deriv == -3 ) THEN + t5469 = t5440 - t5443 - t5446 - t5449 - & + t5451 - t5454 - t5456 + t5459 - & + t5462 + t5466 - t5468 + t5478 = 0.240e2_dp * t1616 * t973 * t645 * t1425 + t5489 = 0.1600000000e2_dp * t1429 * t1658 + t5531 = 0.160e2_dp * t112 * t1626 + t5533 = 0.160e2_dp * t112 * t1632 + t5537 = 0.160e2_dp * t112 * t1622 + t5541 = t5472 - t5478 - t5523 + t5525 + & + t5531 + t5533 + t5535 + t5537 + & + t5540 + t5565 = t112 * t1685 + t5575 = t5545 - t5548 + t5551 + t5553 - & + t5558 + t5560 - t5562 + t5564 - & + 0.80e1_dp * t5565 + t5568 + t5572 + & + t5574 + t5611 = t5579 - t5585 + t5590 - t5595 + & + t5597 - t5602 + t5604 + t5607 + & + t5610 + t5613 = t5469 + t5541 + t5575 + t5611 + t6223 = t6189 - & + 0.3333333336e0_dp * t83 * t84 * t5613 + & + t6222 + t6227 = - t8 * (t5305 + t6223) + e_ndrho_ndrho_rho(ii) = e_ndrho_ndrho_rho(ii) + & + t6227 * sx + t6352 = t5440 - t5443 - t5446 - t5449 - & + t5451 - t5454 + & + 0.40e1_dp * t102 * t327 * t2057 * t557 - & + t5456 + t5459 - t5462 + t5466 - & + t5468 + t6363 = t5480 - t5489 + & + 0.9600000000e2_dp * t1054 * t640 * t3679 + t6367 = t5472 - t5474 - t5478 - t5523 + & + t5525 + t5531 + t5533 + t5535 + & + t5537 - 0.20e1_dp * t102 * t105 * t6363 + & + t5540 + t6370 = t5545 - t5548 + t5551 + t5553 - & + t5558 + t5560 - t5562 + t5564 - & + 0.40e1_dp * t5565 + & + t5568 + t5572 + t5574 + t6373 = t5579 - t5585 + t5590 - t5595 + & + t5597 - t5602 + t5604 + t5607 + & + t5610 + t6375 = t6352 + t6367 + t6370 + t6373 + t6380 = - 0.3333333336e0_dp * t83 * t84 * t6375 + t5701 + t6669 = -t4704 - t8 * (t6344 + t6380 + t6665) + e_ndrho_ndrho_ndrho(ii) = e_ndrho_ndrho_ndrho(ii) + & + t6669 * sx + END IF + END DO + END SUBROUTINE xb88_lr_adiabatic_lda_calc + Index: Fortran/gfortran/regression/reassoc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -fdump-tree-optimized" } + +! Make sure that FRE does not replace c with b in d = c - 5 + +function test(a) + real a, b, c, d + b = a + 5. + c = (a + 5.) + d = c - 5. + call foo(b) + test = d +end + +! { dg-final { scan-tree-dump "- 5" "optimized" } } Index: Fortran/gfortran/regression/reassoc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O -ffast-math -fdump-tree-original -fdump-tree-optimized" } + +! Verify we associate properly during folding +! Verify we propagate constants in the presence of PAREN_EXPR + +function test(a) + real b, c, d + c = a + d = 5 + b = (c + 5 - c) + b = (c + d - c) + test = a + b - 5 +end + +! { dg-final { scan-tree-dump "b = 5" "original" } } +! { dg-final { scan-tree-dump-times " = " 1 "optimized" } } Index: Fortran/gfortran/regression/reassoc_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_4.f @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -fdump-tree-reassoc1 --param max-completely-peeled-insns=200" } + subroutine anisonl(w,vo,anisox,s,ii1,jj1,weight) + integer ii1,jj1,i1,iii1,j1,jjj1,k1,l1,m1,n1 + real*8 w(3,3),vo(3,3),anisox(3,3,3,3),s(60,60),weight +! +! This routine replaces the following lines in e_c3d.f for +! an anisotropic material +! + do i1=1,3 + iii1=ii1+i1-1 + do j1=1,3 + jjj1=jj1+j1-1 + do k1=1,3 + do l1=1,3 + s(iii1,jjj1)=s(iii1,jjj1) + & +anisox(i1,k1,j1,l1)*w(k1,l1)*weight + do m1=1,3 + s(iii1,jjj1)=s(iii1,jjj1) + & +anisox(i1,k1,m1,l1)*w(k1,l1) + & *vo(j1,m1)*weight + & +anisox(m1,k1,j1,l1)*w(k1,l1) + & *vo(i1,m1)*weight + do n1=1,3 + s(iii1,jjj1)=s(iii1,jjj1) + & +anisox(m1,k1,n1,l1) + & *w(k1,l1)*vo(i1,m1)*vo(j1,n1)*weight + enddo + enddo + enddo + enddo + enddo + enddo + + return + end + +! There should be 22 multiplications left after un-distributing +! weigth, w(k1,l1), vo(i1,m1) and vo(j1,m1) on the innermost two +! unrolled loops. + +! { dg-final { scan-tree-dump-times "\[0-9\] \\\* " 22 "reassoc1" } } Index: Fortran/gfortran/regression/reassoc_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -fdump-tree-optimized -fno-protect-parens" } +! +! PR fortran/35259 +! Test for -fno-protect-parens +! +function test(b) + real a + a = (b + 5.) - 5. + test = a +end + +! Test copied from reassoc_1.f90 which checked for -fprotect-parens (default), +! and thus for the occurance of "5 - 5". +! +! We need an explicit +5 and -5, and an intermediate ((bla)) expression +! (the reassoc barrier). Make use of "." matching lineends. +! { dg-final { scan-tree-dump-times "\\\+ 5.*\\\)\\\).* - 5" 0 "optimized" } } Index: Fortran/gfortran/regression/reassoc_6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_6.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } + + subroutine test(nb,nx,r2) + implicit none + integer nb,nx,i,l + real*8 r2(nb,nx) + + + do i=1,nx + do l=1,nb + r2(l,i)=0.0d0 + enddo + enddo + + return + end +! Verify that offset of the first element is simplified +! { dg-final { scan-tree-dump-not "~" "optimized" } } Index: Fortran/gfortran/regression/reassoc_7.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_7.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -ffp-contract=off -fdump-tree-optimized" } + + SUBROUTINE S55199(P,Dvdph) + implicit none + real(8) :: c1,c2,c3,P,Dvdph + c1=0.1d0 + c2=0.2d0 + c3=0.3d0 + Dvdph = c1 + 2.*P*c2 + 3.*P**2*c3 + END + +! There should be two multiplies following un-distribution. + +! { dg-final { scan-tree-dump-times " \\\* " 2 "optimized" } } Index: Fortran/gfortran/regression/reassoc_8.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_8.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -ffp-contract=off -fdump-tree-optimized" } + + SUBROUTINE S55199(P,Dvdph) + implicit none + real(8) :: c1,c2,c3,P,Dvdph + c1=0.1d0 + c2=0.2d0 + c3=0.3d0 + Dvdph = c1 + 2.*P**2*c2 + 3.*P**3*c3 + END + +! There should be three multiplies following un-distribution +! and power expansion. + +! { dg-final { scan-tree-dump-times " \\\* " 3 "optimized" } } Index: Fortran/gfortran/regression/reassoc_9.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reassoc_9.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math -ffp-contract=off -fdump-tree-optimized" } + + SUBROUTINE S55199(P,Dvdph) + implicit none + real(8) :: c1,c2,c3,P,Dvdph + c1=0.1d0 + c2=0.2d0 + c3=0.3d0 + Dvdph = c1 + 2.*P**2*c2 + 3.*P**4*c3 + END + +! There should be three multiplies following un-distribution +! and power expansion. + +! { dg-final { scan-tree-dump-times " \\\* " 3 "optimized" } } Index: Fortran/gfortran/regression/record_marker_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/record_marker_1.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-frecord-marker=4" } + +program main + implicit none + integer(kind=4) :: i1, i2, i3 + + open(15,form="UNFORMATTED") + write (15) 1_4 + close (15) + open (15,form="UNFORMATTED",access="DIRECT",recl=4) + i1 = 1_4 + i2 = 2_4 + i3 = 3_4 + read (15,rec=1) i1 + read (15,rec=2) i2 + read (15,rec=3) i3 + close (15, status="DELETE") + if (i1 /= 4_4) STOP 1 + if (i2 /= 1_4) STOP 2 + if (i3 /= 4_4) STOP 3 + + open(15,form="UNFORMATTED",convert="SWAP") + write (15) 1_4 + close (15) + open (15,form="UNFORMATTED",access="DIRECT",convert="SWAP",recl=4) + i1 = 1_4 + i2 = 2_4 + i3 = 3_4 + read (15,rec=1) i1 + read (15,rec=2) i2 + read (15,rec=3) i3 + close(15,status="DELETE") + if (i1 /= 4_4) STOP 4 + if (i2 /= 1_4) STOP 5 + if (i3 /= 4_4) STOP 6 + +end program main Index: Fortran/gfortran/regression/record_marker_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/record_marker_2.f @@ -0,0 +1,83 @@ +! { dg-do run { target fd_truncate } } +! { dg-options "-frecord-marker=4" } +! This file is all about BACKSPACE +! Adapted from gfortran.dg/backspace.f + + integer i, n, nr + real x(10), y(10) + +! PR libfortran/20068 + open (20, status='scratch') + write (20,*) 1 + write (20,*) 2 + write (20,*) 3 + rewind (20) + read (20,*) i + if (i .ne. 1) STOP 1 + backspace (20) + read (20,*) i + if (i .ne. 1) STOP 2 + close (20) + +! PR libfortran/20125 + open (20, status='scratch') + write (20,*) 7 + backspace (20) + read (20,*) i + if (i .ne. 7) STOP 3 + close (20) + + open (20, status='scratch', form='unformatted') + write (20) 8 + backspace (20) + read (20) i + if (i .ne. 8) STOP 4 + close (20) + +! PR libfortran/20471 + do n = 1, 10 + x(n) = sqrt(real(n)) + end do + open (3, form='unformatted', status='scratch') + write (3) (x(n),n=1,10) + backspace (3) + rewind (3) + read (3) (y(n),n=1,10) + + do n = 1, 10 + if (abs(x(n)-y(n)) > 0.00001) STOP 5 + end do + close (3) + +! PR libfortran/20156 + open (3, form='unformatted', status='scratch') + do i = 1, 5 + x(1) = i + write (3) n, (x(n),n=1,10) + end do + nr = 0 + rewind (3) + 20 continue + read (3,end=30,err=90) n, (x(n),n=1,10) + nr = nr + 1 + goto 20 + 30 continue + if (nr .ne. 5) STOP 6 + + do i = 1, nr+1 + backspace (3) + end do + + do i = 1, nr + read(3,end=70,err=90) n, (x(n),n=1,10) + if (abs(x(1) - i) .gt. 0.001) STOP 7 + end do + close (3) + stop + + 70 continue + STOP 8 + 90 continue + STOP 9 + + end Index: Fortran/gfortran/regression/record_marker_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/record_marker_3.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-frecord-marker=8" } + +program main + implicit none + integer (kind=8) :: i1, i2, i3 + + open(15,form="UNFORMATTED") + write (15) 1_8 + close (15) + open (15,form="UNFORMATTED",access="DIRECT",recl=8) + i1 = 1 + i2 = 2 + i3 = 3 + read (15,rec=1) i1 + read (15,rec=2) i2 + read (15,rec=3) i3 + close (15, status="DELETE") + if (i1 /= 8) STOP 1 + if (i2 /= 1) STOP 2 + if (i3 /= 8) STOP 3 + + open(15,form="UNFORMATTED",convert="SWAP") + write (15) 1_8 + close (15) + open (15,form="UNFORMATTED",access="DIRECT",convert="SWAP",recl=8) + i1 = 1 + i2 = 2 + i3 = 3 + read (15,rec=1) i1 + read (15,rec=2) i2 + read (15,rec=3) i3 + close(15,status="DELETE") + if (i1 /= 8) STOP 4 + if (i2 /= 1) STOP 5 + if (i3 /= 8) STOP 6 + +end program main Index: Fortran/gfortran/regression/recursive_alloc_comp_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_alloc_comp_1.f08 @@ -0,0 +1,70 @@ +! { dg-do run } +! +! Tests functionality of recursive allocatable derived types. +! + type :: recurses + type(recurses), allocatable :: c + integer, allocatable :: ia + end type + + type(recurses), allocatable, target :: a, d + type(recurses), pointer :: b + + integer :: total = 0 + +! Check chained allocation. + allocate(a) + a%ia = 1 + allocate (a%c) + a%c%ia = 2 + +! Check move_alloc. + allocate (d) + d%ia = 3 + call move_alloc (d, a%c%c) + + if (a%ia .ne. 1) STOP 1 + if (a%c%ia .ne. 2) STOP 2 + if (a%c%c%ia .ne. 3) STOP 3 + +! Check that we can point anywhere in the chain + b => a%c%c + if (b%ia .ne. 3) STOP 4 + b => a%c + if (b%ia .ne. 2) STOP 5 + +! Check that the pointer can be used as if it were an element in the chain. + if (.not.allocated (b%c)) STOP 6 + b => a%c%c + if (.not.allocated (b%c)) allocate (b%c) + b%c%ia = 4 + if (a%c%c%c%ia .ne. 4) STOP 7 + +! A rudimentary iterator. + b => a + do while (associated (b)) + total = total + b%ia + b => b%c + end do + if (total .ne. 10) STOP 8 + +! Take one element out of the chain. + call move_alloc (a%c%c, d) + call move_alloc (d%c, a%c%c) + if (d%ia .ne. 3) STOP 9 + deallocate (d) + +! Checkcount of remaining chain. + total = 0 + b => a + do while (associated (b)) + total = total + b%ia + b => b%c + end do + if (total .ne. 7) STOP 10 + +! Deallocate to check that there are no memory leaks. + deallocate (a%c%c) + deallocate (a%c) + deallocate (a) +end Index: Fortran/gfortran/regression/recursive_alloc_comp_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_alloc_comp_2.f08 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Tests functionality of recursive allocatable derived types. +! +module m + type :: recurses + type(recurses), allocatable :: left + type(recurses), allocatable :: right + integer, allocatable :: ia + end type +contains +! Obtain checksum from "keys". + recursive function foo (this) result (res) + type(recurses) :: this + integer :: res + res = this%ia + if (allocated (this%left)) res = res + foo (this%left) + if (allocated (this%right)) res = res + foo (this%right) + end function +! Return pointer to member of binary tree matching "key", null otherwise. + recursive function bar (this, key) result (res) + type(recurses), target :: this + type(recurses), pointer :: res + integer :: key + if (key .eq. this%ia) then + res => this + return + else + res => NULL () + end if + if (allocated (this%left)) res => bar (this%left, key) + if (associated (res)) return + if (allocated (this%right)) res => bar (this%right, key) + end function +end module + + use m + type(recurses), allocatable, target :: a + type(recurses), pointer :: b => NULL () + +! Check chained allocation. + allocate(a) + a%ia = 1 + allocate (a%left) + a%left%ia = 2 + allocate (a%left%left) + a%left%left%ia = 3 + allocate (a%left%right) + a%left%right%ia = 4 + allocate (a%right) + a%right%ia = 5 + +! Checksum OK? + if (foo(a) .ne. 15) STOP 1 + +! Return pointer to tree item that is present. + b => bar (a, 3) + if (.not.associated (b) .or. (b%ia .ne. 3)) STOP 2 +! Return NULL to tree item that is not present. + b => bar (a, 6) + if (associated (b)) STOP 3 + +! Deallocate to check that there are no memory leaks. + deallocate (a) +end Index: Fortran/gfortran/regression/recursive_alloc_comp_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_alloc_comp_3.f08 @@ -0,0 +1,61 @@ +! { dg-do run } +! +! Tests functionality of recursive allocatable derived types. +! +module m + type :: stack + integer :: value + integer :: index + type(stack), allocatable :: next + end type stack +end module + + use m +! Here is how to add a new entry at the top of the stack: + type (stack), allocatable :: top, temp, dum + + call poke (1) + call poke (2) + call poke (3) + if (top%index .ne. 3) STOP 1 + call output (top) + call pop + if (top%index .ne. 2) STOP 2 + call output (top) + deallocate (top) +contains + subroutine output (arg) + type(stack), target, allocatable :: arg + type(stack), pointer :: ptr + + if (.not.allocated (arg)) then + print *, "empty stack" + return + end if + + print *, " idx value" + ptr => arg + do while (associated (ptr)) + print *, ptr%index, " ", ptr%value + ptr => ptr%next + end do + end subroutine + subroutine poke(arg) + integer :: arg + integer :: idx + if (allocated (top)) then + idx = top%index + 1 + else + idx = 1 + end if + allocate (temp) + temp%value = arg + temp%index = idx + call move_alloc(top,temp%next) + call move_alloc(temp,top) + end subroutine + subroutine pop + call move_alloc(top%next,temp) + call move_alloc(temp,top) + end subroutine +end Index: Fortran/gfortran/regression/recursive_alloc_comp_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_alloc_comp_4.f08 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! Tests functionality of recursive allocatable derived types. +! Here the recursive components are arrays, unlike the first three testcases. +! Notice that array components are fiendishly difficult to use :-( +! +module m + type :: recurses + type(recurses), allocatable :: c(:) + integer, allocatable :: ia + end type +end module + + use m + type(recurses), allocatable, target :: a, d(:) + type(recurses), pointer :: b1 + + integer :: total = 0 + +! Check chained allocation. + allocate(a) + a%ia = 1 + allocate (a%c(2)) + b1 => a%c(1) + b1%ia = 2 + +! Check move_alloc. + allocate (d(2)) + d(1)%ia = 3 + d(2)%ia = 4 + b1 => d(2) + allocate (b1%c(1)) + b1 => b1%c(1) + b1%ia = 5 + call move_alloc (d, a%c(2)%c) + + if (a%ia .ne. 1) STOP 1 + if (a%c(1)%ia .ne. 2) STOP 2 + if (a%c(2)%c(1)%ia .ne. 3) STOP 3 + if (a%c(2)%c(2)%ia .ne. 4) STOP 4 + if (a%c(2)%c(2)%c(1)%ia .ne. 5) STOP 5 + + if (allocated (a)) deallocate (a) + if (allocated (d)) deallocate (d) + +end Index: Fortran/gfortran/regression/recursive_check_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_1.f @@ -0,0 +1,27 @@ +! { dg-do compile } +! PR fortran/26551 + SUBROUTINE SUB() + CALL SUB() ! { dg-error "is not RECURSIVE" } + END SUBROUTINE + + FUNCTION FUNC() RESULT (FOO) + INTEGER FOO + FOO = FUNC() ! { dg-error "is not RECURSIVE" } + END FUNCTION + + SUBROUTINE SUB2() + ENTRY ENT2() + CALL ENT2() ! { dg-error "is not RECURSIVE" } + END SUBROUTINE + + function func2() + integer func2 + func2 = 42 + return + entry c() result (foo) + foo = b() ! { dg-error "is not RECURSIVE" } + return + entry b() result (bar) + bar = 12 + return + end function Index: Fortran/gfortran/regression/recursive_check_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_10.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! +! PR fortran/39577 +! +! OK - no recursion +program test + integer :: i + i = f(.false.) + print *,i + i = f(.false.) + print *,i +contains + integer function f(rec) + logical :: rec + if(rec) then + f = g() + else + f = 42 + end if + end function f + integer function g() + g = f(.false.) + end function g +end program test Index: Fortran/gfortran/regression/recursive_check_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_11.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! { dg-shouldfail "Recursion check" } +! +! { dg-output "Fortran runtime error: Recursive call to nonrecursive procedure 'f'" } +! +! PR fortran/39577 +! +! wrong - recursion +program test + integer :: i + i = f(.false.) + print *,i + i = f(.true.) + print *,i +contains + integer function f(rec) + logical :: rec + if(rec) then + f = g() + else + f = 42 + end if + end function f + integer function g() + g = f(.false.) + end function g +end program test Index: Fortran/gfortran/regression/recursive_check_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_12.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! +! PR fortran/39577 +! +! OK - no recursion +module m + implicit none +contains + subroutine f(rec) + logical :: rec + if(rec) then + call h() + end if + return + entry g() + end subroutine f + subroutine h() + call f(.false.) + end subroutine h +end module m + +program test + use m + implicit none + call f(.false.) + call f(.false.) +end program test Index: Fortran/gfortran/regression/recursive_check_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_13.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! { dg-shouldfail "Recursion check" } +! +! { dg-output "Fortran runtime error: Recursive call to nonrecursive procedure 'master.0.f'" } +! +! PR fortran/39577 +! +! invalid - recursion +module m + implicit none +contains + subroutine f(rec) + logical :: rec + if(rec) then + call h() + end if + return + entry g() + end subroutine f + subroutine h() + call f(.false.) + end subroutine h +end module m + +program test + use m + implicit none + call f(.false.) + call f(.true.) +end program test Index: Fortran/gfortran/regression/recursive_check_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_14.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! +! PR fortran/39577 +! +! Recursive but valid program +! Contributed by Dominique Dhumieres +! +recursive function fac(i) result (res) + integer :: i, j, k, res + k = 1 + goto 100 +entry bifac(i,j) result (res) + k = j +100 continue + if (i < k) then + res = 1 + else + res = i * bifac(i-k,k) + end if +end function + +program test +interface + recursive function fac(n) result (res) + integer :: res + integer :: n + end function fac + recursive function bifac(m,n) result (res) + integer :: m, n, res + end function bifac +end interface + + print *, fac(5) + print *, bifac(5,2) + print*, fac(6) + print *, bifac(6,2) + print*, fac(0) + print *, bifac(1,2) +end program test Index: Fortran/gfortran/regression/recursive_check_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_15.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR41909 ICE with "call foo" in "program foo" +program test ! { dg-error "Global name" } + implicit none + call test() ! { dg-error "" } +contains + subroutine one(a) + real, dimension(:,:), intent(inout), optional :: a + call two(a) + end subroutine one +end program test + Index: Fortran/gfortran/regression/recursive_check_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_16.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! ! { dg-options "-fcheck=recursion" } +! PR 95743 - this used cause a runtime error. +! Test case by Antoine Lemoine + +program test_recursive_call + implicit none + + type t_tree_node + type(t_tree_node), dimension(:), allocatable :: child + end type + + type t_tree + type(t_tree_node), allocatable :: root + end type + + type(t_tree), allocatable :: tree + + allocate(tree) + allocate(tree%root) + allocate(tree%root%child(1)) + ! If the line below is removed, the code works fine. + allocate(tree%root%child(1)%child(1)) + deallocate(tree) +end program Index: Fortran/gfortran/regression/recursive_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/26551 + function func2() + integer func2 + func2 = 42 + return + entry c() result (foo) + foo = barbar() + return + entry b() result (bar) + bar = 12 + return + contains + function barbar () + barbar = b () ! { dg-error "is not RECURSIVE" } + end function barbar + end function Index: Fortran/gfortran/regression/recursive_check_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +module m1 +contains +pure pure subroutine a1(b) ! { dg-error "Duplicate PURE attribute specified" } + real, intent(in) :: b ! { dg-error "Unexpected data declaration statement" } +end subroutine a1 ! { dg-error "Expecting END MODULE" } +end module m1 + +module m2 +contains +elemental elemental subroutine a2(b) ! { dg-error "Duplicate ELEMENTAL attribute" } + real, intent(in) :: b ! { dg-error "Unexpected data declaration statement" } +end subroutine a2 ! { dg-error "Expecting END MODULE" } +end module m2 + +module m3 +contains +recursive recursive subroutine a3(b) ! { dg-error "Duplicate RECURSIVE attribute" } + real, intent(in) :: b ! { dg-error "Unexpected data declaration statement" } +end subroutine a3 ! { dg-error "Expecting END MODULE" } +end module m3 Index: Fortran/gfortran/regression/recursive_check_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_4.f03 @@ -0,0 +1,34 @@ +! { dg-do compile } + +! PR fortran/37779 +! Check that using a non-recursive procedure as "value" is an error. + +MODULE m + IMPLICIT NONE + +CONTAINS + + SUBROUTINE test () + IMPLICIT NONE + PROCEDURE(test), POINTER :: procptr + + CALL bar (test) ! { dg-warning "Non-RECURSIVE" } + procptr => test ! { dg-warning "Non-RECURSIVE" } + END SUBROUTINE test + + INTEGER FUNCTION test2 () RESULT (x) + IMPLICIT NONE + PROCEDURE(test2), POINTER :: procptr + + CALL bar (test2) ! { dg-warning "Non-RECURSIVE" } + procptr => test2 ! { dg-warning "Non-RECURSIVE" } + + x = 1812 + END FUNCTION test2 + + INTEGER FUNCTION func () + ! Using a result variable is ok of course! + func = 42 ! { dg-bogus "Non-RECURSIVE" } + END FUNCTION func + +END MODULE m Index: Fortran/gfortran/regression/recursive_check_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_5.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-frecursive" } + +! PR fortran/37779 +! Check that -frecursive allows using procedures in as procedure expressions. + +MODULE m + IMPLICIT NONE + +CONTAINS + + SUBROUTINE test () + IMPLICIT NONE + PROCEDURE(test), POINTER :: procptr + + CALL bar (test) ! { dg-bogus "Non-RECURSIVE" } + procptr => test ! { dg-bogus "Non-RECURSIVE" } + END SUBROUTINE test + + INTEGER FUNCTION func () + ! Using a result variable is ok of course! + func = 42 ! { dg-bogus "Non-RECURSIVE" } + END FUNCTION func + +END MODULE m Index: Fortran/gfortran/regression/recursive_check_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_6.f03 @@ -0,0 +1,64 @@ +! { dg-do compile } + +! PR fortran/37779 +! Check that a call to a procedure's containing procedure counts as recursive +! and is rejected if the containing procedure is not RECURSIVE. + +MODULE m + IMPLICIT NONE + +CONTAINS + + SUBROUTINE test_sub () + CALL bar () + CONTAINS + SUBROUTINE bar () + IMPLICIT NONE + PROCEDURE(test_sub), POINTER :: procptr + + CALL test_sub () ! { dg-error "not RECURSIVE" } + procptr => test_sub ! { dg-warning "Non-RECURSIVE" } + CALL foobar (test_sub) ! { dg-warning "Non-RECURSIVE" } + END SUBROUTINE bar + END SUBROUTINE test_sub + + INTEGER FUNCTION test_func () RESULT (x) + x = bar () + CONTAINS + INTEGER FUNCTION bar () + IMPLICIT NONE + PROCEDURE(test_func), POINTER :: procptr + + bar = test_func () ! { dg-error "not RECURSIVE" } + procptr => test_func ! { dg-warning "Non-RECURSIVE" } + CALL foobar (test_func) ! { dg-warning "Non-RECURSIVE" } + END FUNCTION bar + END FUNCTION test_func + + SUBROUTINE sub_entries () + ENTRY sub_entry_1 () + ENTRY sub_entry_2 () + CALL bar () + CONTAINS + SUBROUTINE bar () + CALL sub_entry_1 () ! { dg-error "is not RECURSIVE" } + END SUBROUTINE bar + END SUBROUTINE sub_entries + + INTEGER FUNCTION func_entries () RESULT (x) + ENTRY func_entry_1 () RESULT (x) + ENTRY func_entry_2 () RESULT (x) + x = bar () + CONTAINS + INTEGER FUNCTION bar () + bar = func_entry_1 () ! { dg-error "is not RECURSIVE" } + END FUNCTION bar + END FUNCTION func_entries + + SUBROUTINE main () + CALL test_sub () + CALL sub_entries () + PRINT *, test_func (), func_entries () + END SUBROUTINE main + +END MODULE m Index: Fortran/gfortran/regression/recursive_check_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/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' + STOP 1 +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'" } Index: Fortran/gfortran/regression/recursive_check_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_8.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! +! PR fortran/39577 +! +! OK - no recursion +program test + call f(.false.) + call f(.false.) +contains + subroutine f(rec) + logical :: rec + if(rec) then + call g() + end if + return + end subroutine f + subroutine g() + call f(.false.) + return + end subroutine g +end program test Index: Fortran/gfortran/regression/recursive_check_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_check_9.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! { dg-shouldfail "Recursion check" } +! +! { dg-output "Fortran runtime error: Recursive call to nonrecursive procedure 'f'" } +! +! PR fortran/39577 +! +! Invalid - recursion +program test + call f(.false.) + call f(.true.) +contains + subroutine f(rec) + logical :: rec + if(rec) then + call g() + end if + return + end subroutine f + subroutine g() + call f(.false.) + return + end subroutine g +end program test Index: Fortran/gfortran/regression/recursive_interface_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_interface_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/54107 +! The compiler used to ICE on recursive interfaces. + +module m + contains + function foo() result(r1) + procedure(foo), pointer :: r1 + end function foo + + function bar() result(r2) + procedure(baz), pointer :: r2 + end function bar + + function baz() result(r3) + procedure(bar), pointer :: r3 + end function baz +end module m + Index: Fortran/gfortran/regression/recursive_interface_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_interface_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/54107 +! Recursive interfaces used to lead to an infinite recursion during +! translation. + +module m + contains + subroutine foo (arg) + procedure(foo) :: arg + end subroutine + function foo2 (arg) result(r) + procedure(foo2) :: arg + procedure(foo2), pointer :: r + end function + subroutine bar (arg) + procedure(baz) :: arg + end subroutine + subroutine baz (arg) + procedure(bar) :: arg + end subroutine +end module m Index: Fortran/gfortran/regression/recursive_parameter_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_parameter_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PR39334 in which the recursive parameter declaration +! caused a sgfault. +! +! Reported by James van Buskirk on comp.lang.fortran +! +program recursive_parameter + implicit none + integer, parameter :: dp = kind(1.0_dp) ! { dg-error "Missing kind-parameter" } + write(*,*) dp ! { dg-error "has no IMPLICIT type" } +end program recursive_parameter Index: Fortran/gfortran/regression/recursive_reference_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_reference_1.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! Tests the patch for PR27613, in which directly recursive, scalar +! functions were generating an "unclassifiable statement" error +! for the recursive statement(s). This was subsequently determined +! to be wrong code and the error on 'bad_stuff' was removed. +! See 12.5.2.1 of the standard and PR30876. +! +! Based on PR testcase by Nicolas Bock +! +program test + if (original_stuff(1) .ne. 5) STOP 1 + if (scalar_stuff(-4) .ne. 10) STOP 2 + if (any (array_stuff((/-19,-30/)) .ne. (/25,25/))) STOP 3 +contains + recursive function original_stuff(n) + integer :: original_stuff + integer :: n + original_stuff = 1 + if(n < 5) then + original_stuff = original_stuff + original_stuff (n+1) ! { dg-error "name of a recursive function" } + endif + end function original_stuff + + recursive function scalar_stuff(n) result (tmp) + integer :: tmp + integer :: n + tmp = 1 + if(n < 5) then + tmp = tmp + scalar_stuff (n+1) + endif + end function scalar_stuff + + recursive function array_stuff(n) result (tmp) + integer :: tmp (2) + integer :: n (2) + tmp = 1 + if(maxval (n) < 5) then + tmp = tmp + array_stuff (n+1) + endif + end function array_stuff + + recursive function bad_stuff(n) + integer :: bad_stuff (2) + integer :: n(2) + bad_stuff = 1 + if(maxval (n) < 5) then + bad_stuff = bad_stuff + bad_stuff (n+1) + endif + end function bad_stuff +end program test Index: Fortran/gfortran/regression/recursive_reference_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_reference_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Tests the fix for PR30876 in which interface derived types were +! not always being associated. +! +! Contributed by Joost VandeVondele +! +MODULE M1 +CONTAINS + FUNCTION correct_input(i) + INTEGER :: i,correct_input(5), ans(5) = 0 + IF (i<1) correct_input=test(1) + IF (i>5) correct_input=test(5) + END FUNCTION correct_input + + RECURSIVE FUNCTION test(i) + INTEGER :: test(5),i,j + IF (i<1 .OR. i>5) THEN + test=correct_input(i) + ELSE + test=0 + test(1:6-i)=(/(j,j=i,5)/) + test=test(3) + ENDIF + END FUNCTION + +END MODULE M1 + +USE M1 +integer :: ans(5) +IF (ANY(TEST(3).NE.(/5,5,5,5,5/))) STOP 1 +IF (ANY(TEST(6).NE.(/0,0,0,0,0/))) STOP 2 +END Index: Fortran/gfortran/regression/recursive_reference_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_reference_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! PR fortran/105138 - recursive procedures and shadowing of intrinsics + +RECURSIVE FUNCTION LOG_GAMMA(Z) RESULT(RES) + COMPLEX, INTENT(IN) :: Z + COMPLEX :: RES + RES = LOG_GAMMA(Z) +END FUNCTION LOG_GAMMA + +recursive subroutine date_and_time (z) + real :: z + if (z > 0) call date_and_time (z-1) +end subroutine date_and_time Index: Fortran/gfortran/regression/recursive_stack.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_stack.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-frecursive" } +program recursive_stack + call foo (.true.) +end program recursive_stack + +subroutine foo (recurse) + logical recurse + integer iarray(100,100) + if (recurse) then + iarray(49,49) = 17 + call bar + if (iarray(49,49) .ne. 17) STOP 1 + else + iarray(49,49) = 21 + end if +end subroutine foo + +subroutine bar + call foo (.false.) +end subroutine bar Index: Fortran/gfortran/regression/recursive_statement_functions.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/recursive_statement_functions.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR20866 - A statement function cannot be recursive. +! Contributed by Joost VandeVondele +! +! Modified 20051110 to check that regressions PR24655 and PR24755 +! are fixed. Thanks to pavarini@pv.infn.it and tdeutsch@cea.fr for +! the tests. +! + INTEGER :: i, st1, st2, st3, lambda, n + REAL :: x, z(2,2) + character(8) :: ch + real(8) :: fi, arg, sigma, dshpfunc + real(8), parameter :: one=1d0 +! +! Test check for recursion via other statement functions, string +! length references, function actual arguments and array index +! references. +! + st1 (i) = len (ch(st2 (1):8)) + st2 (i) = max (st3 (1), 4) + st3 (i) = 2 + cos (z(st1 (1), i)) ! { dg-error "is recursive" } +! +! Test the two regressions. +! + fi (n) = n *one + dshpfunc (arg)=-lambda/sigma*(arg/sigma)**(lambda-1)*exp(-(arg/sigma)**lambda) +! +! References to each statement function. +! + write(6,*) st1 (1), fi (2), dshpfunc (1.0_8) + END Index: Fortran/gfortran/regression/redefined_intrinsic_assignment.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/redefined_intrinsic_assignment.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Tests the fix for PR25077 in which no diagnostic was produced +! for the redefinition of an intrinsic type assignment. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + IMPLICIT NONE + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE T1 + END INTERFACE +CONTAINS + SUBROUTINE T1(I,J) ! { dg-error "redefine an INTRINSIC type assignment" } + INTEGER, INTENT(OUT) :: I + INTEGER, INTENT(IN) :: J + I=-J + END SUBROUTINE T1 +END MODULE M1 Index: Fortran/gfortran/regression/redefined_intrinsic_assignment_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/redefined_intrinsic_assignment_2.f90 @@ -0,0 +1,66 @@ +! { dg-do compile } +! +! PR fortran/47448 +! +! ASSIGNMENT(=) checks. Defined assignment is allowed if and only if +! it does not override an intrinsic assignment. +! + +module test1 + interface assignment(=) + module procedure valid, valid2 + end interface +contains + ! Valid: scalar = array + subroutine valid (lhs,rhs) + integer, intent(out) :: lhs + integer, intent(in) :: rhs(:) + lhs = rhs(1) + end subroutine valid + + ! Valid: array of different ranks + subroutine valid2 (lhs,rhs) + integer, intent(out) :: lhs(:) + integer, intent(in) :: rhs(:,:) + lhs(:) = rhs(:,1) + end subroutine valid2 +end module test1 + +module test2 + interface assignment(=) + module procedure invalid + end interface +contains + ! Invalid: scalar = scalar + subroutine invalid (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" } + integer, intent(out) :: lhs + integer, intent(in) :: rhs + lhs = rhs + end subroutine invalid +end module test2 + +module test3 + interface assignment(=) + module procedure invalid2 + end interface +contains + ! Invalid: array = scalar + subroutine invalid2 (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" } + integer, intent(out) :: lhs(:) + integer, intent(in) :: rhs + lhs(:) = rhs + end subroutine invalid2 +end module test3 + +module test4 + interface assignment(=) + module procedure invalid3 + end interface +contains + ! Invalid: array = array for same rank + subroutine invalid3 (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" } + integer, intent(out) :: lhs(:) + integer, intent(in) :: rhs(:) + lhs(:) = rhs(:) + end subroutine invalid3 +end module test4 Index: Fortran/gfortran/regression/reduction.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reduction.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! PR 16946 +! Not all allowed combinations of arguments for MAXVAL, MINVAL, +! PRODUCT and SUM were supported. +program reduction_mask + implicit none + logical :: equal(3) + + integer, parameter :: res(4*9) = (/ 3, 3, 3, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 6, 6, 6, 2, 2, 2, 2, 2, 2, 6, 6, 6, 3, 3, 3, 3, 3, 3 /) + integer :: val(4*9) + complex :: cval(2*9), cin(3) + + equal = (/ .true., .true., .false. /) + + ! use all combinations of the dim and mask arguments for the + ! reduction intrinsics + val( 1) = maxval((/ 1, 2, 3 /)) + val( 2) = maxval((/ 1, 2, 3 /), 1) + val( 3) = maxval((/ 1, 2, 3 /), dim=1) + val( 4) = maxval((/ 1, 2, 3 /), equal) + val( 5) = maxval((/ 1, 2, 3 /), mask=equal) + val( 6) = maxval((/ 1, 2, 3 /), 1, equal) + val( 7) = maxval((/ 1, 2, 3 /), 1, mask=equal) + val( 8) = maxval((/ 1, 2, 3 /), dim=1, mask=equal) + val( 9) = maxval((/ 1, 2, 3 /), mask=equal, dim=1) + + val(10) = minval((/ 1, 2, 3 /)) + val(11) = minval((/ 1, 2, 3 /), 1) + val(12) = minval((/ 1, 2, 3 /), dim=1) + val(13) = minval((/ 1, 2, 3 /), equal) + val(14) = minval((/ 1, 2, 3 /), mask=equal) + val(15) = minval((/ 1, 2, 3 /), 1, equal) + val(16) = minval((/ 1, 2, 3 /), 1, mask=equal) + val(17) = minval((/ 1, 2, 3 /), dim=1, mask=equal) + val(18) = minval((/ 1, 2, 3 /), mask=equal, dim=1) + + val(19) = product((/ 1, 2, 3 /)) + val(20) = product((/ 1, 2, 3 /), 1) + val(21) = product((/ 1, 2, 3 /), dim=1) + val(22) = product((/ 1, 2, 3 /), equal) + val(23) = product((/ 1, 2, 3 /), mask=equal) + val(24) = product((/ 1, 2, 3 /), 1, equal) + val(25) = product((/ 1, 2, 3 /), 1, mask=equal) + val(26) = product((/ 1, 2, 3 /), dim=1, mask=equal) + val(27) = product((/ 1, 2, 3 /), mask=equal, dim=1) + + val(28) = sum((/ 1, 2, 3 /)) + val(29) = sum((/ 1, 2, 3 /), 1) + val(30) = sum((/ 1, 2, 3 /), dim=1) + val(31) = sum((/ 1, 2, 3 /), equal) + val(32) = sum((/ 1, 2, 3 /), mask=equal) + val(33) = sum((/ 1, 2, 3 /), 1, equal) + val(34) = sum((/ 1, 2, 3 /), 1, mask=equal) + val(35) = sum((/ 1, 2, 3 /), dim=1, mask=equal) + val(36) = sum((/ 1, 2, 3 /), mask=equal, dim=1) + + if (any (val /= res)) STOP 1 + + ! Tests for complex arguments. These were broken by the original fix. + + cin = cmplx((/1,2,3/)) + + cval(1) = product(cin) + cval(2) = product(cin, 1) + cval(3) = product(cin, dim=1) + cval(4) = product(cin, equal) + cval(5) = product(cin, mask=equal) + cval(6) = product(cin, 1, equal) + cval(7) = product(cin, 1, mask=equal) + cval(8) = product(cin, dim=1, mask=equal) + cval(9) = product(cin, mask=equal, dim=1) + + cval(10) = sum(cin) + cval(11) = sum(cin, 1) + cval(12) = sum(cin, dim=1) + cval(13) = sum(cin, equal) + cval(14) = sum(cin, mask=equal) + cval(15) = sum(cin, 1, equal) + cval(16) = sum(cin, 1, mask=equal) + cval(17) = sum(cin, dim=1, mask=equal) + cval(18) = sum(cin, mask=equal, dim=1) + + if (any (cval /= cmplx(res(19:36)))) STOP 2 +end program reduction_mask Index: Fortran/gfortran/regression/repack_arrays_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repack_arrays_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-frepack-arrays" } +! +! Check that arrays marked with TARGET attribute are not repacked. +! +program test2 + use iso_c_binding + implicit none + real, target :: x(7) + type(c_ptr) cp1, cp2 + + x = 42 + if (.not. c_associated(c_loc(x(3)),point(x(::2)))) STOP 1 +contains + function point(x) + use iso_c_binding + real, intent(in), target :: x(:) + type(c_ptr) point + real, pointer :: p + + p => x(2) + point = c_loc(p) + end function point +end program test2 Index: Fortran/gfortran/regression/repeat_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-shouldfail "negative NCOPIES argument to REPEAT intrinsic" } + character(len=80) :: str + integer :: i + i = -1 + write(str,"(a)") repeat ("a", f()) + if (trim(str) /= "aaaa") STOP 1 + write(str,"(a)") repeat ("a", i) + +contains + + integer function f() + integer :: x = 5 + save x + + x = x - 1 + f = x + end function f +end +! { dg-output "Fortran runtime error: Argument NCOPIES of REPEAT intrinsic is negative \\(its value is -1\\)" } Index: Fortran/gfortran/regression/repeat_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_2.f90 @@ -0,0 +1,92 @@ +! REPEAT intrinsic +! +! { dg-do run } +subroutine foo(i, j, s, t) + implicit none + integer, intent(in) :: i, j + character(len=i), intent(in) :: s + character(len=i*j), intent(in) :: t + + if (repeat(s,j) /= t) STOP 1 + call bar(j,s,t) +end subroutine foo + +subroutine bar(j, s, t) + implicit none + integer, intent(in) :: j + character(len=*), intent(in) :: s + character(len=len(s)*j), intent(in) :: t + + if (repeat(s,j) /= t) STOP 2 +end subroutine bar + +program test + implicit none + character(len=0), parameter :: s0 = "" + character(len=1), parameter :: s1 = "a" + character(len=2), parameter :: s2 = "ab" + character(len=0) :: t0 + character(len=1) :: t1 + character(len=2) :: t2 + integer :: i + + t0 = "" + t1 = "a" + t2 = "ab" + + if (repeat(t0, 0) /= "") STOP 3 + if (repeat(t1, 0) /= "") STOP 4 + if (repeat(t2, 0) /= "") STOP 5 + if (repeat(t0, 1) /= "") STOP 6 + if (repeat(t1, 1) /= "a") STOP 7 + if (repeat(t2, 1) /= "ab") STOP 8 + if (repeat(t0, 2) /= "") STOP 9 + if (repeat(t1, 2) /= "aa") STOP 10 + if (repeat(t2, 2) /= "abab") STOP 11 + + if (repeat(s0, 0) /= "") STOP 12 + if (repeat(s1, 0) /= "") STOP 13 + if (repeat(s2, 0) /= "") STOP 14 + if (repeat(s0, 1) /= "") STOP 15 + if (repeat(s1, 1) /= "a") STOP 16 + if (repeat(s2, 1) /= "ab") STOP 17 + if (repeat(s0, 2) /= "") STOP 18 + if (repeat(s1, 2) /= "aa") STOP 19 + if (repeat(s2, 2) /= "abab") STOP 20 + + i = 0 + if (repeat(t0, i) /= "") STOP 21 + if (repeat(t1, i) /= "") STOP 22 + if (repeat(t2, i) /= "") STOP 23 + i = 1 + if (repeat(t0, i) /= "") STOP 24 + if (repeat(t1, i) /= "a") STOP 25 + if (repeat(t2, i) /= "ab") STOP 26 + i = 2 + if (repeat(t0, i) /= "") STOP 27 + if (repeat(t1, i) /= "aa") STOP 28 + if (repeat(t2, i) /= "abab") STOP 29 + + i = 0 + if (repeat(s0, i) /= "") STOP 30 + if (repeat(s1, i) /= "") STOP 31 + if (repeat(s2, i) /= "") STOP 32 + i = 1 + if (repeat(s0, i) /= "") STOP 33 + if (repeat(s1, i) /= "a") STOP 34 + if (repeat(s2, i) /= "ab") STOP 35 + i = 2 + if (repeat(s0, i) /= "") STOP 36 + if (repeat(s1, i) /= "aa") STOP 37 + if (repeat(s2, i) /= "abab") STOP 38 + + call foo(0,0,"","") + call foo(0,1,"","") + call foo(0,2,"","") + call foo(1,0,"a","") + call foo(1,1,"a","a") + call foo(1,2,"a","aa") + call foo(2,0,"ab","") + call foo(2,1,"ab","ab") + call foo(2,2,"ab","abab") +end program test Index: Fortran/gfortran/regression/repeat_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_3.f90 @@ -0,0 +1,29 @@ +! REPEAT intrinsic, test for PR 31304 +! We check that REPEAT accepts all kind arguments for NCOPIES +! +! { dg-do run } +program test + implicit none + + integer(kind=1) i1 + integer(kind=2) i2 + integer(kind=4) i4 + integer(kind=4) i8 + real(kind=8) r + character(len=2) s1, s2 + + i1 = 1 ; i2 = 1 ; i4 = 1 ; i8 = 1 + r = 1 + s1 = '42' + r = nearest(r,r) + + s2 = repeat(s1,i1) + if (s2 /= s1) STOP 1 + s2 = repeat(s1,i2) + if (s2 /= s1) STOP 2 + s2 = repeat(s1,i4) + if (s2 /= s1) STOP 3 + s2 = repeat(s1,i8) + if (s2 /= s1) STOP 4 + +end program test Index: Fortran/gfortran/regression/repeat_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_4.f90 @@ -0,0 +1,39 @@ +! REPEAT intrinsic -- various checks should be enforced +! +! { dg-do compile } +program test + use iso_c_binding, only: k => c_size_t + implicit none + character(len=0), parameter :: s0 = "" + character(len=1), parameter :: s1 = "a" + character(len=2), parameter :: s2 = "ab" + character(len=0) :: t0 + character(len=1) :: t1 + character(len=2) :: t2 + + t0 = "" ; t1 = "a" ; t2 = "ab" + + ! Check for negative NCOPIES argument + print *, repeat(s0, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(s1, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(s2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t0, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t1, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + + ! Check for too large NCOPIES argument and limit cases + print *, repeat(t0, huge(0_k)) + print *, repeat(t1, huge(0_k)) + print *, repeat(t2, huge(0_k)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0_k)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + + print *, repeat(t0, huge(0_k)/2) + print *, repeat(t1, huge(0_k)/2) + print *, repeat(t2, huge(0_k)/2) + + print *, repeat(t0, huge(0_k)/2+1) + print *, repeat(t1, huge(0_k)/2+1) + print *, repeat(t2, huge(0_k)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0_k)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + +end program test Index: Fortran/gfortran/regression/repeat_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_5.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR32472 -- character literals were not implemented in REPEAT. +! +! Contributed by Tobias Burnus +! + CHARACTER(len=1025) :: string2 = repeat('?',1025) + print *, string2 +end Index: Fortran/gfortran/regression/repeat_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_6.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! +! PR34559 -- ICE on empty string literals +! +! Contributed by Tobias Burnus +! + + character(len=200) :: string = "a" // repeat ("", 3) & + // repeat ("xxx", 0) & + // repeat ("string", 2) + + if (string /= "astringstring") STOP 1 +end Index: Fortran/gfortran/regression/repeat_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/repeat_7.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 66310 +! Make sure there is a limit to how large arrays we try to handle at +! compile time. +program p + character, parameter :: z = 'z' + print *, repeat(z, huge(1_4)) ! { dg-warning "Evaluation of string" } +end program p Index: Fortran/gfortran/regression/reshape-alloc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape-alloc.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR 20074: This used to segfault at runtime. +! Test case contributed by "Alfredo Buttari" + +program tryreshape + + integer,allocatable :: vect1(:),resh1(:,:) + integer,pointer :: vect(:),resh(:,:) + integer :: vect2(2*4), resh2(2,4) + integer :: r, s(2) + + r=2; nb=4 + + s(:)=(/r,nb/) + + allocate(vect(nb*r),vect1(nb*r)) + allocate(resh(r,nb),resh1(r,nb)) + + vect =1 + vect1=1 + vect2=1 + + resh2 = reshape(vect2,s) + if (resh2(1,1) /= 1.0) STOP 1 + + resh1 = reshape(vect1,s) + if (resh1(1,1) /= 1.0) STOP 2 + + resh = reshape(vect,s) + if (resh(1,1) /= 1.0) STOP 3 + +end program tryreshape Index: Fortran/gfortran/regression/reshape-complex.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape-complex.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 21127: Reshape of complex didn't work. +! PR 21480: Reshape of packed complex arrays didn't work either. +program main + complex, dimension(8) :: b + complex, dimension(2,2) :: a + complex, dimension(2) :: c,d + integer :: i + b = (/(i,i=1,8)/) + a = reshape(b(1:8:2),shape(a)) + if (a(1,1) /= (1.0, 0.0) .or. a(2,1) /= (3.0, 0.0) .or. & + a(1,2) /= (5.0, 0.0) .or. a(2,2) /= (7.0, 0.0)) STOP 1 + c = (/( 3.14, -3.14), (2.71, -2.71)/) + d = reshape(c, shape (d)) + if (any (c .ne. d)) STOP 2 +end Index: Fortran/gfortran/regression/reshape.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! This tests a few reshape PRs. +program resh + implicit none + real, dimension (2,3) :: a,c + real, dimension (12) :: b + type foo + real :: r + end type foo + type(foo), dimension (2,3) :: ar + type(foo), dimension (12) :: br + + character (len=80) line1, line2, line3 + integer :: i + + ! PR 21108: This used to give undefined results. + b = (/(i,i=1,12)/) + a = reshape(b(1:12:2),shape(a),order=(/2,1/)) + c = reshape(b(1:12:2),shape(a),order=(/2,1/)) + if (any (a /= c)) STOP 1 + + ! Test generic reshape + br%r = b + ar = reshape(br(1:12:2),shape(a),order=(/2,1/)) + if (any (ar%r /= a)) STOP 2 + + ! Test callee-allocated memory with a write statement + write (line1,'(6F8.3)') reshape(b(1:12:2),shape(a),order=(/2,1/)) + write (line2,'(6F8.3)') a + if (line1 /= line2 ) STOP 3 + write (line3,'(6F8.3)') reshape(br(1:12:2),shape(ar),order=(/2,1/)) + if (line1 /= line3 ) STOP 4 +end Index: Fortran/gfortran/regression/reshape_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR34556 Rejects valid with bogus error message: parameter initalization +! Found using the Fortran Company Fortran 90 Test Suite (Lite), +! Version 1.4 +! Test case modified by Jerry DeLisle +! +program test + integer :: a(2,0) + a = reshape([1,2,3,4], [2,0]) + print *, a +end +! { dg-final { scan-tree-dump-times "data" 4 "original" } } Index: Fortran/gfortran/regression/reshape_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_9.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/103411 - ICE in gfc_conv_array_initializer +! Based on testcase by G. Steinmetz +! Test simplifications for checks of shape argument to reshape intrinsic + +program p + integer :: i + integer, parameter :: a(2) = [2,2] + integer, parameter :: u(5) = [1,2,2,42,2] + integer, parameter :: v(1,3) = 2 + integer, parameter :: d(2,2) = reshape([1,2,3,4,5], a) + integer, parameter :: c(2,2) = reshape([1,2,3,4], a) + integer, parameter :: b(2,2) = & + reshape([1,2,3], a) ! { dg-error "not enough elements" } + print *, reshape([1,2,3], a) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], a) + print *, reshape([1,2,3,4,5], a) + print *, b, c, d + print *, reshape([1,2,3], [(u(i),i=1,2)]) + print *, reshape([1,2,3], [(u(i),i=2,3)]) ! { dg-error "not enough elements" } + print *, reshape([1,2,3], & + [(u(i)*(-1)**i,i=2,3)]) ! { dg-error "has negative element" } + print *, reshape([1,2,3,4], u(5:3:-2)) + print *, reshape([1,2,3], u(5:3:-2)) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], u([5,3])) + print *, reshape([1,2,3] , u([5,3])) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], v(1,2:)) + print *, reshape([1,2,3], v(1,2:)) ! { dg-error "not enough elements" } + print *, reshape([1,2,3,4], v(1,[2,1])) + print *, reshape([1,2,3] , v(1,[2,1])) ! { dg-error "not enough elements" } +end Index: Fortran/gfortran/regression/reshape_empty_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_empty_1.f03 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/38184 +! invariant RESHAPE not expanded if SOURCE is empty. +! +! Original program by James Van Buskirk + +integer, parameter :: N = 3 +integer, parameter :: A(N,N) = reshape([integer::],[N,N],reshape([1],[N+1],[2])) +integer, parameter :: K = N*A(2,2)+A(2,3) +integer :: B(N,N) = reshape([1,2,2,2,1,2,2,2,1],[3,3]) +integer :: i +i = 5 +if (any(A /= B)) STOP 1 +if (K /= i) STOP 2 +end + +! { dg-final { scan-tree-dump-times "\\\{1, 2, 2, 2, 1, 2, 2, 2, 1\\\}" 2 "original" } } Index: Fortran/gfortran/regression/reshape_order_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_order_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Duplicate value 2 in ORDER argument to RESHAPE intrinsic" } +program main + implicit none + integer(kind=1), dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 3/) + integer(kind=1), dimension(2) :: pad1 = (/ 0, 0/) + character(len=200) :: l1, l2 + integer :: i1, i2 + + l1 = "2 2" + read(unit=l1,fmt=*) i1, i2 + write (unit=l2,fmt=*) reshape(source1, shape1, pad1, (/i1, i2/)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Duplicate value 2 in ORDER argument to RESHAPE intrinsic" } + + Index: Fortran/gfortran/regression/reshape_order_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_order_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Value 3 out of range in ORDER argument to RESHAPE intrinsic" } +program main + implicit none + integer(kind=1), dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 3/) + integer(kind=1), dimension(2) :: pad1 = (/ 0, 0/) + character(len=200) :: l1, l2 + integer :: i1, i2 + + l1 = "3 2" + read(unit=l1,fmt=*) i1, i2 + write (unit=l2,fmt=*) reshape(source1, shape1, pad1, (/i1, i2/)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Value 3 out of range in ORDER argument to RESHAPE intrinsic" } Index: Fortran/gfortran/regression/reshape_order_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_order_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Duplicate value 2 in ORDER argument to RESHAPE intrinsic" } +program main + implicit none + integer(kind=4), dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 3/) + integer(kind=4), dimension(2) :: pad1 = (/ 0, 0/) + character(len=200) :: l1, l2 + integer :: i1, i2 + + l1 = "2 2" + read(unit=l1,fmt=*) i1, i2 + write (unit=l2,fmt=*) reshape(source1, shape1, pad1, (/i1, i2/)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Duplicate value 2 in ORDER argument to RESHAPE intrinsic" } Index: Fortran/gfortran/regression/reshape_order_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_order_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Value 0 out of range in ORDER argument to RESHAPE intrinsic" } +program main + implicit none + integer(kind=4), dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 3/) + integer(kind=4), dimension(2) :: pad1 = (/ 0, 0/) + character(len=200) :: l1, l2 + integer :: i1, i2 + + l1 = "0 2" + read(unit=l1,fmt=*) i1, i2 + write (unit=l2,fmt=*) reshape(source1, shape1, pad1, (/i1, i2/)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Value 0 out of range in ORDER argument to RESHAPE intrinsic" } Index: Fortran/gfortran/regression/reshape_order_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_order_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/37203 - check RESHAPE arguments +! + + integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: shape1 = (/ 2, 5/) + integer, dimension(2) :: pad1 = (/ 0, 0/) + integer, dimension(2) :: t(2,5) + + t = reshape(source1, shape1, pad1, (/2, 1/)) ! ok + t = reshape(source1, shape1, pad1, (/2.1, 1.2/)) ! { dg-error "must be INTEGER" } + t = reshape(source1, shape1, pad1, (/2, 2/)) ! { dg-error "invalid permutation" } + t = reshape(source1, shape1, pad1, (/2, 3/)) ! { dg-error "out-of-range dimension" } + t = reshape(source1, shape1, pad1, (/2/)) ! { dg-error "wrong number of elements" } +end Index: Fortran/gfortran/regression/reshape_pad_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_pad_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR 38135 - pad to RESHAPE didn't work correctly when SOURCE +! was an empty array. + +program main + implicit none + integer, parameter :: N = 3 + integer(kind=1) :: A1(N,N) + integer(kind=1) :: b1(n+1) + integer(kind=4) :: A4(n,n) + integer(kind=4) :: b4(n+1) + character(len=9) :: line + + b1 = (/ 1, 2, 2, 2 /) + + A1(1:N,1:N)=reshape(A1(1:0,1),(/N,N/),b1) + write(unit=line,fmt='(100i1)') A1 + if (line .ne. "122212221") STOP 1 + + b4 = (/ 3, 4, 4, 4 /) + + a4 = reshape(a4(:0,1),(/n,n/),b4) + write(unit=line,fmt='(100i1)') a4 + if (line .ne. "344434443") STOP 2 +end program main Index: Fortran/gfortran/regression/reshape_rank7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_rank7.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR 21075: Reshape with rank 7 used to segfault. +program main + integer :: a(256), b(2,2,2,2,2,2,2) + do i=1,256 + a(i) = i + end do + b = reshape(a(1:256:2), shape(b)) + do i1=1,2 + do i2=1,2 + do i3=1,2 + do i4=1,2 + do i5=1,2 + do i6=1,2 + do i7=1,2 + if (b(i1,i2,i3,i4,i5,i6,i7) /= & + 2*((i1-1)+(i2-1)*2+(i3-1)*4+(i4-1)*8+& + (i5-1)*16+(i6-1)*32+(i7-1)*64)+1) & + STOP 1 + end do + end do + end do + end do + end do + end do + end do +end program main Index: Fortran/gfortran/regression/reshape_shape_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_shape_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/37203 - check RESHAPE arguments +! + + integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /) + integer, dimension(2) :: pad1 = (/ 0, 0/) + integer, dimension(2) :: t(2,5) + integer :: i + + t = reshape(source1, SHAPE(0), pad1, (/2, 1/)) ! { dg-error "is empty" } + t = reshape(source1, (/(i,i=1,32)/), pad1, (/2, 1/)) ! { dg-error "has more than" } + t = reshape(source1, (/ 2, -5/), pad1, (/2, 1/)) ! { dg-error "negative element" } +end Index: Fortran/gfortran/regression/reshape_shape_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_shape_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/102717 + +program p + integer, parameter :: a(1) = 2 + integer, parameter :: b(2) = reshape([3,4], -[a]) ! { dg-error "negative" } +end Index: Fortran/gfortran/regression/reshape_source_size_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_source_size_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests patch for PR29758, which arose from PR29431. There was no check that there +! were enough elements in the source to match the shape. +! +! Contributed by Paul Thomas +! + real :: a(2,2), b = 1.0, c(3), d(4) + a = reshape ([b], [2,2]) ! { dg-error "not enough elements" } + a = reshape (c, [2,2]) ! { dg-error "not enough elements" } + a = reshape (d, [2,2]) +end Index: Fortran/gfortran/regression/reshape_transpose_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_transpose_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR 31196 - reshape of transposed derived types generated +! wront results. +program main + implicit none + TYPE datatype + INTEGER :: I + END TYPE datatype + character (len=20) line1, line2 + TYPE(datatype), dimension(2,2) :: data, result + data(1,1)%i = 1 + data(2,1)%i = 2 + data(1,2)%i = 3 + data(2,2)%i = 4 + write (unit=line1, fmt="(4I4)") reshape(transpose(data),shape(data)) + write (unit=line2, fmt="(4I4)") (/ 1, 3, 2, 4 /) + if (line1 /= line2) STOP 1 +END program main Index: Fortran/gfortran/regression/reshape_zerosize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_zerosize_1.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR 35960 - there was a run-time abort when the SHAPE argument to +! RESHAPE was zero-sized. +! Test case contributed by Dick Henderson. + program try_gf1065 + + +! fails on Windows XP +! gcc version 4.4.0 20080312 (experimental) [trunk revision 133139] + + + call gf1065(1, 2, 3, 4, 7, 8, 9) + end + + SUBROUTINE GF1065(nf1,nf2,nf3,nf4,nf7,nf8,nf9) + + REAL RDA(10,9) + REAL RCA1(90) + integer ila(2) + RDA(NF9:NF8, NF7:NF3) = RESHAPE(RCA1,(/0,0/), (/1.0/),(/2,1/)) + + rDA(NF9:NF8, NF7:NF3) = RESHAPE(rCA1,(/0,0/),ORDER=(/2,1/)) + + ILA(1) = 5 + ILA(2) = 0 + rDA(NF4:NF8, NF7:NF3) = RESHAPE(rcA1,ILA) + + RdA(NF4:NF8, NF7:NF3) = RESHAPE(RcA1,ILA,PAD=(/-1.0/)) + + ILA(1) = 0 + ILA(2) = 5 + RdA(NF9:NF8,NF4:NF8)=RESHAPE(RcA1,ILA,(/-1.0/),(/NF2,NF1/)) + + ILA(1) = 5 + ILA(2) = 0 + RdA(NF4:NF8, NF7:NF3) = RESHAPE(RcA1,ILA,ORDER=(/NF1,NF2/)) + + + END SUBROUTINE Index: Fortran/gfortran/regression/reshape_zerosize_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_zerosize_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } + + ! Simplifier of RESHAPE was broken when reshaping an empty array. + INTEGER, PARAMETER :: empty(0,0) = RESHAPE(SHAPE(1), (/0, 0/)) + + ! same with surplus padding + INTEGER, PARAMETER :: empty_padding(0,0) = RESHAPE(SHAPE(1), (/0, 0/), PAD=( (/ 1, 2 /) )) + + ! same with required padding + INTEGER, PARAMETER :: non_empty(2,2) = RESHAPE(SHAPE(1), (/2, 2/), PAD=( (/ 1, 2 /) )) +END Index: Fortran/gfortran/regression/reshape_zerosize_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_zerosize_3.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! PR 49479 - this used not to print anything. +! Test case by Joost VandeVondele. +MODULE M1 + IMPLICIT NONE + type foo + character(len=5) :: x + end type foo +CONTAINS + SUBROUTINE S1(data) + INTEGER, DIMENSION(:), INTENT(IN), & + OPTIONAL :: DATA + character(20) :: line + IF (.not. PRESENT(data)) STOP 1 + write (unit=line,fmt='(I5)') size(data) + if (line /= ' 0 ') STOP 2 + END SUBROUTINE S1 + + subroutine s_type(data) + type(foo), dimension(:), intent(in), optional :: data + character(20) :: line + IF (.not. PRESENT(data)) STOP 3 + write (unit=line,fmt='(I5)') size(data) + if (line /= ' 0 ') STOP 4 + end subroutine s_type + + SUBROUTINE S2(N) + INTEGER :: N + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: blki + type(foo), allocatable, dimension(:, :) :: bar + ALLOCATE(blki(3,N)) + allocate (bar(3,n)) + blki=0 + CALL S1(RESHAPE(blki,(/3*N/))) + call s_type(reshape(bar, (/3*N/))) + END SUBROUTINE S2 + +END MODULE M1 + +USE M1 +CALL S2(0) +END Index: Fortran/gfortran/regression/reshape_zerosize_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/reshape_zerosize_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR fortran/99206 - ICE in add_init_expr_to_sym, at fortran/decl.c:1980 +! Check simplifier of RESHAPE for character arrays. + +program p + character(*), parameter :: a(0) = reshape([ 'ab'], [0]) + character(*,kind=4), parameter :: c(0) = reshape([4_'cd'], [0]) + if (len (a) /= 2) stop 1 + if (len (reshape ( ['ab'], [0])) /= 2) stop 2 + if (kind(reshape ( ['ab'], [0])) /= 1) stop 3 + if (len (c) /= 2) stop 4 + if (len (reshape ([4_'cd'], [0])) /= 2) stop 5 + if (kind(reshape ([4_'cd'], [0])) /= 4) stop 6 +end Index: Fortran/gfortran/regression/restricted_expression_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/restricted_expression_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-pedantic -ffixed-form" } + +! PR fortran/35723 +! An argument subscript into a parameter array was not allowed as +! dimension. Check this is fixed. + +! Contributed by Dick Hendrickson + + call vf0016( 1, 2, 3) + + end + SUBROUTINE VF0016(nf1,nf2,nf3) + CHARACTER(LEN=9,KIND=1),DIMENSION(3), PARAMETER + $ :: TEST_STRINGS = + $ (/' HI','ABC ',' CDEFG '/) + CHARACTER :: TEST_ARRAY + $(LEN_TRIM(ADJUSTL(TEST_STRINGS(nf1))), + $ SUM(LEN_TRIM(ADJUSTL(TEST_STRINGS))), + $ LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(3)))), + $ SUM(LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(NF1:NF3:NF2))))) ) + + print *, 2, 10, 5, 7 + print *, shape (test_array) + end Index: Fortran/gfortran/regression/restricted_expression_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/restricted_expression_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-pedantic -ffixed-form" } + +! PR fortran/35723 +! Check that a program using a local variable subscript is still rejected. + +! Contributed by Tobias Burnus + + call vf0016( 1, 2, 3) + + end + SUBROUTINE VF0016(nf1,nf2,nf3) + CHARACTER(LEN=9,KIND=1),DIMENSION(3), PARAMETER + $ :: TEST_STRINGS = + $ (/' HI','ABC ',' CDEFG '/) + INTEGER :: i = 2 + CHARACTER :: TEST_ARRAY + $(LEN_TRIM(ADJUSTL(TEST_STRINGS(i))), ! { dg-error "'i' cannot appear" } + $ SUM(LEN_TRIM(ADJUSTL(TEST_STRINGS))), + $ LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(3)))), + $ SUM(LEN_TRIM(ADJUSTL(ADJUSTR(TEST_STRINGS(NF1:NF3:NF2))))) ) + + print *, 2, 10, 5, 7 + print *, shape (test_array) + end Index: Fortran/gfortran/regression/restricted_expression_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/restricted_expression_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } + +! PR fortran/35723 +! Check that a dummy-argument array with non-restricted subscript is +! rejected and some more reference-checks. + +PROGRAM main + IMPLICIT NONE + CALL test (5, (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), "0123456789" ) + +CONTAINS + + SUBROUTINE test (n, arr, str) + IMPLICIT NONE + INTEGER :: n, arr(:) + CHARACTER(len=10) :: str + + INTEGER :: i = 5 + INTEGER :: ok1(arr(n)), ok2(LEN_TRIM (str(3:n))) + INTEGER :: ok3(LEN_TRIM("hello, world!"(2:n))) + INTEGER :: wrong1(arr(i)) ! { dg-error "'i' cannot appear" } + INTEGER :: wrong2(LEN_TRIM (str(i:n))) ! { dg-error "'i' cannot appear" } + INTEGER :: wrong3(LEN_TRIM ("hello, world!"(i:n))) ! { dg-error "'i' cannot appear" } + END SUBROUTINE test + +END PROGRAM main Index: Fortran/gfortran/regression/result_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 36704: Procedure pointer as function result +! +! Contributed by Janus Weil + +function f() result(r) +real, parameter :: r = 5.0 ! { dg-error "attribute conflicts" } +end function + +function g() result(s) +real :: a,b,c +namelist /s/ a,b,c ! { dg-error "attribute conflicts" } +end function + +function h() result(t) +type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" } +end type t ! { dg-error "Expecting END FUNCTION statement" } +end function + +function i() result(t) +type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" } +end function Index: Fortran/gfortran/regression/result_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR 50379: ICE in gfc_typenode_for_spec at fortran/trans-types.c +! +! Contributed by Vittorio Zecca + + function f() result(res) + interface res ! { dg-error "attribute conflicts with" } + end Index: Fortran/gfortran/regression/result_default_init_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_default_init_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-O" } +! Test the fix for PR29216 in which function results did not +! get default initialization. +! Contributed by Stephan Kramer +! + type A + integer, pointer:: p => null () + integer:: i=3 + end type A + type(A):: x,y + if (associated(x%p) .or. x%i /= 3) STOP 1 + x=f() + if (associated(x%p) .or. x%i /= 3) STOP 2 + x=g() + if (associated(x%p) .or. x%i /= 3) STOP 3 +contains + function f() result (fr) + type(A):: fr + if (associated(fr%p) .or. fr%i /= 3) STOP 4 + end function f + function g() + type(A):: g + if (associated(g%p) .or. g%i /= 3) STOP 5 + end function g +end Index: Fortran/gfortran/regression/result_in_spec_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_in_spec_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Tests the check for PR31215, in which actual/formal interface +! was not being correctly handled for the size of 'r' because +! it is a result. +! +! Contributed by Joost VandeVondele +! +module test1 + implicit none +contains + character(f(x)) function test2(x) result(r) + implicit integer (x) + dimension r(len(r)+1) + integer, intent(in) :: x + interface + pure function f(x) + integer, intent(in) :: x + integer f + end function f + end interface + integer i + do i = 1, len(r) + r(:)(i:i) = achar(mod(i,32)+iachar('@')) + end do + end function test2 +end module test1 + +program test + use test1 + implicit none +! Original problem + if (len(test2(10)) .ne. 21) STOP 1 +! Check non-intrinsic calls are OK and check that fix does +! not confuse result variables. + if (any (myfunc (test2(1)) .ne. "ABC")) STOP 2 +contains + function myfunc (ch) result (chr) + character (*) :: ch(:) + character(len(ch)) :: chr(4) + if (len (ch) .ne. 3) STOP 3 + if (any (ch .ne. "ABC")) STOP 4 + chr = test2 (1) + if (len(test2(len(chr))) .ne. 7) STOP 5 + end function myfunc +end program test + +pure function f(x) + integer, intent(in) :: x + integer f + f = 2*x+1 +end function f Index: Fortran/gfortran/regression/result_in_spec_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_in_spec_2.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! Tests the fix for PR32047, in which the null agument +! function for the character length would cause an ICE. +! +! Contributed by Tobias Burnus +! +module test1 + implicit none +contains + character(f()) function test2() result(r) + interface + pure function f() + integer f + end function f + end interface + r = '123' + end function test2 +end module test1 + +pure function f() + integer :: f + f = 3 +end function f + +program test + use test1 + implicit none + if(len (test2()) /= 3) STOP 1 + if(test2() /= '123') STOP 2 +end program test Index: Fortran/gfortran/regression/result_in_spec_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_in_spec_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=gnu -Wreturn-type" } +! PR fortran/34248 +! +! There was an ICE for assumed-length functions +! if RESULT(...) was used and no value assigned +! to the result variable. +! +character(*) FUNCTION test() RESULT(ctab) + ctab = "Hello" +END function test + +FUNCTION test2() RESULT(res) ! { dg-warning "not set" } + character(*) :: res +END function test2 Index: Fortran/gfortran/regression/result_in_spec_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/result_in_spec_4.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/49648 +! ICE for calls to a use-associated function returning an array whose spec +! depends on a function call. + +! Contributed by Tobias Burnus + +module m2 + COMPLEX, SAVE, ALLOCATABLE :: P(:) +contains + FUNCTION getPhaseMatrix() RESULT(PM) + COMPLEX:: PM(SIZE(P),3) + PM=0.0 + END FUNCTION +end module m2 + +module m + use m2 +contains + SUBROUTINE gf_generateEmbPot() + COMPLEX :: sigma2(3,3) + sigma2 = MATMUL(getPhaseMatrix(), sigma2) + END SUBROUTINE +end module m Index: Fortran/gfortran/regression/ret_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ret_array_1.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! Test functions returning arrays of indeterminate size. +program ret_array_1 + integer, dimension(:, :), allocatable :: a + integer, dimension(2) :: b + + allocate (a(2, 3)) + a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/)) + + ! Using the return value as an actual argument + b = 0; + b = sum (transpose (a), 1); + if (any (b .ne. (/9, 12/))) STOP 1 + + ! Using the return value in an expression + b = 0; + b = sum (transpose (a) + 1, 1); + if (any (b .ne. (/12, 15/))) STOP 2 + + ! Same again testing a user function +! TODO: enable these once this is implemented +! b = 0; +! b = sum (my_transpose (a), 1); +! if (any (b .ne. (/9, 12/))) STOP 3 +! +! ! Using the return value in an expression +! b = 0; +! b = sum (my_transpose (a) + 1, 1); +! if (any (b .ne. (/12, 15/))) STOP 4 +contains +subroutine test(x, n) + integer, dimension (:, :) :: x + integer n + + if (any (shape (x) .ne. (/3, 2/))) STOP 1 + if (any (x .ne. (n + reshape((/1, 4, 2, 5, 3, 6/), (/3, 2/))))) STOP 2 +end subroutine + +function my_transpose (x) result (r) + interface + pure function obfuscate (i) + integer obfuscate + integer, intent(in) :: i + end function + end interface + integer, dimension (:, :) :: x + integer, dimension (obfuscate(ubound(x, 2)), & + obfuscate(ubound(x, 1))) :: r + integer i + + do i = 1, ubound(x, 1) + r(:, i) = x(i, :) + end do +end function +end program + +pure function obfuscate (i) + integer obfuscate + integer, intent(in) :: i + + obfuscate = i +end function + Index: Fortran/gfortran/regression/ret_pointer_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ret_pointer_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test functions returning array pointers +program ret_pointer_1 + integer, pointer, dimension(:) :: a + integer, target, dimension(2) :: b + integer, pointer, dimension (:) :: p + + a => NULL() + a => foo() + p => b + if (.not. associated (a, p)) STOP 1 +contains +subroutine bar(p) + integer, pointer, dimension(:) :: p +end subroutine +function foo() result(r) + integer, pointer, dimension(:) :: r + + r => b +end function +end program + Index: Fortran/gfortran/regression/ret_pointer_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ret_pointer_2.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! PR 25806: Functions returning pointers to arrays +program a + integer, target :: storage(5) + integer :: s(3) + + + print *, x(3) ! { dg-output " *1 *2 *3" } + + if (ssum(x(3)) /= 6) STOP 1 + + s = 0 + s = x(3) + if (any(s /= (/1, 2, 3/))) STOP 2 + +contains + + function x(n) result(t) + integer, intent(in) :: n + integer, pointer :: t(:) + integer :: i + + t => storage(1:n) + t = (/ (i, i = 1, n) /) + + end function x + + + integer function ssum(a) + integer, intent(in) :: a(:) + + ssum = sum(a) + + end function ssum + +end program a + + Index: Fortran/gfortran/regression/return_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/return_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Test cases where no blank is required after RETURN +subroutine sub(*) +return(1) +return1 ! { dg-error "" } +end subroutine Index: Fortran/gfortran/regression/rewind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rewind_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Check that rewind doesn't delete a file. +! Writing to the file truncates it at the end of the current record. Out +! IO library was defering the actual truncation until the file was rewound. +! A second rewind would then (incorrectly) think the file had just been +! written to, and truncate the file to zero length. +program foo + character*11 s + open(unit=11, status="SCRATCH") + write(11, '(a11)') "Hello World" + rewind(11) + rewind(11) + s = "" + read(11, '(a11)') s + close(11) + if (s .ne. "Hello World") STOP 1 +end program + Index: Fortran/gfortran/regression/round_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/round_1.f03 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR35962 Implement F2003 rounding modes. +! Test case prepared by Jerry DeLisle +character(11) :: fmt(7) +character(80) :: line +integer :: i +fmt = (/'(RU,6F10.1)', '(RD,6F10.1)', '(RZ,6F10.1)', & + '(RN,6F10.2)', '(RC,6F10.2)', '(RP,6F10.1)', & + '(SP,6F10.1)' /) +do i = 1, 7 + !print fmt(i), 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +end do +write(line, fmt(1)) 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +if (line.ne." 1.3 1.3 1.3 1.3 1.3 1.2") STOP 1 +write(line, fmt(2)) 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +if (line.ne." 1.2 1.2 1.2 1.2 1.2 1.1") STOP 2 +write(line, fmt(3)) 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +if (line.ne." 1.2 1.2 1.2 1.2 1.2 1.1") STOP 3 +write(line, fmt(4)) 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +if (line.ne." 1.20 1.22 1.25 1.27 1.30 1.12") STOP 4 +write(line, fmt(5)) 1.20, 1.22, 1.25, 1.27, 1.30, 1.125 +if (line.ne." 1.20 1.22 1.25 1.27 1.30 1.13") STOP 5 +write(line, fmt(6)) 1.20, 1.22, 1.250001, 1.27, 1.30, 1.125 +if (line.ne." 1.2 1.2 1.3 1.3 1.3 1.1") STOP 6 +write(line, fmt(7)) 1.20, 1.22, 1.250001, 1.27, 1.30, 1.125 +if (line.ne." +1.2 +1.2 +1.3 +1.3 +1.3 +1.1") STOP 7 + +end Index: Fortran/gfortran/regression/round_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/round_2.f03 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR35962 Implement F2003 rounding modes. +! Test case prepared by Jerry Delisle +integer,parameter :: j = max(4, selected_real_kind (precision (0.0_4) + 1)) +integer,parameter :: k = max(4, selected_real_kind (precision (0.0_8) + 1)) +character(64) :: line + write(line, '(RN, 4F10.3)') 0.0625_j, 0.1875_j + if (line.ne." 0.062 0.188") STOP 1 + write(line, '(RN, 4F10.2)') 0.125_j, 0.375_j, 1.125_j, 1.375_j + if (line.ne." 0.12 0.38 1.12 1.38") STOP 2 + write(line, '(RN, 4F10.1)') 0.25_j, 0.75_j, 1.25_j, 1.75_j + if (line.ne." 0.2 0.8 1.2 1.8") STOP 3 + write(line, '(RN, 4F10.0)') 0.5_j, 1.5_j, 2.5_j, 3.5_j + if (line.ne." 0. 2. 2. 4.") STOP 4 + + write(line, '(RN, 4F10.3)') 0.0625_k, 0.1875_k + if (line.ne." 0.062 0.188") STOP 5 + write(line, '(RN, 4F10.2)') 0.125_k, 0.375_k, 1.125_k, 1.375_k + if (line.ne." 0.12 0.38 1.12 1.38") STOP 6 + write(line, '(RN, 4F10.1)') 0.25_k, 0.75_k, 1.25_k, 1.75_k + if (line.ne." 0.2 0.8 1.2 1.8") STOP 7 + write(line, '(RN, 4F10.0)') 0.5_k, 1.5_k, 2.5_k, 3.5_k + if (line.ne." 0. 2. 2. 4.") STOP 8 +end Index: Fortran/gfortran/regression/round_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/round_3.f08 @@ -0,0 +1,148 @@ +! { dg-do run } +! PR48615 Invalid UP/DOWN rounding with E and ES descriptors +! Test case provided by Thomas Henlich. +program pr48615 + call checkfmt("(RU,F17.0)", 2.5, " 3.") + call checkfmt("(RU,-1P,F17.1)", 2.5, " 0.3") + call checkfmt("(RU,E17.1)", 2.5, " 0.3E+01") + call checkfmt("(RU,1P,E17.0)", 2.5, " 3.E+00") + call checkfmt("(RU,ES17.0)", 2.5, " 3.E+00") + call checkfmt("(RU,EN17.0)", 2.5, " 3.E+00") + call checkfmt("(RU,F2.0)", 2.0, "2.") + call checkfmt("(RU,F6.4)", 2.0, "2.0000") + call checkfmt("(RU,1P,E6.0E2)", 2.0, "2.E+00") + call checkfmt("(RU,1P,E7.1E2)", 2.5, "2.5E+00") + call checkfmt("(RU,1P,E10.4E2)", 2.5, "2.5000E+00") + call checkfmt("(RU,1P,G6.0E2)", 2.0, "2.E+00") + call checkfmt("(RU,1P,G10.4E2)", 2.3456e5, "2.3456E+05") + + call checkfmt("(RC,G10.2)", 99.5, " 0.10E+03") ! pr59774 + call checkfmt("(RC,G10.2)", 995., " 0.10E+04") ! pr59774 + call checkfmt("(RC,G10.3)", 999.5, " 0.100E+04") ! pr59774 + call checkfmt("(RC,G10.3)", 9995., " 0.100E+05") ! pr59774 + call checkfmt("(RU,G10.2)", .099, " 0.10 ") ! pr59774 + call checkfmt("(RC,G10.1)", .095, " 0.1 ") ! pr59774 + call checkfmt("(RU,G10.3)", .0999, " 0.100 ") ! pr59774 + call checkfmt("(RC,G10.2)", .0995, " 0.10 ") ! pr59774 + + call checkfmt("(RU,G9.3)", 891.1, " 892.") ! pr59836 + call checkfmt("(RD,G9.3)", -891.1, "-892.") ! pr59836 + + call checkfmt("(RU,F6.4)", 0.00006, "0.0001")! 0. + call checkfmt("(RU,F5.3)", 0.0007, "0.001") ! 0. + call checkfmt("(RU,F4.2)", 0.008, "0.01") ! 0. + call checkfmt("(RU,F3.1)", 0.09, "0.1") ! 0. + + call checkfmt("(RU,F2.0)", 0.09, "1.") ! 0. + call checkfmt("(RD,F3.0)", -0.09, "-1.") ! -0. + call checkfmt("(RU,F2.0)", 0.9, "1.") ! pr59836 + call checkfmt("(RC,F2.0)", 0.4, "0.") ! pr59836 + call checkfmt("(RC,F2.0)", 0.5, "1.") ! pr59836 + call checkfmt("(RC,F2.0)", 0.6, "1.") ! pr59836 + call checkfmt("(RD,F3.0)", -0.9, "-1.") ! pr59836 + call checkfmt("(RC,F3.0)", -0.4, "-0.") ! pr59836 + call checkfmt("(RC,F3.0)", -0.5, "-1.") ! pr59836 + call checkfmt("(RC,F3.0)", -0.6, "-1.") ! pr59836 + call checkfmt("(RU,F2.0)", 2.0, "2.") ! 3. + call checkfmt("(RD,F3.0)", -2.0, "-2.") ! -3. + call checkfmt("(RU,F6.4)", 2.0, "2.0000") ! 2.0001 + call checkfmt("(RD,F7.4)", -2.0, "-2.0000") ! -2.0001 + call checkfmt("(RU,1P,E6.0E2)", 2.0, "2.E+00") ! 3.E+00 + call checkfmt("(RD,1P,E7.0E2)", -2.0, "-2.E+00") ! -3.E+00 + call checkfmt("(RU,1P,E7.1E2)", 2.5, "2.5E+00") ! 2.6E+00 + call checkfmt("(RD,1P,E8.1E2)", -2.5, "-2.5E+00") ! -2.6E+00 + call checkfmt("(RU,1P,E10.4E2)", 2.5, "2.5000E+00") ! 2.5001E+00 + call checkfmt("(RD,1P,E11.4E2)", -2.5, "-2.5000E+00") ! -2.5001E+00 + call checkfmt("(RU,1P,G6.0E2)", 2.0, "2.E+00") ! 3.E+00 + call checkfmt("(RD,1P,G7.0E2)", -2.0, "-2.E+00") ! -3.E+00 + call checkfmt("(RU,1P,G10.4E2)", 2.3456e5, "2.3456E+05") ! 2.3457E+05 + call checkfmt("(RD,1P,G11.4E2)", -2.3456e5, "-2.3456E+05") ! -2.3457E+05 + + call checkfmt("(RD,F17.0)", 2.5, " 2.") + call checkfmt("(RD,-1P,F17.1)", 2.5, " 0.2") + call checkfmt("(RD,E17.1)", 2.5, " 0.2E+01") + call checkfmt("(RD,1P,E17.0)", 2.5, " 2.E+00") + call checkfmt("(RD,ES17.0)", 2.5, " 2.E+00") + call checkfmt("(RD,EN17.0)", 2.5, " 2.E+00") + + call checkfmt("(RC,F17.0)", 2.5, " 3.") + call checkfmt("(RC,-1P,F17.1)", 2.5, " 0.3") + call checkfmt("(RC,E17.1)", 2.5, " 0.3E+01") + call checkfmt("(RC,1P,E17.0)", 2.5, " 3.E+00") + call checkfmt("(RC,ES17.0)", 2.5, " 3.E+00") + call checkfmt("(RC,EN17.0)", 2.5, " 3.E+00") + + call checkfmt("(RN,F17.0)", 2.5, " 2.") + call checkfmt("(RN,-1P,F17.1)", 2.5, " 0.2") + call checkfmt("(RN,E17.1)", 2.5, " 0.2E+01") + call checkfmt("(RN,1P,E17.0)", 2.5, " 2.E+00") + call checkfmt("(RN,ES17.0)", 2.5, " 2.E+00") + call checkfmt("(RN,EN17.0)", 2.5, " 2.E+00") + + call checkfmt("(RZ,F17.0)", 2.5, " 2.") + call checkfmt("(RZ,-1P,F17.1)", 2.5, " 0.2") + call checkfmt("(RZ,E17.1)", 2.5, " 0.2E+01") + call checkfmt("(RZ,1P,E17.0)", 2.5, " 2.E+00") + call checkfmt("(RZ,ES17.0)", 2.5, " 2.E+00") + call checkfmt("(RZ,EN17.0)", 2.5, " 2.E+00") + + call checkfmt("(RZ,F17.0)", -2.5, " -2.") + call checkfmt("(RZ,-1P,F17.1)", -2.5, " -0.2") + call checkfmt("(RZ,E17.1)", -2.5, " -0.2E+01") + call checkfmt("(RZ,1P,E17.0)", -2.5, " -2.E+00") + call checkfmt("(RZ,ES17.0)", -2.5, " -2.E+00") + call checkfmt("(RZ,EN17.0)", -2.5, " -2.E+00") + + call checkfmt("(RN,F17.0)", -2.5, " -2.") + call checkfmt("(RN,-1P,F17.1)", -2.5, " -0.2") + call checkfmt("(RN,E17.1)", -2.5, " -0.2E+01") + call checkfmt("(RN,1P,E17.0)", -2.5, " -2.E+00") + call checkfmt("(RN,ES17.0)", -2.5, " -2.E+00") + call checkfmt("(RN,EN17.0)", -2.5, " -2.E+00") + + call checkfmt("(RC,F17.0)", -2.5, " -3.") + call checkfmt("(RC,-1P,F17.1)", -2.5, " -0.3") + call checkfmt("(RC,E17.1)", -2.5, " -0.3E+01") + call checkfmt("(RC,1P,E17.0)", -2.5, " -3.E+00") + call checkfmt("(RC,ES17.0)", -2.5, " -3.E+00") + call checkfmt("(RC,EN17.0)", -2.5, " -3.E+00") + + call checkfmt("(RU,E17.1)", nearest(2.0, 1.0), " 0.3E+01") + call checkfmt("(RD,E17.1)", nearest(3.0, -1.0), " 0.2E+01") + + call checkfmt("(G12.2)", 99.0, " 99. ") + call checkfmt("(G12.2)", 99.5, " 0.10E+03") + call checkfmt("(G12.2)", 100.0, " 0.10E+03") + call checkfmt("(G12.2)", -99.0, " -99. ") + call checkfmt("(G12.2)", -99.5, " -0.10E+03") + call checkfmt("(G12.2)", -100.0, " -0.10E+03") + call checkfmt("(RU,G12.2)", 99.0, " 99. ") ! pr93567 + call checkfmt("(RU,G12.2)", 99.01, " 0.10E+03") + call checkfmt("(RU,G12.2)", -99.0, " -99. ") + call checkfmt("(RU,G12.2)", -99.01, " -99. ") + call checkfmt("(RU,G12.2)", -100.01, " -0.10E+03") + call checkfmt("(RU,G12.4)", 99.0 , " 99.00 ") + call checkfmt("(RU,G12.4)", 99.01, " 99.02 ") + call checkfmt("(RD,G12.2)", 99.0, " 99. ") + call checkfmt("(RD,G12.2)", 99.01, " 99. ") + call checkfmt("(RD,G12.2)", 100.01, " 0.10E+03") + call checkfmt("(RD,G12.2)", -99.0, " -99. ") + call checkfmt("(RD,G12.2)", -99.01, " -0.10E+03") + call checkfmt("(RD,G12.2)", -100.00, " -0.10E+03") + call checkfmt("(Rz,G12.2)", 99.01, " 99. ") + call checkfmt("(Rz,G12.2)", 100.01, " 0.10E+03") + call checkfmt("(Rz,G12.2)", -99.01, " -99. ") + call checkfmt("(Rz,G12.2)", -100.01, " -0.10E+03") + +contains + subroutine checkfmt(fmt, x, cmp) + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*), intent(in) :: cmp + character(len=20) :: s + + write(s, fmt) x + if (s /= cmp) STOP 1 + !if (s /= cmp) print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + end subroutine +end program Index: Fortran/gfortran/regression/round_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/round_4.f90 @@ -0,0 +1,121 @@ +! { dg-do run { xfail i?86-*-freebsd* } } +! { dg-add-options ieee } +! { dg-skip-if "PR libfortran/58015" { hppa*-*-hpux* } } +! { dg-skip-if "IBM long double 31 bits of precision, test requires 38" { powerpc*-*-linux* } } +! +! PR fortran/35862 +! +! Test whether I/O rounding works. Uses internally (libgfortran) strtod +! for the conversion - and sets the CPU rounding mode accordingly. +! +! Only few strtod implementations currently support rounding. Therefore +! we use a heuristic to determine if the rounding support is available. +! The assumption is that if strtod gives *different* results for up/down +! rounding, then it will give *correct* results for nearest/zero/up/down +! rounding too. And that is what is effectively checked. +! +! If it doesn't work on your system, please check whether strtod handles +! rounding correctly and whether your system is supported in +! libgfortran/config/fpu*.c +! +! Please only add ... run { target { ! { triplets } } } if it is unfixable +! on your target - and a note why (strtod has broken rounding support, etc.) +! +program main + use iso_fortran_env + implicit none + + ! The following uses kinds=10 and 16 if available or + ! 8 and 10 - or 8 and 16 - or 4 and 8. + integer, parameter :: xp = real_kinds(ubound(real_kinds,dim=1)-1) + integer, parameter :: qp = real_kinds(ubound(real_kinds,dim=1)) + + real(4) :: r4p, r4m, ref4u, ref4d + real(8) :: r8p, r8m, ref8u, ref8d + real(xp) :: r10p, r10m, ref10u, ref10d + real(qp) :: r16p, r16m, ref16u, ref16d + character(len=20) :: str, round + logical :: rnd4, rnd8, rnd10, rnd16 + + ! Test for which types glibc's strtod function supports rounding + str = '0.01 0.01 0.01 0.01' + read (str, *, round='up') r4p, r8p, r10p, r16p + read (str, *, round='down') r4m, r8m, r10m, r16m + rnd4 = r4p /= r4m + rnd8 = r8p /= r8m + rnd10 = r10p /= r10m + rnd16 = r16p /= r16m +! write (*, *) rnd4, rnd8, rnd10, rnd16 + + ref4u = 0.100000001_4 + ref8u = 0.10000000000000001_8 + + if (xp == 4) then + ref10u = 0.100000001_xp + elseif (xp == 8) then + ref10u = 0.10000000000000001_xp + else ! xp == 10 + ref10u = 0.1000000000000000000014_xp + end if + + if (qp == 8) then + ref16u = 0.10000000000000001_qp + elseif (qp == 10) then + ref16u = 0.1000000000000000000014_qp + else ! qp == 16 + ref16u = 0.10000000000000000000000000000000000481_qp + end if + + ! ref*d = 9.999999... + ref4d = nearest (ref4u, -1.0_4) + ref8d = nearest (ref8u, -1.0_8) + ref10d = nearest (ref10u, -1.0_xp) + ref16d = nearest (ref16u, -1.0_qp) + + round = 'up' + call t() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4d)) STOP 1 + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8d)) STOP 2 + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10d)) STOP 3 + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16d)) STOP 4 + + round = 'down' + call t() + if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4u)) STOP 5 + if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8u)) STOP 6 + if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10u)) STOP 7 + if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16u)) STOP 8 + + round = 'zero' + call t() + if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4d)) STOP 9 + if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8d)) STOP 10 + if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10d)) STOP 11 + if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16d)) STOP 12 + + round = 'nearest' + call t() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) STOP 13 + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) STOP 14 + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) STOP 15 + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) STOP 16 + +! Same as nearest (but rounding towards zero if there is a tie +! [does not apply here]) + round = 'compatible' + call t() + if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) STOP 17 + if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) STOP 18 + if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) STOP 19 + if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) STOP 20 +contains + subroutine t() +! print *, round + str = "0.1 0.1 0.1 0.1" + read (str, *,round=round) r4p, r8p, r10p, r16p +! write (*, '(*(g0:" "))') r4p, r8p, r10p, r16p + str = "-0.1 -0.1 -0.1 -0.1" + read (str, *,round=round) r4m, r8m, r10m, r16m +! write (*, *) r4m, r8m, r10m, r16m + end subroutine t +end program main Index: Fortran/gfortran/regression/rrspacing_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/rrspacing_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +program m + integer i + real x,y + real, parameter :: a = -3.0 + i = int(rrspacing(a)) + if (i /= 12582912) STOP 1 +end program m Index: Fortran/gfortran/regression/runtime_warning_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/runtime_warning_1.f90 @@ -0,0 +1,17 @@ +! Test runtime warnings using non-standard $ editing - PR20006. +! +! Contributor Francois-Xavier Coudert +! +! { dg-options "-pedantic" } +! { dg-do run } +! + character(5) c + open (42,status='scratch') + write (42,'(A,$)') 'abc' ! { dg-warning ".*descriptor" } + write (42,'(A)') 'de' + rewind (42) + read (42,'(A)') c + close (42) + if (c /= 'abcde') STOP 1 + end +