Index: Fortran/gfortran/regression/20181025-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/20181025-1.f @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-Ofast" } +! { dg-additional-options "-mavx2" { target { x86_64-*-* i?86-*-* } } } + SUBROUTINE FOO(EF3,CA,ZA,NATA,IC4,NFRGPT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MXATM=500) + COMMON DE(3,MXATM) + DIMENSION CA(3,NATA) + DIMENSION ZA(NATA) + DIMENSION EF3(3,NFRGPT) + DO II = 1,NATA + XII = XJ - CA(1,II) + YII = YJ - CA(2,II) + ZII = ZJ - CA(3,II) + RJII = SQRT(XII*XII + YII*YII + ZII*ZII) + R3 = RJII*RJII*RJII + IF (IC4.EQ.0) THEN + DE(1,II) = DE(1,II) - S2*ZA(II)*XII/R3 + DE(2,II) = DE(2,II) - S2*ZA(II)*YII/R3 + DE(3,II) = DE(3,II) - S2*ZA(II)*ZII/R3 + ELSE + EF3(1,IC4+II) = EF3(1,IC4+II) - S2*ZA(II)*XII/R3 + EF3(2,IC4+II) = EF3(2,IC4+II) - S2*ZA(II)*YII/R3 + EF3(3,IC4+II) = EF3(3,IC4+II) - S2*ZA(II)*ZII/R3 + END IF + END DO + RETURN + END Index: Fortran/gfortran/regression/same_name_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/same_name_1.f90 @@ -0,0 +1,13 @@ +! { dg-do assemble } +module n +private u +contains + subroutine u + end subroutine u +end module n +module m + private :: u +contains + subroutine u + end subroutine u +end module m Index: Fortran/gfortran/regression/same_name_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/same_name_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests the fix for PR27701, in which two same name procedures +! were not diagnosed if they had no arguments. +! +! Contributed by Arjen Markus +! +module aha +contains +subroutine aa ! { dg-error "Procedure" } + write(*,*) 'AA' +end subroutine aa +subroutine aa ! { dg-error "is already defined" } + write(*,*) 'BB' ! { dg-error "Unexpected WRITE statement in CONTAINS section" } +end subroutine aa ! { dg-error "Expecting END MODULE statement" } +end module Index: Fortran/gfortran/regression/same_type_as_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/same_type_as_1.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF. +! +! Contributed by Janus Weil + + type :: t1 + integer :: i + end type + + type :: ts + sequence + integer :: j + end type + + TYPE(t1) :: x1 + TYPE(ts) :: x2 + + integer :: i + + print *, SAME_TYPE_AS (i,x1) ! { dg-error "cannot be of type INTEGER" } + print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" } + + print *, EXTENDS_TYPE_OF (i,x1) ! { dg-error "cannot be of type INTEGER" } + print *, EXTENDS_TYPE_OF (x1,x2) ! { dg-error "must be of an extensible type" } + +end Index: Fortran/gfortran/regression/same_type_as_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/same_type_as_2.f03 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS. +! +! Contributed by Janus Weil + + type :: t1 + integer :: i + end type + + type, extends(t1) :: t2 + integer :: j + end type + + CLASS(t1), pointer :: c1,c2 + TYPE(t1), target :: x1 + TYPE(t2) ,target :: x2 + + intrinsic :: SAME_TYPE_AS + logical :: l + + c1 => NULL() + + l = SAME_TYPE_AS (x1,x1) + print *,l + if (.not.l) STOP 1 + l = SAME_TYPE_AS (x1,x2) + print *,l + if (l) STOP 2 + + c1 => x1 + l = SAME_TYPE_AS (c1,x1) + print *,l + if (.not.l) STOP 3 + l = SAME_TYPE_AS (c1,x2) + print *,l + if (l) STOP 4 + + c1 => x2 + c2 => x2 + l = SAME_TYPE_AS (c1,c2) + print *,l + if (.not.l) STOP 5 + + c1 => x1 + c2 => x2 + l = SAME_TYPE_AS (c1,c2) + print *,l + if (l) STOP 6 + +end Index: Fortran/gfortran/regression/same_type_as_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/same_type_as_3.f03 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Test the fix for PR57710. +! +! Contributed by Tobias Burnus +! +module m + type t + end type t + type t2 + integer :: ii + class(t), allocatable :: x + end type t2 +contains + subroutine fini(x) + type(t) :: x + end subroutine fini +end module m + +use m +block + type(t) :: z + type(t2) :: y + y%ii = 123 + if (.not. same_type_as(y%x, z)) call abort () +end block +end Index: Fortran/gfortran/regression/save_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-O2 -fno-automatic" } + subroutine foo (b) + logical b + integer i, j + character*24 s + save i + if (b) then + i = 26 + j = 131 + s = 'This is a test string' + else + if (i .ne. 26 .or. j .ne. 131) STOP 1 + if (s .ne. 'This is a test string') STOP 2 + end if + end subroutine foo + subroutine bar (s) + character*42 s + if (s .ne. '0123456789012345678901234567890123456') STOP 3 + call foo (.false.) + end subroutine bar + subroutine baz + character*42 s + ! Just clobber stack a little bit. + s = '0123456789012345678901234567890123456' + call bar (s) + end subroutine baz + call foo (.true.) + call baz + call foo (.false.) + end Index: Fortran/gfortran/regression/save_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_2.f90 @@ -0,0 +1,22 @@ +! PR fortran/28415 +! { dg-do run } +! { dg-options "-O2 -fno-automatic" } + + program foo + integer arrlen + arrlen = 30 + call bar(arrlen) + stop + end + + subroutine bar(arg) + integer arg + double precision arr(arg) + do i = 1, arg + arr(i) = 1.0d0 + enddo + do i = 1, arg + write(*,*) i, arr(i) + enddo + return + end Index: Fortran/gfortran/regression/save_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_3.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +! PR fortran/35837 +! We used do have a problem with resolving "save all" and nested namespaces. + +! Contributed by Tobias Burnus + +module g95bug +save +integer :: i=20 +contains +pure function tell_i() result (answer) + integer :: answer + answer=i +end function tell_i +end module g95bug Index: Fortran/gfortran/regression/save_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/53597 +! +MODULE somemodule + IMPLICIT NONE + TYPE sometype + INTEGER :: i + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: coef => NULL() + END TYPE sometype + TYPE(sometype) :: somevariable ! { dg-error "Fortran 2008: Implied SAVE for module variable 'somevariable' at .1., needed due to the default initialization" } +END MODULE somemodule Index: Fortran/gfortran/regression/save_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_5.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-fno-automatic" } +! +! PR fortran/55733 +! +! Check that -fno-automatic makes the local variable SAVEd +! + +! Scalar allocatable +subroutine foo(i) + integer :: i + integer, allocatable :: j + if (i == 1) j = 42 + if (.not. allocated (j)) STOP 1 + if (j /= 42) STOP 2 +end + +! Deferred-length string scalar +subroutine bar() + logical, save :: first = .true. + character(len=:), allocatable :: str + if (first) then + first = .false. + if (allocated (str)) STOP 3 + str = "ABCDEF" + end if + if (.not. allocated (str)) STOP 4 + if (len (str) /= 6) STOP 5 + if (str(1:6) /= "ABCDEF") STOP 6 +end subroutine bar + +! Deferred-length string array +subroutine bar_array() + logical, save :: first = .true. + character(len=:), allocatable :: str + if (first) then + first = .false. + if (allocated (str)) STOP 7 + str = "ABCDEF" + end if + if (.not. allocated (str)) STOP 8 + if (len (str) /= 6) STOP 9 + if (str(1:6) /= "ABCDEF") STOP 10 +end subroutine bar_array + +call foo(1) +call foo(2) +call bar() +call bar_array() +call bar() +call bar_array() +end Index: Fortran/gfortran/regression/save_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_6.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! { dg-require-effective-target lto } +! { dg-options "-fno-automatic -flto -g" } +! +! PR fortran/55733 +! +! Check that -fno-automatic makes the local variable SAVEd +! Check that -flto -g works +! + +! Scalar allocatable +subroutine foo(i) + integer :: i + integer, allocatable :: j + if (i == 1) j = 42 + if (.not. allocated (j)) STOP 1 + if (j /= 42) STOP 2 +end + +! Deferred-length string scalar +subroutine bar() + logical, save :: first = .true. + character(len=:), allocatable :: str + if (first) then + first = .false. + if (allocated (str)) STOP 3 + str = "ABCDEF" + end if + if (.not. allocated (str)) STOP 4 + if (len (str) /= 6) STOP 5 + if (str(1:6) /= "ABCDEF") STOP 6 +end subroutine bar + +! Deferred-length string array +subroutine bar_array() + logical, save :: first = .true. + character(len=:), allocatable :: str + if (first) then + first = .false. + if (allocated (str)) STOP 7 + str = "ABCDEF" + end if + if (.not. allocated (str)) STOP 8 + if (len (str) /= 6) STOP 9 + if (str(1:6) /= "ABCDEF") STOP 10 +end subroutine bar_array + +call foo(1) +call foo(2) +call bar() +call bar_array() +call bar() +call bar_array() +end Index: Fortran/gfortran/regression/save_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_7.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O2 -fno-automatic" } +! +! PR fortran/95107 - do not make associate variables TREE_STATIC +! Contributed by G.Steinmetz + +program p + type t + real, pointer :: a => null() + end type + type t2 + type(t) :: b(1) + end type + type(t2), save :: x + associate (y => x%b) + end associate +end Index: Fortran/gfortran/regression/save_common.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_common.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR20847 - A common variable may not have the SAVE attribute. +! Contributed by Joost VandeVondele +INTEGER, SAVE :: X +COMMON /COM/ X ! { dg-error "conflicts with SAVE attribute" } +END Index: Fortran/gfortran/regression/save_parameter.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_parameter.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/32633 - implied SAVE conflicts with parameter attribute +! Testcase contributed by: Joost VandeVondele + +MODULE test + CHARACTER(len=1), PARAMETER :: backslash = '\\' + PUBLIC :: backslash +END MODULE Index: Fortran/gfortran/regression/save_result.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/save_result.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR20856 - A function result may not have SAVE attribute. +! Contributed by Joost VandeVondele +FUNCTION X() RESULT(Y) +REAL, SAVE :: Y ! { dg-error "RESULT attribute conflicts with SAVE" } +y = 1 +END FUNCTION X +END Index: Fortran/gfortran/regression/saved_automatic_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/saved_automatic_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests patch for PR23091, in which autmatic objects caused +! an ICE if they were given the SAVE attribute. +! +! Contributed by Valera Veryazov +! +Subroutine My(n1) + integer :: myArray(n1) + character(n1) :: ch + save ! OK because only allowed objects are saved globally. + call xxx(myArray, ch) + return + end + +Subroutine Thy(n1) + integer, save :: myArray(n1) ! { dg-error "SAVE attribute" } + character(n1), save :: ch ! { dg-error "SAVE attribute" } + call xxx(myArray, ch) + return + end + Index: Fortran/gfortran/regression/scalar_mask_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalar_mask_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +program main + implicit none + real, dimension(2) :: a + a(1) = 2.0 + a(2) = 3.0 + if (product (a, .false.) /= 1.0) STOP 1 + if (product (a, .true.) /= 6.0) STOP 2 + if (sum (a, .false.) /= 0.0) STOP 3 + if (sum (a, .true.) /= 5.0) STOP 4 + if (maxval (a, .true.) /= 3.0) STOP 5 + if (maxval (a, .false.) > -1e38) STOP 6 + if (maxloc (a, 1, .true.) /= 2) STOP 7 + if (maxloc (a, 1, .false.) /= 0) STOP 8! Change to F2003 requirement. +end program main Index: Fortran/gfortran/regression/scalar_mask_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalar_mask_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +program main + ! Test scalar masks for different intrinsics. + real, dimension(2,2) :: a + logical(kind=2) :: lo + lo = .false. + a(1,1) = 1. + a(1,2) = -1. + a(2,1) = 13. + a(2,2) = -31. + if (any (minloc (a, lo) /= 0)) STOP 1 + if (any (minloc (a, .true.) /= (/ 2, 2 /))) STOP 2 + if (any (minloc(a, 1, .true.) /= (/ 1, 2/))) STOP 3 + if (any (minloc(a, 1, lo ) /= (/ 0, 0/))) STOP 4 + + if (any (maxloc (a, lo) /= 0)) STOP 5 + if (any (maxloc (a, .true.) /= (/ 2,1 /))) STOP 6 + if (any (maxloc(a, 1, .true.) /= (/ 2, 1/))) STOP 7 + if (any (maxloc(a, 1, lo) /= (/ 0, 0/))) STOP 8 + + if (any (maxval(a, 1, lo) /= -HUGE(a))) STOP 9 + if (any (maxval(a, 1, .true.) /= (/13., -1./))) STOP 10 + if (any (minval(a, 1, lo) /= HUGE(a))) STOP 11 + if (any (minval(a, 1, .true.) /= (/1., -31./))) STOP 12 + + if (any (product(a, 1, .true.) /= (/13., 31./))) STOP 13 + if (any (product(a, 1, lo ) /= (/1., 1./))) STOP 14 + + if (any (sum(a, 1, .true.) /= (/14., -32./))) STOP 15 + if (any (sum(a, 1, lo) /= (/0., 0./))) STOP 16 + +end program main Index: Fortran/gfortran/regression/scalar_pointer_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalar_pointer_1.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/84924 +! Testcase contributed by Seth Johnson +! +module ftest + use ISO_C_BINDING + implicit none + + type :: Cls + end type + + type :: ClsHandle + class(Cls), pointer :: ptr + end type +contains + subroutine to_ptr(c, p) + use ISO_C_BINDING + class(Cls), intent(in), target :: c + type(C_PTR), intent(out) :: p + type(ClsHandle), pointer :: handle + allocate(handle) + handle%ptr => c + p = c_loc(handle) + end subroutine + + subroutine from_ptr(p, c) + use ISO_C_BINDING + type(C_PTR), intent(in) :: p + class(Cls), intent(out), pointer :: c + type(ClsHandle), pointer :: handle + call c_f_pointer(cptr=p, fptr=handle) + c => handle%ptr + deallocate(handle) + end subroutine +end module Index: Fortran/gfortran/regression/scalar_return_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalar_return_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! tests the fix for pr25082 in which the return of an array by a +! subroutine went undremarked. +! +! Contributed by Joost VandeVondele +! +SUBROUTINE S1(*) +INTEGER :: a(2) +RETURN a ! { dg-error " requires a SCALAR" } +END SUBROUTINE S1 Index: Fortran/gfortran/regression/scalarize_parameter_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalarize_parameter_array_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Tests the fix for pr32682, in which the scalarization loop variables +! were not being determined when 'c' came first in an expression. +! +! Contributed by Janus Weil +! +program matrix + + implicit none + real,dimension(2,2),parameter::c=reshape((/1,2,3,4/),(/2,2/)) + real,dimension(2,2)::m, n + + m=f()+c + if (any (m .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 1 + m=c+f() + if (any (m .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 2 + call sub(m+f()) + if (any (n .ne. reshape((/3,4,5,6/),(/2,2/)))) STOP 3 + call sub(c+m) + if (any (n .ne. reshape((/3,5,7,9/),(/2,2/)))) STOP 4 + call sub(f()+c) + if (any (n .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 5 + call sub(c+f()) + if (any (n .ne. reshape((/2,3,4,5/),(/2,2/)))) STOP 6 + +contains + + function f() + implicit none + real, dimension(2,2)::f + f=1 + end function f + + subroutine sub(a) + implicit none + real, dimension(2,2)::a + n = a + end subroutine sub + +end program matrix Index: Fortran/gfortran/regression/scalarize_parameter_array_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scalarize_parameter_array_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Test the fix for PR45305. The if statements should simplify away so +! that 'I_do_not_exist' is not referenced. +! +! Contributed by Tobias Burnus +! +if (any (abs(bessel_jn([1,2], 1.0) - bessel_jn([1,2], 1.0)) & + > epsilon(0.0))) & + call I_do_not_exist() + +if (any (abs(bessel_jn(1, 2, 1.0) - bessel_jn([1,2], 1.0)) & + > epsilon(0.0))) & + call I_do_not_exist() +end Index: Fortran/gfortran/regression/scale_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scale_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! inspired by PR17175 +REAL X +DOUBLE PRECISION Y + +INTEGER, PARAMETER :: DP = KIND(Y) + +INTEGER(kind=1) I1 +INTEGER(kind=2) I2 +INTEGER(kind=4) I4 +INTEGER(kind=8) I8 + +X = 1. +Y = 1._DP + +I1 = 10 +I2 = -10 +I4 = 20 +I8 = -20 + +X = SCALE (X, I1) +X = SCALE (X, I2) +IF (X.NE.1.) STOP 1 +X = SCALE (X, I4) +X = SCALE (X, I8) +IF (X.NE.1.) STOP 2 + +Y = SCALE (Y, I1) +Y = SCALE (Y, I2) +IF (Y.NE.1._DP) STOP 3 +Y = SCALE (Y, I4) +Y = SCALE (Y, I8) +IF (Y.NE.1._DP) STOP 4 + +END Index: Fortran/gfortran/regression/scan_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scan_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +program b + integer w + character(len=2) s, t + s = 'xi' + + w = scan(s, 'iI') + if (w /= 2) STOP 1 + w = scan(s, 'xX', .true.) + if (w /= 1) STOP 2 + w = scan(s, 'ab') + if (w /= 0) STOP 3 + w = scan(s, 'ab', .true.) + if (w /= 0) STOP 4 + + s = 'xi' + t = 'iI' + w = scan(s, t) + if (w /= 2) STOP 5 + t = 'xX' + w = scan(s, t, .true.) + if (w /= 1) STOP 6 + t = 'ab' + w = scan(s, t) + if (w /= 0) STOP 7 + w = scan(s, t, .true.) + if (w /= 0) STOP 8 + +end program b + + + Index: Fortran/gfortran/regression/scan_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scan_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54608 +! +! Contributed by James Van Buskirk +! +module m1 + implicit none + contains + subroutine s1(A) + logical A + integer iscan, iverify + character(7), parameter :: tf(2) = ['.FALSE.','.TRUE. '] + + iscan = scan('AA','A',back=A) + iverify = verify('xx','A',back=A) + if (iscan /= 2 .or. iverify /= 2) STOP 1 + print *, iverify, iscan +! write(*,'(a)') 'SCAN test: A = '//trim(tf(iscan)) ! should print true +! write(*,'(a)') 'VERIFY test: A = '//trim(tf(iverify)) ! should print true + end subroutine s1 +end module m1 + +program p1 + use m1 + implicit none + logical B + + call s1(.TRUE.) +end program p1 + +! { dg-final { scan-tree-dump-times "_gfortran_string_scan \\(2," 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_string_verify \\(2," 1 "original" } } Index: Fortran/gfortran/regression/scan_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scan_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/103789 +! Check the absence of ICE when generating calls to SCAN with a KIND argument. + +program p + character(len=10) :: y(2) + integer :: z(2), x(2), w(2), v(2) + y = ['abc', 'def'] + z = scan(y, 'e', kind=4) + 1 + x = scan(y, 'e', back=.false., kind=4) + 1 + w = scan(y, 'e', .false., kind=4) + 1 + v = scan(y, 'e', .false., 4) + 1 +end program p Index: Fortran/gfortran/regression/scratch_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/scratch_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! Check that we can open more than 26 scratch files concurrently + integer :: i + do i = 1, 30 + print *, i + open(100+i,status="scratch") + end do +end Index: Fortran/gfortran/regression/secnds-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/secnds-1.f @@ -0,0 +1,30 @@ +C { dg-do run } +C { dg-options "-ffloat-store" } +C Tests fix for PR29099 - SECNDS intrinsic wrong result with no delay. +C +C Contributed by Paul Thomas +C + character*20 dum1, dum2, dum3 + real t1, t1a, t2, t2a + real*4 dat1, dat2 + integer i, j, values(8), k + t1 = secnds (0.0) + call date_and_time (dum1, dum2, dum3, values) + t1a = secnds (0.0) + dat1 = 0.001 * real(values(8)) + real(values(7)) + + & 60.0 * real(values(6)) + 3600.0 * real(values(5)) + ! handle midnight shift + if ((t1a - t1) < -12.0*3600.0 ) t1 = t1 - 24.0*3600.0 + if ((t1a - dat1) < -12.0*3600.0 ) dat1 = dat1 - 24.0*3600.0 + if ((dat1 < nearest(t1, -1.)) .or. (dat1 > nearest(t1a, 1.))) + & STOP 1 + t2a = secnds (t1a) + call date_and_time (dum1, dum2, dum3, values) + t2 = secnds (t1) + dat2 = 0.001 * real(values(8)) + real(values(7)) + + & 60.0 * real(values(6)) + 3600.0 * real(values(5)) + ! handle midnight shift + if ((dat2 - dat1) < -12.0*3600.0 ) dat1 = dat1 - 24.0*3600.0 + if (((dat2 - dat1) < t2a - 0.008) .or. + & ((dat2 - dat1) > t2 + 0.008)) STOP 2 + end Index: Fortran/gfortran/regression/secnds.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/secnds.f @@ -0,0 +1,34 @@ +C { dg-do run } +C { dg-options "-O0 -ffloat-store" } +C Tests fix for PR14994 - SECNDS intrinsic not supported. +C +C Contributed by Paul Thomas +C + character*20 dum1, dum2, dum3 + real t1, t1a, t2, t2a + real*4 dat1, dat2 + integer i, j, values(8), k + t1 = secnds (0.0) + call date_and_time (dum1, dum2, dum3, values) + t1a = secnds (0.0) + dat1 = 0.001 * real(values(8)) + real(values(7)) + + & 60.0 * real(values(6)) + 3600.0 * real(values(5)) + ! handle midnight shift + if ((t1a - t1) < -12.0*3600.0 ) t1 = t1 - 24.0*3600.0 + if ((t1a - dat1) < -12.0*3600.0 ) dat1 = dat1 - 24.0*3600.0 + if ((dat1 < nearest(t1, -1.)) .or. (dat1 > nearest(t1a, 1.))) + & STOP 1 + do j=1,10000 + do i=1,10000 + end do + end do + t2a = secnds (t1a) + call date_and_time (dum1, dum2, dum3, values) + t2 = secnds (t1) + dat2 = 0.001 * real(values(8)) + real(values(7)) + + & 60.0 * real(values(6)) + 3600.0 * real(values(5)) + ! handle midnight shift + if ((dat2 - dat1) < -12.0*3600.0 ) dat1 = dat1 - 24.0*3600.0 + if (((dat2 - dat1) < t2a - 0.008) .or. + & ((dat2 - dat1) > t2 + 0.008)) STOP 2 + end Index: Fortran/gfortran/regression/select_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Simple test for SELECT CASE +! +program select_2 + integer i + do i = 1, 5 + select case(i) + case (1) + if (i /= 1) STOP 1 + case (2:3) + if (i /= 2 .and. i /= 3) STOP 2 + case (4) + if (i /= 4) STOP 3 + case default + if (i /= 5) STOP 4 + end select + end do +end program select_2 Index: Fortran/gfortran/regression/select_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_10.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/103776 - ICE in gfc_compare_string +! Contributed by G.Steinmetz + +program p + integer :: n + select case (n) + case ([1]) ! { dg-error "must be scalar" } + end select + select case (n) + case (:[2]) ! { dg-error "must be scalar" } + end select + select case (n) + case (['1']) ! { dg-error "must be scalar" } + end select + select case (n) + case (['1']:2) ! { dg-error "must be scalar" } + end select + select case (n) + case(['1']:['2']) ! { dg-error "must be scalar" } + end select + select case (n) + case(1:['2']) ! { dg-error "must be scalar" } + end select +end Index: Fortran/gfortran/regression/select_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_2.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Simple test program to see if gfortran eliminates the 'case (3:2)' +! statement. This is an unreachable CASE because the range is empty. +! +program select_3 + integer i + do i = 1, 4 + select case(i) + case (1) + if (i /= 1) STOP 1 + case (3:2) + STOP 2 + case (4) + if (i /= 4) STOP 3 + case default + if (i /= 2 .and. i /= 3) STOP 4 + end select + end do +end program select_3 Index: Fortran/gfortran/regression/select_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Short test program with a CASE statement that uses a range. +! +program select_4 + integer i + do i = 1, 34, 4 + select case(i) + case (:5) + if (i /= 1 .and. i /= 5) STOP 1 + case (13:21) + if (i /= 13 .and. i /= 17 .and. i /= 21) STOP 2 + case (29:) + if (i /= 29 .and. i /= 33) STOP 3 + case default + if (i /= 9 .and. i /= 25) STOP 4 + end select + end do +end program select_4 Index: Fortran/gfortran/regression/select_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Check for overlapping case range diagnostics. +! +program select_5 + integer i + select case(i) + case (20:30) ! { dg-error "overlaps with CASE" } + case (25:) ! { dg-error "overlaps with CASE" } + end select + select case(i) + case (30) ! { dg-error "overlaps with CASE" } + case (25:) ! { dg-error "overlaps with CASE" } + end select + select case(i) + case (20:30) ! { dg-error "overlaps with CASE" } + case (25) ! { dg-error "overlaps with CASE" } + end select +end program select_5 Index: Fortran/gfortran/regression/select_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Test mismatched type kinds in a select statement. +program select_5 + integer(kind=1) i ! kind = 1, -128 <= i < 127 + do i = 1, 3 + select case (i) + + ! kind = 4, reachable + case (1_4) + if (i /= 1_4) STOP 1 + + ! kind = 8, reachable + case (2_8) + if (i /= 2_8) STOP 2 + + ! kind = 4, unreachable because of range of i + case (200) ! { dg-warning "not in the range" } + STOP 3 + + case default + if (i /= 3) STOP 4 + end select + end do +end program select_5 Index: Fortran/gfortran/regression/select_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_6.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/27457 +! This lead to a segfault previously. + implicit none + integer(kind=1) :: i + real :: r(3) + select case (i) + case (129) r(4) = 0 ! { dg-error "Syntax error in CASE specification" } + end select + end Index: Fortran/gfortran/regression/select_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_7.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR25073 in which overlap in logical case +! expressions was permitted. +! +! Contributed by Joost VandeVondele +! +LOGICAL :: L +SELECT CASE(L) +CASE(.true.) +CASE(.false.) +CASE(.true.) ! { dg-error "value in CASE statement is repeated" } +END SELECT +END Index: Fortran/gfortran/regression/select_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_8.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 56081: [4.7/4.8 Regression] Segfault ICE on select with bad case +! +! Contributed by Richard L Lozes + + implicit none + integer :: a(4) + select case(a) ! { dg-error "must be a scalar expression" } + case (0) + end select +end Index: Fortran/gfortran/regression/select_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_9.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/103591 - ICE in gfc_compare_string +! Contributed by G.Steinmetz + +program p + integer :: n + select case (n) + case ('1':2.) ! { dg-error "cannot be REAL" } + end select +end Index: Fortran/gfortran/regression/select_char_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_char_1.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +integer function char_select (s) + character(len=*), intent(in) :: s + + select case(s) + case ("foo") + char_select = 1 + case ("bar", "gee") + char_select = 2 + case ("111", "999") + char_select = 3 + case ("1024", "1900") + char_select = 4 + case ("12", "17890") + char_select = 5 + case default + char_select = -1 + end select +end function char_select + +integer function char_select2 (s) + character(len=*), intent(in) :: s + + char_select2 = -1 + select case(s) + case ("foo") + char_select2 = 1 + case ("bar", "gee") + char_select2 = 2 + case ("111", "999") + char_select2 = 3 + case ("1024", "1900") + char_select2 = 4 + case ("12", "17890") + char_select2 = 5 + end select +end function char_select2 + + +program test + interface + integer function char_select (s) + character(len=*), intent(in) :: s + end function char_select + integer function char_select2 (s) + character(len=*), intent(in) :: s + end function char_select2 + end interface + + if (char_select("foo") /= 1) STOP 1 + if (char_select("foo ") /= 1) STOP 2 + if (char_select("foo2 ") /= -1) STOP 3 + if (char_select("bar") /= 2) STOP 4 + if (char_select("gee") /= 2) STOP 5 + if (char_select("000") /= -1) STOP 6 + if (char_select("101") /= -1) STOP 7 + if (char_select("109") /= -1) STOP 8 + if (char_select("111") /= 3) STOP 9 + if (char_select("254") /= -1) STOP 10 + if (char_select("999") /= 3) STOP 11 + if (char_select("9989") /= -1) STOP 12 + if (char_select("1882") /= -1) STOP 13 + + if (char_select2("foo") /= 1) STOP 14 + if (char_select2("foo ") /= 1) STOP 15 + if (char_select2("foo2 ") /= -1) STOP 16 + if (char_select2("bar") /= 2) STOP 17 + if (char_select2("gee") /= 2) STOP 18 + if (char_select2("000") /= -1) STOP 19 + if (char_select2("101") /= -1) STOP 20 + if (char_select2("109") /= -1) STOP 21 + if (char_select2("111") /= 3) STOP 22 + if (char_select2("254") /= -1) STOP 23 + if (char_select2("999") /= 3) STOP 24 + if (char_select2("9989") /= -1) STOP 25 + if (char_select2("1882") /= -1) STOP 26 +end program test Index: Fortran/gfortran/regression/select_char_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_char_2.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } + + if (foo ('E') .ne. 1) STOP 1 + if (foo ('e') .ne. 1) STOP 2 + if (foo ('f') .ne. 2) STOP 3 + if (foo ('g') .ne. 2) STOP 4 + if (foo ('h') .ne. 2) STOP 5 + if (foo ('Q') .ne. 3) STOP 6 + if (foo (' ') .ne. 4) STOP 7 + if (bar ('e') .ne. 1) STOP 8 + if (bar ('f') .ne. 3) STOP 9 +contains + function foo (c) + character :: c + integer :: foo + select case (c) + case ('E','e') + foo = 1 + case ('f':'h ') + foo = 2 + case default + foo = 3 + case ('') + foo = 4 + end select + end function + function bar (c) + character :: c + integer :: bar + select case (c) + case ('ea':'ez') + bar = 2 + case ('e') + bar = 1 + case default + bar = 3 + case ('fd') + bar = 4 + end select + end function +end + +! { dg-final { scan-tree-dump-not "_gfortran_select_string" "original" } } Index: Fortran/gfortran/regression/select_char_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_char_3.f90 @@ -0,0 +1,15 @@ +! PR fortran/40206 +! { dg-do compile } +! { dg-options "-O2 -Wuninitialized" } + +function char2type (char) + character, intent(in) :: char + integer :: char2type + + select case (char) + case ('E','e') + char2type=1 + case default + char2type=-1234 + end select +end function Index: Fortran/gfortran/regression/select_rank_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_rank_1.f90 @@ -0,0 +1,179 @@ +! { dg-do run } +! +! Basic tests of SELECT RANK +! +! Contributed by Paul Thomas +! + implicit none + type mytype + real :: r + end type + type, extends(mytype) :: thytype + integer :: i + end type + +! Torture using integers +ints: block + integer, dimension(2,2) :: y = reshape ([1,2,3,4],[2,2]) + integer, dimension(4) :: z = [1,2,3,4] + integer, dimension(2,2,2) :: q = reshape ([11,12,13,14,15,16,17,18],[2,2,2]) + integer :: i = 42 + + call ifoo(y, "y") + if (any (y .ne. reshape ([10,11,12,13], [2,2]))) stop 1 + call ifoo(z, "z") + call ifoo(i, "i") + call ifoo(q, "q") + if (any (q .ne. reshape ([11,12,10,11,15,16,12,13], [2,2,2]))) stop 2 + call ibar(y) +end block ints + +! Check derived types +types: block + integer :: i + type(mytype), allocatable, dimension(:,:) :: t + type(mytype), allocatable :: u + + allocate (t, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2])) + call tfoo(t, "t") + if (any (size (t) .ne. [1,1])) stop 3 ! 't' has been reallocated! + if (abs (t(1,1)%r - 42.0) .ge. 1e-6) stop 4 + allocate (u, source = mytype(42.0)) + call tfoo(u, "u") +end block types + +! Check classes +classes: block + integer :: i + class(mytype), allocatable, dimension(:,:) :: v + class(mytype), allocatable :: w + + allocate (v, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2])) + call cfoo(v, "v") + select type (v) + type is (mytype) + stop 5 + type is (thytype) + if (any (ubound (v) .ne. [3,3])) stop 6 + if (any (abs (v%r - 99.0) .ge. 1e-6)) stop 7 + if (any (v%i .ne. 42)) stop 8 + end select + allocate (w, source = thytype(42.0, 99)) + call cfoo(w, "w") +end block classes + +! Check unlimited polymorphic. +unlimited: block + integer(4) :: i + class(*), allocatable, dimension(:,:,:) :: v + + allocate (v, source = reshape ([(i, i = 1,8)],[2,2,2])) + call ufoo(v, "v") + select type (v) + type is (integer(4)) + stop 9 + type is (real(4)) + if (any (ubound(v) .ne. [2,2,1])) stop 10 + if (abs (sum (v) - 10.0) .gt. 1e-6) stop 11 + end select +end block unlimited + +contains + + recursive subroutine ifoo(w, chr) + integer, dimension(..) :: w + character(1) :: chr + + OUTER: select rank (x => w) + rank (2) + if ((chr .eq. 'y') .and. (any (x(1,:) .ne. [1,3]))) stop 12 + if ((chr .eq. 'r') .and. (any (x(1,:) .ne. [13,17]))) stop 13 + x = reshape ([10,11,12,13], [2,2]) + rank (0) + if ((chr .eq. 'i') .and. (x .ne. 42)) stop 14 + rank (*) + if ((chr .eq. 'w') .and. (any (x(1:4) .ne. [10,11,12,13]))) stop 15 + rank default + if ((chr .eq. 'z') .and. (rank (x) .ne. 1)) stop 16 + if ((chr .eq. 'q') .and. (rank (x) .ne. 3)) stop 17 + INNER: select rank (x) + rank (1) INNER + if ((chr .eq. 'z') .and. (any (x(1:4) .ne. [1,2,3,4]))) stop 18 + rank (3) INNER + ! Pass a rank 2 section otherwise an infinite loop ensues. + call ifoo(x(:,2,:), 'r') + end select INNER + end select OUTER + end subroutine ifoo + + subroutine ibar(x) + integer, dimension(*) :: x + + call ifoo(x, "w") + end subroutine ibar + + subroutine tfoo(w, chr) + type(mytype), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + type(mytype), dimension(2,2) :: r + + select rank (x => w) + rank (2) + if (chr .eq. 't') then + r = reshape ([(mytype(real(i)), i = 1,4)],[2,2]) + if (any (abs (x%r - r%r) .gt. 1e-6)) stop 19 + if (allocated (x)) deallocate (x) + allocate (x(1,1)) + x(1,1) = mytype (42.0) + end if + rank default + if ((chr .eq. 'u') .and. (rank (x) .ne. 0)) stop 20 + end select + end subroutine tfoo + + subroutine cfoo(w, chr) + class(mytype), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + type(mytype), dimension(2,2) :: r + + select rank (c => w) + rank (2) + select type (c) + type is (mytype) + if (chr .eq. 'v') then + r = reshape ([(mytype(real(i)), i = 1,4)],[2,2]) + if (any (abs (c%r - r%r) .gt. 1e-6)) stop 21 + end if + class default + stop 22 + end select + if (allocated (c)) deallocate (c) + allocate (c(3,3), source = thytype (99.0, 42)) + rank default + if ((chr .eq. 'w') .and. (rank (c) .ne. 0)) stop 23 + end select + end subroutine cfoo + + subroutine ufoo(w, chr) + class(*), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + + select rank (c => w) + rank (3) + select type (c) + type is (integer(4)) + if (chr .eq. 'v' .and. (sum (c) .ne. 36)) stop 24 + class default + stop 25 + end select + if (allocated (c)) deallocate(c) + allocate (c, source = reshape ([(real(i), i = 1,4)],[2,2,1])) + rank default + stop 26 + end select + end subroutine ufoo + +end Index: Fortran/gfortran/regression/select_rank_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_rank_2.f90 @@ -0,0 +1,85 @@ +! { dg-do compile } +! +! Basic tests of SELECT RANK +! +! Contributed by Paul Thomas +! +subroutine foo1 (arg) + integer :: i + integer, dimension(3) :: arg + select rank (arg) ! { dg-error "must be an assumed rank variable" } + rank (3) ! { dg-error "Unexpected RANK statement" } + print *, arg + end select ! { dg-error "Expecting END SUBROUTINE" } +end + +subroutine foo2 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (i) ! { dg-error "must be a scalar" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + end select +end + +subroutine foo3 (arg) + integer :: i + integer, parameter :: r = 3 + integer, dimension(..) :: arg + select rank (arg) + rank (16) ! { dg-error "must not be less than zero or greater than 15" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + rank (-1) ! { dg-error "must not be less than zero or greater than 15" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + rank (r) ! OK + print *, arg + end select +end + +subroutine foo4 (arg) + integer :: i + integer, dimension(..), pointer :: arg + select rank (arg) ! { dg-error "cannot be used with the pointer or allocatable selector" } + rank (*) ! { dg-error "cannot be used with the pointer or allocatable selector" } + print *, arg(1:1) + rank (1) + print *, arg + end select +end + +subroutine foo5 (arg) + integer :: i + integer, dimension(..), ALLOCATABLE :: arg + select rank (arg) ! { dg-error "cannot be used with the pointer or allocatable selector" } + rank (*) ! { dg-error "pointer or allocatable selector|deferred shape or assumed rank" } + print *, arg(1:1) + rank (1) + print *, arg + end select +end + +subroutine foo6 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (*) + print *, arg ! { dg-error "assumed.size array" } + rank (1) + print *, arg + end select +end + +subroutine foo7 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (1) ! { dg-error "is repeated" } + arg = 1 + rank (1) ! { dg-error "is repeated" } + arg = 1 + rank (*) ! { dg-error "is repeated" } + rank (*) ! { dg-error "is repeated" } + rank default ! { dg-error "is repeated" } + rank default ! { dg-error "is repeated" } + end select +end Index: Fortran/gfortran/regression/select_rank_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_rank_3.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Test the fix for PR91729 +! +! Contributed by Gerhardt Steinmetz +! +subroutine s(x) + integer :: x(..) + select rank (-x) ! { dg-error "must be an assumed rank" } + rank (1) ! { dg-error "Unexpected RANK statement" } + print *, x ! { dg-error "may only be used as actual argument" } + end select ! { dg-error "Expecting END SUBROUTINE" } +end + +subroutine t(x) + integer :: x(..) + select rank (z => -x) ! { dg-error "must be an assumed rank" } + rank (1) ! { dg-error "Unexpected RANK statement" } + print *, z + end select ! { dg-error "Expecting END SUBROUTINE" } +end Index: Fortran/gfortran/regression/select_rank_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_rank_4.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/93522 +! +! Contributed by Shubham Narlawar + +program rank_new + implicit none + integer :: some_var_assumed + integer, DIMENSION(3,2,1) :: array + PRINT *, RANK(array) + call CALL_ME(array) + contains +!No error expected + subroutine CALL_ME23(x) + implicit none + integer:: x(..), a=10,b=20 + integer, dimension(10) :: arr = (/1,2,3,4,5/) ! { dg-error "Different shape for array assignment at .1. on dimension 1 .10 and 5." } + select rank(arr(1:3)) ! { dg-error "Syntax error in argument list" } + RANK(1) ! { dg-error "Unexpected RANK statement" } + print *, "1" + rank(2) ! { dg-error "Unexpected RANK statement" } + print *, "2" + end select ! { dg-error "Expecting END SUBROUTINE statement" } + end subroutine +end program Index: Fortran/gfortran/regression/select_rank_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_rank_5.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Test the fixes for PR97723 and PR97694. +! +! Contributed by Martin +! +module mod + implicit none + private + public cssel + +contains + +function cssel(x) result(s) + character(len=:), allocatable :: s + class(*), dimension(..), optional, intent(in) :: x + if (present(x)) then + select rank (x) + rank (0) + s = '0' ! PR97723: ‘assign’ at (1) is not a function + ! PR97694: ICE in trans-stmt.c(trans_associate_var) + rank (1) + s = '1' ! PR97723: ‘assign’ at (1) is not a function + rank default + s = '?' ! PR97723: ‘assign’ at (1) is not a function + end select + else + s = '-' + end if +end function cssel + +end module mod + +program classstar_rank + use mod + implicit none + + integer :: x + real, dimension(1:3) :: y + logical, dimension(1:2,1:2) :: z + + if (any ([cssel(x),cssel(y),cssel(z),cssel()] .ne. ['0','1','?','-'])) stop 1 + +end program classstar_rank Index: Fortran/gfortran/regression/select_type_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_1.f03 @@ -0,0 +1,73 @@ +! { dg-do compile } +! +! Error checking for the SELECT TYPE statement +! +! Contributed by Janus Weil + + type :: t1 + integer :: i = 42 + class(t1),pointer :: cp + end type + + type, extends(t1) :: t2 + integer :: j = 99 + end type + + type :: t3 + real :: r + end type + + type :: ts + sequence + integer :: k = 5 + end type + + class(t1), pointer :: a => NULL() + class(t1), allocatable, dimension(:) :: ca + type(t1), target :: b + type(t2), target :: c + a => b + print *, a%i + + type is (t1) ! { dg-error "Unexpected TYPE IS statement" } + + select type (3.5) ! { dg-error "is not a named variable" } + select type (a%cp) ! { dg-error "is not a named variable" } + select type (ca(1))! { dg-error "is not a named variable" } + select type (b) ! { dg-error "Selector shall be polymorphic" } + end select + + select type (a) + print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" } + type is (t1) + print *,"a is TYPE(t1)" + type is (t2) + print *,"a is TYPE(t2)" + class is (ts) ! { dg-error "must be extensible" } + print *,"a is TYPE(ts)" + type is (t3) ! { dg-error "must be an extension of" } + print *,"a is TYPE(t3)" + type is (t4) ! { dg-error "error in TYPE IS specification" } + print *,"a is TYPE(t3)" + class is (t1) + print *,"a is CLASS(t1)" + class is (t2) label ! { dg-error "Syntax error" } + print *,"a is CLASS(t2)" + class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } + print *,"default" + class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } + print *,"default2" + end select + +label: select type (a) + type is (t1) label + print *,"a is TYPE(t1)" + type is (t2) ! { dg-error "overlaps with TYPE IS" } + print *,"a is TYPE(t2)" + type is (t2) ! { dg-error "overlaps with TYPE IS" } + print *,"a is still TYPE(t2)" + class is (t1) labe ! { dg-error "Expected block name" } + print *,"a is CLASS(t1)" + end select label + +end Index: Fortran/gfortran/regression/select_type_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_10.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 42167: [OOP] SELECT TYPE with function return value +! +! Contributed by Damian Rouson + +module bar_module + + implicit none + type :: bar + real ,dimension(:) ,allocatable :: f + contains + procedure :: total + end type + +contains + + function total(lhs,rhs) + class(bar) ,intent(in) :: lhs + class(bar) ,intent(in) :: rhs + class(bar) ,pointer :: total + select type(rhs) + type is (bar) + allocate(bar :: total) + select type(total) + type is (bar) + total%f = lhs%f + rhs%f + end select + end select + end function + +end module Index: Fortran/gfortran/regression/select_type_11.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_11.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 42335: [OOP] ICE on CLASS IS (bad_identifier) +! +! Contributed by Harald Anlauf + + implicit none + type, abstract :: vector_class + end type vector_class + + type, extends(vector_class) :: trivial_vector_type + real :: elements(100) + end type trivial_vector_type + +contains + + subroutine bar (this,v) + class(trivial_vector_type), intent(inout) :: this + class(vector_class), intent(in) :: v + + select type (v) + class is (bad_id) ! { dg-error " error in CLASS IS specification" } + this%elements(:) = v%elements(:) ! { dg-error "is not a member of" } + end select + + end subroutine bar + +end Index: Fortran/gfortran/regression/select_type_12.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_12.f03 @@ -0,0 +1,51 @@ +! { dg-do compile } +! +! PR 44044: [OOP] SELECT TYPE with class-valued function +! +! Contributed by Janus Weil + +implicit none + +type :: t1 + integer :: i +end type + +type, extends(t1) :: t2 +end type + +type(t1),target :: x1 +type(t2),target :: x2 + +select type ( y => fun(1) ) +type is (t1) + print *,"t1" +type is (t2) + print *,"t2" +class default + print *,"default" +end select + +select type ( y => fun(-1) ) +type is (t1) + print *,"t1" +type is (t2) + print *,"t2" +class default + print *,"default" +end select + +contains + + function fun(i) + class(t1),pointer :: fun + integer :: i + if (i>0) then + fun => x1 + else if (i<0) then + fun => x2 + else + fun => NULL() + end if + end function + +end Index: Fortran/gfortran/regression/select_type_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_13.f03 @@ -0,0 +1,26 @@ +! { dg-do run } + +! PR fortran/45384 +! Double free happened, check that it works now. + +! Contributed by Salvatore Filippone + +program bug20 + + type :: d_base_sparse_mat + integer :: v(10) = 0. + end type d_base_sparse_mat + + class(d_base_sparse_mat),allocatable :: a + + allocate (d_base_sparse_mat :: a) + + select type(aa => a) + type is (d_base_sparse_mat) + write(0,*) 'NV = ',size(aa%v) + if (size(aa%v) /= 10) STOP 1 + class default + write(0,*) 'Not implemented yet ' + end select + +end program bug20 Index: Fortran/gfortran/regression/select_type_14.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_14.f03 @@ -0,0 +1,24 @@ +! { dg-do run } + +! PR fortran/44047 +! Double free happened, check that it works now. + +! Contributed by Janus Weil, janus@gcc.gnu.org. + +implicit none +type t0 + integer :: j = 42 +end type t0 +type t + integer :: i + class(t0), allocatable :: foo +end type t +type(t) :: m +allocate(t0 :: m%foo) +m%i = 5 +select type(bar => m%foo) +type is(t0) + print *, bar + if (bar%j /= 42) STOP 1 +end select +end Index: Fortran/gfortran/regression/select_type_15.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_15.f03 @@ -0,0 +1,74 @@ +! { dg-do run } +! +! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause +! +! Contributed by Salvatore Filippone + + +module base_mat_mod + + type :: base_sparse_mat + contains + procedure, pass(a) :: get_fmt => base_get_fmt + end type base_sparse_mat + +contains + + function base_get_fmt(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'NULL' + end function base_get_fmt + +end module base_mat_mod + + +module d_base_mat_mod + + use base_mat_mod + + type, extends(base_sparse_mat) :: d_base_sparse_mat + contains + procedure, pass(a) :: get_fmt => d_base_get_fmt + end type d_base_sparse_mat + + type, extends(d_base_sparse_mat) :: x_base_sparse_mat + contains + procedure, pass(a) :: get_fmt => x_base_get_fmt + end type x_base_sparse_mat + +contains + + function d_base_get_fmt(a) result(res) + implicit none + class(d_base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'DBASE' + end function d_base_get_fmt + + function x_base_get_fmt(a) result(res) + implicit none + class(x_base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'XBASE' + end function x_base_get_fmt + +end module d_base_mat_mod + + +program bug20 + use d_base_mat_mod + class(d_base_sparse_mat), allocatable :: a + + allocate(x_base_sparse_mat :: a) + if (a%get_fmt()/="XBASE") STOP 1 + + select type(a) + type is (d_base_sparse_mat) + STOP 2 + class default + if (a%get_fmt()/="XBASE") STOP 3 + end select + +end program bug20 Index: Fortran/gfortran/regression/select_type_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_16.f03 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 45439: [OOP] SELECT TYPE bogus complaint about INTENT +! +! Contributed by Salvatore Filippone + + +module d_base_mat_mod + + implicit none + + type :: d_base_sparse_mat + contains + procedure, pass(a) :: mv_to_coo => d_base_mv_to_coo + end type d_base_sparse_mat + + interface + subroutine d_base_mv_to_coo(a) + import d_base_sparse_mat + class(d_base_sparse_mat), intent(inout) :: a + end subroutine d_base_mv_to_coo + end interface + + type :: d_sparse_mat + class(d_base_sparse_mat), allocatable :: a + end type d_sparse_mat + +contains + + subroutine bug21(ax) + type(d_sparse_mat), intent(inout) :: ax + select type(aa=> ax%a) + class default + call aa%mv_to_coo() + end select + end subroutine bug21 + +end module d_base_mat_mod Index: Fortran/gfortran/regression/select_type_17.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_17.f03 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/44044 +! Definability check for select type to expression. +! This is "bonus feature #2" from comment #3 of the PR. + +! Contributed by Janus Weil, janus@gcc.gnu.org. + +implicit none + +type :: t1 + integer :: i +end type + +type, extends(t1) :: t2 +end type + +type(t1),target :: x1 +type(t2),target :: x2 + +select type ( y => fun(1) ) +type is (t1) + y%i = 1 ! { dg-error "variable definition context" } +type is (t2) + y%i = 2 ! { dg-error "variable definition context" } +end select + +contains + + function fun(i) + class(t1),pointer :: fun + integer :: i + if (i>0) then + fun => x1 + else if (i<0) then + fun => x2 + else + fun => NULL() + end if + end function + +end + Index: Fortran/gfortran/regression/select_type_18.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_18.f03 @@ -0,0 +1,88 @@ +! { dg-do compile } + +! PR fortran/45783 +! PR fortran/45795 +! This used to fail because of incorrect compile-time typespec on the +! SELECT TYPE selector. + +! This is the test-case from PR 45795. +! Contributed by Salvatore Filippone, sfilippone@uniroma2.it. + +module base_mod + + type :: base + integer :: m, n + end type base + +end module base_mod + +module s_base_mod + + use base_mod + + type, extends(base) :: s_base + contains + procedure, pass(a) :: cp_to_foo => s_base_cp_to_foo + + end type s_base + + + type, extends(s_base) :: s_foo + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + real, allocatable :: val(:) + + contains + + procedure, pass(a) :: cp_to_foo => s_cp_foo_to_foo + + end type s_foo + + + interface + subroutine s_base_cp_to_foo(a,b,info) + import :: s_base, s_foo + class(s_base), intent(in) :: a + class(s_foo), intent(inout) :: b + integer, intent(out) :: info + end subroutine s_base_cp_to_foo + end interface + + interface + subroutine s_cp_foo_to_foo(a,b,info) + import :: s_foo + class(s_foo), intent(in) :: a + class(s_foo), intent(inout) :: b + integer, intent(out) :: info + end subroutine s_cp_foo_to_foo + end interface + +end module s_base_mod + + +subroutine trans2(a,b) + use s_base_mod + implicit none + + class(s_base), intent(out) :: a + class(base), intent(in) :: b + + type(s_foo) :: tmp + integer err_act, info + + + info = 0 + select type(b) + class is (s_base) + call b%cp_to_foo(tmp,info) + class default + info = -1 + write(*,*) 'Invalid dynamic type' + end select + + if (info /= 0) write(*,*) 'Error code ',info + + return + +end subroutine trans2 Index: Fortran/gfortran/regression/select_type_19.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_19.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR 46581: [4.6 Regression] [OOP] segfault in SELECT TYPE with associate-name +! +! Contributed by Salvatore Filippone + + + implicit none + + type :: t1 + integer, allocatable :: ja(:) + end type + + class(t1), allocatable :: a + + allocate(a) + + select type (aa=>a) + type is (t1) + if (allocated(aa%ja)) STOP 1 + end select + +end Index: Fortran/gfortran/regression/select_type_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_2.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! +! executing simple SELECT TYPE statements +! +! Contributed by Janus Weil + + type :: t1 + integer :: i + end type t1 + + type, extends(t1) :: t2 + integer :: j + end type t2 + + type, extends(t1) :: t3 + real :: r + end type + + class(t1), pointer :: cp + type(t1), target :: a + type(t2), target :: b + type(t3), target :: c + integer :: i + + cp => a + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t1) + i = 3 + end select + + if (i /= 1) STOP 1 + + cp => b + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t2) + i = 3 + end select + + if (i /= 2) STOP 2 + + cp => c + i = 0 + + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class default + i = 3 + end select + + if (i /= 3) STOP 3 + +end Index: Fortran/gfortran/regression/select_type_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_20.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR fortran/45848 +! PR fortran/47204 +! +! Contributed by Harald Anlauf and Zdenek Sojka +! +module gfcbug111 + implicit none + + type, abstract :: inner_product_class + end type inner_product_class + + type, extends(inner_product_class) :: trivial_inner_product_type + end type trivial_inner_product_type + +contains + + function my_dot_v_v (this,a,b) ! { dg-error "has no IMPLICIT type" } + class(trivial_inner_product_type), intent(in) :: this + class(vector_class), intent(in) :: a,b ! { dg-error "Derived type" } + real :: my_dot_v_v + + select type (a) ! { dg-error "Selector shall be polymorphic" } + class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" } + select type (b) ! { dg-error "Expected TYPE IS" } + class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" } + class default + end select + class default + end select ! { dg-error "Expecting END FUNCTION" } + end function my_dot_v_v +end module gfcbug111 + +select type (a) +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/select_type_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_21.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/45848 +! PR fortran/47204 +! +select type (a) ! { dg-error "Selector shall be polymorphic" } +end select +end Index: Fortran/gfortran/regression/select_type_22.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_22.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 47330: [OOP] ICE on invalid source in connection with SELECT TYPE +! +! Contributed by Andrew Benson + + type treeNode + end type +contains + subroutine proc1 (thisNode) + class (treeNode), target :: thisNode + select type (thisNode) + type is (treeNode) + workNode => thisNode ! { dg-error "Non-POINTER in pointer association context" } + end select + end subroutine +end Index: Fortran/gfortran/regression/select_type_23.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_23.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE +! +! Contributed by Salvatore Filippone +! +! Updated for PR fortran/48887 + +program testmv2 + + type bar + integer, allocatable :: ia(:), ja(:) + end type bar + + class(bar), allocatable :: sm,sm2 + + allocate(sm2) + + select type(sm2) + type is (bar) + call move_alloc(sm2,sm) ! { dg-error "must be ALLOCATABLE" } + end select + +end program testmv2 Index: Fortran/gfortran/regression/select_type_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_24.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! PR fortran/48887 +! +! "If the selector is allocatable, it shall be allocated; the +! associate name is associated with the data object and does +! not have the ALLOCATABLE attribute." +! +module m + type t + end type t +contains + subroutine one(a) + class(t), allocatable :: a + class(t), allocatable :: b + allocate (b) + select type (b) + type is(t) + call move_alloc (b, a) ! { dg-error "must be ALLOCATABLE" } + end select + end subroutine one + + subroutine two (a) + class(t), allocatable :: a + type(t), allocatable :: b + allocate (b) + associate (c => b) + call move_alloc (b, c) ! { dg-error "must be ALLOCATABLE" } + end associate + end subroutine two +end module m + +type t +end type t +class(t), allocatable :: x + +select type(x) + type is(t) + print *, allocated (x) ! { dg-error "must be ALLOCATABLE" } +end select + +select type(y=>x) + type is(t) + print *, allocated (y) ! { dg-error "must be ALLOCATABLE" } +end select + +associate (y=>x) + print *, allocated (y) ! { dg-error "must be ALLOCATABLE" } +end associate +end Index: Fortran/gfortran/regression/select_type_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_25.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/51605 +! + +subroutine one() +type t +end type t +! (a) Invalid (was ICEing before) +class(t), target :: p1 ! { dg-error "must be dummy, allocatable or pointer" } +class(t), pointer :: p2 + +select type(p1) + type is(t) + p2 => p1 + class is(t) + p2 => p1 +end select +end subroutine one + +subroutine two() +type t +end type t +class(t), allocatable, target :: p1 ! (b) Valid +class(t), pointer :: p2 + +select type(p1) + type is(t) + p2 => p1 + class is(t) + p2 => p1 +end select +end subroutine two + +subroutine three() +type t +end type t +class(t), allocatable :: p1 ! (c) Invalid as not TARGET +class(t), pointer :: p2 + +select type(p1) + type is(t) + p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" } + class is(t) + p2 => p1 ! { dg-error "Pointer assignment target is neither TARGET nor POINTER" } +end select +end subroutine three + +subroutine four() +type t +end type t +class(t), pointer :: p1 ! (d) Valid +class(t), pointer :: p2 + +select type(p1) + type is(t) + p2 => p1 + class is(t) + p2 => p1 +end select +end subroutine four + +subroutine caf(x) + type t + end type t + class(t) :: x[*] + select type(x) + type is(t) + end select +end subroutine caf Index: Fortran/gfortran/regression/select_type_26.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_26.f03 @@ -0,0 +1,110 @@ +! { dg-do run } +! Tests fix for PR41600 and further SELECT TYPE functionality. +! +! Reported by Tobias Burnus +! + implicit none + type t0 + integer :: j = 42 + end type t0 + + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + + type t + integer :: i + class(t0), allocatable :: foo(:) + end type t + + type t_scalar + integer :: i + class(t0), allocatable :: foo + end type t_scalar + + type(t) :: m + type(t_scalar) :: m1(4) + integer :: n + +! Test the fix for PR41600 itself - first with m%foo of declared type. + allocate(m%foo(3), source = [(t0(n), n = 1,3)]) + select type(bar => m%foo) + type is(t0) + if (any (bar%j .ne. [1,2,3])) STOP 1 + type is(t1) + STOP 2 + end select + + deallocate(m%foo) + allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)]) + +! Then with m%foo of another dynamic type. + select type(bar => m%foo) + type is(t0) + STOP 3 + type is(t1) + if (any (bar%k .ne. [40,50,60])) STOP 4 + end select + +! Try it with a selector array section. + select type(bar => m%foo(2:3)) + type is(t0) + STOP 5 + type is(t1) + if (any (bar%k .ne. [50,60])) STOP 6 + end select + +! Try it with a selector array element. + select type(bar => m%foo(2)) + type is(t0) + STOP 7 + type is(t1) + if (bar%k .ne. 50) STOP 8 + end select + +! Now try class is and a selector which is an array section of an associate name. + select type(bar => m%foo) + type is(t0) + STOP 9 + class is (t1) + if (any (bar%j .ne. [4,5,6])) STOP 10 + select type (foobar => bar(3:2:-1)) + type is (t1) + if (any (foobar%k .ne. [60,50])) STOP 11 + end select + end select + +! Now try class is and a selector which is an array element of an associate name. + select type(bar => m%foo) + type is(t0) + STOP 12 + class is (t1) + if (any (bar%j .ne. [4,5,6])) STOP 13 + select type (foobar => bar(2)) + type is (t1) + if (foobar%k .ne. 50) STOP 14 + end select + end select + +! Check class a component of an element of an array. Note that an array of such +! objects cannot be allowed since the elements could have different dynamic types. +! (F2003 C614) + do n = 1, 2 + allocate(m1(n)%foo, source = t1(n*99, n*999)) + end do + do n = 3, 4 + allocate(m1(n)%foo, source = t0(n*99)) + end do + select type(bar => m1(3)%foo) + type is(t0) + if (bar%j .ne. 297) STOP 15 + type is(t1) + STOP 16 + end select + select type(bar => m1(1)%foo) + type is(t0) + STOP 17 + type is(t1) + if (bar%k .ne. 999) STOP 18 + end select +end Index: Fortran/gfortran/regression/select_type_27.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_27.f03 @@ -0,0 +1,115 @@ +! { dg-do run } +! Tests fix for PR41600 and further SELECT TYPE functionality. +! This differs from the original and select_type_26.f03 by 'm' +! being a class object rather than a derived type. +! +! Reported by Tobias Burnus +! + implicit none + type t0 + integer :: j = 42 + end type t0 + + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + + type t + integer :: i + class(t0), allocatable :: foo(:) + end type t + + type t_scalar + integer :: i + class(t0), allocatable :: foo + end type t_scalar + + class(t), allocatable :: m + class(t_scalar), allocatable :: m1(:) + integer :: n + + allocate (m) + allocate (m1(4)) + +! Test the fix for PR41600 itself - first with m%foo of declared type. + allocate(m%foo(3), source = [(t0(n), n = 1,3)]) + select type(bar => m%foo) + type is(t0) + if (any (bar%j .ne. [1,2,3])) STOP 1 + type is(t1) + STOP 2 + end select + + deallocate(m%foo) + allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)]) + +! Then with m%foo of another dynamic type. + select type(bar => m%foo) + type is(t0) + STOP 3 + type is(t1) + if (any (bar%k .ne. [40,50,60])) STOP 4 + end select + +! Try it with a selector array section. + select type(bar => m%foo(2:3)) + type is(t0) + STOP 5 + type is(t1) + if (any (bar%k .ne. [50,60])) STOP 6 + end select + +! Try it with a selector array element. + select type(bar => m%foo(2)) + type is(t0) + STOP 7 + type is(t1) + if (bar%k .ne. 50) STOP 8 + end select + +! Now try class is and a selector which is an array section of an associate name. + select type(bar => m%foo) + type is(t0) + STOP 9 + class is (t1) + if (any (bar%j .ne. [4,5,6])) STOP 10 + select type (foobar => bar(3:2:-1)) + type is (t1) + if (any (foobar%k .ne. [60,50])) STOP 11 + end select + end select + +! Now try class is and a selector which is an array element of an associate name. + select type(bar => m%foo) + type is(t0) + STOP 12 + class is (t1) + if (any (bar%j .ne. [4,5,6])) STOP 13 + select type (foobar => bar(2)) + type is (t1) + if (foobar%k .ne. 50) STOP 14 + end select + end select + +! Check class a component of an element of an array. Note that an array of such +! objects cannot be allowed since the elements could have different dynamic types. +! (F2003 C614) + do n = 1, 2 + allocate(m1(n)%foo, source = t1(n*99, n*999)) + end do + do n = 3, 4 + allocate(m1(n)%foo, source = t0(n*99)) + end do + select type(bar => m1(3)%foo) + type is(t0) + if (bar%j .ne. 297) STOP 15 + type is(t1) + STOP 16 + end select + select type(bar => m1(1)%foo) + type is(t0) + STOP 17 + type is(t1) + if (bar%k .ne. 999) STOP 18 + end select +end Index: Fortran/gfortran/regression/select_type_28.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_28.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Fix for PR53191 +! + implicit none + type t0 + integer :: j = 42 + end type t0 + type, extends(t0) :: t1 + integer :: k = 99 + end type t1 + type t + integer :: i + class(t0), allocatable :: foo + end type t + type(t) :: m(4) + integer :: n + + do n = 1, 2 + allocate(m(n)%foo, source = t0(n*99)) + end do + do n = 3, 4 + allocate(m(n)%foo, source = t1(n*99, n*999)) + end do + +! An array of objects with ultimate class components cannot be a selector +! since each element could have a different dynamic type. (F2003 C614) + + select type(bar => m%foo) ! { dg-error "part reference with nonzero rank" } + type is(t0) + if (any (bar%j .ne. [99, 198, 297, 396])) STOP 1 + type is(t1) + STOP 2 + end select + +end Index: Fortran/gfortran/regression/select_type_29.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_29.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 54435: [4.7/4.8 Regression] ICE with SELECT TYPE on a non-CLASS object +! +! Contributed by xarthisius + +subroutine foo(x) + integer :: x + select type (x) ! { dg-error "Selector shall be polymorphic" } + end select +end + + +! PR 54443: [4.7/4.8 Regression] Segmentation Fault when Compiling for code using Fortran Polymorphic Entities +! +! Contributed by Mark Beyer + +program class_test + type hashnode + character(4) :: htype + end type + class(hashnode), pointer :: hp + + select type(hp%htype) ! { dg-error "is not a named variable" } + +end program Index: Fortran/gfortran/regression/select_type_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_3.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! SELECT TYPE with temporaries +! +! Contributed by Janus Weil + + type :: t1 + integer :: i = -1 + end type t1 + + type, extends(t1) :: t2 + integer :: j = -1 + end type t2 + + class(t1), pointer :: cp + type(t2), target :: b + + cp => b + + select type (cp) + type is (t1) + cp%i = 1 + type is (t2) + cp%j = 2 + end select + + print *,b%i,b%j + if (b%i /= -1) STOP 1 + if (b%j /= 2) STOP 2 + + select type (cp) + type is (t1) + cp%i = 4 + type is (t2) + cp%i = 3*cp%j + end select + + print *,b%i,b%j + if (b%i /= 6) STOP 3 + if (b%j /= 2) STOP 4 + +end Index: Fortran/gfortran/regression/select_type_30.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_30.f03 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016 +! +! Contributed by Richard L Lozes + + implicit none + + type treeNode + end type + + class(treeNode), pointer :: theNode + logical :: lstatus + + select type( theNode ) + type is (treeNode) + call DestroyNode (theNode, lstatus ) + class is (treeNode) + call DestroyNode (theNode, lstatus ) + end select + +contains + + subroutine DestroyNode( theNode, lstatus ) + type(treeNode), pointer :: theNode + logical, intent(out) :: lstatus + end subroutine + +end Index: Fortran/gfortran/regression/select_type_31.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_31.f03 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! Test the fix for PR55172. +! +! Contributed by Arjen Markus +! +module gn + type :: ncb + end type ncb + type, public :: tn + class(ncb), allocatable, dimension(:) :: cb + end type tn +contains + integer function name(self) + implicit none + class (tn), intent(in) :: self + select type (component => self%cb(i)) ! { dg-error "has no IMPLICIT type" } + end select + end function name +end module gn + +! Further issues, raised by Tobias Burnus in the course of fixing the PR + +module gn1 + type :: ncb1 + end type ncb1 + type, public :: tn1 + class(ncb1), allocatable, dimension(:) :: cb + end type tn1 +contains + integer function name(self) + implicit none + class (tn1), intent(in) :: self + select type (component => self%cb([4,7+1])) ! { dg-error "needs a temporary" } + end select + end function name +end module gn1 + +module gn2 + type :: ncb2 + end type ncb2 + type, public :: tn2 + class(ncb2), allocatable :: cb[:] + end type tn2 +contains + integer function name(self) + implicit none + class (tn2), intent(in) :: self + select type (component => self%cb[4]) ! { dg-error "must not be coindexed" } + end select + end function name +end module gn2 Index: Fortran/gfortran/regression/select_type_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_32.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/55763 +! +! Contributed by Harald Anlauf +! + +module gfcbug122 + implicit none + type myobj + class(*), allocatable :: x + contains + procedure :: print + end type myobj +contains + subroutine print(this) + class(myobj) :: this + select type (this) + type is (integer) ! { dg-error "Unexpected intrinsic type 'INTEGER'" } + type is (real) ! { dg-error "Unexpected intrinsic type 'REAL'" } + type is (complex) ! { dg-error "Unexpected intrinsic type 'COMPLEX'" } + type is (character(len=*)) ! { dg-error "Unexpected intrinsic type 'CHARACTER'" } + end select + end subroutine print +end module gfcbug122 Index: Fortran/gfortran/regression/select_type_33.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_33.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR fortran/56816 +! The unfinished SELECT TYPE statement below was leading to an ICE because +! at the time the statement was rejected, the compiler tried to free +! some symbols that had already been freed with the SELECT TYPE +! namespace. +! +! Original testcase from Dominique Pelletier +! +module any_list_module + implicit none + + private + public :: anylist, anyitem + + type anylist + end type + + type anyitem + class(*), allocatable :: value + end type +end module any_list_module + + +module my_item_list_module + + use any_list_module + implicit none + + type, extends (anyitem) :: myitem + end type myitem + +contains + + subroutine myprint (this) + class (myitem) :: this + + select type ( v => this % value ! { dg-error "parse error in SELECT TYPE" } + end select ! { dg-error "Expecting END SUBROUTINE" } + end subroutine myprint + +end module my_item_list_module Index: Fortran/gfortran/regression/select_type_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_34.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 58185: [4.8/4.9 Regression] [OOP] ICE when selector in SELECT TYPE is non-polymorphic +! +! Contributed by John + + integer :: array + select type (a => array) ! { dg-error "Selector shall be polymorphic" } + end select +end Index: Fortran/gfortran/regression/select_type_35.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_35.f03 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Contributed by Nathanael Huebbe +! Check fix for PR/70842 + +program foo + + TYPE, ABSTRACT :: t_Intermediate + END TYPE t_Intermediate + + type, extends(t_Intermediate) :: t_Foo + character(:), allocatable :: string + end type t_Foo + + class(t_Foo), allocatable :: obj + + allocate(obj) + obj%string = "blabarfoo" + + call bar(obj) + + deallocate(obj) +contains + subroutine bar(me) + class(t_Intermediate), target :: me + + class(*), pointer :: alias + + select type(me) + type is(t_Foo) + if (len(me%string) /= 9) STOP 1 + end select + + alias => me + select type(alias) + type is(t_Foo) + if (len(alias%string) /= 9) STOP 2 + end select + end subroutine bar +end program foo + Index: Fortran/gfortran/regression/select_type_36.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_36.f03 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Test the fix for PR69834 in which the two derived types below +! had the same hash value and so generated an error in the resolution +! of SELECT TYPE. +! +! Reported by James van Buskirk on clf: +! https://groups.google.com/forum/#!topic/comp.lang.fortran/0bm3E5xJpkM +! +module types + implicit none + type CS5SS + integer x + real y + end type CS5SS + type SQS3C + logical u + character(7) v + end type SQS3C + contains + subroutine sub(x, switch) + class(*), allocatable :: x + integer :: switch + select type(x) + type is(CS5SS) + if (switch .ne. 1) STOP 1 + type is(SQS3C) + if (switch .ne. 2) STOP 2 + class default + STOP 3 + end select + end subroutine sub +end module types + +program test + use types + implicit none + class(*), allocatable :: u1, u2 + + allocate(u1,source = CS5SS(2,1.414)) + allocate(u2,source = SQS3C(.TRUE.,'Message')) + call sub(u1, 1) + call sub(u2, 2) +end program test Index: Fortran/gfortran/regression/select_type_37.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_37.f03 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! Checks the fix for PR69556 in which using implicit function results +! in SELECT TYPE caused all sorts of problems, especially in the form +! in 'return_pointer1' with "associate_name => selector". The original +! PR is encapsulated in 'return_pointer'. Explicit results, such as in +! 'return_pointer2' always worked. +! +! Contributed by James Greenhalgh +! +program pr69556 + class(*), pointer :: ptr(:) + character(40) :: buffer1, buffer2 + real :: cst1(2) = [1.0, 2.0] + real :: cst2(2) = [3.0, 4.0] + real :: cst3(2) = [5.0, 6.0] + + write (buffer1, *) cst1 + if (.not.associated(return_pointer1(cst1))) STOP 1 + if (trim (buffer1) .ne. trim (buffer2)) STOP 2 + select type (ptr) + type is (real) + if (any (ptr .ne. cst2)) STOP 3 + end select + deallocate (ptr) + + write (buffer1, *) cst2 + if (.not.associated(return_pointer(cst2))) STOP 4 + if (trim (buffer1) .ne. trim (buffer2)) STOP 5 + select type (ptr) + type is (real) + if (any (ptr .ne. cst3)) STOP 6 + end select + deallocate (ptr) + + write (buffer1, *) cst1 + if (.not.associated(return_pointer2(cst1))) STOP 7 + if (trim (buffer1) .ne. trim (buffer2)) STOP 8 + select type (ptr) + type is (real) + if (any (ptr .ne. cst2)) STOP 9 + end select + deallocate (ptr) + +contains + + function return_pointer2(arg) result (res) ! Explicit result always worked. + class(*), pointer :: res(:) + real, intent(inout) :: arg(:) + allocate (res, source = arg) + ptr => res ! Check association and cleanup + select type (z => res) + type is (real(4)) + write (buffer2, *) z ! Check associate expression is OK. + z = cst2 ! Check associate is OK for lvalue. + end select + end function + + function return_pointer1(arg) + class(*), pointer :: return_pointer1(:) + real, intent(inout) :: arg(:) + allocate (return_pointer1, source = arg) + ptr => return_pointer1 + select type (z => return_pointer1) ! This caused a segfault in compilation. + type is (real(4)) + write (buffer2, *) z + z = cst2 + end select + end function + + function return_pointer(arg) ! The form in the PR. + class(*), pointer :: return_pointer(:) + real, intent(inout) :: arg(:) + allocate (return_pointer, source = cst2) + ptr => return_pointer + select type (return_pointer) + type is (real(4)) ! Associate-name ‘__tmp_REAL_4’ at (1) is used as array + write (buffer2, *) return_pointer + return_pointer = cst3 + end select + end function +end program + Index: Fortran/gfortran/regression/select_type_38.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_38.f03 @@ -0,0 +1,10 @@ + type :: t1 + end type + type, extends(t1) :: t2 + end type + class(t1), pointer :: a +lab1: select type (a) + end select lab1 +lab1: select type (a) ! { dg-error "Duplicate construct label" } + end select lab1 ! { dg-error "Expecting END PROGRAM statement" } +end Index: Fortran/gfortran/regression/select_type_39.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_39.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Tests the fix for PR67564 comment #9. +! +! Contributed by Neil Carlson +! +class(*), allocatable :: val(:) +call get_value (val) +select type (val) +type is (character(*)) + if (size (val) .ne. 2) STOP 1 + if (len(val) .ne. 3) STOP 2 + if (any (val .ne. ['foo','bar'])) STOP 3 +end select +contains + subroutine get_value (value) + class(*), allocatable, intent(out) :: value(:) + allocate(value, source=['foo','bar']) + end subroutine +end Index: Fortran/gfortran/regression/select_type_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_4.f90 @@ -0,0 +1,174 @@ +! { dg-do run } +! +! Contributed by by Richard Maine +! http://coding.derkeiler.com/Archive/Fortran/comp.lang.fortran/2006-10/msg00104.html +! +module poly_list + + !-- Polymorphic lists using type extension. + + implicit none + + type, public :: node_type + private + class(node_type), pointer :: next => null() + end type node_type + + type, public :: list_type + private + class(node_type), pointer :: head => null(), tail => null() + end type list_type + +contains + + subroutine append_node (list, new_node) + + !-- Append a node to a list. + !-- Caller is responsible for allocating the node. + + !---------- interface. + + type(list_type), intent(inout) :: list + class(node_type), target :: new_node + + !---------- executable code. + + if (.not.associated(list%head)) list%head => new_node + if (associated(list%tail)) list%tail%next => new_node + list%tail => new_node + return + end subroutine append_node + + function first_node (list) + + !-- Get the first node of a list. + + !---------- interface. + + type(list_type), intent(in) :: list + class(node_type), pointer :: first_node + + !---------- executable code. + + first_node => list%head + return + end function first_node + + function next_node (node) + + !-- Step to the next node of a list. + + !---------- interface. + + class(node_type), target :: node + class(node_type), pointer :: next_node + + !---------- executable code. + + next_node => node%next + return + end function next_node + + subroutine destroy_list (list) + + !-- Delete (and deallocate) all the nodes of a list. + + !---------- interface. + type(list_type), intent(inout) :: list + + !---------- local. + class(node_type), pointer :: node, next + + !---------- executable code. + + node => list%head + do while (associated(node)) + next => node%next + deallocate(node) + node => next + end do + nullify(list%head, list%tail) + return + end subroutine destroy_list + +end module poly_list + +program main + + use poly_list + + implicit none + integer :: cnt + + type, extends(node_type) :: real_node_type + real :: x + end type real_node_type + + type, extends(node_type) :: integer_node_type + integer :: i + end type integer_node_type + + type, extends(node_type) :: character_node_type + character(1) :: c + end type character_node_type + + type(list_type) :: list + class(node_type), pointer :: node + type(integer_node_type), pointer :: integer_node + type(real_node_type), pointer :: real_node + type(character_node_type), pointer :: character_node + + !---------- executable code. + + !----- Build the list. + + allocate(real_node) + real_node%x = 1.23 + call append_node(list, real_node) + + allocate(integer_node) + integer_node%i = 42 + call append_node(list, integer_node) + + allocate(node) + call append_node(list, node) + + allocate(character_node) + character_node%c = "z" + call append_node(list, character_node) + + allocate(real_node) + real_node%x = 4.56 + call append_node(list, real_node) + + !----- Retrieve from it. + + node => first_node(list) + + cnt = 0 + do while (associated(node)) + cnt = cnt + 1 + select type (node) + type is (real_node_type) + write (*,*) node%x + if (.not.( (cnt == 1 .and. node%x == 1.23) & + .or. (cnt == 5 .and. node%x == 4.56))) then + STOP 1 + end if + type is (integer_node_type) + write (*,*) node%i + if (cnt /= 2 .or. node%i /= 42) STOP 2 + type is (node_type) + write (*,*) "Node with no data." + if (cnt /= 3) STOP 3 + class default + Write (*,*) "Some other node type." + if (cnt /= 4) STOP 4 + end select + + node => next_node(node) + end do + if (cnt /= 5) STOP 5 + call destroy_list(list) + stop +end program main Index: Fortran/gfortran/regression/select_type_40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_40.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-additional-options "-fdefault-integer-8" } +! PR 78238 - this used to cause an ICE. +! Original test cae by Gerhard Steinmetz +class(*), allocatable :: q +select type (x => q) +type is (real) +end select +end Index: Fortran/gfortran/regression/select_type_41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_41.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O2" } +! +! Tests the fix for PR80965 in which the use of the name 'loc' +! for the dummy argument of 'xyz' caused an ICE. If the module +! was used, the error "DUMMY attribute conflicts with INTRINSIC +! attribute in ‘loc’ at (1)" was emitted. Note that although 'loc' +! is a GNU extension and so can be over-ridden, this is not very +! good practice. +! +! Contributed by David Sagan +! +module mode3_mod +contains + subroutine xyz (loc) + implicit none + class(*) :: loc + real x(6) + integer ix_use + select type (loc) + type is (integer) + x = 0 + print *, "integer" + type is (real) + ix_use = 0 + print *, "real" + end select + end subroutine xyz +end module mode3_mod + Index: Fortran/gfortran/regression/select_type_42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_42.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Tests the fix for PR82275. +! Associating a name with a reduced-dimension section of a +! multidimensional array precluded subsequent use of the name +! with the appropriately reduced dimensionality and instead +! required use of the (invalid) full set of original dimensions. +! +! Contributed by Damian Rouson +! + type component + integer :: i + end type + type container + class(component), allocatable :: component_array(:,:) + end type + type(container) bag + type(component) section_copy + allocate(bag%component_array, source = reshape ([component(10), component (100)], [1,2])) + select type(associate_name=>bag%component_array(1,:)) + type is (component) + section_copy = associate_name(2) ! gfortran rejected valid +! section_copy = associate_name(1,1)! gfortran accepted invalid + end select + if (section_copy%i .ne. 100) stop 1 +end Index: Fortran/gfortran/regression/select_type_43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_43.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Tests the fix for PR87277 - runtime segfault as indicated. +! +! Contributed by Andrew Baldwin on clf. +! + MODULE INTS_TYPE_MODULE + TYPE INTS_TYPE + INTEGER, ALLOCATABLE :: INTS(:) + END TYPE INTS_TYPE + CONTAINS + SUBROUTINE ALLOCATE_INTS_TYPE (IT_OBJ) + CLASS (INTS_TYPE), POINTER, INTENT (OUT) :: IT_OBJ + + ALLOCATE (INTS_TYPE :: IT_OBJ) + + SELECT TYPE (IT_OBJ) + TYPE IS (INTS_TYPE) + CALL ALLOCATE_ARRAY (IT_OBJ%INTS) ! Sefaulted at runtime here. + if (.not.allocated (IT_OBJ%INTS)) stop 1 + if (any (IT_OBJ%INTS .ne. [1,2,3,4])) stop 2 + END SELECT + + RETURN + END SUBROUTINE ALLOCATE_INTS_TYPE + + SUBROUTINE ALLOCATE_ARRAY (ALLOC_ARR) + INTEGER, ALLOCATABLE, INTENT (OUT) :: ALLOC_ARR(:) + INTEGER :: I + + ALLOCATE (ALLOC_ARR(4)) + + DO I = 1, SIZE(ALLOC_ARR) + ALLOC_ARR(I) = I + END DO + + RETURN + END SUBROUTINE ALLOCATE_ARRAY + END MODULE INTS_TYPE_MODULE + + PROGRAM MFE + USE INTS_TYPE_MODULE + IMPLICIT NONE + + CLASS (INTS_TYPE), POINTER :: IT_OBJ + + CALL ALLOCATE_INTS_TYPE (IT_OBJ) + END PROGRAM MFE Index: Fortran/gfortran/regression/select_type_44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_44.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR87566 +! +! Contributed by Antony Lewis +! + call AddArray +contains + subroutine AddArray() + type Object_array_pointer + class(*), pointer :: p(:) => null() + end type Object_array_pointer + class(*), pointer :: Pt => null() + type (Object_array_pointer) :: obj + character(3), target :: tgt1(2) = ['one','two'] + character(5), target :: tgt2(2) = ['three','four '] + + allocate (Pt, source = Object_array_pointer ()) + select type (Pt) + type is (object_array_pointer) + Pt%p => tgt1 + end select + + select type (Pt) + class is (object_array_pointer) + select type (Point=> Pt%P) + type is (character(*)) + if (any (Point .ne. tgt1)) stop 1 + Point = ['abc','efg'] + end select + end select + + select type (Pt) + class is (object_array_pointer) + select type (Point=> Pt%P) + type is (character(*)) + if (any (Point .ne. ['abc','efg'])) stop 2 + end select + end select + + end subroutine AddArray +end Index: Fortran/gfortran/regression/select_type_45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_45.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! Tests the fix for PR80260 +! +! Contributed by Damian Rouson +! + type foo + end type foo + type, extends(foo) :: bar + end type +contains + subroutine f(x) + class(foo) x(:,:) + select type(x) + class is (bar) + call g(x(1,:)) ! ICEd here. + end select + end subroutine + subroutine g(y) + class(bar) y(:) + end subroutine +end Index: Fortran/gfortran/regression/select_type_46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_46.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Tests the fix for PR82077 +! +! Contributed by Damian Rouson +! + type parent + end type parent + type, extends(parent) :: child + end type + class(parent), allocatable :: foo(:,:) + allocate(child::foo(1,1)) + select type(foo) + class is (child) + call gfortran7_ICE(foo(1,:)) ! ICEd here. + end select +contains + subroutine gfortran7_ICE(bar) + class(child) bar(:) + end subroutine +end Index: Fortran/gfortran/regression/select_type_47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_47.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! +! PR fortran/87632 +! +! Contributed by Jürgen Reuter +! +module m +type t + integer :: i +end type t +type t2 + type(t) :: phs_config +end type t2 +end module m + +module m2 +use m +implicit none +type t3 +end type t3 + +type process_t + private + type(t2), allocatable :: component(:) +contains + procedure :: get_phs_config => process_get_phs_config +end type process_t + +contains + subroutine process_extract_resonance_history_set & + (process, include_trivial, i_component) + class(process_t), intent(in), target :: process + logical, intent(in), optional :: include_trivial + integer, intent(in), optional :: i_component + integer :: i + i = 1; if (present (i_component)) i = i_component + select type (phs_config => process%get_phs_config (i)) + class is (t) + call foo() + class default + call bar() + end select + end subroutine process_extract_resonance_history_set + + function process_get_phs_config (process, i_component) result (phs_config) + class(t), pointer :: phs_config + class(process_t), intent(in), target :: process + integer, intent(in) :: i_component + if (allocated (process%component)) then + phs_config => process%component(i_component)%phs_config + else + phs_config => null () + end if + end function process_get_phs_config +end module m2 + +program main + use m2 +end program main Index: Fortran/gfortran/regression/select_type_48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_48.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Test the fix for PR92976, in which the TYPE IS statement caused an ICE +! because of the explicit bounds of 'x'. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer :: i + end type + class(t), allocatable :: c(:) + allocate (c, source = [t(1111),t(2222),t(3333)]) + call s(c) + if (sum (c%i) .ne. 3333) stop 1 +contains + subroutine s(x) + class(t) :: x(2) + select type (x) +! ICE as compiler attempted to assign descriptor to an array + type is (t) + x%i = 0 +! Make sure that bounds are correctly translated. + call counter (x) + end select + end + subroutine counter (arg) + type(t) :: arg(:) + if (size (arg, 1) .ne. 2) stop 2 + end +end Index: Fortran/gfortran/regression/select_type_49.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_49.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 95366 - this did not work due the wrong hashes +! being generated for CHARACTER variables. +MODULE mod1 + implicit none + integer :: tst(3) +CONTAINS + subroutine showpoly(poly) + CLASS(*), INTENT(IN) :: poly(:) + SELECT TYPE (poly) + TYPE IS(INTEGER) + tst(1) = tst(1) + 1 + TYPE IS(character(*)) + tst(2) = tst(2) + 1 + class default + tst(3) = tst(3) + 1 + end select + end subroutine showpoly +END MODULE mod1 +MODULE mod2 + implicit none +CONTAINS +subroutine polytest2() + use mod1 + integer :: a(1) + character(len=42) :: c(1) + call showpoly(a) + if (any(tst /= [1,0,0])) stop 1 + call showpoly(c) + if (any(tst /= [1,1,0])) stop 2 +end subroutine polytest2 +END MODULE mod2 +PROGRAM testpoly + use mod2 + CALL polytest2() +END PROGRAM testpoly +! The value of the hashes are also checked. If you get +! a failure here, be aware that changing that value is +! an ABI change. + +! { dg-final { scan-tree-dump-times "== 17759" 1 "original" } } +! { dg-final { scan-tree-dump-times "== 85893463" 1 "original" } } Index: Fortran/gfortran/regression/select_type_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_5.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! SELECT TYPE with associate-name +! +! Contributed by Janus Weil + + type :: t1 + integer :: i = -1 + class(t1), pointer :: c + end type t1 + + type, extends(t1) :: t2 + integer :: j = -1 + end type t2 + + type(t2), target :: b + integer :: aa + + b%c => b + aa = 5 + + select type (aa => b%c) + type is (t1) + aa%i = 1 + type is (t2) + aa%j = 2 + end select + + print *,b%i,b%j + if (b%i /= -1) STOP 1 + if (b%j /= 2) STOP 2 + + select type (aa => b%c) + type is (t1) + aa%i = 4 + type is (t2) + aa%i = 3*aa%j + end select + + print *,b%i,b%j + if (b%i /= 6) STOP 3 + if (b%j /= 2) STOP 4 + + print *,aa + if (aa/=5) STOP 5 + +end Index: Fortran/gfortran/regression/select_type_50.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_50.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Test the fix for PR97045. The report was for the INTEGER version. Testing +! revealed a further bug with the character versions. +! +! Contributed by Igor Gayday +! +program test_prg + implicit none + integer :: i + integer, allocatable :: arr(:, :) + character(kind = 1, len = 2), allocatable :: chr(:, :) + character(kind = 4, len = 2), allocatable :: chr4(:, :) + + arr = reshape ([(i, i = 1, 9)], [3, 3]) + do i = 1, 3 + call write_array(arr(1:2, i), i) + end do + + chr = reshape([(char (i)//char (i+1), i = 65, 83, 2)], [3, 3]) + do i = 1, 3 + call write_array (chr(1:2, i), i) + end do + + chr4 = reshape([(char (i, kind = 4)//char (i+1, kind = 4), i = 65, 83, 2)], & + [3, 3]) + do i = 1, 3 + call write_array (chr4(1:2, i), i) + end do + +contains + + subroutine write_array(array, j) + class(*), intent(in) :: array(:) + integer :: i = 2 + integer :: j, k + + select type (elem => array(i)) + type is (integer) + k = 3*(j-1)+i + if (elem .ne. k) stop 1 + type is (character(kind = 1, len = *)) + k = 63 + 2*(3*(j-1)+i) + if (elem .ne. char (k)//char (k+1)) print *, elem, " ", char (k)//char (k+1) + type is (character(kind = 4, len = *)) + k = 63 + 2*(3*(j-1)+i) + if (elem .ne. char (k, kind = 4)//char (k+1, kind = 4)) stop 3 + end select + + end subroutine + +end program Index: Fortran/gfortran/regression/select_type_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_6.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! PR 41579: [OOP/Polymorphism] Nesting of SELECT TYPE +! +! Contributed by Tobias Burnus + + type t1 + end type t1 + + type, extends(t1) :: t2 + integer :: i + end type t2 + + type, extends(t1) :: t3 + integer :: j + end type t3 + + class(t1), allocatable :: mt2, mt3 + allocate(t2 :: mt2) + allocate(t3 :: mt3) + + select type (mt2) + type is(t2) + mt2%i = 5 + print *,mt2%i + select type(mt3) + type is(t3) + mt3%j = 2*mt2%i + print *,mt3%j + if (mt3%j /= 10) STOP 1 + class default + STOP 2 + end select + class default + STOP 3 + end select + +end Index: Fortran/gfortran/regression/select_type_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_7.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR 41766: [OOP] SELECT TYPE selector as actual argument with INTENT(INOUT) +! +! Contributed by Janus Weil + + implicit none + + type t1 + integer :: a + end type + + type, extends(t1) :: t2 + integer :: b + end type + + class(t1),allocatable :: cp + + allocate(t2 :: cp) + + select type (cp) + type is (t2) + cp%a = 98 + cp%b = 76 + call s(cp) + print *,cp%a,cp%b + if (cp%a /= cp%b) STOP 1 + class default + STOP 2 + end select + +contains + + subroutine s(f) + type(t2), intent(inout) :: f + f%a = 3 + f%b = 3 + end subroutine + +end Index: Fortran/gfortran/regression/select_type_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_8.f03 @@ -0,0 +1,98 @@ +! { dg-do run } +! +! executing SELECT TYPE statements with CLASS IS blocks +! +! Contributed by Janus Weil + + implicit none + + type :: t1 + integer :: i + end type t1 + + type, extends(t1) :: t2 + integer :: j + end type t2 + + type, extends(t2) :: t3 + real :: r + end type + + class(t1), pointer :: cp + type(t1), target :: a + type(t2), target :: b + type(t3), target :: c + integer :: i + + cp => c + i = 0 + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t1) + i = 3 + class default + i = 4 + end select + print *,i + if (i /= 3) STOP 1 + + cp => a + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + class is (t1) + i = 3 + end select + print *,i + if (i /= 1) STOP 2 + + cp => b + select type (cp) + type is (t1) + i = 1 + class is (t3) + i = 3 + class is (t2) + i = 4 + class is (t1) + i = 5 + end select + print *,i + if (i /= 4) STOP 3 + + cp => b + select type (cp) + type is (t1) + i = 1 + class is (t1) + i = 5 + class is (t2) + i = 4 + class is (t3) + i = 3 + end select + print *,i + if (i /= 4) STOP 4 + + cp => a + select type (cp) + type is (t2) + i = 1 + class is (t2) + i = 2 + class default + i = 3 + class is (t3) + i = 4 + type is (t3) + i = 5 + end select + print *,i + if (i /= 3) STOP 5 + +end Index: Fortran/gfortran/regression/select_type_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/select_type_9.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 42053: [OOP] SELECT TYPE: reject duplicate CLASS IS blocks +! +! Contributed by Janus Weil + + type :: t + integer :: i + end type + + CLASS(t),pointer :: x + + select type (x) + class is (t) + print *,"a" + class is (t) ! { dg-error "Double CLASS IS block" } + print *,"b" + end select + +end Index: Fortran/gfortran/regression/selected_char_kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_char_kind_1.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Checks for the SELECTED_CHAR_KIND intrinsic +! + integer, parameter :: ascii = selected_char_kind ("ascii") + integer, parameter :: default = selected_char_kind ("default") + + character(kind=ascii) :: s1 + character(kind=default) :: s2 + character(kind=selected_char_kind ("ascii")) :: s3 + character(kind=selected_char_kind ("default")) :: s4 + + if (kind (s1) /= selected_char_kind ("ascii")) STOP 1 + if (kind (s2) /= selected_char_kind ("default")) STOP 2 + if (kind (s3) /= ascii) STOP 3 + if (kind (s4) /= default) STOP 4 + + if (selected_char_kind("ascii") /= 1) STOP 5 + if (selected_char_kind("default") /= 1) STOP 6 + if (selected_char_kind("defauLt") /= 1) STOP 7 + if (selected_char_kind("foo") /= -1) STOP 8 + if (selected_char_kind("asciiiii") /= -1) STOP 9 + if (selected_char_kind("default ") /= 1) STOP 10 + + call test("ascii", 1) + call test("default", 1) + call test("defauLt", 1) + call test("asciiiiii", -1) + call test("foo", -1) + call test("default ", 1) + call test("default x", -1) + + call test(ascii_"ascii", 1) + call test(ascii_"default", 1) + call test(ascii_"defauLt", 1) + call test(ascii_"asciiiiii", -1) + call test(ascii_"foo", -1) + call test(ascii_"default ", 1) + call test(ascii_"default x", -1) + + call test(default_"ascii", 1) + call test(default_"default", 1) + call test(default_"defauLt", 1) + call test(default_"asciiiiii", -1) + call test(default_"foo", -1) + call test(default_"default ", 1) + call test(default_"default x", -1) + + if (kind (selected_char_kind ("")) /= kind(0)) STOP 11 +end + +subroutine test(s,i) + character(len=*,kind=selected_char_kind("ascii")) s + integer i + + call test2(s,i) + if (selected_char_kind (s) /= i) STOP 12 +end subroutine test + +subroutine test2(s,i) + character(len=*,kind=selected_char_kind("default")) s + integer i + + if (selected_char_kind (s) /= i) STOP 13 +end subroutine test2 Index: Fortran/gfortran/regression/selected_char_kind_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_char_kind_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Check that nonexisting character kinds are not rejected by the compiler +! + character(kind=selected_char_kind("")) :: s1 ! { dg-error "is not supported for CHARACTER" } + character(kind=selected_char_kind(" ")) :: s2 ! { dg-error "is not supported for CHARACTER" } + character(kind=selected_char_kind("asciii")) :: s3 ! { dg-error "is not supported for CHARACTER" } + character(kind=selected_char_kind("I don't exist")) :: s4 ! { dg-error "is not supported for CHARACTER" } + + print *, selected_char_kind() ! { dg-error "Missing actual argument" } + print *, selected_char_kind(12) ! { dg-error "must be CHARACTER" } + print *, selected_char_kind(["foo", "bar"]) ! { dg-error "must be a scalar" } + +end Index: Fortran/gfortran/regression/selected_char_kind_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_char_kind_3.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95 -pedantic -Wall -Wno-intrinsics-std" } +! +! Check that SELECTED_CHAR_KIND is rejected with -std=f95 +! + implicit none + character(kind=selected_char_kind("ascii")) :: s ! { dg-error "has no IMPLICIT type" } + s = "" ! { dg-error "has no IMPLICIT type" } + print *, s +end Index: Fortran/gfortran/regression/selected_char_kind_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_char_kind_4.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! Check that runtime result values of SELECTED_CHAR_KIND agree with +! front-end simplification results. +! + implicit none + character(len=20) :: s + + s = "ascii" + if (selected_char_kind(s) /= selected_char_kind("ascii")) STOP 1 + + s = "default" + if (selected_char_kind(s) /= selected_char_kind("default")) STOP 2 + + s = "iso_10646" + if (selected_char_kind(s) /= selected_char_kind("iso_10646")) STOP 3 + + s = "" + if (selected_char_kind(s) /= selected_char_kind("")) STOP 4 + + s = "invalid" + if (selected_char_kind(s) /= selected_char_kind("invalid")) STOP 5 + +end Index: Fortran/gfortran/regression/selected_kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_kind_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! PR fortran/32968 +program selected + + if (selected_int_kind (1) /= 1) STOP 1 + if (selected_int_kind (3) /= 2) STOP 2 + if (selected_int_kind (5) /= 4) STOP 3 + if (selected_int_kind (10) /= 8) STOP 4 + if (selected_real_kind (1) /= 4) STOP 5 + if (selected_real_kind (2) /= 4) STOP 6 + if (selected_real_kind (9) /= 8) STOP 7 + if (selected_real_kind (10) /= 8) STOP 8 + +end program selected + Index: Fortran/gfortran/regression/selected_real_kind_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_real_kind_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/44347 - arguments of SELECTED_REAL_KIND shall be scalar +! Testcase contributed by Vittorio Zecca +! + + dimension ip(1), ir(1) + i = selected_real_kind(ip, i) ! { dg-error "must be a scalar" } + j = selected_real_kind(i, ir) ! { dg-error "must be a scalar" } +end Index: Fortran/gfortran/regression/selected_real_kind_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_real_kind_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } +! + +integer :: p, r, rdx + +! Compile-time version + +if (selected_real_kind(radix=2) /= 4) call should_not_fail() +if (selected_real_kind(radix=4) /= -5) call should_not_fail() +if (selected_real_kind(precision(0.0),range(0.0),radix(0.0)) /= kind(0.0)) & + call should_not_fail() +if (selected_real_kind(precision(0.0d0),range(0.0d0),radix(0.0d0)) /= kind(0.0d0)) & + call should_not_fail() + +! Run-time version + +rdx = 2 +if (selected_real_kind(radix=rdx) /= 4) STOP 1 +rdx = 4 +if (selected_real_kind(radix=rdx) /= -5) STOP 2 + +rdx = radix(0.0) +p = precision(0.0) +r = range(0.0) +if (selected_real_kind(p,r,rdx) /= kind(0.0)) STOP 3 + +rdx = radix(0.0d0) +p = precision(0.0d0) +r = range(0.0d0) +if (selected_real_kind(p,r,rdx) /= kind(0.0d0)) STOP 4 +end Index: Fortran/gfortran/regression/selected_real_kind_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/selected_real_kind_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +print *, selected_real_kind(p=precision(0.0),radix=2) ! { dg-error "Fortran 2008" } +print *, selected_real_kind() ! { dg-error "neither 'P' nor 'R' argument" } +end Index: Fortran/gfortran/regression/semicolon_fixed.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/semicolon_fixed.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 19259 Semicolon cannot start a line (in F2003) + x=1; y=1; + x=2;; + x=3; + ; ! { dg-error "Fortran 2008: Semicolon at" } + ;; ! { dg-error "Fortran 2008: Semicolon at" } + 900 ; ! { dg-error "Semicolon at" } + end Index: Fortran/gfortran/regression/semicolon_fixed_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/semicolon_fixed_2.f @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! PR 19259 Semicolon cannot start a line +! but it F2008 it can! + x=1; y=1; + x=2;; + x=3; + ; ! OK + ;; ! OK + 900 ; ! { dg-error "Semicolon at" } + end Index: Fortran/gfortran/regression/semicolon_free.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/semicolon_free.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR 19259 Semicolon cannot start a line +x=1; y=1; +x=2;; +x=3; + ; ! { dg-error "Semicolon at" } +;; ! { dg-error "Semicolon at" } +111 ; ! { dg-error "Semicolon at" } +end Index: Fortran/gfortran/regression/semicolon_free_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/semicolon_free_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! PR 19259 Semicolon cannot start a line +x=1; y=1; +x=2;; +x=3; + ; ! OK +;; ! OK +111 ; ! { dg-error "Semicolon at" } +end Index: Fortran/gfortran/regression/sequence_types_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sequence_types_1.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! Tests the fix for PR28590, in which pointer components of sequence +! types would give the error that the component is itself not a +! sequence type (4.4.1) if the component was not already defined. +! +! Contributed by Chris Nelson +! +module data_types + Integer, Parameter :: kindAry = selected_int_kind(r=8) + Integer, Parameter :: kindInt = selected_int_kind(r=8) + + Integer, Parameter :: kindQ = selected_real_kind(p=6,r=37) + Integer, Parameter :: kindXYZ = selected_real_kind(p=13,r=200) + Integer, Parameter :: kindDouble = selected_real_kind(p=13,r=200) + + type GroupLoadInfo + sequence + Integer(kindAry) :: loadMode + Integer(kindAry) :: normalDir + Real(kindQ) :: refS, refL, refX, refY, refZ + Real(kindQ) :: forcex, forcey, forcez + Real(kindQ) :: forcexv, forceyv, forcezv + Real(kindQ) :: momx, momy, momz + Real(kindQ) :: momxv, momyv, momzv + Real(kindQ) :: flmassx, flmassy, flmassz + Real(kindQ) :: flmomtmx, flmomtmy, flmomtmz + Real(kindQ) :: flheatN + end type GroupLoadInfo + + type GroupRigidMotion + sequence + Integer(kindInt) :: motiontyp + Real(kindXYZ), dimension(3) :: xref + Real(kindXYZ), dimension(3) :: angCurrent + Real(kindXYZ), dimension(3) :: xdot + Real(kindXYZ), dimension(3) :: angNew + Real(kindXYZ), dimension(3) :: angRate + Real(kindDouble) :: curTim + Real(kindXYZ) , pointer :: properties + Type(PrescribedMotionData) , pointer :: PrescribeDat + end type GroupRigidMotion + + type PrescribedMotionData + sequence + Integer(kindInt) :: prescr_typ + Real(kindXYZ), dimension(3) :: xvel + Real(kindXYZ) :: amplitude + Real(kindXYZ) :: frequency + Real(kindXYZ) :: phase + Real(kindXYZ), dimension(3) :: thetadot + Real(kindXYZ), dimension(3) :: thetaddot + end type PrescribedMotionData + + type GroupDeformingMotion + sequence + Integer(kindAry) :: nmodes + end type GroupDeformingMotion + + type GroupLL + sequence + type(GroupLL) , pointer :: next + type(GroupLL) , pointer :: parent + character(32) :: name + type(GroupDefLL) , pointer :: entities + type(GroupLoadInfo) , pointer :: loadInfo + type(GroupRigidMotion) , pointer :: RigidMotion + type(GroupDeformingMotion), pointer :: DeformingMotion + end type GroupLL + + type GroupDefLL + sequence + type ( GroupDefLL ), pointer :: next + Integer(kindInt) :: zone + Integer(kindInt) :: surface + type ( GroupLL ), pointer :: subGrp + Integer(kindInt) :: normalDir + Integer(kindInt), dimension(:), pointer :: subset + end type GroupDefLL +end module data_types Index: Fortran/gfortran/regression/set_vm_limit.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/set_vm_limit.c @@ -0,0 +1,33 @@ +/* Called by pr68078. */ + +#include +#include +#include +#include + +void +set_vm_limit (int vm_limit) +{ + struct rlimit rl; + int r; + + r = getrlimit (RLIMIT_AS, &rl); + if (r) + { + perror ("get_vm_limit"); + exit (1); + } + + if (vm_limit >= rl.rlim_cur) + return; + + rl.rlim_cur = vm_limit; + r = setrlimit (RLIMIT_AS, &rl); + if (r) + { + perror ("set_vm_limit"); + exit (1); + } + + return; +} Index: Fortran/gfortran/regression/shape_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 13201 we used to not give an error in those cases +subroutine foo(n) + integer, parameter :: a(n) = 1 ! { dg-error "cannot be automatic" "automatic shape" } + integer, parameter :: z(:) = (/ 1,2,3 /) ! { dg-error "cannot be automatic" "deferred shape" } +end subroutine Index: Fortran/gfortran/regression/shape_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_10.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/102716 + +program p + integer, parameter :: a(1) = shape([2], [1]) ! { dg-error "must be a scalar" } +end Index: Fortran/gfortran/regression/shape_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_11.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/103610 - ICE while simplifying SHAPE +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(-1) = 1 + integer, parameter :: b(1) = maskl(shape(a)) + integer, parameter :: c(1) = shape(a) + integer, parameter :: d(1) = maskr(shape(a)) + if (b(1) /= 0) stop 1 + if (c(1) /= 0) stop 2 + if (d(1) /= 0) stop 3 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/shape_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_2.f90 @@ -0,0 +1,30 @@ +! Check that lbound() and ubound() work correctly for assumed shapes. +! { dg-do run } +program main + integer, dimension (40, 80) :: a = 1 + call test (a) +contains + subroutine test (b) + integer, dimension (11:, -8:), target :: b + integer, dimension (:, :), pointer :: ptr + + if (lbound (b, 1) .ne. 11) STOP 1 + if (ubound (b, 1) .ne. 50) STOP 2 + if (lbound (b, 2) .ne. -8) STOP 3 + if (ubound (b, 2) .ne. 71) STOP 4 + + if (lbound (b (:, :), 1) .ne. 1) STOP 5 + if (ubound (b (:, :), 1) .ne. 40) STOP 6 + if (lbound (b (:, :), 2) .ne. 1) STOP 7 + if (ubound (b (:, :), 2) .ne. 80) STOP 8 + + if (lbound (b (20:30:3, 40), 1) .ne. 1) STOP 9 + if (ubound (b (20:30:3, 40), 1) .ne. 4) STOP 10 + + ptr => b + if (lbound (ptr, 1) .ne. 11) STOP 11 + if (ubound (ptr, 1) .ne. 50) STOP 12 + if (lbound (ptr, 2) .ne. -8) STOP 13 + if (ubound (ptr, 2) .ne. 71) STOP 14 + end subroutine test +end program main Index: Fortran/gfortran/regression/shape_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 34980 - we got a segfault for calling shape +! with a scalar. +program main + integer :: n + n = 5 + open(10,status="scratch") + write (10,*) shape(n) + close(10,status="delete") +end + Index: Fortran/gfortran/regression/shape_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_4.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 35001 - we need to return 0 for the shapes of +! negative extents. Test case adapted from Tobias Burnus. +program main + implicit none + integer :: i,j, a(10,10),res(2) + j = 1 + i = 10 + res = shape(a(1:1,i:j:1)) + if (res(1) /=1 .or. res(2) /= 0) STOP 1 + res = shape(a(1:1,j:i:-1)) + if (res(1) /=1 .or. res(2) /= 0) STOP 2 +end program main Index: Fortran/gfortran/regression/shape_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_5.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 40067 - this used to segfault on an unallocated return array. + integer, dimension(10) :: int1d + integer, dimension(:), pointer :: int1d_retrieved + + allocate(int1d_retrieved(10)) + if (any(shape(int1d_retrieved) /= shape(INT1D))) STOP 1 + end Index: Fortran/gfortran/regression/shape_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_6.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/47531 +! +! Contributed by James Van Buskirk +! +! Check for the presence of the optional kind= argument +! of F2003. +! + +program bug1 + use ISO_C_BINDING + implicit none + real,allocatable :: weevil(:,:) + + write(*,*) achar(64,C_CHAR) + write(*,*) char(64,C_CHAR) + write(*,*) iachar('A',C_INTPTR_T) + write(*,*) ichar('A',C_INTPTR_T) + write(*,*) len('A',C_INTPTR_T) + write(*,*) len_trim('A',C_INTPTR_T) + allocate(weevil(2,2)) + weevil = 42 + write(*,*) ceiling(weevil,C_INTPTR_T) + write(*,*) floor(weevil,C_INTPTR_T) + write(*,*) shape(weevil,C_INTPTR_T) + write(*,*) storage_size(weevil,C_INTPTR_T) +end program bug1 + Index: Fortran/gfortran/regression/shape_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_7.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/52093 +! +! Contributed by Mohammad Rahmani +! + +Program Main + Implicit None + Integer:: X(2,2) + Integer:: X2(7:11,8:9) + + if (size((X)) /= 4) STOP 1 + if (any (Shape((X)) /= [2,2])) STOP 2 + if (any (lbound((X)) /= [1,1])) STOP 3 + if (any (ubound((X)) /= [2,2])) STOP 4 + + if (size(X2) /= 10) STOP 5 + if (any (Shape(X2) /= [5,2])) STOP 6 + if (any (lbound(X2) /= [7,8])) STOP 7 + if (any (ubound(X2) /= [11,9])) STOP 8 + + if (size((X2)) /= 10) STOP 9 + if (any (Shape((X2)) /= [5,2])) STOP 10 + if (any (lbound((X2)) /= [1,1])) STOP 11 + if (any (ubound((X2)) /= [5,2])) STOP 12 +End Program Main + +! { dg-final { scan-tree-dump-times "_gfortran_stop" 0 "original" } } + Index: Fortran/gfortran/regression/shape_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_8.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! Check that we can use SHAPE with optional kind argument +! +program test + implicit none + real, allocatable :: x(:,:) + + allocate(x(2,5)) + if (any(shape(x) /= [ 2, 5 ])) STOP 1 + if (any(shape(x,kind=1) /= [ 2, 5 ])) STOP 2 + if (any(shape(x,kind=2) /= [ 2, 5 ])) STOP 3 + if (any(shape(x,kind=4) /= [ 2, 5 ])) STOP 4 + if (any(shape(x,kind=8) /= [ 2, 5 ])) STOP 5 +end Index: Fortran/gfortran/regression/shape_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shape_9.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-require-effective-target lto } +! { dg-options "-flto" } +! Check that there are no warnings with LTO for a KIND argument. +! +program test + implicit none + real, allocatable :: x(:,:) + + allocate(x(2,5)) + if (any(shape(x) /= [ 2, 5 ])) STOP 1 + if (any(shape(x,kind=1) /= [ 2, 5 ])) STOP 2 + if (any(shape(x,kind=2) /= [ 2, 5 ])) STOP 3 + if (any(shape(x,kind=4) /= [ 2, 5 ])) STOP 4 + if (any(shape(x,kind=8) /= [ 2, 5 ])) STOP 5 + end program test Index: Fortran/gfortran/regression/shift-alloc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shift-alloc.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR 22144: eoshift1, eoshift3 and cshift1 used to lack memory +! allocation, which caused the writes to segfault. +program main + implicit none + integer, dimension (:,:),allocatable :: a + integer, dimension (3) :: sh, bo + character(len=80) line1, line2 + integer :: i + + allocate (a(3,3)) + a = reshape((/(i,i=1,9)/),shape(a)) + sh = (/ 2, -1, -2 /) + bo = (/ -3, -2, -1 /) + write(unit=line1,fmt='(10I5)') cshift(a, shift=sh) + write(unit=line1,fmt='(10I5)') eoshift(a, shift=sh) + write(unit=line1,fmt='(10I5)') eoshift(a, shift=sh, boundary=bo) +end program main Index: Fortran/gfortran/regression/shift-kind.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shift-kind.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! PR 22143: We didn' have shift arguments to eoshift of kind=1 +! and kind=2. +program main + implicit none + integer, dimension (3,3) :: a, b, w + integer(kind=2), dimension (3) :: sh2 + integer(kind=1), dimension (3) :: sh1 + integer, dimension(3) :: bo + integer :: i,j + + a = reshape((/(i,i=1,9)/),shape(a)) + sh1 = (/ -3, -1, 3 /) + sh2 = (/ -3, -1, 3 /) + bo = (/-999, -99, -9 /) + b = cshift(a, shift=sh1) + call foo(b) + b = cshift(a, shift=sh2) + call foo(b) + + b = eoshift(a, shift=sh1) + call foo(b) + b = eoshift(a, shift=sh1, boundary=bo) + call foo(b) + b = eoshift(a, shift=sh2) + call foo(b) + b = eoshift(a, shift=sh2, boundary=bo) + call foo(b) + +end program main + +subroutine foo(b) + ! Do nothing but confuse the optimizer into not removing the + ! function calls. + integer, dimension(3,3) :: b +end subroutine foo + Index: Fortran/gfortran/regression/shift-kind_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shift-kind_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR34540 cshift, eoshift, kind=1 and kind=2 arguments... +program main + integer(kind=1) :: d1 + integer(kind=2) :: d2 + integer(kind=4) :: d4 + integer(kind=8) :: d8 + integer(kind=1), dimension(2) :: s1 + integer(kind=2), dimension(2) :: s2 + integer(kind=4), dimension(2) :: s4 + integer(kind=8), dimension(2) :: s8 + real, dimension(2,2) :: r, r1, r2 + data r /1.0, 2.0, 3.0, 4.0/ + data r1 /2.0, 0.0, 4.0, 0.0/ + data r2 /2.0, 1.0, 4.0, 3.0/ + s1 = (/1, 1/) + s2 = (/1, 1/) + s4 = (/1, 1/) + s8 = (/1, 1/) + d1 = 1 + d2 = 1 + d4 = 1 + d8 = 1 + if (any(eoshift(r,shift=s1,dim=d1) /= r1)) STOP 1 + if (any(eoshift(r,shift=s2,dim=d2) /= r1)) STOP 2 + if (any(eoshift(r,shift=s4,dim=d4) /= r1)) STOP 3 + if (any(eoshift(r,shift=s8,dim=d8) /= r1)) STOP 4 + if (any(cshift(r,shift=s1,dim=d1) /= r2)) STOP 5 + if (any(cshift(r,shift=s2,dim=d2) /= r2)) STOP 6 + if (any(cshift(r,shift=s4,dim=d4) /= r2)) STOP 7 + if (any(cshift(r,shift=s8,dim=d8) /= r2)) STOP 8 +end program main Index: Fortran/gfortran/regression/shiftalr_1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shiftalr_1.F90 @@ -0,0 +1,162 @@ +! Test the SHIFTA, SHIFTL and SHIFTR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + + interface run_shifta + procedure shifta_1 + procedure shifta_2 + procedure shifta_4 + procedure shifta_8 + end interface + interface run_shiftl + procedure shiftl_1 + procedure shiftl_2 + procedure shiftl_4 + procedure shiftl_8 + end interface + interface run_shiftr + procedure shiftr_1 + procedure shiftr_2 + procedure shiftr_4 + procedure shiftr_8 + end interface + interface run_ishft + procedure ishft_1 + procedure ishft_2 + procedure ishft_4 + procedure ishft_8 + end interface + +#define CHECK(I,SHIFT,RESA,RESL,RESR) \ + if (shifta(I,SHIFT) /= RESA) STOP 1; \ + if (shiftr(I,SHIFT) /= RESR) STOP 2; \ + if (shiftl(I,SHIFT) /= RESL) STOP 3; \ + if (run_shifta(I,SHIFT) /= RESA) STOP 4; \ + if (run_shiftr(I,SHIFT) /= RESR) STOP 5; \ + if (run_shiftl(I,SHIFT) /= RESL) STOP 6; \ + if (ishft(I,SHIFT) /= RESL) STOP 7; \ + if (ishft(I,-SHIFT) /= RESR) STOP 8; \ + if (run_ishft(I,SHIFT) /= RESL) STOP 9; \ + if (run_ishft(I,-SHIFT) /= RESR) STOP 10 + + CHECK(0_1,0,0_1,0_1,0_1) + CHECK(11_1,0,11_1,11_1,11_1) + CHECK(-11_1,0,-11_1,-11_1,-11_1) + CHECK(0_1,1,0_1,0_1,0_1) + CHECK(11_1,1,5_1,22_1,5_1) + CHECK(11_1,2,2_1,44_1,2_1) + CHECK(-11_1,1,-6_1,-22_1,huge(0_1)-5_1) + + CHECK(0_2,0,0_2,0_2,0_2) + CHECK(11_2,0,11_2,11_2,11_2) + CHECK(-11_2,0,-11_2,-11_2,-11_2) + CHECK(0_2,1,0_2,0_2,0_2) + CHECK(11_2,1,5_2,22_2,5_2) + CHECK(11_2,2,2_2,44_2,2_2) + CHECK(-11_2,1,-6_2,-22_2,huge(0_2)-5_2) + + CHECK(0_4,0,0_4,0_4,0_4) + CHECK(11_4,0,11_4,11_4,11_4) + CHECK(-11_4,0,-11_4,-11_4,-11_4) + CHECK(0_4,1,0_4,0_4,0_4) + CHECK(11_4,1,5_4,22_4,5_4) + CHECK(11_4,2,2_4,44_4,2_4) + CHECK(-11_4,1,-6_4,-22_4,huge(0_4)-5_4) + + CHECK(0_8,0,0_8,0_8,0_8) + CHECK(11_8,0,11_8,11_8,11_8) + CHECK(-11_8,0,-11_8,-11_8,-11_8) + CHECK(0_8,1,0_8,0_8,0_8) + CHECK(11_8,1,5_8,22_8,5_8) + CHECK(11_8,2,2_8,44_8,2_8) + CHECK(-11_8,1,-6_8,-22_8,huge(0_8)-5_8) + +contains + + function shifta_1 (i, shift) result(res) + integer(kind=1) :: i, res + integer :: shift + res = shifta(i,shift) + end function + function shiftl_1 (i, shift) result(res) + integer(kind=1) :: i, res + integer :: shift + res = shiftl(i,shift) + end function + function shiftr_1 (i, shift) result(res) + integer(kind=1) :: i, res + integer :: shift + res = shiftr(i,shift) + end function + + function shifta_2 (i, shift) result(res) + integer(kind=2) :: i, res + integer :: shift + res = shifta(i,shift) + end function + function shiftl_2 (i, shift) result(res) + integer(kind=2) :: i, res + integer :: shift + res = shiftl(i,shift) + end function + function shiftr_2 (i, shift) result(res) + integer(kind=2) :: i, res + integer :: shift + res = shiftr(i,shift) + end function + + function shifta_4 (i, shift) result(res) + integer(kind=4) :: i, res + integer :: shift + res = shifta(i,shift) + end function + function shiftl_4 (i, shift) result(res) + integer(kind=4) :: i, res + integer :: shift + res = shiftl(i,shift) + end function + function shiftr_4 (i, shift) result(res) + integer(kind=4) :: i, res + integer :: shift + res = shiftr(i,shift) + end function + + function shifta_8 (i, shift) result(res) + integer(kind=8) :: i, res + integer :: shift + res = shifta(i,shift) + end function + function shiftl_8 (i, shift) result(res) + integer(kind=8) :: i, res + integer :: shift + res = shiftl(i,shift) + end function + function shiftr_8 (i, shift) result(res) + integer(kind=8) :: i, res + integer :: shift + res = shiftr(i,shift) + end function + + function ishft_1 (i, shift) result(res) + integer(kind=1) :: i, res + integer :: shift + res = ishft(i,shift) + end function + function ishft_2 (i, shift) result(res) + integer(kind=2) :: i, res + integer :: shift + res = ishft(i,shift) + end function + function ishft_4 (i, shift) result(res) + integer(kind=4) :: i, res + integer :: shift + res = ishft(i,shift) + end function + function ishft_8 (i, shift) result(res) + integer(kind=8) :: i, res + integer :: shift + res = ishft(i,shift) + end function + +end Index: Fortran/gfortran/regression/shiftalr_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shiftalr_2.F90 @@ -0,0 +1,52 @@ +! Test the SHIFTA, SHIFTL and SHIFTR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + + implicit none + +#define CHECK(I,SHIFT,RESA,RESL,RESR) \ + if (shifta(I,SHIFT) /= RESA) STOP 1; \ + if (shiftr(I,SHIFT) /= RESR) STOP 2; \ + if (shiftl(I,SHIFT) /= RESL) STOP 3; \ + if (run_shifta(I,SHIFT) /= RESA) STOP 4; \ + if (run_shiftr(I,SHIFT) /= RESR) STOP 5; \ + if (run_shiftl(I,SHIFT) /= RESL) STOP 6; \ + if (ishft(I,SHIFT) /= RESL) STOP 7; \ + if (ishft(I,-SHIFT) /= RESR) STOP 8; \ + if (run_ishft(I,SHIFT) /= RESL) STOP 9; \ + if (run_ishft(I,-SHIFT) /= RESR) STOP 10 + + CHECK(0_16,0,0_16,0_16,0_16) + CHECK(11_16,0,11_16,11_16,11_16) + CHECK(-11_16,0,-11_16,-11_16,-11_16) + CHECK(0_16,1,0_16,0_16,0_16) + CHECK(11_16,1,5_16,22_16,5_16) + CHECK(11_16,2,2_16,44_16,2_16) + CHECK(-11_16,1,-6_16,-22_16,huge(0_16)-5_16) + +contains + + function run_shifta (i, shift) result(res) + integer(kind=16) :: i, res + integer :: shift + res = shifta(i,shift) + end function + function run_shiftl (i, shift) result(res) + integer(kind=16) :: i, res + integer :: shift + res = shiftl(i,shift) + end function + function run_shiftr (i, shift) result(res) + integer(kind=16) :: i, res + integer :: shift + res = shiftr(i,shift) + end function + function run_ishft (i, shift) result(res) + integer(kind=16) :: i, res + integer :: shift + res = ishft(i,shift) + end function + +end Index: Fortran/gfortran/regression/shiftalr_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/shiftalr_3.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test shift intrinsics when the SHIFT argument equals BIT_SIZE(arg1). + +program test + implicit none + ! Test compile-time simplifications + if (ishft (-1, 32) /= 0) stop 1 ! 0 -> simplify_shift OK + if (ishft (-1,-32) /= 0) stop 2 ! 0 -> simplify_shift OK + if (shiftl (-1, 32) /= 0) stop 3 ! 0 -> simplify_shift OK + if (shiftr (-1, 32) /= 0) stop 4 ! 0 -> simplify_shift OK + if (shifta (-1, 32) /= -1) stop 5 ! -1 -> simplify_shift OK + if (rshift (-1, 32) /= -1) stop 6 ! -1 -> simplify_shift OK + if (lshift (-1, 32) /= 0) stop 7 ! 0 -> simplify_shift OK + ! Test run-time + call foo (-1) +contains + subroutine foo (n) + integer(4) :: i, j, k, n + integer, parameter :: bb = bit_size (n) + ! Test code generated by gfc_conv_intrinsic_ishft + i = ishft (n, bb) ! Logical (left) shift (Fortran 2008) + j = ishft (n,-bb) ! Logical (right) shift (Fortran 2008) + if (i /= 0) stop 11 + if (j /= 0) stop 12 + ! Test code generated by gfc_conv_intrinsic_shift: + i = shiftl (n, bb) ! Logical left shift (Fortran 2008) + j = shiftr (n, bb) ! Logical right shift (Fortran 2008) + k = shifta (n, bb) ! Arithmetic right shift (Fortran 2008) + if (i /= 0) stop 13 + if (j /= 0) stop 14 + if (k /= -1) stop 15 + i = lshift (n, bb) ! Logical left shift (GNU extension) + j = rshift (n, bb) ! Arithmetic right shift (GNU extension) + if (i /= 0) stop 16 + if (j /= -1) stop 17 + do i = bb-1,bb + if (shifta (n, i) /= -1) stop 18 + if (rshift (n, i) /= -1) stop 19 + end do + end subroutine foo +end program test Index: Fortran/gfortran/regression/short_circuiting.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/short_circuiting.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-additional-options "-Wextra" } +! +! PR 85599: warn about short-circuiting of logical expressions for non-pure functions +! +! Contributed by Janus Weil + +module a + + interface impl_pure_a + module procedure impl_pure_a1 + end interface + +contains + + logical function impl_pure_a1() + impl_pure_a1 = .true. + end function + +end module + + +program short_circuit + + use a + + logical :: flag + flag = .false. + flag = check() .and. flag + flag = flag .and. check() ! { dg-warning "might not be evaluated" } + flag = flag .and. pure_check() + flag = flag .and. impl_pure_1() + flag = flag .and. impl_pure_2() + flag = flag .and. impl_pure_a1() + flag = flag .and. impl_pure_a() + +contains + + logical function check() + integer, save :: i = 1 + print *, "check", i + i = i + 1 + check = .true. + end function + + logical pure function pure_check() + pure_check = .true. + end function + + logical function impl_pure_1() + impl_pure_1 = .true. + end function + + logical function impl_pure_2() + impl_pure_2 = impl_pure_1() + end function + + +end Index: Fortran/gfortran/regression/short_circuiting_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/short_circuiting_2.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-O0" } +! +! PR 57160: short-circuit IF only with -ffrontend-optimize +! +! this checks that short-circuiting is not done with -O0 +! +! Contributed by Janus Weil + +program short_circuit + + integer, save :: i = 0 + logical :: flag + + flag = .false. + flag = check() .and. flag + flag = flag .and. check() + + if (i /= 2) stop 1 + +contains + + logical function check() + i = i + 1 + check = .true. + end function + +end Index: Fortran/gfortran/regression/short_circuiting_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/short_circuiting_3.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-O3" } +! +! PR 57160: short-circuit IF only with -ffrontend-optimize +! +! this checks that short-circuiting is done with -O3 +! +! Contributed by Janus Weil + +program short_circuit + + integer, save :: i = 0 + logical :: flag + + flag = .false. + flag = check() .and. flag + flag = flag .and. check() + + if (i /= 1) stop 1 + +contains + + logical function check() + i = i + 1 + check = .true. + end function + +end Index: Fortran/gfortran/regression/sibling_dummy_procedure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sibling_dummy_procedure_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! This checks the fix for PR 26041. +! +! Contributed by H.J. Lu +module foo + public bar_ + interface bar_ + module procedure bar + end interface + public xxx_ + interface xxx_ + module procedure xxx + end interface +contains + subroutine bar(self, z) + interface + function self(z) result(res) + real z + real(kind=kind(1.0d0)) :: res + end function + end interface + end subroutine + subroutine xxx(self,z) + interface + function self(z) result(res) + real z + real(kind=kind(1.0d0)) :: res + end function + end interface + call bar(self, z) + end subroutine +end Index: Fortran/gfortran/regression/sibling_dummy_procedure_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sibling_dummy_procedure_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! This checks the fix for PR 26041. +! +! Contributed by H.J. Lu +module foo + public bar_ + interface bar_ + module procedure bar + end interface + public xxx_ + interface xxx_ + module procedure xxx + end interface +contains + subroutine bar(self, z) + interface + function self(z) result(res) + real z + real(kind=kind(1.0d0)) :: res + end function + end interface + end subroutine + subroutine xxx(self,z) + interface + function self(z) result(res) + real z + real(kind=kind(1.0d0)) :: res + end function + end interface + call bar_(self, z) + end subroutine +end Index: Fortran/gfortran/regression/sibling_dummy_procedure_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sibling_dummy_procedure_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! This checks the fix for PR 26064 +! +! Contributed by Sven Buijssen +module ice + implicit none + contains + + subroutine foo() + contains + + subroutine bar(baz) + integer, optional :: baz + if (present(baz)) then + endif + end subroutine bar + end subroutine foo +end module Index: Fortran/gfortran/regression/simd-builtins-1.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-1.h @@ -0,0 +1,4 @@ +!GCC$ builtin (sin) attributes simd (inbranch) +!GCC$ builtin (sinf) attributes simd (notinbranch) +!GCC$ builtin (cosf) attributes simd +!GCC$ builtin (cosf) attributes simd (notinbranch) Index: Fortran/gfortran/regression/simd-builtins-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile { target i?86-*-linux* x86_64-*-linux* aarch64*-*-linux* } } +! { dg-additional-options "-nostdinc -Ofast -fpre-include=simd-builtins-1.h -fdump-tree-optimized" } +! { dg-additional-options "-msse2 -mno-avx" { target i?86-*-linux* x86_64-*-linux* } } + +program test_overloaded_intrinsic + real(4) :: x4(3200), y4(3200) + real(8) :: x8(3200), y8(3200) + + ! this should be using simd clone + y4 = sin(x4) + print *, y4 + + ! this should not be using simd clone + y4 = sin(x8) + print *, y8 +end + +! { dg-final { scan-tree-dump "sinf.simdclone" "optimized" } } +! { dg-final { scan-tree-dump "__builtin_sin" "optimized" } } +! { dg-final { scan-assembler "call.*_ZGVbN4v_sinf" { target i?86-*-linux* x86_64-*-* } } } +! { dg-final { scan-assembler "bl.*_ZGVnN4v_sinf" { target aarch64*-*-* } } } Index: Fortran/gfortran/regression/simd-builtins-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile { target { i?86-*-linux* x86_64-*-linux* aarch64*-*-linux* } } } +! { dg-additional-options "-nostdinc -Ofast -fdump-tree-optimized" } +! { dg-additional-options "-msse2" { target i?86-*-linux* x86_64-*-linux* } } + +program test_overloaded_intrinsic + real(4) :: x4(3200), y4(3200) + real(8) :: x8(3200), y8(3200) + + ! this should not be using simd clone + y4 = sin(x4) + print *, y4 + + ! this should not be using simd clone + y4 = sin(x8) + print *, y8 +end + +! { dg-final { scan-tree-dump "__builtin_sinf" "optimized" } } */ +! { dg-final { scan-tree-dump "__builtin_sin" "optimized" } } */ +! { dg-final { scan-tree-dump-not "simdclone" "optimized" } } */ +! { dg-final { scan-assembler-not "call.*_ZGVbN4v_sinf" } } +! { dg-final { scan-assembler-not "bl.*_ZGVnN4v_sinf" } } Index: Fortran/gfortran/regression/simd-builtins-3.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-3.h @@ -0,0 +1,8 @@ +!GCC$ builtin (sin) attributes simd (inbranch) +!GCC$ builtin ( sin) attributes simd (inbranch) +!GCC$ builtin (sin ) attributes simd (inbranch) +!GCC$ builtin (sin) attributes simd ( inbranch) +!GCC$ builtin (sin) attributes simd (inbranch ) +!GCC$ builtin(sin ) attributes simd ( inbranch ) +!GCC$ builtin ( sin ) attributes simd ( inbranch ) +!GCC$ builtin ( sin ) attributes simd Index: Fortran/gfortran/regression/simd-builtins-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-3.f90 @@ -0,0 +1 @@ +! { dg-additional-options "-nostdinc -fpre-include=simd-builtins-3.h" } Index: Fortran/gfortran/regression/simd-builtins-4.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-4.h @@ -0,0 +1,8 @@ +!GCC$ builtin (sin) attributes simd (inbranch) +!GCC$ builtin ( sin) attributes simd (inbranch) +!GCC$ builtin (sin ) attributes simd (inbranch) +!GCC$ builtin (sin) attributes simd ( inbranch) +!GCC$ builtin (sin) attributes simd (inbranch ) +!GCC$ builtin(sin ) attributes simd ( inbranch ) +!GCC$ builtin ( sin ) attributes simd ( inbranch ) +!GCC$ builtin ( sin ) attributes simd Index: Fortran/gfortran/regression/simd-builtins-4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-4.f @@ -0,0 +1 @@ +! { dg-additional-options "-nostdinc -fpre-include=simd-builtins-4.h" } Index: Fortran/gfortran/regression/simd-builtins-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-5.f @@ -0,0 +1,9 @@ +! { dg-do compile } + +!GCC$ buil tin (s in) attributes simd (inbranch) +!GCC$ builtin (sinf) at tributes simd (notinbranch) +!GCC$ builtin (cosf) att r i bu tes s imd +!GCC$ buil ti n ( cosf) attrib utes simd (noti nbranch) + + PROGRAM Z + END Index: Fortran/gfortran/regression/simd-builtins-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-6.f90 @@ -0,0 +1,26 @@ +! { dg-do compile { target { i?86-*-linux* x86_64-*-linux* aarch64*-*-linux* } } } +! { dg-additional-options "-nostdinc -Ofast -fdump-tree-optimized" } +! { dg-additional-options "-msse2 -mno-avx" { target i?86-*-linux* x86_64-*-linux* } } + +!GCC$ builtin (sin) attributes simd (inbranch) +!GCC$ builtin (sinf) attributes simd (notinbranch) +!GCC$ builtin (cosf) attributes simd +!GCC$ builtin (cosf) attributes simd (notinbranch) + +program test_overloaded_intrinsic + real(4) :: x4(3200), y4(3200) + real(8) :: x8(3200), y8(3200) + + ! this should be using simd clone + y4 = sin(x4) + print *, y4 + + ! this should not be using simd clone + y4 = sin(x8) + print *, y8 +end + +! { dg-final { scan-tree-dump "sinf.simdclone" "optimized" } } */ +! { dg-final { scan-tree-dump "__builtin_sin" "optimized" } } */ +! { dg-final { scan-assembler "call.*_ZGVbN4v_sinf" { target i?86-*-linux* x86_64-*-* } } } +! { dg-final { scan-assembler "bl.*_ZGVnN4v_sinf" { target aarch64*-*-* } } } Index: Fortran/gfortran/regression/simd-builtins-7.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-7.h @@ -0,0 +1,2 @@ +!GCC$ builtin (sin) attributes simd (notinbranch) if('x86_64') +!GCC$ builtin (sinf) attributes simd (notinbranch) if('i386') Index: Fortran/gfortran/regression/simd-builtins-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile { target { i?86-*-linux* x86_64-*-linux* } } } +! { dg-additional-options "-msse2 -mno-avx -nostdinc -Ofast -fpre-include=simd-builtins-7.h -fdump-tree-optimized" } + +program test_overloaded_intrinsic + real(4) :: x4(3200), y4(3200) + real(8) :: x8(3200), y8(3200) + + y4 = sin(x4) + print *, y4 + + y4 = sin(x8) + print *, y8 +end + +! { dg-final { scan-tree-dump "sinf.simdclone" "optimized" { target ia32 } } } */ +! { dg-final { scan-tree-dump-not "sin.simdclone" "optimized" { target ia32 } } } */ + +! { dg-final { scan-tree-dump "sin.simdclone" "optimized" { target lp64} } } */ +! { dg-final { scan-tree-dump-not "sinf.simdclone" "optimized" { target lp64 } } } */ Index: Fortran/gfortran/regression/simd-builtins-8.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-8.h @@ -0,0 +1,4 @@ +!GCC$ builtin (sin) attributes simd (notinbranch) if('aarch64') +!GCC$ builtin (sin) attributes simd (notinbranch) if('aarch64_be') +!GCC$ builtin (sinf) attributes simd (notinbranch) if('aarch64_ilp32') +!GCC$ builtin (sinf) attributes simd (notinbranch) if('aarch64_be_ilp32') Index: Fortran/gfortran/regression/simd-builtins-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simd-builtins-8.f90 @@ -0,0 +1,19 @@ +! { dg-do compile { target { aarch64*-*-linux* } } } +! { dg-additional-options "-nostdinc -Ofast -fpre-include=simd-builtins-8.h -fdump-tree-optimized" } + +program test_overloaded_intrinsic + real(4) :: x4(3200), y4(3200) + real(8) :: x8(3200), y8(3200) + + y4 = sin(x4) + print *, y4 + + y4 = sin(x8) + print *, y8 +end + +! { dg-final { scan-tree-dump "sinf.simdclone" "optimized" { target ilp32 } } } */ +! { dg-final { scan-tree-dump-not "sin.simdclone" "optimized" { target ilp32 } } } */ + +! { dg-final { scan-tree-dump "sin.simdclone" "optimized" { target lp64 } } } */ +! { dg-final { scan-tree-dump-not "sinf.simdclone" "optimized" { target lp64 } } } */ Index: Fortran/gfortran/regression/simpleif_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simpleif_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 17074 +! Verifies that FORALL and WHERE after a simple if work. +DIMENSION ia(4,4) +logical,dimension(4,4) :: index + +if (.true.) forall (i = 1:4, j = 1:4) ia(i,j) = 1 +if (any (ia.ne.1)) STOP 1 + +index(:,:)=.false. +index(2,3) = .true. + +if (.true.) where (index) ia = 2 +if (ia(2,3).ne.2) STOP 2 + +end Index: Fortran/gfortran/regression/simpleif_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simpleif_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Test fix for regression caused by +! 2006-06-23 Steven G. Kargl +! PR fortran/27981 +! * match.c (gfc_match_if): Handle errors in assignment in simple if. +! +module read + integer i, j, k + contains + subroutine a + integer, parameter :: n = 2 + if (i .eq. 0) read(j,*) k + if (i .eq. 0) n = j ! { dg-error "Named constant 'n' in variable definition context" } + end subroutine a +end module read Index: Fortran/gfortran/regression/simplify_argN_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_argN_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Tests the fix for PR35780, in which the assignment for C was not +! scalarized in expr.c. +! +! Contributed by Dick Hendrickson +! +MODULE MODS + integer, parameter :: N = 10 + INTEGER, PARAMETER, DIMENSION(N) :: A = [(i, i = 1, N)] + INTEGER, PARAMETER, DIMENSION(N) :: B = [(i - 5, i = 1, N)] + INTEGER, PARAMETER, DIMENSION(N) :: C = ISHFTC(3, B, 5) !ICE + INTEGER, PARAMETER, DIMENSION(N) :: D = ISHFTC(A, 3, 5) ! OK + INTEGER, PARAMETER, DIMENSION(N) :: E = ISHFTC(A, B, 5) ! OK + +END MODULE MODS + + use mods + integer, dimension(N) :: X = A + integer, dimension(N) :: Y = B + +! Check the simplifed expressions against the library + if (any (ISHFTC(3, Y, 5) /= C)) STOP 1 + if (any (ISHFTC(X, 3, 5) /= D)) STOP 2 + if (any (ISHFTC(X, Y, 5) /= E)) STOP 3 +end Index: Fortran/gfortran/regression/simplify_cshift_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_cshift_1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +program foo + + implicit none + + type t + integer i + end type t + + type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)] + type(t) e(5), q(5) + + integer, parameter :: a(5) = [1, 2, 3, 4, 5] + integer i, b(5), c(5), v(5) + + c = [1, 2, 3, 4, 5] + + b = cshift(a, -2) + v = cshift(c, -2) + if (any(b /= v)) STOP 1 + + b = cshift(a, 2) + v = cshift(c, 2) + if (any(b /= v)) STOP 2 + + ! Special cases shift = 0, size(a), -size(a) + b = cshift([1, 2, 3, 4, 5], 0) + if (any(b /= a)) STOP 3 + b = cshift([1, 2, 3, 4, 5], size(a)) + if (any(b /= a)) STOP 4 + b = cshift([1, 2, 3, 4, 5], -size(a)) + if (any(b /= a)) STOP 5 + + ! simplification of array arg. + b = cshift(2 * a, 0) + if (any(b /= 2 * a)) STOP 6 + + ! An array of derived types works too. + e = [t(1), t(2), t(3), t(4), t(5)] + e = cshift(e, 3) + q = cshift(d, 3) + do i = 1, 5 + if (e(i)%i /= q(i)%i) STOP 7 + end do + +end program foo Index: Fortran/gfortran/regression/simplify_cshift_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_cshift_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +subroutine foo(u, n, fl) + implicit none + integer n + real u(5, n), fl(5,n), wl(5,n) + real c + c = 1 + wl = u + fl = cshift(c * wl, 1, 2) +end subroutine foo Index: Fortran/gfortran/regression/simplify_cshift_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_cshift_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +subroutine foo () + real(4), allocatable, save :: tmp (:, :) + real(4), pointer, save :: arr (:, :, :) + integer :: l, m, n + tmp = (cshift(cshift(arr (:,:,l),m,2),n,1)) +end subroutine foo Index: Fortran/gfortran/regression/simplify_cshift_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_cshift_4.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +program main + implicit none + integer :: i + integer, parameter, dimension(3,3) :: a = & + reshape([1,2,3,4,5,6,7,8,9], shape(a)) + integer, dimension(3,3) :: b + integer, parameter, dimension(3,4,5) :: c = & + reshape([(i**2,i=1,3*4*5)],shape(c)) + integer, dimension(3,4,5) :: d + integer, dimension(4,5), parameter :: sh1 =& + reshape([(i**3-12*i**2,i=1,4*5)],shape(sh1)) + integer, dimension(3,5), parameter :: sh2 = & + reshape([(i**3-7*i**2,i=1,3*5)], shape(sh2)) + integer, dimension(3,4), parameter :: sh3 = & + reshape([(i**3-3*i**2,i=1,3*4)], shape(sh3)) + integer, parameter, dimension(3,4,5) :: c1 = cshift(c,shift=sh1,dim=1) + integer, parameter, dimension(3,4,5) :: c2 = cshift(c,shift=sh2,dim=2) + integer, parameter, dimension(3,4,5) :: c3 = cshift(c,shift=sh3,dim=3) + + b = a + if (any(cshift(a,1) /= cshift(b,1))) STOP 1 + if (any(cshift(a,2) /= cshift(b,2))) STOP 2 + if (any(cshift(a,1,dim=2) /= cshift(b,1,dim=2))) STOP 3 + d = c + if (any(cshift(c,1) /= cshift(d,1))) STOP 4 + if (any(cshift(c,2) /= cshift(d,2))) STOP 5 + if (any(cshift(c,3) /= cshift(d,3))) STOP 6 + + if (any(cshift(c,1,dim=2) /= cshift(d,1,dim=2))) STOP 7 + if (any(cshift(c,2,dim=2) /= cshift(d,2,dim=2))) STOP 8 + if (any(cshift(c,3,dim=3) /= cshift(d,3,dim=3))) STOP 9 + + if (any(cshift(d,shift=sh1,dim=1) /= c1)) STOP 10 + if (any(cshift(d,shift=sh2,dim=2) /= c2)) STOP 11 + if (any(cshift(d,shift=sh3,dim=3) /= c3)) STOP 12 +end program main Index: Fortran/gfortran/regression/simplify_eoshift_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_eoshift_1.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +program main + implicit none + integer :: i,n1, n2, n3 + integer, parameter :: a(3) = [1,2,3] + integer, parameter :: b1(3) = eoshift(a,0) + integer, parameter :: b2(3) = eoshift(a,1) + integer, parameter :: b3(3) = eoshift(a,-2) + integer, parameter :: b4(3) = eoshift(a,4,boundary=42) + integer, parameter :: c(3,3) = reshape([(i,i=1,3*3)],shape(c)) + integer, parameter :: b5(3,3) = eoshift(c,shift=1,dim=1,boundary=33) + integer, parameter :: b6(3,3) = eoshift(c,shift=2,dim=1) + integer, parameter :: b7(3,3) = eoshift(c,shift=-1,dim=2) + integer, parameter :: b8(3,3) = eoshift(c,shift=-1,dim=2,boundary=[-1,-2,-3]) + integer, parameter :: b9(3,3) = eoshift(c,shift=[-1,-1,-1]) + integer, parameter :: b10(3,3) = eoshift(c,shift=[-1,0,1]); + integer, parameter :: b11(3,3) = eoshift(c,dim=2,shift=[-2,-1,1],boundary=42); + integer, parameter :: b12(3,3) = eoshift(c,dim=1,shift=[-1,-2,0],boundary=[-3,-7,-9]) + real, parameter :: r(3,4,5) = reshape([(1.0*i**2,i=1,3*4*5)],shape(r)) + real, parameter :: q1(3,4,5) = eoshift(r,shift=1,dim=3) + integer, parameter :: sh1(3,4) = reshape([-1,-2,0,3,2,5,6,-6,3,1,-1,-5],shape(sh1)) + real, parameter :: bnd1(3,4) = reshape([-1.,-2.,-3.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,-11.,-12.],shape(bnd1)) + real, parameter :: q2(3,4,5) = eoshift(r,dim=3,shift=sh1) + real, parameter :: q3(3,4,5) = eoshift(r,dim=3,shift=sh1,boundary=bnd1) + complex(kind=8), parameter :: s(3,3) = reshape([(cmplx(i*i-5*i,-i+4,kind=8),i=1,9)],shape(s)) + complex(kind=8), parameter :: t(3,3) = eoshift(s,shift=4) + character(len=3), parameter :: e(2,3,4) = reshape([(repeat(achar(i),3),i=iachar('a'),iachar('a')+2*3*4-1)], & + shape(e)) + character(len=3) :: e2(2,3,4) + character(len=3), parameter :: f1(2,3,4) = eoshift(e,1) + character(len=3), parameter :: bnd2(2,4) = reshape([(repeat(achar(i),3),i=iachar('A'),iachar('A')+2*4-1)], & + shape(bnd2)) + character(len=3), parameter :: f2(2,3,4) = eoshift(e,dim=2,shift=-1,boundary=bnd2); + integer, parameter :: sh2(2,3) = reshape([1, -2, 0, 1, 2, -1, 2, 0],shape(sh2)) + character(len=3), parameter :: f3(2,3,4) = eoshift(e,dim=3,shift=sh2) + integer, parameter :: empty(1:0) =[integer ::] + integer, parameter :: empty2(1:0) = eoshift(empty,1) + + n1 = 1 + n2 = 2 + n3 = 3 + + if (any(b1 /= a)) STOP 1 + if (any(b2 /= [2, 3, 0])) STOP 2 + if (any(b3 /= [0, 0, 1])) STOP 3 + if (any(b4 /= 42)) STOP 4 + if (any(eoshift(c,shift=1,dim=n1,boundary=33) /= b5)) STOP 5 + if (any(eoshift(c,shift=2,dim=1) /= b6)) STOP 6 + if (any(eoshift(c,shift=-1,dim=2) /= b7)) STOP 7 + if (any(eoshift(c,shift=-1,dim=n2,boundary=[-1,-2,-3]) /= b8)) STOP 8 + if (any(eoshift(c,shift=-1) /= b9)) STOP 9 + if (any(eoshift(r,shift=1,dim=n3) /= q1)) STOP 10 + if (any(b10 /= reshape([ 0, 1, 2, 4, 5, 6, 8, 9, 0],shape(b10)))) STOP 11 + if (any(b11 /= reshape([42, 42, 6, 42, 2, 9, 1, 5, 42],shape(b11)))) STOP 12 + if (any(b12 /= reshape([ -3, 1, 2, -7, -7, 4, 7, 8, 9],shape(b11)))) STOP 13 + if (any(q1 /= reshape([169.,196.,225.,256.,289.,324.,361.,400.,441.,484.,529.,576.,625.,& + 676.,729.,784.,841.,900.,961.,1024.,1089.,1156.,1225.,1296.,1369.,1444.,1521.,& + 1600.,1681.,1764.,1849.,1936.,2025.,2116.,2209.,2304.,2401.,2500.,2601.,2704.,& + 2809.,2916.,3025.,3136.,3249.,3364.,3481.,3600.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.],& + shape(q1)))) STOP 14 + if (any(q2 /= reshape([0.,0.,9.,1600.,841.,0.,0.,0.,2025.,484.,0.,0.,1.,0.,225.,2704.,& + 1681.,0.,0.,0.,3249.,1156.,121.,0.,169.,4.,729.,0.,2809.,0.,0.,0.,0.,2116.,& + 529.,0.,625.,196.,1521.,0.,0.,0.,0.,0.,0.,3364.,1225.,0.,1369.,676.,2601.,& + 0.,0.,0.,0.,0.,0.,0.,2209.,0.],shape(q2)))) STOP 15 + if (any(q3 /= reshape([-1.,-2.,9.,1600.,841.,-6.,-7.,-8.,2025.,484.,-11.,-12.,1.,& + -2.,225.,2704.,1681.,-6.,-7.,-8.,3249.,1156.,121.,-12.,169.,4.,729.,-4.,& + 2809.,-6.,-7.,-8.,-9.,2116.,529.,-12.,625.,196.,1521.,-4.,-5.,-6.,-7.,-8.,& + -9.,3364.,1225.,-12.,1369.,676.,2601.,-4.,-5.,-6.,-7.,-8.,-9.,-10.,2209.,-12.],& + shape(q3)))) STOP 16 + if (any(f1 /= reshape(["bbb"," ","ddd"," ","fff"," ","hhh"," ","jjj"," ","lll"," ",& + "nnn"," ","ppp"," ","rrr"," ","ttt"," ","vvv"," ","xxx"," "], & + shape(f1)))) STOP 17 + if (any(f2 /= reshape(["AAA","BBB","aaa","bbb","ccc","ddd","CCC","DDD","ggg","hhh","iii","jjj",& + "EEE","FFF","mmm","nnn","ooo","ppp","GGG","HHH","sss","ttt","uuu","vvv"],shape(f2)))) STOP 18 + + e2 = e + if (any (f2 /= eoshift(e2,dim=2,shift=-1,boundary=bnd2))) STOP 19 + if (any (f3 /= reshape (["ggg"," ","ccc","jjj","qqq"," ","mmm"," ","iii","ppp",& + "www","fff","sss","bbb","ooo","vvv"," ","lll"," ","hhh","uuu",& + " "," ","rrr"], shape(f3)))) STOP 20 + if (size(empty) /=0) STOP 21 + if (any(t /= (0.0_8, 0.0_8))) STOP 22 +end program main Index: Fortran/gfortran/regression/simplify_modulo.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/simplify_modulo.f90 @@ -0,0 +1,5 @@ +! { dg-do run } + +if (modulo (-8., -5.) .ne. -3.) STOP 1 + +end Index: Fortran/gfortran/regression/single_char_string.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/single_char_string.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! PR12456 - Optimize string(k:k) as single character. + +Program pr12456 +character a +character b +character (len=5) :: c +integer i + +b = 'a' +a = b +if (a .ne. 'a') STOP 1 +if (a .ne. b) STOP 2 +c (3:3) = 'a' +if (c (3:3) .ne. b) STOP 3 +if (c (3:3) .ne. 'a') STOP 4 +if (LGT (a, c (3:3))) STOP 5 +if (LGT (a, 'a')) STOP 6 + +i = 3 +c (i:i) = 'a' +if (c (i:i) .ne. b) STOP 7 +if (c (i:i) .ne. 'a') STOP 8 +if (LGT (a, c (i:i))) STOP 9 + +if (a .gt. char (255)) STOP 10 +end + +! There should not be _gfortran_compare_string and _gfortran_copy_string in +! the dumped file. + +! { dg-final { scan-tree-dump-times "_gfortran_compare_string" 0 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_copy_string" 0 "original" } } + Index: Fortran/gfortran/regression/size_dim.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/size_dim.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! Check size with initialization expression value for dim= +! PR fortran/30882 +! +! Contributed by Joost VandeVondele +! +program main + integer :: a(10) + call S1(a) +contains + subroutine S1(a) + integer :: a(*) + if(size(a(1:10),1) /= 10) STOP 1 + end subroutine S1 +end program main Index: Fortran/gfortran/regression/size_kind.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/size_kind.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/36153 +! Contributed by Jonathan Hogg +! +program test_64 + implicit none + + integer, parameter :: long = selected_int_kind(18) + integer, parameter :: short = kind(0) + + integer(long), parameter :: big_sz = huge(0_short)+1000_long + integer(long), parameter :: max_32 = huge(0_short) + integer, dimension(:), allocatable :: array + + integer(long) :: i + + print *, "2**31 = ", 2_long**31 + print *, "max_32 = ", max_32 + print *, "big_sz = ", big_sz + +! Disabled as it overflows on 32bit systems (at compile time) +! (conversion of integer(8) to integer(4)) +! allocate(array(big_sz)) + print *, "sz = ", size(array) + print *, "sz = ", size(array, kind=long) +end program Index: Fortran/gfortran/regression/size_kind_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/size_kind_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/57142 +! +integer :: B(huge(1)+3_8,2_8) +integer(8) :: var1(2), var2, var3 + +var1 = shape(B,kind=8) +var2 = size(B,kind=8) +var3 = size(B,dim=1,kind=8) +end + +! { dg-final { scan-tree-dump "static integer.kind=8. A..\\\[2\\\] = \\\{2147483650, 2\\\};" "original" } } +! { dg-final { scan-tree-dump "var2 = 4294967300;" "original" } } +! { dg-final { scan-tree-dump "var3 = 2147483650;" "original" } } Index: Fortran/gfortran/regression/size_kind_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/size_kind_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/57142 +! +integer :: B(huge(1)+3_8,2_8) +integer(8) :: var1(2), var2, var3 + +var1 = shape(B) ! { dg-error "SHAPE overflows its kind" } +var2 = size(B) ! { dg-error "SIZE overflows its kind" } +var3 = size(B,dim=1) ! { dg-error "SIZE overflows its kind" } +end Index: Fortran/gfortran/regression/size_optional_dim_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/size_optional_dim_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 30865 - passing a subroutine optional argument to size(dim=...) +! used to segfault. +program main + implicit none + integer :: a(2,3) + integer :: ires + + call checkv (ires, a) + if (ires /= 6) STOP 1 + call checkv (ires, a, 1) + if (ires /= 2) STOP 2 +contains + subroutine checkv(ires,a1,opt1) + integer, intent(out) :: ires + integer :: a1(:,:) + integer, optional :: opt1 + + ires = size (a1, dim=opt1) + end subroutine checkv +end program main + +! Ensure inline code is generated, cf. PR fortran/94070 +! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } } Index: Fortran/gfortran/regression/sizeof.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! Verify that the sizeof intrinsic does as advertised +subroutine check_int (j) + INTEGER(4) :: i, ia(5), ib(5,4), ip, ipa(:) + target :: ib + POINTER :: ip, ipa + logical :: l(6) + integer(8) :: jb(5,4) + + if (sizeof (jb) /= 2*sizeof (ib)) STOP 1 + + if (sizeof(j) == 4) then + if (sizeof (j) /= sizeof (i)) STOP 2 + else + if (sizeof (j) /= 2 * sizeof (i)) STOP 3 + end if + + ipa=>ib(2:3,1) + + l = (/ sizeof(i) == 4, sizeof(ia) == 20, sizeof(ib) == 80, & + sizeof(ip) == 4, sizeof(ipa) == 8, sizeof(ib(1:5:2,3)) == 12 /) + + if (any(.not.l)) STOP 4 + + if (sizeof(l) /= 6*sizeof(l(1))) STOP 5 +end subroutine check_int + +subroutine check_real (x, y) + dimension y(5) + real(4) :: r(20,20,20), rp(:,:) + target :: r + pointer :: rp + double precision :: d(5,5) + complex(kind=4) :: c(5) + + if (sizeof (y) /= 5*sizeof (x)) STOP 6 + + if (sizeof (r) /= 8000*4) STOP 7 + rp => r(5,2:10,1:5) + if (sizeof (rp) /= 45*4) STOP 8 + rp => r(1:5,1:5,1) + if (sizeof (d) /= 2*sizeof (rp)) STOP 9 + if (sizeof (c(1)) /= 2*sizeof(r(1,1,1))) STOP 10 +end subroutine check_real + +subroutine check_derived () + type dt + integer i + end type dt + type (dt) :: a + integer :: i + type foo + integer :: i(5000) + real :: j(5) + type(dt) :: d + end type foo + type bar + integer :: j(5000) + real :: k(5) + type(dt) :: d + end type bar + type (foo) :: oof + type (bar) :: rab + integer(8) :: size_500, size_200, sizev500, sizev200 + type all + real, allocatable :: r(:) + end type all + real :: r(200), s(500) + type(all) :: v + + if (sizeof(a) /= sizeof(i)) STOP 11 + if (sizeof(oof) /= sizeof(rab)) STOP 12 + allocate (v%r(500)) + sizev500 = sizeof (v) + size_500 = sizeof (v%r) + deallocate (v%r) + allocate (v%r(200)) + sizev200 = sizeof (v) + size_200 = sizeof (v%r) + deallocate (v%r) + if (size_500 - size_200 /= sizeof(s) - sizeof(r) .or. sizev500 /= sizev200) & + STOP 13 +end subroutine check_derived + +call check_int (1) +call check_real (1.0, (/1.0, 2.0, 3.0, 4.0, 5.0/)) +call check_derived () +end Index: Fortran/gfortran/regression/sizeof_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_2.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/56650 +! PR fortran/36437 +! +subroutine foo(x, y) + use iso_c_binding + type(*) :: x + integer :: y(*) + integer(8) :: ii + procedure() :: proc + + ii = sizeof (x) ! { dg-error "'x' argument of 'sizeof' intrinsic at \\(1\\) shall not be TYPE\\(\\*\\)" } + ii = c_sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic c_sizeof" } + ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" } + + ii = sizeof (y) ! { dg-error "shall not be an assumed-size array" } + ii = c_sizeof (y) ! { dg-error "shall not be an assumed-size array" } + ii = storage_size (y) ! okay, element-size is known + + ii = sizeof (proc) ! { dg-error "shall not be a procedure" } + ii = c_sizeof (proc) ! { dg-error "Procedure unexpected as argument" } + ii = storage_size (proc) ! { dg-error "shall not be a procedure" } +end Index: Fortran/gfortran/regression/sizeof_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_3.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/56650 +! PR fortran/36437 +! +module m + use iso_c_binding, only: c_sizeof, c_int + implicit none + + integer(c_int), bind(C) :: MPI_Status_C_obj + integer,parameter :: MPI_STATUS_SIZE = c_sizeof(MPI_Status_C_obj) +end module m + +module m2 + use iso_c_binding, only: c_sizeof, c_int + implicit none + + integer(c_int), bind(C) :: MPI_Status_C_obj2 + integer,parameter :: MPI_STATUS_SIZE2 & + = c_sizeof(MPI_Status_C_obj2)*8/bit_size(0) +end module m2 + +subroutine test() + use m + use m2 + integer :: m1test, m2test + m1test = MPI_STATUS_SIZE + m2test = MPI_STATUS_SIZE2 +end subroutine test + +type t + character(len=20) :: str +end type t +type(t):: x(5) +integer :: iii, jjj +iii = sizeof (x) ! 5*20 (whole size in bytes) +jjj = storage_size (x) ! 8*20 (element size in bits) +end + +! { dg-final { scan-tree-dump-times "m1test = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "m2test = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iii = 100;" 1 "original" } } +! { dg-final { scan-tree-dump-times "jjj = 160;" 1 "original" } } Index: Fortran/gfortran/regression/sizeof_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_4.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! PR fortran/61881 +! PR fortran/61888 +! +! +use iso_c_binding +implicit none + +call dim0(5, 4) + +call dim1([1, 2, 3], 4*3) + +call dimd(5, 4) +call dimd([1, 2, 3], 4*3) +call dimd(reshape([1, 4, 2, 3],[2, 2]), 4*4) + +call tdim1([1, 2, 3], 4*3) +call tdim1([1_8, 2_8, 3_8], 8*3) + +call tdimd(5, 4) +call tdimd([1, 2, 3], 4*3) +call tdimd(reshape([1, 4, 2, 3], [2, 2]), 4*4) +call tdimd(5_8, 8) +call tdimd([1_8, 2_8, 3_8], 8*3) +call tdimd(reshape([1_8, 4_8, 2_8, 3_8],[2,2]), 8*4) + +call cdim0(5, 4) + +call cdim1([1, 2, 3], 4*3) + +call cdimd(5, 4) +call cdimd([1, 2, 3], 4*3) +call cdimd(reshape([1,4,2,3],[2,2]), 4*4) +call cdimd(5_8, 8) +call cdimd([1_8, 2_8, 3_8], 8*3) +call cdimd(reshape([1_8, 4_8, 2_8, 3_8], [2, 2]), 8*4) + +contains + +subroutine dim0(x, expected_size) + integer :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 1 + if (storage_size(x)/8 /= expected_size) STOP 2 +end + +subroutine dim1(x, expected_size) + integer, dimension(:) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 3 + if (storage_size(x)/8*size(x) /= expected_size) STOP 4 +end + +subroutine dimd(x, expected_size) + integer, dimension(..) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 5 + if (storage_size(x)/8*size(x) /= expected_size) STOP 6 +end + +subroutine cdim0(x, expected_size) + class(*) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 7 + if (storage_size(x)/8 /= expected_size) STOP 8 +end + +subroutine cdim1(x, expected_size) + class(*), dimension(:) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 9 + if (storage_size(x)/8*size(x) /= expected_size) STOP 10 +end + +subroutine cdimd(x, expected_size) + class(*), dimension(..) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 11 + if (storage_size(x)/8*size(x) /= expected_size) STOP 12 +end + +subroutine tdim1(x, expected_size) + type(*), dimension(:) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 13 +end + +subroutine tdimd(x, expected_size) + type(*), dimension(..) :: x + integer, value :: expected_size + if (sizeof(x) /= expected_size) STOP 14 +end + +end Index: Fortran/gfortran/regression/sizeof_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/65889 +! +! +module m + type n + end type n +contains + subroutine g(ns) + class(n), intent(out), allocatable, dimension(:) :: ns + class(n), allocatable, dimension(:) :: tmp + write (0,*) sizeof(ns), sizeof(tmp) + end subroutine g +end module m Index: Fortran/gfortran/regression/sizeof_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_6.f90 @@ -0,0 +1,437 @@ +! { dg-do run } +! +! Check that sizeof is properly handled +! +use iso_c_binding +implicit none (type, external) + +type t + integer, allocatable :: a(:,:,:), aa + integer :: b(5), c +end type t + +type t2 + class(t), allocatable :: d(:,:), e +end type t2 + +type, extends(t2) :: t2e + integer :: q(7), z +end type t2e + +type t3 + class(t2), allocatable :: ct2, ct2a(:,:,:) + type(t2), allocatable :: tt2, tt2a(:,:,:) + integer, allocatable :: ii, iia(:,:,:) +end type t3 + +type(t3) :: var, vara(5) +type(t3), allocatable :: avar, avara(:) +class(t3), allocatable :: cvar, cvara(:) +type(t2), allocatable :: ax, axa(:,:,:) +class(t2), allocatable :: cx, cxa(:,:,:) + +integer(c_size_t) :: n + +allocate (t3 :: avar, avara(5)) +allocate (t3 :: cvar, cvara(5)) + +n = sizeof(var) + +! Assume alignment plays no tricks and system has 32bit/64bit. +! If needed change +if (n /= 376 .and. n /= 200) error stop + +if (n /= sizeof(avar)) error stop +if (n /= sizeof(cvar)) error stop +if (n * 5 /= sizeof(vara)) error stop +if (n * 5 /= sizeof(avara)) error stop +if (n * 5 /= sizeof(cvara)) error stop + +if (n /= sz_ar(var,var,var,var)) error stop +if (n /= sz_s(var,var)) error stop +if (n /= sz_t3(var,var,var,var)) error stop +if (n /= sz_ar(avar,avar,avar,avar)) error stop +if (n /= sz_s(avar,avar)) error stop +if (n /= sz_t3(avar,avar,avar,avar)) error stop +if (n /= sz_t3_at(avar,avar)) error stop +if (n /= sz_ar(cvar,cvar,cvar,cvar)) error stop +if (n /= sz_s(cvar,cvar)) error stop +if (n /= sz_t3(cvar,cvar,cvar,cvar)) error stop +if (n /= sz_t3_a(cvar,cvar)) error stop + +if (n*5 /= sz_ar(vara,vara,vara,vara)) error stop +if (n*5 /= sz_r1(vara,vara,vara,vara)) error stop +if (n*5 /= sz_t3(vara,vara,vara,vara)) error stop +if (n*5 /= sz_ar(avara,avara,avara,avara)) error stop +if (n*5 /= sz_r1(avara,avara,avara,avara)) error stop +if (n*5 /= sz_t3(avara,avara,avara,avara)) error stop +if (n*5 /= sz_t3_at(avara,avara)) error stop +if (n*5 /= sz_ar(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_r1(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_t3(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_t3_a(cvara,cvara)) error stop + +allocate (var%ct2, var%ct2a(5,4,2), var%tt2, var%tt2a(5,4,2), var%ii, var%iia(5,3,2)) +allocate (avar%ct2, avar%ct2a(5,4,2), avar%tt2, avar%tt2a(5,4,2), avar%ii, avar%iia(5,3,2)) +allocate (cvar%ct2, cvar%ct2a(5,4,2), cvar%tt2, cvar%tt2a(5,4,2), cvar%ii, cvar%iia(5,3,2)) +allocate (vara(1)%ct2, vara(1)%ct2a(5,4,2), vara(1)%tt2, vara(1)%tt2a(5,4,2), vara(1)%ii, vara(1)%iia(5,3,2)) +allocate (avara(1)%ct2, avara(1)%ct2a(5,4,2), avara(1)%tt2, avara(1)%tt2a(5,4,2), avara(1)%ii, avara(1)%iia(5,3,2)) +allocate (cvara(1)%ct2, cvara(1)%ct2a(5,4,2), cvara(1)%tt2, cvara(1)%tt2a(5,4,2), cvara(1)%ii, cvara(1)%iia(5,3,2)) +allocate (ax, axa(5,4,2), cx, cxa(5,4,2)) + +! Should be still be the same +if (n /= sizeof(avar)) error stop +if (n /= sizeof(cvar)) error stop +if (n * 5 /= sizeof(vara)) error stop +if (n * 5 /= sizeof(avara)) error stop +if (n * 5 /= sizeof(cvara)) error stop + +if (n /= sz_ar(var,var,var,var)) error stop +if (n /= sz_s(var,var)) error stop +if (n /= sz_t3(var,var,var,var)) error stop +if (n /= sz_ar(avar,avar,avar,avar)) error stop +if (n /= sz_s(avar,avar)) error stop +if (n /= sz_t3(avar,avar,avar,avar)) error stop +if (n /= sz_t3_at(avar,avar)) error stop +if (n /= sz_ar(cvar,cvar,cvar,cvar)) error stop +if (n /= sz_s(cvar,cvar)) error stop +if (n /= sz_t3(cvar,cvar,cvar,cvar)) error stop +if (n /= sz_t3_a(cvar,cvar)) error stop + +if (n*5 /= sz_ar(vara,vara,vara,vara)) error stop +if (n*5 /= sz_r1(vara,vara,vara,vara)) error stop +if (n*5 /= sz_t3(vara,vara,vara,vara)) error stop +if (n*5 /= sz_ar(avara,avara,avara,avara)) error stop +if (n*5 /= sz_r1(avara,avara,avara,avara)) error stop +if (n*5 /= sz_t3(avara,avara,avara,avara)) error stop +if (n*5 /= sz_t3_at(avara,avara)) error stop +if (n*5 /= sz_ar(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_r1(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_t3(cvara,cvara,cvara,cvara)) error stop +if (n*5 /= sz_t3_a(cvara,cvara)) error stop + +! This one did segfault before in gfc_conv_intrinsic_sizeof +n = sizeof(var%ct2) +if (n /= 112 .and. n /= 60) error stop +if (n /= sizeof (var%tt2)) error stop +if (n /= sizeof (avar%ct2)) error stop +if (n /= sizeof (avar%tt2)) error stop +if (n /= sizeof (cvar%ct2)) error stop +if (n /= sizeof (cvar%tt2)) error stop +if (n /= sizeof (vara(1)%tt2)) error stop +if (n /= sizeof (avara(1)%ct2)) error stop +if (n /= sizeof (avara(1)%tt2)) error stop +if (n /= sizeof (cvara(1)%ct2)) error stop +if (n /= sizeof (cvara(1)%tt2)) error stop + +if (n /= sizeof (ax)) error stop +if (n /= sizeof (cx)) error stop + +if (n /= sz_ar(var%ct2,var%ct2,var%ct2,var%ct2)) error stop +if (n /= sz_s(var%ct2,var%ct2)) error stop +if (n /= sz_t2(var%ct2,var%ct2,var%ct2,var%ct2,.false.)) error stop +if (n /= sz_t2_a(var%ct2,var%ct2)) error stop +if (n /= sz_ar(var%tt2,var%tt2,var%tt2,var%tt2)) error stop +if (n /= sz_s(var%tt2,var%tt2)) error stop +if (n /= sz_t2(var%tt2,var%tt2,var%tt2,var%tt2,.false.)) error stop +if (n /= sz_t2_at(var%tt2,var%tt2)) error stop + +if (n*5*4*2 /= sizeof (var%tt2a)) error stop +if (n*5*4*2 /= sizeof (avar%ct2a)) error stop +if (n*5*4*2 /= sizeof (avar%tt2a)) error stop +if (n*5*4*2 /= sizeof (cvar%ct2a)) error stop +if (n*5*4*2 /= sizeof (cvar%tt2a)) error stop +if (n*5*4*2 /= sizeof (vara(1)%tt2a)) error stop +if (n*5*4*2 /= sizeof (avara(1)%ct2a)) error stop +if (n*5*4*2 /= sizeof (avara(1)%tt2a)) error stop +if (n*5*4*2 /= sizeof (cvara(1)%ct2a)) error stop +if (n*5*4*2 /= sizeof (cvara(1)%tt2a)) error stop + +if (n*5*4*2 /= sizeof (axa)) error stop +if (n*5*4*2 /= sizeof (cxa)) error stop + +if (n*5*4*2 /= sz_ar(var%ct2a,var%ct2a,var%ct2a,var%ct2a)) error stop +if (n*5*4*2 /= sz_r3(var%ct2a,var%ct2a,var%ct2a,var%ct2a)) error stop +if (n*5*4*2 /= sz_t2(var%ct2a,var%ct2a,var%ct2a,var%ct2a,.false.)) error stop +if (n*5*4*2 /= sz_t2_a(var%ct2a,var%ct2a)) error stop +if (n*5*4*2 /= sz_ar(var%tt2a,var%tt2a,var%tt2a,var%tt2a)) error stop +if (n*5*4*2 /= sz_r3(var%tt2a,var%tt2a,var%tt2a,var%tt2a)) error stop +if (n*5*4*2 /= sz_t2(var%tt2a,var%tt2a,var%tt2a,var%tt2a,.false.)) error stop +if (n*5*4*2 /= sz_t2_at(var%tt2a,var%tt2a)) error stop + +n = sizeof(var%ii) +if (n /= 4) error stop +if (n /= sizeof (var%ii)) error stop +if (n /= sizeof (avar%ii)) error stop +if (n /= sizeof (avar%ii)) error stop +if (n /= sizeof (cvar%ii)) error stop +if (n /= sizeof (cvar%ii)) error stop +if (n /= sizeof (vara(1)%ii)) error stop +if (n /= sizeof (avara(1)%ii)) error stop +if (n /= sizeof (avara(1)%ii)) error stop +if (n /= sizeof (cvara(1)%ii)) error stop +if (n /= sizeof (cvara(1)%ii)) error stop + +if (n*5*3*2 /= sizeof (var%iia)) error stop +if (n*5*3*2 /= sizeof (avar%iia)) error stop +if (n*5*3*2 /= sizeof (avar%iia)) error stop +if (n*5*3*2 /= sizeof (cvar%iia)) error stop +if (n*5*3*2 /= sizeof (cvar%iia)) error stop +if (n*5*3*2 /= sizeof (vara(1)%iia)) error stop +if (n*5*3*2 /= sizeof (avara(1)%iia)) error stop +if (n*5*3*2 /= sizeof (avara(1)%iia)) error stop +if (n*5*3*2 /= sizeof (cvara(1)%iia)) error stop +if (n*5*3*2 /= sizeof (cvara(1)%iia)) error stop + +deallocate (var%ct2, var%ct2a, var%tt2, var%tt2a, var%ii, var%iia) +deallocate (avar%ct2, avar%ct2a, avar%tt2, avar%tt2a, avar%ii, avar%iia) +deallocate (cvar%ct2, cvar%ct2a, cvar%tt2, cvar%tt2a, cvar%ii, cvar%iia) +deallocate (vara(1)%ct2, vara(1)%ct2a, vara(1)%tt2, vara(1)%tt2a, vara(1)%ii, vara(1)%iia) +deallocate (avara(1)%ct2, avara(1)%ct2a, avara(1)%tt2, avara(1)%tt2a, avara(1)%ii, avara(1)%iia) +deallocate (cvara(1)%ct2, cvara(1)%ct2a, cvara(1)%tt2, cvara(1)%tt2a, cvara(1)%ii, cvara(1)%iia) +deallocate (ax, axa, cx, cxa) + +allocate (t2e :: var%ct2, var%ct2a(5,4,2)) +allocate (t2e :: avar%ct2, avar%ct2a(5,4,2)) +allocate (t2e :: cvar%ct2, cvar%ct2a(5,4,2)) +allocate (t2e :: vara(1)%ct2, vara(1)%ct2a(5,4,2)) +allocate (t2e :: avara(1)%ct2, avara(1)%ct2a(5,4,2)) +allocate (t2e :: cvara(1)%ct2, cvara(1)%ct2a(5,4,2)) +allocate (t2e :: cx, cxa(5,4,2)) + +n = sizeof(cx) +if (n /= 144 .and. n /= 92) error stop +if (n /= sizeof(var%ct2)) error stop +if (n /= sizeof(avar%ct2)) error stop +if (n /= sizeof(cvar%ct2)) error stop +if (n /= sizeof(vara(1)%ct2)) error stop +if (n /= sizeof(avara(1)%ct2)) error stop +if (n /= sizeof(cvara(1)%ct2)) error stop +if (n*5*4*2 /= sizeof(cxa)) error stop +if (n*5*4*2 /= sizeof(var%ct2a)) error stop +if (n*5*4*2 /= sizeof(avar%ct2a)) error stop +if (n*5*4*2 /= sizeof(cvar%ct2a)) error stop +if (n*5*4*2 /= sizeof(vara(1)%ct2a)) error stop +if (n*5*4*2 /= sizeof(avara(1)%ct2a)) error stop +if (n*5*4*2 /= sizeof(cvara(1)%ct2a)) error stop + +! FAILS as declare not dynamic type arrives for TYPE(*),dimension(..) +! -> FIXME, PR fortran/104844 (trice) +!if (n /= sz_ar(var%ct2,var%ct2,var%ct2,var%ct2)) error stop ! FIXME +if (n /= sz_s(var%ct2,var%ct2)) error stop +if (n /= sz_t2(var%ct2,var%ct2,var%ct2,var%ct2,.true.)) error stop +if (n /= sz_t2_a(var%ct2,var%ct2)) error stop +!if (n*5*4*2 /= sz_ar(var%ct2a,var%ct2a,var%ct2a,var%ct2a)) error stop ! FIXME +!if (n*5*4*2 /= sz_r3(var%ct2a,var%ct2a,var%ct2a,var%ct2a)) error stop ! FIXME +if (n*5*4*2 /= sz_t2(var%ct2a,var%ct2a,var%ct2a,var%ct2a,.true.)) error stop +if (n*5*4*2 /= sz_t2_a(var%ct2a,var%ct2a)) error stop + +allocate (t :: var%ct2%d(3,2), var%ct2a(5,4,2)%d(3,2)) +allocate (t :: avar%ct2%d(3,2), avar%ct2a(5,4,2)%d(3,2)) +allocate (t :: cvar%ct2%d(3,2), cvar%ct2a(5,4,2)%d(3,2)) +allocate (t :: vara(1)%ct2%d(3,2), vara(1)%ct2a(5,4,2)%d(3,2)) +allocate (t :: avara(1)%ct2%d(3,2), avara(1)%ct2a(5,4,2)%d(3,2)) +allocate (t :: cvara(1)%ct2%d(3,2), cvara(1)%ct2a(5,4,2)%d(3,2)) +allocate (t :: cx%d(3,2), cxa(5,4,2)%d(3,2)) + +allocate (t :: var%ct2%e, var%ct2a(5,4,2)%e) +allocate (t :: avar%ct2%e, avar%ct2a(5,4,2)%e) +allocate (t :: cvar%ct2%e, cvar%ct2a(5,4,2)%e) +allocate (t :: vara(1)%ct2%e, vara(1)%ct2a(5,4,2)%e) +allocate (t :: avara(1)%ct2%e, avara(1)%ct2a(5,4,2)%e) +allocate (t :: cvara(1)%ct2%e, cvara(1)%ct2a(5,4,2)%e) +allocate (t :: cx%e, cxa(5,4,2)%e) + +n = sizeof(cx%e) +if (n /= 144 .and. n /= 88) error stop +if (n /= sizeof(var%ct2%e)) error stop +if (n /= sizeof(var%ct2a(5,4,2)%e)) error stop +if (n /= sizeof(avar%ct2%e)) error stop +if (n /= sizeof(avar%ct2a(5,4,2)%e)) error stop +if (n /= sizeof(cvar%ct2%e)) error stop +if (n /= sizeof(cvar%ct2a(5,4,2)%e)) error stop +if (n /= sizeof(avara(1)%ct2%e)) error stop +if (n /= sizeof(avara(1)%ct2a(5,4,2)%e)) error stop +if (n /= sizeof(cvara(1)%ct2%e)) error stop +if (n /= sizeof(cvara(1)%ct2a(5,4,2)%e)) error stop + +if (n /= sz_ar(var%ct2%e,var%ct2a(5,3,2)%e,cvar%ct2%e,cvar%ct2a(5,3,2)%e)) error stop +if (n /= sz_s(var%ct2%e,var%ct2a(5,3,2)%e)) error stop +if (n /= sz_t(var%ct2%e,var%ct2a(5,3,2)%e,cvar%ct2%e,cvar%ct2a(5,3,2)%e)) error stop +if (n /= sz_t_a(var%ct2%e,var%ct2a(5,3,2)%e)) error stop + +! FIXME - all of the following fail as size(... % ct2a(5,3,2) % d) == 0 instead of 6 +! See PR fortran/104845 +!if (n*3*2 /= sz_ar(var%ct2%d,var%ct2a(5,3,2)%d,cvar%ct2%d,cvar%ct2a(5,3,2)%d)) error stop +!if (n*3*2 /= sz_r2(var%ct2%d,var%ct2a(5,3,2)%d,cvar%ct2%d,cvar%ct2a(5,3,2)%d)) error stop +!if (n*3*2 /= sz_t(var%ct2%d,var%ct2a(5,3,2)%d,cvar%ct2%d,cvar%ct2a(5,3,2)%d)) error stop +!if (n*3*2 /= sz_t_a(var%ct2%d,var%ct2a(5,3,2)%d)) error stop + +if (n*3*2 /= sizeof(var%ct2%d)) error stop +if (n*3*2 /= sizeof(var%ct2a(5,4,2)%d)) error stop +if (n*3*2 /= sizeof(avar%ct2%d)) error stop +if (n*3*2 /= sizeof(avar%ct2a(5,4,2)%d)) error stop +if (n*3*2 /= sizeof(cvar%ct2%d)) error stop +if (n*3*2 /= sizeof(cvar%ct2a(5,4,2)%d)) error stop +if (n*3*2 /= sizeof(avara(1)%ct2%d)) error stop +if (n*3*2 /= sizeof(avara(1)%ct2a(5,4,2)%d)) error stop +if (n*3*2 /= sizeof(cvara(1)%ct2%d)) error stop +if (n*3*2 /= sizeof(cvara(1)%ct2a(5,4,2)%d)) error stop + +deallocate (var%ct2, var%ct2a) +deallocate (avar%ct2, avar%ct2a) +deallocate (cvar%ct2, cvar%ct2a) +deallocate (cx, cxa) + +deallocate (avar, avara) +deallocate (cvar, cvara) + +contains + integer(c_size_t) function sz_ar (a, b, c, d) result(res) + type(*) :: a(..), c(..) + class(*) :: b(..), d(..) + optional :: c, d + res = sizeof(a) + if (sizeof(b) /= res) error stop + if (sizeof(c) /= res) error stop + if (sizeof(d) /= res) error stop + end + integer(c_size_t) function sz_ar_a (a, b) result(res) + class(*), allocatable :: a(..), b(..) + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_s (a, b) result(res) + class(*) :: a, b + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_s_a (a, b) result(res) + class(*), allocatable :: a, b + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_r1 (a, b, c, d) result(res) + type(*) :: a(:), c(:) + class(*) :: b(:), d(:) + optional :: c, d + res = sizeof(a) + if (sizeof(b) /= res) error stop + if (sizeof(c) /= res) error stop + if (sizeof(d) /= res) error stop + end + integer(c_size_t) function sz_r1_a (a, b) result(res) + class(*), allocatable :: a(:), b(:) + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_r2 (a, b, c, d) result(res) + type(*) :: a(:,:), c(:,:) + class(*) :: b(:,:), d(:,:) + optional :: c, d + res = sizeof(a) + if (sizeof(b) /= res) error stop + if (sizeof(c) /= res) error stop + if (sizeof(d) /= res) error stop + end + integer(c_size_t) function sz_r2_a (a, b) result(res) + class(*), allocatable :: a(:,:), b(:,:) + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_r3 (a, b, c, d) result(res) + type(*) :: a(:,:,:), c(:,:,:) + class(*) :: b(:,:,:), d(:,:,:) + optional :: c, d + res = sizeof(a) + if (sizeof(b) /= res) error stop + if (sizeof(c) /= res) error stop + if (sizeof(d) /= res) error stop + end + integer(c_size_t) function sz_r3_a (a, b) result(res) + class(*), allocatable :: a(:,:,:), b(:,:,:) + optional :: b + res = sizeof(a) + if (sizeof(b) /= res) error stop + end + integer(c_size_t) function sz_t (a, b, c, d) result(res) + type(t) :: a(..), c(..) + class(t) :: b(..), d(..) + optional :: c, d + + res = sizeof(b) + if (sizeof(d) /= sizeof(b)) error stop + if (sizeof(a) /= sizeof(c)) error stop + if (sizeof(a) /= res) error stop + end + integer(c_size_t) function sz_t_a (a, b) result(res) + class(t), allocatable :: a(..), b(..) + optional :: b + + res = sizeof(b) + if (sizeof(b) /= sizeof(a)) error stop + end + integer(c_size_t) function sz_t_at (a, b) result(res) + type(t), allocatable :: a(..), b(..) + optional :: b + + res = sizeof(b) + if (sizeof(b) /= sizeof(a)) error stop + end + integer(c_size_t) function sz_t2 (a, b, c, d, extends) result(res) + type(t2) :: a(..), c(..) + class(t2) :: b(..), d(..) + optional :: c, d + logical, value :: extends + + res = sizeof(b) + if (sizeof(d) /= sizeof(b)) error stop + if (sizeof(a) /= sizeof(c)) error stop + if (.not.extends) then + if (sizeof(a) /= res) error stop + else + ! Here, extension has extra elements + if (sizeof(a) >= res) error stop + end if + end + integer(c_size_t) function sz_t2_a (a, b) result(res) + class(t2), allocatable :: a(..), b(..) + optional :: b + + res = sizeof(b) + if (sizeof(b) /= sizeof(a)) error stop + end + integer(c_size_t) function sz_t2_at (a, b) result(res) + type(t2), allocatable :: a(..), b(..) + optional :: b + + res = sizeof(b) + if (sizeof(b) /= sizeof(a)) error stop + end + integer(c_size_t) function sz_t3 (a, b, c, d) result(res) + type(t3) :: a(..), c(..) + class(t3) :: b(..), d(..) + optional :: c, d + res = sizeof(b) + if (sizeof(d) /= sizeof(b)) error stop + if (sizeof(a) /= sizeof(c)) error stop + if (sizeof(a) /= res) error stop + end + integer(c_size_t) function sz_t3_a (a, b) result(res) + class(t3), allocatable :: a(..), b(..) + optional :: b + res = sizeof(b) + if (sizeof(a) /= sizeof(b)) error stop + end + integer(c_size_t) function sz_t3_at (a, b) result(res) + type(t3), allocatable :: a(..), b(..) + optional :: b + res = sizeof(b) + if (sizeof(a) /= sizeof(b)) error stop + end +end Index: Fortran/gfortran/regression/sizeof_proc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sizeof_proc.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 47023: C_Sizeof: Rejects valid code +! +! Contributed by Janus Weil + +use iso_c_binding +procedure(real) :: proc +procedure(real), pointer :: pp +pp => sin + +print *,sizeof(proc) ! { dg-error "shall not be a procedure" } +print *,sizeof(pp) ! { dg-error "shall not be a procedure" } +print *,sizeof(pp(0.)) +print *,sizeof(sub) ! { dg-error "shall not be a procedure" } +print *,sizeof(func) ! { dg-error "shall not be a procedure" } +print *,sizeof(func()) + +contains + + subroutine sub + end subroutine + + real function func() + func = 0. + end function + +end Index: Fortran/gfortran/regression/slash_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/slash_1.f90 @@ -0,0 +1,13 @@ +! PR libfortran/22170 +! { dg-do run } + integer i + open (10,status='scratch') + write (10,'(A,2/,A)') '12', '17' + rewind (10) + read (10,'(I2)') i + if (i /= 12) STOP 1 + read (10,'(I2)') i + if (i /= 0) STOP 2 + read (10,'(I2)') i + if (i /= 17) STOP 3 + end Index: Fortran/gfortran/regression/sms-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sms-1.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-O2 -fmodulo-sched" } +! This testcase related to INC instruction which is +! currently not supported in SMS. +program main + integer (kind = 8) :: i, l8, u8, step8 + integer (kind = 4) :: l4, step4 + integer (kind = 8), parameter :: big = 10000000000_8 + + u8 = big * 40 + 200 + l4 = 200 + step8 = -big + call test ((/ (i, i = u8, l4, step8) /), u8, l4 + 0_8, step8) +contains + subroutine test (a, l, u, step) + integer (kind = 8), dimension (:), intent (in) :: a + integer (kind = 8), intent (in) :: l, u, step + integer (kind = 8) :: i + integer :: j + + j = 1 + do i = l, u, step + if (a (j) .ne. i) STOP 1 + j = j + 1 + end do + if (size (a, 1) .ne. j - 1) STOP 2 + end subroutine test +end program main + + Index: Fortran/gfortran/regression/sms-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sms-2.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-O2 -fmodulo-sched" } +! This testcase related to wrong order within a cycle fix. +! +program foo + real, dimension (5, 5, 5, 5) :: a + + a (:, :, :, :) = 4 + a (:, 2, :, 4) = 10 + a (:, 2, :, 1) = 0 + + forall (i = 1:5, i == 3) + a(i, i, i, i) = -5 + end forall + + if (sum (a) .ne. 2541.0) STOP 1 +end + + Index: Fortran/gfortran/regression/spec_expr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR 20323 +! We didn't verify that character length expressions are specification +! expressions. +function testpresent(arg) + integer, intent(in), optional :: arg + character(len=arg) :: s ! { dg-error "OPTIONAL" } + logical :: testpresent + + testpresent=.true. + +end function testpresent Index: Fortran/gfortran/regression/spec_expr_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 22273: Allow INTENT(OUT) dummy:s as arguments to LEN() in specification +! expr:s +subroutine lecligne (ligne) + character(len=*), intent(out) :: ligne + character(len=len(ligne)) :: comment +end subroutine lecligne Index: Fortran/gfortran/regression/spec_expr_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/18271 +subroutine sub(imax) + implicit none + integer, intent(in) :: imax + real :: aux1(25000+int(0.82*imax)) +end subroutine Index: Fortran/gfortran/regression/spec_expr_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests the fix for PR27709 in which the specification expression on +! line 22 was not resolved because of the multiple component references. +! +! Contributed by David Ham +! +module elements + implicit none + type element_type + type(ele_numbering_type), pointer :: numbering + end type element_type + type ele_numbering_type + integer, dimension(:,:), pointer :: number2count + end type ele_numbering_type +end module elements +module global_numbering + use elements + implicit none +contains + function element_local_coords(element) result (coords) + type(element_type), intent(in) :: element + real, dimension(size(element%numbering%number2count, 1)) :: coords + coords=0.0 + end function element_local_coords +end module global_numbering + + use global_numbering + type (element_type) :: e + type (ele_numbering_type), target :: ent + allocate (ent%number2count (2,2)) + e%numbering => ent + print *, element_local_coords (e) +end Index: Fortran/gfortran/regression/spec_expr_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_5.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 33689 +! Wrongly rejected valid code due to non-trivial expression for array bound + subroutine grylmr() + integer, parameter :: lmaxd = 20 + REAL, save :: c(0:(lmaxd+1)*(lmaxd+1)) + end subroutine grylmr +end Index: Fortran/gfortran/regression/spec_expr_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_6.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! PR fortran/43591 +! +! Pureness check for TPB/PPC in specification expressions +! +! Based on a test case of Thorsten Ohl +! +! + +module m + implicit none + type t + procedure(p1_type), nopass, pointer :: p1 => NULL() + contains + procedure, nopass :: tbp => p1_type + end type t +contains + subroutine proc (t1, t2) + type(t), intent(in) :: t1, t2 + integer, dimension(t1%p1(), t2%tbp()) :: table + end subroutine proc + pure function p1_type() + integer :: p1_type + p1_type = 42 + end function p1_type + pure subroutine p(t1) + type(t), intent(inout) :: t1 + integer :: a(t1%p1()) + end subroutine p +end module m + +module m2 + implicit none + type t + procedure(p1_type), nopass, pointer :: p1 => NULL() + contains + procedure, nopass :: tbp => p1_type + end type t +contains + subroutine proc (t1, t2) + type(t), intent(in) :: t1, t2 + integer, dimension(t1%p1()) :: table1 ! { dg-error "must be PURE" } + integer, dimension(t2%tbp()) :: table2 ! { dg-error "must be PURE" } + end subroutine proc + function p1_type() + integer :: p1_type + p1_type = 42 + end function p1_type +end module m2 Index: Fortran/gfortran/regression/spec_expr_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spec_expr_7.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 60777: [F03] RECURSIVE function rejected in specification expression +! +! Contributed by Vladimir Fuka + +module recur + implicit none +contains + + pure recursive function f(n) result(answer) + integer, intent(in) :: n + integer :: answer + if (n<2) then + answer = 1 + else + answer = f(n-1)*n + end if + end function + + pure function usef(n) + integer,intent(in) :: n + character(f(n)) :: usef + usef = repeat('*',f(n)) + end function +end module + +program testspecexpr + use recur + implicit none + if (usef(1) /= '*') STOP 1 + if (usef(2) /= '**') STOP 2 + if (usef(3) /= '******') STOP 3 +end Index: Fortran/gfortran/regression/specification_type_resolution_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/specification_type_resolution_1.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Test of the fix of PR27089, where gfortran was unable to resolve the +! type of n_elements_uncommon_with_ in the specification expression on +! line 21. +! +! Test extracted from vec{int}.F90 of tonto. +! +module test + public n_elements_uncommon_with_ + interface n_elements_uncommon_with_ + module procedure n_elements_uncommon_with + end interface +contains + pure function n_elements_uncommon_with(x) result(res) + integer(4), dimension(:), intent(in) :: x + integer(4) :: res + res = size (x, 1) + end function + pure function elements_uncommon_with(x) result(res) + integer(4), dimension(:), intent(in) :: x + integer(4), dimension(n_elements_uncommon_with_(x)) :: res + res = x + end function +end module test + use test + integer(4) :: z(4) + z = 1 + print *, elements_uncommon_with (z) + print *, n_elements_uncommon_with_ (z) +end Index: Fortran/gfortran/regression/specification_type_resolution_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/specification_type_resolution_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Tests the fix for PR30283 in which the type of the result +! of bar was getting lost + +! Contributed by Harald Anlauf + +module gfcbug50 + implicit none +contains + + subroutine foo (n, y) + integer, intent(in) :: n + integer, dimension(bar (n)) :: y + ! Array bound is specification expression, which is allowed (F2003, sect.7.1.6) + end subroutine foo + + pure function bar (n) result (l) + integer, intent(in) :: n + integer :: l + l = n + end function bar + +end module gfcbug50 Index: Fortran/gfortran/regression/specifics_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/specifics_1.f90 @@ -0,0 +1,318 @@ +! Program to test intrinsic functions as actual arguments +! +! Copied from gfortran.fortran-torture/execute/specifics.f90 +! Please keep them in sync +! +! It is run here with -ff2c option +! +! { dg-do run } +! { dg-options "-ff2c" } +! Program to test intrinsic functions as actual arguments +subroutine test_c(fn, val, res) + complex fn + complex val, res + + if (diff(fn(val),res)) STOP 1 +contains +function diff(a,b) + complex a,b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_z(fn, val, res) + double complex fn + double complex val, res + + if (diff(fn(val),res)) STOP 2 +contains +function diff(a,b) + double complex a,b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_cabs(fn, val, res) + real fn, res + complex val + + if (diff(fn(val),res)) STOP 3 +contains +function diff(a,b) + real a,b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_cdabs(fn, val, res) + double precision fn, res + double complex val + + if (diff(fn(val),res)) STOP 4 +contains +function diff(a,b) + double precision a,b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_r(fn, val, res) + real fn + real val, res + + if (diff(fn(val), res)) STOP 5 +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d(fn, val, res) + double precision fn + double precision val, res + + if (diff(fn(val), res)) STOP 6 +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_r2(fn, val1, val2, res) + real fn + real val1, val2, res + + if (diff(fn(val1, val2), res)) STOP 7 +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d2(fn, val1, val2, res) + double precision fn + double precision val1, val2, res + + if (diff(fn(val1, val2), res)) STOP 8 +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_dprod(fn) + double precision fn + if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) STOP 9 +end subroutine + +subroutine test_nint(fn,val,res) + integer fn, res + real val + if (res .ne. fn(val)) STOP 10 +end subroutine + +subroutine test_idnint(fn,val,res) + integer fn, res + double precision val + if (res .ne. fn(val)) STOP 11 +end subroutine + +subroutine test_idim(fn,val1,val2,res) + integer fn, res, val1, val2 + if (res .ne. fn(val1,val2)) STOP 12 +end subroutine + +subroutine test_iabs(fn,val,res) + integer fn, res, val + if (res .ne. fn(val)) STOP 13 +end subroutine + +subroutine test_len(fn,val,res) + integer fn, res + character(len=*) val + if (res .ne. fn(val)) STOP 14 +end subroutine + +subroutine test_index(fn,val1,val2,res) + integer fn, res + character(len=*) val1, val2 + if (fn(val1,val2) .ne. res) STOP 15 +end subroutine + +program specifics + intrinsic abs + intrinsic aint + intrinsic anint + intrinsic acos + intrinsic acosh + intrinsic asin + intrinsic asinh + intrinsic atan + intrinsic atanh + intrinsic cos + intrinsic sin + intrinsic tan + intrinsic cosh + intrinsic sinh + intrinsic tanh + intrinsic alog + intrinsic alog10 + intrinsic exp + intrinsic sign + intrinsic isign + intrinsic amod + + intrinsic dabs + intrinsic dint + intrinsic dnint + intrinsic dacos + intrinsic dacosh + intrinsic dasin + intrinsic dasinh + intrinsic datan + intrinsic datanh + intrinsic dcos + intrinsic dsin + intrinsic dtan + intrinsic dcosh + intrinsic dsinh + intrinsic dtanh + intrinsic dlog + intrinsic dlog10 + intrinsic dexp + intrinsic dsign + intrinsic dmod + + intrinsic conjg + intrinsic ccos + intrinsic cexp + intrinsic clog + intrinsic csin + intrinsic csqrt + + intrinsic dconjg + intrinsic cdcos + intrinsic cdexp + intrinsic cdlog + intrinsic cdsin + intrinsic cdsqrt + intrinsic zcos + intrinsic zexp + intrinsic zlog + intrinsic zsin + intrinsic zsqrt + + intrinsic cabs + intrinsic cdabs + intrinsic zabs + + intrinsic dprod + + intrinsic nint + intrinsic idnint + intrinsic dim + intrinsic ddim + intrinsic idim + intrinsic iabs + intrinsic mod + intrinsic len + intrinsic index + + intrinsic aimag + intrinsic dimag + + call test_r (abs, -1.0, abs(-1.0)) + call test_r (aint, 1.7, aint(1.7)) + call test_r (anint, 1.7, anint(1.7)) + call test_r (acos, 0.5, acos(0.5)) + call test_r (acosh, 1.5, acosh(1.5)) + call test_r (asin, 0.5, asin(0.5)) + call test_r (asinh, 0.5, asinh(0.5)) + call test_r (atan, 0.5, atan(0.5)) + call test_r (atanh, 0.5, atanh(0.5)) + call test_r (cos, 1.0, cos(1.0)) + call test_r (sin, 1.0, sin(1.0)) + call test_r (tan, 1.0, tan(1.0)) + call test_r (cosh, 1.0, cosh(1.0)) + call test_r (sinh, 1.0, sinh(1.0)) + call test_r (tanh, 1.0, tanh(1.0)) + call test_r (alog, 2.0, alog(2.0)) + call test_r (alog10, 2.0, alog10(2.0)) + call test_r (exp, 1.0, exp(1.0)) + call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0)) + call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0)) + + call test_d (dabs, -1d0, abs(-1d0)) + call test_d (dint, 1.7d0, 1d0) + call test_d (dnint, 1.7d0, 2d0) + call test_d (dacos, 0.5d0, dacos(0.5d0)) + call test_d (dacosh, 1.5d0, dacosh(1.5d0)) + call test_d (dasin, 0.5d0, dasin(0.5d0)) + call test_d (dasinh, 0.5d0, dasinh(0.5d0)) + call test_d (datan, 0.5d0, datan(0.5d0)) + call test_d (datanh, 0.5d0, datanh(0.5d0)) + call test_d (dcos, 1d0, dcos(1d0)) + call test_d (dsin, 1d0, dsin(1d0)) + call test_d (dtan, 1d0, dtan(1d0)) + call test_d (dcosh, 1d0, dcosh(1d0)) + call test_d (dsinh, 1d0, dsinh(1d0)) + call test_d (dtanh, 1d0, dtanh(1d0)) + call test_d (dlog, 2d0, dlog(2d0)) + call test_d (dlog10, 2d0, dlog10(2d0)) + call test_d (dexp, 1d0, dexp(1d0)) + call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0)) + call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0)) + + call test_dprod (dprod) + + call test_c (conjg, (1.2,-4.), conjg((1.2,-4.))) + call test_c (ccos, (1.2,-4.), ccos((1.2,-4.))) + call test_c (cexp, (1.2,-4.), cexp((1.2,-4.))) + call test_c (clog, (1.2,-4.), clog((1.2,-4.))) + call test_c (csin, (1.2,-4.), csin((1.2,-4.))) + call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.))) + + call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0))) + call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0))) + call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0))) + call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0))) + call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0))) + call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0))) + call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0))) + call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0))) + call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0))) + call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0))) + call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0))) + + call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.))) + call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0))) + call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0))) + call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.))) + call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0))) + + call test_nint (nint, -1.2, nint(-1.2)) + call test_idnint (idnint, -1.2d0, idnint(-1.2d0)) + call test_idim (isign, -42, 17, isign(-42, 17)) + call test_idim (idim, -42, 17, idim(-42,17)) + call test_idim (idim, 42, 17, idim(42,17)) + call test_r2 (dim, 1.2, -4., dim(1.2, -4.)) + call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0)) + call test_iabs (iabs, -7, iabs(-7)) + call test_idim (mod, 5, 2, mod(5,2)) + call test_len (len, "foobar", len("foobar")) + call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar")) + +end program + Index: Fortran/gfortran/regression/specifics_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/specifics_2.f90 @@ -0,0 +1,81 @@ +! { dg-do compile } +! This is the list of intrinsics allowed as actual arguments + intrinsic abs,acos,acosh,aimag,aint,alog,alog10,amod,anint,asin,asinh,atan,& + atan2,atanh,cabs,ccos,cexp,clog,conjg,cos,cosh,csin,csqrt,dabs,dacos,& + dacosh,dasin,dasinh,datan,datan2,datanh,dconjg,dcos,dcosh,ddim,dexp,dim,& + dimag,dint,dlog,dlog10,dmod,dnint,dprod,dsign,dsin,dsinh,dsqrt,dtan,dtanh,& + exp,iabs,idim,idnint,index,isign,len,mod,nint,sign,sin,sinh,sqrt,tan,& + tanh,zabs,zcos,zexp,zlog,zsin,zsqrt + + call foo(abs) + call foo(acos) + call foo(acosh) + call foo(aimag) + call foo(aint) + call foo(alog) + call foo(alog10) + call foo(amod) + call foo(anint) + call foo(asin) + call foo(asinh) + call foo(atan) + call foo(atan2) + call foo(atanh) + call foo(cabs) + call foo(ccos) + call foo(cexp) + call foo(clog) + call foo(conjg) + call foo(cos) + call foo(cosh) + call foo(csin) + call foo(csqrt) + call foo(dabs) + call foo(dacos) + call foo(dacosh) + call foo(dasin) + call foo(dasinh) + call foo(datan) + call foo(datan2) + call foo(datanh) + call foo(dconjg) + call foo(dcos) + call foo(dcosh) + call foo(ddim) + call foo(dexp) + call foo(dim) + call foo(dimag) + call foo(dint) + call foo(dlog) + call foo(dlog10) + call foo(dmod) + call foo(dnint) + call foo(dprod) + call foo(dsign) + call foo(dsin) + call foo(dsinh) + call foo(dsqrt) + call foo(dtan) + call foo(dtanh) + call foo(exp) + call foo(iabs) + call foo(idim) + call foo(idnint) + call foo(index) + call foo(isign) + call foo(len) + call foo(mod) + call foo(nint) + call foo(sign) + call foo(sin) + call foo(sinh) + call foo(sqrt) + call foo(tan) + call foo(tanh) + call foo(zabs) + call foo(zcos) + call foo(zexp) + call foo(zlog) + call foo(zsin) + call foo(zsqrt) + end Index: Fortran/gfortran/regression/spellcheck-operator.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spellcheck-operator.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! test levenshtein based spelling suggestions + +module mymod1 + implicit none + contains + function something_good (iarg1) + integer :: something_good + integer, intent(in) :: iarg1 + something_good = iarg1 + 42 + end function something_good +end module mymod1 + +program spellchekc + use mymod1 + implicit none + + interface operator (.mywrong.) + module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" } + end interface + + interface operator (.mygood.) + module procedure something_good + end interface + + integer :: i, j, added + i = 0 + j = 0 + added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" } +end program spellchekc Index: Fortran/gfortran/regression/spellcheck-parameter.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spellcheck-parameter.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Contributed by Joost VandeVondele +! test levenshtein based spelling suggestions for keyword arguments + +module test +contains + subroutine mysub(iarg1) + integer :: iarg1 + end subroutine +end module + +use test +call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" } + +end Index: Fortran/gfortran/regression/spellcheck-procedure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spellcheck-procedure_1.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! test levenshtein based spelling suggestions + +module mymod1 + implicit none + contains + function something_else (iarg1) + integer :: something_else + integer, intent(in) :: iarg1 + something_else = iarg1 + 42 + end function something_else + function add_fourtytwo (iarg1) + integer :: add_fourtytwo + integer, intent(in) :: iarg1 + add_fourtytwo = iarg1 + 42 + end function add_fourtytwo +end module mymod1 + +function myadd(iarg1, iarg2) + implicit none + integer :: myadd + integer, intent(in) :: iarg1, iarg2 + myadd = iarg1 + iarg2 +end function myadd + +program spellchekc + use mymod1, something_good => something_else + implicit none + + integer :: myadd, i, j, myvar + i = 0 + j = 0 + + j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" } + j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" } + if (j /= 42) STOP 1 + j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" } + myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" } + if (j /= 42 * 2) STOP 2 + +end program spellchekc Index: Fortran/gfortran/regression/spellcheck-procedure_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spellcheck-procedure_2.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! test levenshtein based spelling suggestions + + +program spellchekc + implicit none (external) + + interface + subroutine bark_unless_zero(iarg) + implicit none + integer, intent(in) :: iarg + end subroutine bark_unless_zero + end interface + + integer :: i + i = 0 + + if (i /= 1) STOP 1 + call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" } +! call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" } + +contains +! We cannot reliably see this ATM, would need an unambiguous bit somewhere + subroutine complain_about_zero(iarg) + integer, intent(in) :: iarg + if (iarg /= 0) STOP 2 + end subroutine complain_about_zero + +end program spellchekc + +subroutine bark_unless_zero(iarg) + implicit none + integer, intent(in) :: iarg + if (iarg /= 0) STOP 3 +end subroutine bark_unless_zero Index: Fortran/gfortran/regression/spellcheck-structure.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spellcheck-structure.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! test levenshtein based spelling suggestions +implicit none + +!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!! +type type1 + real :: radius + integer :: i +end type type1 + +type type2 + integer :: myint + type(type1) :: mytype +end type type2 + +type type3 + type(type2) :: type_2 +end type type3 +type type4 + type(type3) :: type_3 +end type type4 + +type(type1) :: t1 +t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" } +t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" } +type(type2) :: t2 +t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" } +t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" } +type(type4) :: t4 +t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" } + +!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!! +integer :: iarg1 +iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" } +end Index: Fortran/gfortran/regression/spread_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_bounds_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of SPREAD intrinsic in dimension 2: is 3, should be 2" } +program main + integer :: source(2), target(2,3) + data source /1,2/ + integer :: times + times = 2 + target = spread(source,2,times) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of SPREAD intrinsic in dimension 2: is 3, should be 2" } + Index: Fortran/gfortran/regression/spread_init_expr.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_init_expr.f03 @@ -0,0 +1,17 @@ +! { dg-do run } + + INTEGER, PARAMETER :: n = 5 + INTEGER, PARAMETER :: a1(n) = SPREAD(1, 1, n) + INTEGER, PARAMETER :: a2(n, 3) = SPREAD([1,2,3], DIM=1, NCOPIES=n) + INTEGER, PARAMETER :: a3(3, n) = SPREAD([1,2,3], DIM=2, NCOPIES=n) + + IF (ANY(a1 /= [ 1, 1, 1, 1, 1 ])) STOP 1 + + IF (ANY(a2(:, 1) /= 1)) STOP 2 + IF (ANY(a2(:, 2) /= 2)) STOP 3 + IF (ANY(a2(:, 3) /= 3)) STOP 4 + + IF (ANY(a3(1, :) /= 1)) STOP 5 + IF (ANY(a3(2, :) /= 2)) STOP 6 + IF (ANY(a3(3, :) /= 3)) STOP 7 +END Index: Fortran/gfortran/regression/spread_init_expr_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_init_expr_2.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +module bug + integer :: ibug(42) = spread(42, 1, 42) ! { dg-error "invalid in an initialization expression" } +end module Index: Fortran/gfortran/regression/spread_scalar_source.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_scalar_source.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-O0" } + + character*1 :: i, j(10) + character*8 :: buffer + integer(kind=1) :: ii, jj(10) + type :: mytype + real(kind=8) :: x + integer(kind=1) :: i + character*15 :: ch + end type mytype + type(mytype) :: iii, jjj(10) + + i = "w" + ii = 42 + iii = mytype (41.9999_8, 77, "test_of_spread_") + +! Test constant sources. + + j = spread ("z", 1 , 10) + if (any (j /= "z")) STOP 1 + jj = spread (19, 1 , 10) + if (any (jj /= 19)) STOP 2 + +! Test variable sources. + + j = spread (i, 1 , 10) + if (any (j /= "w")) STOP 3 + jj = spread (ii, 1 , 10) + if (any (jj /= 42)) STOP 4 + jjj = spread (iii, 1 , 10) + if (any (jjj%x /= 41.9999_8)) STOP 5 + if (any (jjj%i /= 77)) STOP 6 + if (any (jjj%ch /= "test_of_spread_")) STOP 7 + +! Check that spread != 1 is OK. + + jj(2:10:2) = spread (1, 1, 5) + if (any (jj(1:9:2) /= 42) .or. any (jj(2:10:2) /= 1)) STOP 8 + +! Finally, check that temporaries and trans-io.c work correctly. + + write (buffer, '(4a1)') spread (i, 1 , 4) + if (trim(buffer) /= "wwww") STOP 9 + write (buffer, '(4a1)') spread ("r", 1 , 4) + if (trim(buffer) /= "rrrr") STOP 10 + write (buffer, '(4i2)') spread (ii, 1 , 4) + if (trim(buffer) /= "42424242") STOP 11 + write (buffer, '(4i2)') spread (31, 1 , 4) + if (trim(buffer) /= "31313131") STOP 12 + + end Index: Fortran/gfortran/regression/spread_shape_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_shape_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Tests the fix for PR29060 in which the shape of the result +! of SPREAD was not available to the scalarizer. +! +! Contributed by Paul Thomas + real,dimension(:, :),pointer :: ptr + real,dimension(2, 2) :: u + + u = reshape((/0.25, 0.5, 0.75, 1.00/),(/2,2/)) + + allocate (ptr(2,2)) + +! Original PR + ptr(:, :) = u + spread ((/1.0, 2.0/), 2, size(u, 2)) + if (any (ptr .ne. & + reshape ((/1.25, 2.50, 1.75, 3.00/), (/2, 2/)))) STOP 1 + +! Check that the fix works correctly with the source shape after ncopies + ptr(:, :) = u + spread ((/2.0, 3.0/), 1, size (u, 1)) + if (any (ptr .ne. & + reshape ((/2.25, 2.50, 3.75, 4.00/), (/2,2/)))) STOP 2 +end Index: Fortran/gfortran/regression/spread_simplify_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_simplify_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 68426 - simplification used to fail. + module m + implicit none + type t + integer :: i + end type t + type(t), dimension(2), parameter :: a1 = (/ t(1), t(2) /) + type(t), dimension(1), parameter :: c = spread ( a1(1), 1, 1 ) + end module m + + +program main + use m + if (c(1)%i /= 1) stop 1 +end program main Index: Fortran/gfortran/regression/spread_size_limit.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_size_limit.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR40472 in which simplify_spread had mo limit on the +! siz that it would try to expand to. +! +! Contributed by Philippe Marguinaud +! +REAL, DIMENSION(720,360) :: ZLON_MASK +ZLON_MASK(:,:)= SPREAD( (/ (JLON , JLON=1,720) /) , DIM=2, NCOPIES=360 ) +print *, zlon_mask(100,100) +END +! { dg-final { scan-tree-dump-times "_gfortran_spread" 1 "original" } } + Index: Fortran/gfortran/regression/spread_size_limit_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_size_limit_2.f90 @@ -0,0 +1,11 @@ +! PR fortran/91944 +! { dg-do compile } +! { dg-options "-fmax-array-constructor=65535" } + +program pr91944 + integer, parameter :: n = 10 + integer, parameter :: m = 65536 + integer :: i + integer :: x(n,m) = spread([(i,i=1,n)], dim=2, ncopies=m) ! { dg-error "requires an increase of the allowed 65535 upper limit" } + print *, x(n,m) +end Index: Fortran/gfortran/regression/spread_zerosize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/spread_zerosize_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 33298 - zero-sized arrays for spread were handled +! incorrectly. + +program main + real :: x(0,3), y(0) + x = spread(y,2,3) +end Index: Fortran/gfortran/regression/stat_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stat_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-skip-if "" { *-*-mingw* } } +! { dg-options "-std=gnu" } + character(len=*), parameter :: f = "testfile_stat_1" + integer :: s1(13), r1, s2(13), r2, s3(13), r3, d(13), rd + + open (10,file=f) + write (10,"(A)") "foo" + close (10,status="keep") + + open (10,file=f) + call lstat (f, s1, r1) + call stat (f, s2, r2) + call fstat (10, s3, r3) + call stat (".", d, rd) + + if (r1 /= 0 .or. r2 /= 0 .or. r3 /= 0 .or. rd /= 0) STOP 1 + if (any (s1 /= s2) .or. any (s1 /= s3)) STOP 2 + if (s1(5) /= getuid()) STOP 3 +! If the test is run in a directory with the sgid bit set or on a filesystem +! mounted with the grpid option, new files are created with the directory's +! gid instead of the user's primary gid, so allow for that. + if (s1(6) /= getgid() .and. s1(6) /= d(6) .and. getgid() /= 0) STOP 4 + if (s1(8) < 3 .or. s1(8) > 5) STOP 5 + + close (10,status="delete") + end Index: Fortran/gfortran/regression/stat_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stat_2.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-skip-if "" { *-*-mingw* } } +! { dg-options "-std=gnu" } + character(len=*), parameter :: f = "testfile_stat_2" + integer :: s1(13), r1, s2(13), r2, s3(13), r3, d(13), rd + + open (10,file=f) + write (10,"(A)") "foo" + close (10,status="keep") + + open (10,file=f) + r1 = lstat (f, s1) + r2 = stat (f, s2) + r3 = fstat (10, s3) + rd = stat (".", d) + + if (r1 /= 0 .or. r2 /= 0 .or. r3 /= 0 .or. rd /= 0) STOP 1 + if (any (s1 /= s2) .or. any (s1 /= s3)) STOP 2 + if (s1(5) /= getuid()) STOP 3 +! If the test is run in a directory with the sgid bit set or on a filesystem +! mounted with the grpid option, new files are created with the directory's +! gid instead of the user's primary gid, so allow for that. + if (s1(6) /= getgid() .and. s1(6) /= d(6) .and. getgid() /= 0) STOP 4 + if (s1(8) < 3 .or. s1(8) > 5) STOP 5 + + close (10,status="delete") + end Index: Fortran/gfortran/regression/statement_function_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/statement_function_1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR fortran/84276 + subroutine stepns(hh, h, s, w) + real, intent(inout) :: h, hh, s + real, intent(out) :: w + real :: qofs + integer i + qofs(s) = s + w = qofs(hh + h) + i = 42 + w = qofs(i) ! { dg-error "Type mismatch in argument" } + end subroutine stepns + + subroutine step(hh, h, s, w) + real, intent(inout) :: h, hh, s + real, intent(out) :: w + real :: qofs + integer i + qofs(s, i) = i * s + i = 42 + w = qofs(hh, i) + w = qofs(i = i, s = hh) ! { dg-error "invalid in a statement function" } + end subroutine step +! { dg-prune-output " Obsolescent feature" } Index: Fortran/gfortran/regression/statement_function_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/statement_function_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR fortran/54223 +subroutine r(d) + implicit none + integer, optional :: d + integer :: h, q + q(d) = d + 1 ! statement function statement + h = q(d) +end subroutine r + +subroutine s(x) + implicit none + integer, optional :: x + integer :: g, z + g(x) = x + 1 ! statement function statement + z = g() ! { dg-error "Missing actual argument" } +end subroutine s + +subroutine t(a) + implicit none + integer :: a + integer :: f, y + f(a) = a + 1 ! statement function statement + y = f() ! { dg-error "Missing actual argument" } +end subroutine t +! { dg-prune-output " Obsolescent feature" } Index: Fortran/gfortran/regression/statement_function_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/statement_function_3.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/35299 + subroutine phtod(e,n,i,h) + dimension e(n) + hstar(e,b)=b**.4*((1.25*fun(-e/40)+.18)) ! { dg-error "must be scalar" } + a = 1. + h = hstar(e(i-1), a) + end + + function fun(a) + real a(*) + fun = 42 + end +! { dg-prune-output " Obsolescent feature" } + Index: Fortran/gfortran/regression/statement_function_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/statement_function_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/69604 +! Contributed by G.Steinmetz + +program p + x(n) = 1 + n(2.0) ! { dg-error "Invalid use of statement function argument" } + y(k) = k() ! { dg-error "Invalid use of statement function argument" } + z(m) = m ! { dg-warning "Statement function" } + print *, x(n) +end Index: Fortran/gfortran/regression/static_linking_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/static_linking_1.c @@ -0,0 +1,6 @@ +extern void f_(void); +int main (void) +{ + f_(); + return 0; +} Index: Fortran/gfortran/regression/static_linking_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/static_linking_1.f @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-require-effective-target static_libgfortran } +! { dg-additional-sources static_linking_1.c } +! { dg-options "-static" } +! +! This testcase checks that statically linking libgfortran with C main() +! really calls the constructor function +! PR libfortran/22298 + subroutine f + print *, "subroutine output" + end Index: Fortran/gfortran/regression/stfunc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! this is a problem which disappeared between 2005-01-02 and 2005-03-13 +! PR 18600 + logical a, b + a(b) = .true. + b = .false. + if (a(.false.)) b = .true. + if (.not.b) STOP 1 + end Index: Fortran/gfortran/regression/stfunc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 20467 : we didn't check if a statement function had the dummy attribute. +SUBROUTINE a(b) + b(c) = 0 ! { dg-error "Unclassifiable statement" } +END SUBROUTINE a + Index: Fortran/gfortran/regression/stfunc_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Tests the fix for PR20867 in which implicit typing was not done within +! statement functions and so was not confirmed or not by subsequent +! type delarations. +! +! Contributed by Joost VandeVondele +! + REAL :: st1 + st1(I)=I**2 + REAL :: I ! { dg-error " already has basic type of INTEGER" } + END + + Index: Fortran/gfortran/regression/stfunc_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_4.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Tests the fix for PR29389, in which the statement function would not be +! recognised as PURE within a PURE procedure. + +! Contributed by Francois-Xavier Coudert + + INTEGER :: st1, i = 99, a(4), q = 6 + st1 (i) = i * i * i + FORALL(i=1:4) a(i) = st1 (i) + FORALL(i=1:4) a(i) = u (a(i)) - a(i)** 2 + if (any (a .ne. 0)) STOP 1 + if (i .ne. 99) STOP 2 +contains + pure integer function u (x) + integer,intent(in) :: x + st2 (i) = i * i + u = st2(x) + end function +end Index: Fortran/gfortran/regression/stfunc_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_5.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/32724 +! ICE on statement function in specification part of module + +MODULE stmt +f(x) = x**2 ! { dg-error "Unexpected STATEMENT FUNCTION" } +END MODULE Index: Fortran/gfortran/regression/stfunc_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_6.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Tests the fix for the second bit of PR29389, in which the +! statement function would not be recognised as not PURE +! when it referenced a procedure that is not PURE. +! +! This is based on stfunc_4.f90 with the statement function made +! impure by a reference to 'v'. +! +! Contributed by Francois-Xavier Coudert + + INTEGER :: st1, i = 99, a(4), q = 6 + st1 (i) = i * i * i + st3 (i) = i * v(i) + FORALL(i=1:4) a(i) = st1 (i) + FORALL(i=1:4) a(i) = u (a(i)) - a(i)** 2 + if (any (a .ne. 0)) STOP 1 + if (i .ne. 99) STOP 2 + FORALL (i=1:4) a(i) = st3 (i) ! { dg-error "impure function" "impure reference in FORALL" { xfail *-*-*} } + FORALL (i=1:4) a(i) = v(i) ! { dg-error "impure function" } +contains + pure integer function u (x) + integer,intent(in) :: x + st2 (i) = i * v(i) ! { dg-error "impure function" } + u = st2(x) + end function + integer function v (x) + integer,intent(in) :: x + v = i + end function +end Index: Fortran/gfortran/regression/stfunc_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_7.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR 50553: statement function cannot be target (r178939) +! +! Contributed by Vittorio Zecca + +f(x)=x +target f ! { dg-error "attribute conflicts with" } +end Index: Fortran/gfortran/regression/stfunc_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stfunc_8.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/50405 +! +! Submitted by zeccav@gmail.com +! + f(f) = 0 ! { dg-error "Self-referential argument" } + end Index: Fortran/gfortran/regression/stmt_func_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stmt_func_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/47542 +! +integer, target, save :: tgt = 77 +integer, pointer ::ptr_stmt ! { dg-error "Statement function .ptr_stmt. at .1. may not have pointer or allocatable attribute" } +integer, allocatable :: alloc_stmt ! { dg-error "Statement function .alloc_stmt. at .1. may not have pointer or allocatable attribute" } + +ptr_stmt() = tgt +alloc_stmt() = 78 +end Index: Fortran/gfortran/regression/stop_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stop_1.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } + + implicit none + logical :: q = .false. + integer(2) :: p = 99 + real :: x = 0. + character(5) :: s = "stopp" + print *, "Hello" + stop 1, quiet=.false. + stop 2, quiet=q + stop 3, quiet=f(x) + stop; stop! + stop ;stop 4! + stop 5; stop 6 + stop 7 ;stop 8 + stop 1_1; stop 2_2; stop 4_4; stop 8_8 + stop&! + &;stop;&! + stop&! + s& + ; stop "x";&! + ; st&! + &op&! + p + stop s + if(f(x))then;stop 9,quiet=.false.;else;stop 10;endif + error stop 4, quiet=.true. + error stop 5 , quiet=.true. + error stop s, quiet=.true. + stop "last " // s, quiet=.false._2 + stop, quiet=any([.false.]) + stop , quiet=any([f(x)]) + stop "stopp" , quiet=any([f(x)]) + stop s, quiet=all([f(x)]) + stop42, quiet=.false. ! { dg-error "Blank required" } + stop"stopp" , quiet=any([f(x)]) ! { dg-error "Blank required" } + stop 8, quiet=([f(x)]) ! { dg-error "must be a scalar LOGICAL" } +contains + logical function f(x) + real, intent(in) :: x + f = .false. + end function f +end Index: Fortran/gfortran/regression/stop_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stop_2.f @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } + + implicit none + logical :: q = .false. + integer(2) :: p = 99 + real :: x = 0. + character(5) :: s = "stopp" + stop 1, quiet=.false. + stop 2, quiet=q + stop 3, quiet=f(x) + stop42,quiet=.false. + error stop 4, quiet=.true. + error stop 5 , quiet=.true. + stop1_1;stop2_2;stop4_4;stop8_8 + stopp;stops + st + &op42 + stop, quiet=any([.false.]) + stop , quiet=any([f(x)]) + stop"stopp",quiet=any([f(x)]) + stop "stopp" , quiet=any([f(x)]) + s to ps,quiet=all([f(x)]) + e r r o r s t o p 4 3 , q u i e t = . t r u e . + errorstop"stopp",quiet=.not.f(x) + contains + logical function f(x) + real, intent(in) :: x + f = .false. + end function f + end Index: Fortran/gfortran/regression/stop_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stop_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! F95 and F2003 do not require a blank after STOP + + implicit none + integer, parameter :: p = 99 + character(*), parameter :: s = "stopp" + stop1 + stop2! + stop3;stop4! + stopp + stop&! + &;stop;&! + stop&! + s& + ;stop"x";&! + ;st&! + &op&! + p + stops + stop"last " // s +end Index: Fortran/gfortran/regression/stop_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stop_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original -std=f2018" } +! Check that the QUIET specifier to shut up a STOP statement is passed properly + +program p + logical(1) :: q = .true. ! using kind=1 to simplify scanning of tree dump + stop 0, quiet=q + stop 1, quiet=.true. + stop 2 ! the "noisy" default +end program p + +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(0, q\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(1, 1\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(2, 0\\)" "original" } } Index: Fortran/gfortran/regression/stop_shouldfail.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/stop_shouldfail.f90 @@ -0,0 +1,5 @@ +! { dg-do run } +! { dg-shouldfail "STOP 1" } +program main + stop 1 +end program main Index: Fortran/gfortran/regression/storage_size_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_1.f08 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR 44649: [OOP] F2008: storage_size intrinsic +! +! Contributed by Janus Weil + +type :: t + integer(4) :: i + real(4) :: r +end type + +type,extends(t) :: t2 + integer(4) :: j +end type + +type(t) :: a +type(t), dimension(1:3) :: b +class(t), allocatable :: cp + +allocate(t2::cp) + +if (sizeof(a) /= 8) STOP 1 +if (storage_size(a) /= 64) STOP 2 + +if (sizeof(b) /= 24) STOP 3 +if (storage_size(b) /= 64) STOP 4 + +if (sizeof(cp) /= 12) STOP 5 +if (storage_size(cp) /= 96) STOP 6 + +end Index: Fortran/gfortran/regression/storage_size_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_2.f08 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 44649: [OOP] F2008: storage_size intrinsic +! +! Contributed by Janus Weil + +use iso_c_binding, only: c_int, c_sizeof + +type, bind(c) :: t + integer(c_int) :: j +end type + +integer(4) :: i1 +integer(c_int) :: i2 +type(t) :: x + +print *,c_sizeof(i1) +print *,c_sizeof(i2) +print *,c_sizeof(x) +print *, c_sizeof(ran()) + +print *,storage_size(1.0,4) +print *,storage_size(1.0,3.2) ! { dg-error "must be INTEGER" } +print *,storage_size(1.0,(/1,2/)) ! { dg-error "must be a scalar" } +print *,storage_size(1.0,irand()) ! { dg-error "must be a constant" } + +end Index: Fortran/gfortran/regression/storage_size_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_3.f08 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR 47024: [OOP] STORAGE_SIZE (for polymorphic types): Segfault at run time +! PR 47189: [OOP] calling STORAGE_SIZE on a NULL-initialized class pointer +! PR 47194: [OOP] EXTENDS_TYPE_OF still returns the wrong result if the polymorphic variable is unallocated +! +! Contributed by Tobias Burnus + +type t + integer(kind=4) :: a +end type + +class(t), pointer :: x => null() +class(t), allocatable :: y + +if (storage_size(x)/=32) STOP 1 +if (storage_size(y)/=32) STOP 2 + +allocate(y) + +if (storage_size(y)/=32) STOP 3 + +deallocate(y) + +if (storage_size(y)/=32) STOP 4 + +end Index: Fortran/gfortran/regression/storage_size_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/57553 +! +! Ensure that there is no ICE and that compile-time simplication works. +! + use iso_fortran_env + implicit none + integer, parameter :: ESize = storage_size('a') + integer, parameter :: ESize2 = storage_size('aa') + if ( ESize/CHARACTER_STORAGE_SIZE /= 1) STOP 1 + if ( ESize2/CHARACTER_STORAGE_SIZE /= 2) STOP 2 +end + +subroutine S ( A ) + character(len=*), intent(in) :: A + integer :: ESize = 4 + esize = ( storage_size(a) + 7 ) / 8 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop" "original" } } Index: Fortran/gfortran/regression/storage_size_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_5.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +subroutine test() + implicit none + integer :: i0, i1, i2, i3, i4 + i0 = kind(STORAGE_SIZE(5)) + i1 = kind(STORAGE_SIZE(5, kind=1)) + i2 = kind(STORAGE_SIZE(5, kind=2)) + i3 = kind(STORAGE_SIZE(5, kind=4)) + i4 = kind(STORAGE_SIZE(5, kind=8)) +end subroutine test + +subroutine test2(x) + implicit none + class(*) :: x + integer :: j0, j1, j2, j3, j4 + integer(1) :: k1 + integer(2) :: k2 + j0 = kind(STORAGE_SIZE(x)) + j1 = kind(STORAGE_SIZE(x, kind=1)) + j2 = kind(STORAGE_SIZE(x, kind=2)) + j3 = kind(STORAGE_SIZE(x, kind=4)) + j4 = kind(STORAGE_SIZE(x, kind=8)) + + k1 = STORAGE_SIZE(x, kind=1) + k2 = STORAGE_SIZE(x, kind=2) +end subroutine test2 + +! { dg-final { scan-tree-dump-times "i0 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i2 = 2;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i3 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i4 = 8;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j0 = 4;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j2 = 2;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j3 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j4 = 8;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "k1 = \\(integer\\(kind=1\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "k2 = \\(integer\\(kind=2\\)\\)" 1 "original" } } Index: Fortran/gfortran/regression/storage_size_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/storage_size_6.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/66043 +! +! Original code from Gerhard Steinmetz +! +program p + print *, storage_size(null()) ! { dg-error "cannot be an actual" } +end Index: Fortran/gfortran/regression/str_comp_optimize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/str_comp_optimize_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! +! PR fortran/60341 +! An unguarded union access was wrongly enabling a frontend optimization on a +! string comparison, leading to an ICE. +! +! Original testcase from Steve Chapel . +! Reduced by Steven G. Kargl . +! + + subroutine modelg(ncm) + implicit none + integer, parameter :: pc = 30, pm = pc - 1 + integer i + character*4 catt(pm,2) + integer ncm,iatt(pm,pc) + do i=1,ncm + if (catt(i,1)//catt(i,2).eq.'central') exit + end do + iatt(i,4)=1 + end Index: Fortran/gfortran/regression/streamio_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR25828 Stream IO test 1 +! Contributed by Jerry DeLisle . +PROGRAM stream_io_1 + IMPLICIT NONE + integer(kind=4) i + real(kind=8) r + OPEN(UNIT=11, ACCESS="stream") + WRITE(11) "first" + WRITE(11) "second" + WRITE(11) 1234567 + write(11) 3.14159_8 + read(11, pos=12)i + if (i.ne.1234567) STOP 1 + read(11) r + if (r-3.14159 .gt. 0.00001) STOP 2 + CLOSE(UNIT=11, status="delete") +END PROGRAM stream_io_1 \ No newline at end of file Index: Fortran/gfortran/regression/streamio_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_10.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! PR25093 Stream IO test 10 +! Contributed by Jerry DeLisle . +! Test case derived from that given in PR by Steve Kargl. +program stream_io_10 + implicit none + integer(kind=4) :: a(4), b(4) + integer(kind=8) :: thepos + a = (/ 1, 2, 3, 4 /) + b = a + open(10, file="teststream_streamio_10", access="stream") + write(10) a + inquire(10, pos=thepos) + if (thepos.ne.17) STOP 1 + + read(10, pos=1) + inquire(10, pos=thepos) + if (thepos.ne.1) STOP 2 + + write(10, pos=15) + inquire(10, pos=thepos) + if (thepos.ne.15) STOP 3 + + read(10, pos=3) + inquire(10, pos=thepos) + if (thepos.ne.3) STOP 4 + + write(10, pos=1) + inquire(10, pos=thepos) + if (thepos.ne.1) STOP 5 + + a = 0 + read(10) a + if (any(a /= b)) STOP 6 + + close(10, status="delete") +end program stream_io_10 Index: Fortran/gfortran/regression/streamio_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_11.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR29277 Stream IO test 11, tests formatted form. +! Contributed by Tobias Burnas. +program stream_test + implicit none + character(len=*), parameter :: rec1 = 'record1' + character(len=*), parameter :: rec2 = 'record2' + character(len=50) :: str1,str2 + integer :: len, i + real :: r + + open(10,form='formatted',access='stream',& + status='scratch',position='rewind') + write(10,'(a)') rec1//new_line('a')//rec2 + rewind(10) + read(10,*) str1 + read(10,*) str2 + if(str1 /= rec1 .or. str2 /= rec2) STOP 1 + rewind(10) + read(10,'(a)') str1 + read(10,'(a)') str2 + if(str1 /= rec1 .or. str2 /= rec2) STOP 2 + close(10) + + open(10,form='formatted',access='stream',& + status='scratch',position='rewind') + write(10,*) '123 '//trim(rec1)//' 1e-12' + write(10,*) '12345.6789' + rewind(10) + read(10,*) i,str1 + read(10,*) r + if(i /= 123 .or. str1 /= rec1 .or. r /= 12345.6789) & + STOP 3 + close(10) + + open(unit=10,form='unformatted',access='stream', & + status='scratch',position='rewind') + write(10) rec1//new_line('a')//rec2 + len = len_trim(rec1//new_line('a')//rec2) + rewind(10) + read(10) str1(1:len) + if(str1 /= rec1//new_line('a')//rec2) STOP 4 +end program stream_test Index: Fortran/gfortran/regression/streamio_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_12.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR33985 Stream IO test with empty write, array writes, and reads. +program streamtest + implicit none + character(1) :: lf = char(10) + character(1) :: tchar + integer :: i,j,k + real(kind=4), dimension(100,100) :: anarray + open(10, file="teststream_streamio_12", access="stream", form="unformatted") + anarray = 3.14159 + write(10) anarray + write(10, pos=1) ! This is a way to position an unformatted file + anarray = 0.0 + read(10) anarray + anarray = abs(anarray - 3.14159) + if (any(anarray.gt.0.00001)) STOP 1 + close(10,status="delete") +end program streamtest \ No newline at end of file Index: Fortran/gfortran/regression/streamio_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_13.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR 34405 - BACKSPACE for unformatted stream files is prohibited. +program main + implicit none + integer :: ios + character(len=80) :: msg + open(2003,form="unformatted",access="stream",status="scratch") + write (2003) 1 + write (2003) 2 + ios = 0 + msg = ' ' + backspace (2003,iostat=ios,iomsg=msg) + if (ios == 0 .or. msg /="Cannot BACKSPACE an unformatted stream file") & + STOP 1 +end program main Index: Fortran/gfortran/regression/streamio_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_14.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test that we can write an unformatted stream file without +! truncating. +program main + character (len=10) c + open(10, form="unformatted", access="stream", position="rewind") + write (10) '1234567890abcde' + c = '' + read (10,pos=1) c + if (c /= '1234567890') STOP 1 + c = '' + read (10,pos=6) c + if (c /= '67890abcde') STOP 2 + write (10,pos=3) 'AB' + c = '' + read (10,pos=1) c + if (c /= '12AB567890') STOP 3 + c = '' + read (10,pos=6) c + if (c /= '67890abcde') STOP 4 + close (10,status="delete") +end program main Index: Fortran/gfortran/regression/streamio_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_15.f90 @@ -0,0 +1,45 @@ +! { dg-do run { target fd_truncate } } +! PR35132 Formatted stream I/O write should truncate. +! Test case adapted from PR by Jerry DeLisle +program main + implicit none + character(len=6) :: c + integer :: i, newline_length + + open(20,status="scratch",access="stream",form="formatted") + write(20,"()") + inquire(20,pos=newline_length) + newline_length = newline_length - 1 + if (newline_length < 1 .or. newline_length > 2) STOP 1 + close(20) + + open(20,file="foo_streamio_15.txt",form="formatted",access="stream") + write(20,'(A)') '123456' + write(20,'(A)') 'abcdef' + write(20,'(A)') 'qwerty' + rewind 20 + ! Skip over the first line + read(20,'(A)') c + if (c.ne.'123456') STOP 2 + ! Save the position + inquire(20,pos=i) + if (i.ne.7+newline_length) STOP 3 + ! Read in the complete line... + read(20,'(A)') c + if (c.ne.'abcdef') STOP 4 + ! Write out the first four characters + write(20,'(A)',pos=i,advance="no") 'ASDF' + ! Fill up the rest of the line. Here, we know the length. If we + ! don't, things will be a bit more complicated. + write(20,'(A)') c(5:6) + ! Copy the file to standard output + rewind 20 + c = "" + read(20,'(A)') c + if (c.ne.'123456') STOP 5 + read(20,'(A)') c + if (c.ne.'ASDFef') STOP 6 + read(20,'(A)', iostat=i) c + if (i /= -1) STOP 7 + close (20, status="delete") +end program main Index: Fortran/gfortran/regression/streamio_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_16.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR38291 Rejects I/O with POS= if FMT=* +character(15) :: sAccess +character(1) :: instr +integer :: mypos, i +mypos = 0 +open(50, access="stream", form="formatted") +write(50, *, pos=1) "Just something " +do i=1,17 + read( 50, *,pos=i) + inquire(50, access=sAccess, pos=mypos) + if (sAccess.ne."STREAM") STOP 1 + if ((mypos.ne.18).and.(mypos.ne.19)) STOP 2 +end do +read (50,*, end=10) +STOP 3 + 10 continue +close(50,status="delete") +end Index: Fortran/gfortran/regression/streamio_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_17.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +program stream_test +implicit none +integer :: ios +character(128) :: message +open(10, status='scratch', access='stream') +write (10, rec=1, iostat=ios, iomsg=message) "This is a test" ! +if (ios.ne.5001) STOP 1 +if (message.ne. & + &"Record number not allowed for stream access data transfer") & + STOP 2 +end program Index: Fortran/gfortran/regression/streamio_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_18.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR91200 +program foo + implicit none + integer fd + open(newunit=fd, file='test.dat', access='stream', form='formatted') + write(fd,'(A)') '$MeshFormat' + write(fd,'(A)') 'aabbccdd' + close(fd) + call readfile ! Read test.dat +contains + subroutine readfile + character(len=20) buf1, buf2 + integer fd, m, n + open(newunit=fd, file='test.dat', access='stream', form='formatted') + inquire(fd, pos=m) + if (m /= 1) stop 'm /= 1' + read(fd, *) buf1 + read(fd, *, pos=m) buf2 ! Reread by using pos=1 + close(fd, status='delete') + if (buf1 /= buf2) stop 'wrong' + end subroutine readfile +end program Index: Fortran/gfortran/regression/streamio_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR25828 Stream IO test 2 +! Contributed by Jerry DeLisle . +PROGRAM readUstream + IMPLICIT NONE + CHARACTER*3 :: string + INTEGER :: n + string = "123" + n = 13579 + OPEN(UNIT=11, FILE="streamio2", ACCESS="STREAM") + WRITE(11) "first" + WRITE(11) "second" + WRITE(11) 7 + READ(11, POS=3) string + READ(11, POS=12) n + if (string.ne."rst") STOP 1 + if (n.ne.7) STOP 2 + close(unit=11, status="delete") +END PROGRAM readUstream + Index: Fortran/gfortran/regression/streamio_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR25828 Stream IO test 3, tests read_x and inquire. +! Contributed by Jerry DeLisle . +program streamio_3 + implicit none + integer :: i(6),j + character(10) :: myaccess + open(10, access="stream", form="formatted") + i = (/(j,j=1,6)/) + write(10,'(3(2x,i4/)/3(3x,i6/))') i + i = 0 + rewind(10) + read(10,'(3(2x,i4/)/3(3x,i6/))') i + if (any(i.ne.(/(j,j=1,6)/))) STOP 1 + inquire(unit=10, access=myaccess) + if (myaccess.ne."STREAM") STOP 2 + close(10,status="delete") +end program streamio_3 Index: Fortran/gfortran/regression/streamio_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_4.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! PR25828 Stream IO test 4, Tests string read and writes, single byte. +! Verifies buffering is working correctly and position="append" +! Contributed by Jerry DeLisle . +program streamtest + implicit none + character(1) :: lf = char(10) + character(1) :: tchar + integer :: i,j,k + integer, parameter :: lines = 5231 + + open(10, file="teststream_streamio_4", access="stream", form="formatted") + + do i=1,lines + do j=0,9 + write(10,"(i5)") j + end do + end do + + close(10) + + open(10, file="teststream_streamio_4", access="stream",& + &form="formatted", position="append") + do i=1,lines + do j=0,9 + write(10,"(i5)") j + end do + end do + rewind(10) + do i=1,lines + do j=0,9 + read(10,"(i5)") k + if (k.ne.j) STOP 1 + end do + end do + + close(10,status="delete") +end program streamtest Index: Fortran/gfortran/regression/streamio_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_5.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR25828 Stream IO test 5, unformatted single byte +! Contributed by Jerry DeLisle . +program streamtest5 + implicit none + character(1) :: lf = char(10) + character(1) :: tchar + integer :: i,j,k + + open(10, file="teststream_streamio_5", access="stream", form="unformatted") + + do i=1,1229 + do j=0,9 + write(10) j + end do + write(10) lf + end do + + close(10) + + open(10, file="teststream_streamio_5", access="stream", form="unformatted") + + do i=1,1229 + do j=0,9 + read(10) k + if (k.ne.j) STOP 1 + end do + read(10) tchar + if (tchar.ne.lf) STOP 2 + end do + close(10,status="delete") +end program streamtest5 \ No newline at end of file Index: Fortran/gfortran/regression/streamio_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_6.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR25828 Stream IO test 6, random writes and reads. +! Contributed by Jerry DeLisle . +program streamio_6 + implicit none + integer, dimension(100) :: a + character(1) :: c + integer :: i,j,k,ier + real :: x + data a / 13, 9, 34, 41, 25, 98, 6, 12, 11, 44, 79, 3,& + & 64, 61, 77, 57, 59, 2, 92, 38, 71, 64, 31, 60, 28, 90, 26,& + & 97, 47, 26, 48, 96, 95, 82, 100, 90, 45, 71, 71, 67, 72,& + & 76, 94, 49, 85, 45, 100, 22, 96, 48, 13, 23, 40, 14, 76, 99,& + & 96, 90, 65, 2, 8, 60, 96, 19, 45, 1, 100, 48, 91, 20, 92,& + & 72, 81, 59, 24, 37, 43, 21, 54, 68, 31, 19, 79, 63, 41,& + & 42, 12, 10, 62, 43, 9, 30, 9, 54, 35, 4, 5, 55, 3, 94 / + + open(unit=15,file="teststream_streamio_6",access="stream",form="unformatted") + do i=1,100 + k = a(i) + write(unit=15, pos=k) achar(k) + enddo + do j=1,100 + read(unit=15, pos=a(j), iostat=ier) c + if (ier.ne.0) then + STOP 1 + else + if (achar(a(j)) /= c) STOP 2 + endif + enddo + close(unit=15, status="delete") +end program streamio_6 \ No newline at end of file Index: Fortran/gfortran/regression/streamio_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_7.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR25828 Stream IO test 7, Array writes and reads. +! Contributed by Jerry DeLisle . +program streamtest + implicit none + character(1) :: lf = char(10) + character(1) :: tchar + integer :: i,j,k + real(kind=4), dimension(100,100) :: anarray + open(10, file="teststream_streamio_7", access="stream", form="unformatted") + anarray = 3.14159 + write(10) anarray + anarray = 0.0 + read(10, pos=1) anarray + anarray = abs(anarray - 3.14159) + if (any(anarray.gt.0.00001)) STOP 1 + close(10,status="delete") +end program streamtest \ No newline at end of file Index: Fortran/gfortran/regression/streamio_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_8.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! PR25828 Stream IO test 8 +! Contributed by Jerry DeLisle . +PROGRAM stream_io_8 + IMPLICIT NONE + integer(kind=8) mypos + character(10) mystring + real(kind=8) r + mypos = 0 + mystring = "not yet" + r = 12.25d0 + OPEN(UNIT=11, ACCESS="stream") + inquire(unit=11, pos=mypos) + if (mypos.ne.1) STOP 1 + WRITE(11) "first" + inquire(unit=11, pos=mypos) + if (mypos.ne.6) STOP 2 + WRITE(11) "second" + inquire(unit=11, pos=mypos) + if (mypos.ne.12) STOP 3 + WRITE(11) 1234567_4 + inquire(unit=11, pos=mypos) + if (mypos.ne.16) STOP 4 + write(11) r + r = 0.0 + inquire (11, pos=mypos) + read(11,pos=16)r + if (abs(r-12.25d0)>1e-10) STOP 5 + inquire(unit=11, pos=mypos) + inquire(unit=11, access=mystring) + if (mypos.ne.24) STOP 6 + if (mystring.ne."STREAM") STOP 7 + CLOSE(UNIT=11, status="delete") +END PROGRAM stream_io_8 Index: Fortran/gfortran/regression/streamio_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/streamio_9.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! PR29053 Stream IO test 9. +! Contributed by Jerry DeLisle . +! Test case derived from that given in PR by Steve Kargl. +program pr29053 + implicit none + real dt, t, u, a(10), b(10) + integer i, place + dt = 1.e-6 + a = real( (/ (i, i=1, 10) /) ) + b = a + open(unit=11, file='a.dat', access='stream') + open(unit=12, file='b.dat', access='stream') + do i = 1, 10 + t = i * dt + write(11) t + write(12) a + end do + rewind(11) + rewind(12) + do i = 1, 10 + t = i * dt + read(12) a + if (any(a.ne.b)) STOP 1 + read(11) u + if (u.ne.t) STOP 2 + end do + close(11, status="delete") + close(12, status="delete") +end program pr29053 + Index: Fortran/gfortran/regression/string_0xfe_0xff_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_0xfe_0xff_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 30452 - this used to cause syntax errors due to the presence, +! as characters, of bytes 0xfe and 0xff. +program main + if (char (254) /= "þ") STOP 1 + if (char (255) /= "ÿ") STOP 2 +end program main Index: Fortran/gfortran/regression/string_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-require-effective-target ilp32 } +! +program main + implicit none + integer(kind=8), parameter :: l1 = 2_8**32_8 + character (len=2_8**32_8+4_8), parameter :: s = "" ! { dg-error "too large" } + character (len=2_8**32_8+4_8) :: ch ! { dg-error "too large" } + character (len=l1 + 1_8) :: v ! { dg-error "too large" } + character (len=int(huge(0_4),kind=8) + 1_8) :: z ! { dg-error "too large" } + character (len=int(huge(0_4),kind=8) + 0_8) :: w + +end program main Index: Fortran/gfortran/regression/string_1_lp64.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_1_lp64.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-require-effective-target lp64 } +! { dg-require-effective-target fortran_integer_16 } +program main + implicit none + integer(kind=16), parameter :: l1 = 2_16**64_16 + character (len=2_16**64_16+4_16), parameter :: s = "" ! { dg-error "too large" } + character (len=2_16**64_8+4_16) :: ch ! { dg-error "too large" } + character (len=l1 + 1_16) :: v ! { dg-error "too large" } + character (len=int(huge(0_8),kind=16) + 1_16) :: z ! { dg-error "too large" } + character (len=int(huge(0_8),kind=16) + 0_16) :: w + + print *, len(s) + +end program main Index: Fortran/gfortran/regression/string_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +program main + implicit none + character(len=10) :: s + + s = '' + print *, s(1:2_8**32_8+3_8) ! { dg-error "exceeds the string length" } + print *, s(2_8**32_8+3_8:2_8**32_8+4_8) ! { dg-error "exceeds the string length" } + print *, len(s(1:2_8**32_8+3_8)) ! { dg-error "exceeds the string length" } + +end program main Index: Fortran/gfortran/regression/string_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_3.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-require-effective-target ilp32 } +! +subroutine foo(i) + implicit none + integer, intent(in) :: i + character(len=i) :: s + + s = '' + print *, s(1:2_8**32_8+3_8) ! { dg-error "too large" } + print *, s(2_8**32_8+3_8:2_8**32_8+4_8) ! { dg-error "too large" } + print *, len(s(1:2_8**32_8+3_8)) ! { dg-error "too large" } + print *, len(s(2_8**32_8+3_8:2_8**32_8+4_8)) ! { dg-error "too large" } + + print *, s(2_8**32_8+3_8:1) + print *, s(2_8**32_8+4_8:2_8**32_8+3_8) + print *, len(s(2_8**32_8+3_8:1)) + print *, len(s(2_8**32_8+4_8:2_8**32_8+3_8)) + +end subroutine Index: Fortran/gfortran/regression/string_3_lp64.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_3_lp64.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-require-effective-target lp64 } +! { dg-require-effective-target fortran_integer_16 } +subroutine foo(i) + implicit none + integer, intent(in) :: i + character(len=i) :: s + + s = '' + print *, s(1:2_16**64_16+3_16) ! { dg-error "too large" } + print *, s(2_16**64_16+3_16:2_16**64_16+4_16) ! { dg-error "too large" } + print *, len(s(1:2_16**64_16+3_16)) ! { dg-error "too large" } + print *, len(s(2_16**64_16+3_16:2_16**64_16+4_16)) ! { dg-error "too large" } + + print *, s(2_16**64_16+3_16:1) + print *, s(2_16**64_16+4_16:2_16**64_16+3_16) + print *, len(s(2_16**64_16+3_16:1)) + print *, len(s(2_16**64_16+4_16:2_16**64_16+3_16)) + +end subroutine Index: Fortran/gfortran/regression/string_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_4.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "" } +! (options to disable warnings about statement functions etc.) +! +! PR fortran/44352 +! +! Contributed by Vittorio Zecca +! + + SUBROUTINE TEST1() + implicit real*8 (a-h,o-z) + character*32 ddname,stmtfnt1 + stmtfnt1(x)= 'h810 e=0.01 ' + ddname=stmtfnt1(0.d0) + if (ddname /= "h810 e=0.01") STOP 1 + END + + SUBROUTINE TEST2() + implicit none + character(2) :: ddname,stmtfnt2 + real :: x + stmtfnt2(x)= 'x' + ddname=stmtfnt2(0.0) + if(ddname /= 'x') STOP 2 + END + + SUBROUTINE TEST3() + implicit real*8 (a-h,o-z) + character*32 ddname,dname + character*2 :: c + dname(c) = 'h810 e=0.01 ' + ddname=dname("w ") + if (ddname /= "h810 e=0.01") STOP 3 + END + + SUBROUTINE TEST4() + implicit real*8 (a-h,o-z) + character*32 ddname,dname + character*2 :: c + dname(c) = 'h810 e=0.01 ' + c = 'aa' + ddname=dname("w ") + if (ddname /= "h810 e=0.01") STOP 4 + if (c /= "aa") STOP 5 + END + + call test1() + call test2() + call test3() + call test4() + end Index: Fortran/gfortran/regression/string_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +program test + + ! PR fortran/48876 - this used to segfault. + ! Test case contributed by mhp77 (a) gmx.at. + character :: string = "string"( : -1 ) + + ! PR fortran/50409 + character v(3) + v = (/ ('123'(i:1), i = 3, 1, -1) /) + print *, v + +end program test + Index: Fortran/gfortran/regression/string_array_constructor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_array_constructor_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR 62242 +! Array constructor with an array element whose value is a +! character function that is described in an interface block and which +! has an assumed-length result +module gfbug + implicit none + INTERFACE + function UpperCase(string) result(upper) + character(*), intent(IN) :: string + character(LEN(string)) :: upper + end function + function f2(string) result(upper) + character(*), intent(IN) :: string + character(5) :: upper + end function + END INTERFACE +contains + subroutine s1 + character(5) c + character(5), dimension(1) :: ca + ca = (/f2(c)/) ! This compiles + ca = (/Uppercase(c)/) ! This gets an ICE + end subroutine +end module gfbug + Index: Fortran/gfortran/regression/string_array_constructor_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_array_constructor_2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! PR 62242 +! Array constructor with an array element whose value is a +! character function that is described in an interface block and which +! has an assumed-length result +module gfbug + implicit none + INTERFACE + function UpperCase(string) result(upper) + character(*), intent(IN) :: string + character(LEN(string)) :: upper + end function + function f2(string) result(upper) + character(*), intent(IN) :: string + character(5) :: upper + end function + END INTERFACE +contains + subroutine s1 + character(5) c + character(5), dimension(1) :: ca + character(5), dimension(1) :: cb + c = "12345" + ca = (/f2(c)/) ! This works + !print *, ca(1) + cb = (/Uppercase(c)/) ! This gets an ICE + if (ca(1) .ne. cb(1)) then + STOP 1 + end if + !print *, ca(1) + end subroutine +end module gfbug + +function UpperCase(string) result(upper) + character(*), intent(IN) :: string + character(LEN(string)) :: upper + upper = string +end function +function f2(string) result(upper) + character(*), intent(IN) :: string + character(5) :: upper + upper = string +end function + +program main + use gfbug + call s1 +end program Index: Fortran/gfortran/regression/string_array_constructor_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_array_constructor_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR 62242 +! A subprogram calling an array constructor with an array element whose +! value is the result of calling a character function with both an +! assumed-length argument and an assumed-length result +module gfbug + implicit none +contains + function inner(inner_str) result(upper) + character(*), intent(IN) :: inner_str + character(LEN(inner_str)) :: upper + + upper = '123' + end function + + subroutine outer(outer_str) + character(*), intent(IN) :: outer_str + character(5) :: z(1) + + z = [inner(outer_str)] + end subroutine +end module gfbug Index: Fortran/gfortran/regression/string_assign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_assign_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 52861 - optimize this to c = '' so that there is +! no memcpy in the generated code. +program main + character (len=20) :: c + c = ' ' + print *,c +end program main +! { dg-final { scan-tree-dump-times "memcpy" 0 "original" } } Index: Fortran/gfortran/regression/string_assign_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_assign_2.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +program main + character (len=:), allocatable :: a + a = 'a' + if (len(a) /= 1) STOP 1 + a = ' ' + if (len(a) /= 2) STOP 2 +end program main Index: Fortran/gfortran/regression/string_compare_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_compare_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run } + +! PR fortran/37099 +! Check for correct results when comparing array-section-substrings. + +PROGRAM main + IMPLICIT NONE + + CHARACTER(*), PARAMETER :: exprs(1) = (/ 'aa' /) + + CHARACTER(*), PARAMETER :: al1 = 'a'; + CHARACTER(len=LEN (al1)) :: al2 = al1; + + LOGICAL :: tmp(1), tmp2(1) + + tmp = (exprs(1:1)(1:1) == al1) + tmp2 = (exprs(1:1)(1:1) == al2) + + PRINT '(L1)', tmp + PRINT '(L1)', tmp2 + + IF (.NOT. tmp(1) .OR. .NOT. tmp2(1)) THEN + STOP 1 + END IF +END PROGRAM main Index: Fortran/gfortran/regression/string_compare_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_compare_2.f90 @@ -0,0 +1,37 @@ +! { dg-do run } + +! PR fortran/37099 +! Check for correct results when comparing array-section-substrings. + +! This is the original test from the PR. +! Contributed by Dominique d'Humieres + +module xparams + integer,parameter :: exprbeg=100,exprend=154 + character(*),dimension(exprbeg:exprend),parameter :: & + exprs=(/'nint() ','log10() ','sqrt() ','acos() ','asin() ', & + 'atan() ','cosh() ','sinh() ','tanh() ','int() ', & + 'cos() ','sin() ','tan() ','exp() ','log() ','abs() ',& + 'delta() ','step() ','rect() ','max(,) ','min(,) ','bj0() ',& + 'bj1() ','bjn(,) ','by0() ','by1() ','byn(,) ','logb(,) ',& + 'erf() ','erfc() ','lgamma()','gamma() ','csch() ','sech() ',& + 'coth() ','lif(,,) ','gaus() ','sinc() ','atan2(,)','mod(,) ',& + 'nthrt(,)','ramp() ','fbi() ','fbiq() ','uran(,) ','aif(,,,)',& + 'sgn() ','cbrt() ','fact() ','somb() ','bk0() ','bk1() ',& + 'bkn(,) ','bbi(,,) ','bbiq(,,)'/) + logical :: tmp(55,26) + character(26) :: al = 'abcdefghijklmnopqrstuvwxyz' +end + +program pack_bug + use xparams + do i = 1, 1 + tmp(:,i) = (exprs(:)(1:1)==al(i:i)) + print '(55L1)', exprs(:)(1:1)=='a' + print '(55L1)', tmp(:,i) + + if (any ((exprs(:)(1:1)=='a') .neqv. tmp(:,i))) then + STOP 1 + end if + end do +end Index: Fortran/gfortran/regression/string_compare_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_compare_3.f90 @@ -0,0 +1,21 @@ +! { dg-do run } + +! PR fortran/37099 +! Check for correct results when comparing array-section-substrings. + +! This is the test from comment #1 of the PR. +! Contributed by Dominique d'Humieres + +integer, parameter :: n = 10 +integer, parameter :: ilst(n) = (/(i,i=1,n)/) +character(*), parameter :: c0lst(n) = (/(char(96+i),i=1,n)/) +character(*), parameter :: c1lst(n) = (/(char(96+i)//'b',i=1,n)/) +logical :: tmp(n) +i = 5 +print *, ilst(:) == i +print *, c0lst(:)(1:1) == char(96+i) +tmp = c1lst(:)(1:1) == char(96+i) +print *, tmp +print *, c1lst(:)(1:1) == 'e' +if (any(tmp .neqv. (c0lst(:)(1:1) == char(96+i)))) STOP 1 +end Index: Fortran/gfortran/regression/string_compare_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_compare_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR fortran/52537 - optimize comparisons with empty strings +program main + implicit none + character(len=10) :: a + character(len=30) :: line + character(len=4,kind=4) :: c4 + line = 'x' + read (unit=line,fmt='(A)') a + c4 = 4_'foo' + if (c4 == 4_' ') print *,"foobar" + if (trim(a) == '') print *,"empty" + call foo(a) + if (trim(a) == ' ') print *,"empty" +contains + subroutine foo(b) + character(*) :: b + if (b /= ' ') print *,"full" + end subroutine foo +end program main +! { dg-final { scan-tree-dump-times "_gfortran_string_len_trim" 4 "original" } } Index: Fortran/gfortran/regression/string_ctor_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_ctor_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Program to test character array constructors. +! PR17144 +subroutine test1 (n, t, u) + integer n + character(len=n) :: s(2) + character(len=*) :: t + character(len=*) :: u + + ! A variable array constructor. + s = (/t, u/) + ! An array constructor as part of an expression. + if (any (s .ne. (/"Hell", "Worl"/))) STOP 1 +end subroutine + +subroutine test2 + character*5 :: s(2) + + ! A constant array constructor + s = (/"Hello", "World"/) + if ((s(1) .ne. "Hello") .or. (s(2) .ne. "World")) STOP 2 +end subroutine + +subroutine test3 + character*1 s(26) + character*26 t + integer i + + ! A large array constructor + s = (/'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', & + 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'/) + do i=1, 26 + t(i:i) = s(i) + end do + + ! Assignment with dependency + s = (/(s(27-i), i=1, 26)/) + do i=1, 26 + t(i:i) = s(i) + end do + if (t .ne. "zyxwvutsrqponmlkjihgfedcba") STOP 3 +end subroutine + +program string_ctor_1 + call test1 (4, "Hello", "World") + call test2 + call test3 +end program + Index: Fortran/gfortran/regression/string_length_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_length_1.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! Testcase for PR 31203 +! We used to create strings with negative length +subroutine foo(i) + integer :: i + character(len=i) :: s(2) + if (len(s) < 0) STOP 1 + if (len(s) /= max(i,0)) STOP 2 +end + +function gee(i) + integer, intent(in) :: i + character(len=i) :: gee + + gee = "" +end function gee + +subroutine s1(i,j) + character(len=i-j) :: a + if (len(a) < 0) STOP 1 +end subroutine + +program test + interface + function gee(i) + integer, intent(in) :: i + character(len=i) :: gee + end function gee + end interface + + call foo(2) + call foo(-1) + call s1(1,2) + call s1(-1,-8) + call s1(-8,-1) + + if (len(gee(2)) /= 2) STOP 3 + if (len(gee(-5)) /= 0) STOP 4 + if (len(gee(intfunc(3))) /= max(intfunc(3),0)) STOP 5 + if (len(gee(intfunc(2))) /= max(intfunc(2),0)) STOP 6 + + if (len(bar(2)) /= 2) STOP 7 + if (len(bar(-5)) /= 0) STOP 8 + if (len(bar(intfunc(3))) /= max(intfunc(3),0)) STOP 9 + if (len(bar(intfunc(2))) /= max(intfunc(2),0)) STOP 10 + + if (cow(bar(2)) /= 2) STOP 11 + if (cow(bar(-5)) /= 0) STOP 12 + if (cow(bar(intfunc(3))) /= max(intfunc(3),0)) STOP 13 + if (cow(bar(intfunc(2))) /= max(intfunc(2),0)) STOP 14 + +contains + + function bar(i) + integer, intent(in) :: i + character(len=i) :: bar + + bar = "" + end function bar + + function cow(c) + character(len=*), intent(in) :: c + integer :: cow + cow = len(c) + end function cow + + pure function intfunc(i) + integer, intent(in) :: i + integer :: intfunc + + intfunc = 2*i-5 + end function intfunc + +end program test Index: Fortran/gfortran/regression/string_length_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_length_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! Test that all string length calculations are +! optimized away. +program main + character (len=999) :: c + character (len=5) :: unit + unit = ' ' + read (unit=unit,fmt='(I5)') i ! Hide from optimizers + j = 7 + c = '123456789' + if (len(c( 3 : 5 )) /= 3) STOP 1! Case 1 + if (len(c( i*(i+1) : (i+1)*i + 2 )) /= 3) STOP 2! Case 2 + if (len(c( i*(i+1) : 2 + (i+1)*i )) /= 3) STOP 3! Case 3 + if (len(c( i*(i+1) + 2 : (i+1)*i + 3 )) /= 2) STOP 4! Case 4 + if (len(c( 2 + i*(i+1) : (i+1)*i + 3 )) /= 2) STOP 5! Case 5 + if (len(c( i*(i+1) + 2 : 3 + (i+1)*i )) /= 2) STOP 6! Case 6 + if (len(c( 2 + i*(i+1) : 3 + (i+1)*i )) /= 2) STOP 7! Case 7 + if (len(c( i*(i+1) - 1 : (i+1)*i + 1 )) /= 3) STOP 8! Case 8 + if (len(c( i*(i+1) - 1 : 1 + (i+1)*i )) /= 3) STOP 9! Case 9 + if (len(c( i*(i+1) : (i+1)*i -(-1))) /= 2) STOP 10! Case 10 + if (len(c( i*(i+1) +(-2): (i+1)*i - 1 )) /= 2) STOP 11! Case 11 + if (len(c( i*(i+1) + 2 : (i+1)*i -(-4))) /= 3) STOP 12! Case 12 + if (len(c( i*(i+1) - 3 : (i+1)*i - 1 )) /= 3) STOP 13! Case 13 + if (len(c(13 - i*(i+1) :15 - (i+1)*i )) /= 3) STOP 14! Case 14 + if (len(c( i*(i+1) +(-1): (i+1)*i )) /= 2) STOP 15! Case 15 + if (len(c(-1 + i*(i+1) : (i+1)*i )) /= 2) STOP 16! Case 16 + if (len(c( i*(i+1) - 2 : (i+1)*i )) /= 3) STOP 17! Case 17 + if (len(c( (i-2)*(i-3) : (i-3)*(i-2) )) /= 1) STOP 18! Case 18 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_stop" 0 "original" } } Index: Fortran/gfortran/regression/string_length_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_length_3.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 78021 - calls to mylen were folded after shortening the +! argument list. + +PROGRAM test_o_char + implicit none + integer :: n + n = mylen('c') + mylen('c ') + if (n /= 5) STOP 1 +CONTAINS + + FUNCTION mylen(c) + CHARACTER(len=*),INTENT(in) :: c + INTEGER :: mylen + mylen=LEN(c) + END FUNCTION mylen +END PROGRAM test_o_char +! { dg-final { scan-tree-dump-times "__var" 0 "original" } } Index: Fortran/gfortran/regression/string_length_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_length_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-require-effective-target lto } +! { dg-options "-flto" } +! PR 78867, test case adapted from gfortran.dg/string_length_1.f90 +program pr78867 + if (len(bar(2_8)) /= 2) STOP 1 +contains + + function bar(i) + integer(8), intent(in) :: i + character(len=i) :: bar + + bar = "" + end function bar + +end program pr78867 Index: Fortran/gfortran/regression/string_null_compare_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_null_compare_1.f @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 27784 - Different strings should compare unequal even if they +! have CHAR(0) in them. + + program main + character*3 str1, str2 + call setval(str1, str2) + if (str1 == str2) STOP 1 + end + + subroutine setval(str1, str2) + character*3 str1, str2 + str1 = 'a' // CHAR(0) // 'a' + str2 = 'a' // CHAR(0) // 'c' + end Index: Fortran/gfortran/regression/string_pad_trunc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/string_pad_trunc.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR20713. Pad and truncate string. + +character(len = 6),parameter:: a = 'hello' +character(len = 6),parameter:: b = 'hello *' +character(len = 6),parameter:: c (1:1) = 'hello' +character(len = 11) line + +write (line, '(6A)') a, 'world' +if (line .ne. 'hello world') STOP 1 + +write (line, '(6A)') b, 'world' +if (line .ne. 'hello world') STOP 2 + +write (line, '(6A)') c, 'world' +if (line .ne. 'hello world') STOP 3 + +write (line, '(6A)') c(1), 'world' +if (line .ne. 'hello world') STOP 4 +end Index: Fortran/gfortran/regression/structure_constructor_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_1.f03 @@ -0,0 +1,74 @@ +! { dg-do run } +! Simple structure constructors, without naming arguments, default values +! or inheritance and the like. + +PROGRAM test + IMPLICIT NONE + + ! Empty structuer + TYPE :: empty_t + END TYPE empty_t + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i + REAL :: r + COMPLEX :: c + LOGICAL :: l + END TYPE basics_t + + ! Structure with strings + TYPE :: strings_t + CHARACTER(len=5) :: str1, str2 + CHARACTER(len=10) :: long + END TYPE strings_t + + ! Structure with arrays + TYPE :: array_t + INTEGER :: ints(2:5) + REAL :: matrix(2, 2) + END TYPE array_t + + ! Structure containing structures + TYPE :: nestedStruct_t + TYPE(basics_t) :: basics + TYPE(array_t) :: arrays + END TYPE nestedStruct_t + + TYPE(empty_t) :: empty + TYPE(basics_t) :: basics + TYPE(strings_t) :: strings + TYPE(array_t) :: arrays + TYPE(nestedStruct_t) :: nestedStruct + + empty = empty_t () + + basics = basics_t (42, -1.5, (.5, .5), .FALSE.) + IF (basics%i /= 42 .OR. basics%r /= -1.5 & + .OR. basics%c /= (.5, .5) .OR. basics%l) THEN + STOP 1 + END IF + + strings = strings_t ("hello", "abc", "this one is long") + IF (strings%str1 /= "hello" .OR. strings%str2 /= "abc" & + .OR. strings%long /= "this one i") THEN + STOP 2 + END IF + + arrays = array_t ( (/ 1, 2, 3, 4 /), RESHAPE((/ 5, 6, 7, 8 /), (/ 2, 2 /)) ) + IF (arrays%ints(2) /= 1 .OR. arrays%ints(3) /= 2 & + .OR. arrays%ints(4) /= 3 .OR. arrays%ints(5) /= 4 & + .OR. arrays%matrix(1, 1) /= 5. .OR. arrays%matrix(2, 1) /= 6. & + .OR. arrays%matrix(1, 2) /= 7. .OR. arrays%matrix(2, 2) /= 8.) THEN + STOP 3 + END IF + + nestedStruct = nestedStruct_t (basics_t (42, -1.5, (.5, .5), .FALSE.), arrays) + IF (nestedStruct%basics%i /= 42 .OR. nestedStruct%basics%r /= -1.5 & + .OR. nestedStruct%basics%c /= (.5, .5) .OR. nestedStruct%basics%l & + .OR. ANY(nestedStruct%arrays%ints /= arrays%ints) & + .OR. ANY(nestedStruct%arrays%matrix /= arrays%matrix)) THEN + STOP 4 + END IF + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_10.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 41070: [4.5 Regression] Error: Components of structure constructor '' at (1) are PRIVATE +! +! Contributed by Michael Richmond + +MODULE cdf_aux_mod +IMPLICIT NONE + +TYPE :: one_parameter + CHARACTER (8) :: name +END TYPE one_parameter + +TYPE :: the_distribution + CHARACTER (8) :: name +END TYPE the_distribution + +TYPE (the_distribution), PARAMETER :: the_beta = the_distribution('cdf_beta') +END MODULE cdf_aux_mod + +SUBROUTINE cdf_beta() + USE cdf_aux_mod + IMPLICIT NONE + CALL check_complements(the_beta%name) +END SUBROUTINE cdf_beta Index: Fortran/gfortran/regression/structure_constructor_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_11.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54603 +! +! Contributed by Kacper Kowalik +! +module foo + implicit none + + interface + subroutine cg_ext + implicit none + end subroutine cg_ext + end interface + + type :: ext_ptr + procedure(cg_ext), nopass, pointer :: init + procedure(cg_ext), nopass, pointer :: cleanup + end type ext_ptr + + type :: ext_ptr_array + type(ext_ptr) :: a + contains + procedure :: epa_init + end type ext_ptr_array + + type(ext_ptr_array) :: bar + +contains + subroutine epa_init(this, init, cleanup) + implicit none + class(ext_ptr_array), intent(inout) :: this + procedure(cg_ext), pointer, intent(in) :: init + procedure(cg_ext), pointer, intent(in) :: cleanup + + this%a = ext_ptr(null(), null()) ! Wrong code + this%a = ext_ptr(init, cleanup) ! Wrong code + + this%a%init => init ! OK + this%a%cleanup => cleanup ! OK + + this%a = ext_ptr(this%a%init,this%a%cleanup) ! ICE in fold_convert_loc + end subroutine epa_init + +end module foo + +program ala + use foo, only: bar + implicit none + integer :: count1, count2 + count1 = 0 + count2 = 0 + + call setme + call bar%a%cleanup() + call bar%a%init() + + ! They should be called once + if (count1 /= 23 .or. count2 /= 42) STOP 1 + +contains + + subroutine dummy1 + implicit none + !print *, 'dummy1' + count1 = 23 + end subroutine dummy1 + + subroutine dummy2 + implicit none + !print *, 'dummy2' + count2 = 42 + end subroutine dummy2 + + subroutine setme + use foo, only: bar, cg_ext + implicit none + procedure(cg_ext), pointer :: a_init, a_clean + + a_init => dummy1 + a_clean => dummy2 + call bar%epa_init(a_init, a_clean) + end subroutine setme + +end program ala + +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = this->_data->a.init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = this->_data->a.cleanup;" 1 "original" } } Index: Fortran/gfortran/regression/structure_constructor_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_12.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/64943 +! +! Contributed Dominique d'Humieres +! + type :: Test + integer :: i + end type + + type :: TestReference + class(Test), allocatable :: test(:) + end type +print *, TestReference([Test(99), Test(199)]) ! { dg-error "Data transfer element at .1. cannot have ALLOCATABLE components unless it is processed by a defined input/output procedure" } +end Index: Fortran/gfortran/regression/structure_constructor_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_13.f03 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Contributed by Melven Roehrig-Zoellner +! PR fortran/66035 + +program test_pr66035 + type t + end type t + type w + class(t), allocatable :: c + end type w + + type(t) :: o + + call test(o) +contains + subroutine test(o) + class(t), intent(inout) :: o + type(w), dimension(:), allocatable :: list + + select type (o) + class is (t) + list = [w(o)] ! This caused an ICE + class default + STOP 1 + end select + end subroutine +end program Index: Fortran/gfortran/regression/structure_constructor_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_14.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR 48890, PR 83823 +! Test fix for wrong length in parameters. Original test cases +! by mhp77 (a) gmx.at and Harald Anlauf. + +program gfcbug145 + implicit none + type t_obstyp + character(len=8) :: name + end type t_obstyp + type (t_obstyp) ,parameter :: obstyp(*)= & + [ t_obstyp ('SYNOP' ), & + t_obstyp ('DRIBU' ), & + t_obstyp ('TEMP' ), & + t_obstyp ('RADAR' ) ] + logical :: mask(size(obstyp)) = .true. + character(len=100) :: line + type (t_obstyp), parameter :: x = t_obstyp('asdf') + + write(line,'(20(a8,:,"|"))') pack (obstyp% name, mask) + if (line /= 'SYNOP |DRIBU |TEMP |RADAR') STOP 1 + write (line,'("|",A,"|")') x + if (line /= "|asdf |") STOP 2 +end program gfcbug145 Index: Fortran/gfortran/regression/structure_constructor_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_15.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR 85083 +! +! Testcase from PR by G. Steinmetz +! +program p + type t + character(3) :: c + end type t + type(t), allocatable :: z + allocate (z, source=t(.true.,'abc')) ! { dg-error "Too many components" } +end Index: Fortran/gfortran/regression/structure_constructor_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_16.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-Wcharacter-truncation" } +! PR 82743 - warnings were missing on truncation of structure +! constructors. +! Original test case by Simon Klüpfel +PROGRAM TEST + TYPE A + CHARACTER(LEN=1) :: C + END TYPE A + TYPE(A) :: A1 + A1=A("123") ! { dg-warning "CHARACTER expression will be truncated" } + A1=A(C="123") ! { dg-warning "CHARACTER expression will be truncated" } + A1%C="123" ! { dg-warning "CHARACTER expression will be truncated" } +END PROGRAM TEST Index: Fortran/gfortran/regression/structure_constructor_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_17.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! Test the fix for PR97612. +! +! Contributed by Martin Stein +! +program constructor_allocatable + implicit none + + type :: s + integer, dimension(:), allocatable :: u + end type s + + type :: t + type(s), dimension(:), allocatable :: x + end type t + + type(t) :: a = t() + if (allocated (a%x)) stop 1 + +end program constructor_allocatable Index: Fortran/gfortran/regression/structure_constructor_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_2.f03 @@ -0,0 +1,29 @@ +! { dg-do run } +! Structure constructor with component naming. + +PROGRAM test + IMPLICIT NONE + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i + REAL :: r + COMPLEX :: c + LOGICAL :: l + END TYPE basics_t + + TYPE(basics_t) :: basics + + basics = basics_t (42, -1.5, c=(.5, .5), l=.FALSE.) + IF (basics%i /= 42 .OR. basics%r /= -1.5 & + .OR. basics%c /= (.5, .5) .OR. basics%l) THEN + STOP 1 + END IF + + basics = basics_t (r=-1.5, i=42, l=.FALSE., c=(.5, .5)) + IF (basics%i /= 42 .OR. basics%r /= -1.5 & + .OR. basics%c /= (.5, .5) .OR. basics%l) THEN + STOP 2 + END IF + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_3.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Structure constructor with component naming, test that an error is emitted +! if there are arguments without name after ones with name. + +PROGRAM test + IMPLICIT NONE + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i + REAL :: r + END TYPE basics_t + + TYPE(basics_t) :: basics + + basics = basics_t (i=42, 1.5) ! { dg-error "Missing keyword name" } + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_4.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Structure constructor with component naming, test that an error is emitted if +! a component is given two initializers. + +PROGRAM test + IMPLICIT NONE + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i + REAL :: r + END TYPE basics_t + + TYPE(basics_t) :: basics + + basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" } + basics = basics_t (42, r=1., r=-2.) ! { dg-error "has already appeared in the current argument list" } + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_5.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! Structure constructor with default initialization. + +PROGRAM test + IMPLICIT NONE + + ! Type with all default values + TYPE :: quasiempty_t + CHARACTER(len=5) :: greeting = "hello" + END TYPE quasiempty_t + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i = 42 + REAL :: r + COMPLEX :: c = (0., 1.) + END TYPE basics_t + + TYPE(quasiempty_t) :: empty + TYPE(basics_t) :: basics + + empty = quasiempty_t () + IF (empty%greeting /= "hello") THEN + STOP 1 + END IF + + basics = basics_t (r = 1.5) + IF (basics%i /= 42 .OR. basics%r /= 1.5 .OR. basics%c /= (0., 1.)) THEN + STOP 2 + END IF + + basics%c = (0., 0.) ! So we see it's surely gotten re-initialized + basics = basics_t (1, 5.1) + IF (basics%i /= 1 .OR. basics%r /= 5.1 .OR. basics%c /= (0., 1.)) THEN + STOP 3 + END IF + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_6.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Structure constructor with default initialization, test that an error is +! emitted for components without default initializer missing value. + +PROGRAM test + IMPLICIT NONE + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i = 42 + REAL :: r + COMPLEX :: c = (0., 1.) + END TYPE basics_t + + TYPE(basics_t) :: basics + + basics = basics_t (i = 42) ! { dg-error "No initializer for component 'r'" } + basics = basics_t (42) ! { dg-error "No initializer for component 'r'" } + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_7.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Test for errors when excess components are given for a structure-constructor. + +PROGRAM test + IMPLICIT NONE + + ! Structure of basic data types + TYPE :: basics_t + INTEGER :: i + REAL :: r = 1.5 + END TYPE basics_t + + TYPE(basics_t) :: basics + + basics = basics_t (42, 1.5, 1000) ! { dg-error "Too many components" } + basics = basics_t (42, xxx = 1000) ! { dg-error "is not a member" } + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_8.f03 @@ -0,0 +1,60 @@ +! { dg-do compile } +! Test for errors when setting private components inside a structure constructor +! or when constructing a private structure. + +MODULE privmod + IMPLICIT NONE + + TYPE :: haspriv_t + INTEGER :: a + INTEGER, PRIVATE :: b = 42 + END TYPE haspriv_t + + TYPE :: allpriv_t + PRIVATE + INTEGER :: a = 25 + END TYPE allpriv_t + + TYPE, PRIVATE :: ispriv_t + INTEGER :: x + END TYPE ispriv_t + +CONTAINS + + SUBROUTINE testfunc () + IMPLICIT NONE + TYPE(haspriv_t) :: struct1 + TYPE(allpriv_t) :: struct2 + TYPE(ispriv_t) :: struct3 + + ! This should succeed from within the module, no error. + struct1 = haspriv_t (1, 2) + struct2 = allpriv_t (42) + struct3 = ispriv_t (42) + END SUBROUTINE testfunc + +END MODULE privmod + +PROGRAM test + USE privmod + IMPLICIT NONE + + TYPE(haspriv_t) :: struct1 + TYPE(allpriv_t) :: struct2 + + ! This should succeed, not giving value to private component + struct1 = haspriv_t (5) + struct2 = allpriv_t () + + ! These should fail + struct1 = haspriv_t (1, 2) ! { dg-error "is a PRIVATE component" } + struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "is a PRIVATE component" } + + ! This should fail as all components are private + struct2 = allpriv_t (5) ! { dg-error "is a PRIVATE component" } + + ! This should fail as the type itself is private, and the expression should + ! be deduced as call to an undefined function. + WRITE (*,*) ispriv_t (5) ! { dg-error "has no IMPLICIT type" } + +END PROGRAM test Index: Fortran/gfortran/regression/structure_constructor_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/structure_constructor_9.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Check for notify-std-messages when F2003 structure constructors are compiled +! with -std=f95. + +PROGRAM test + IMPLICIT NONE + + ! Basic type with default initializers + TYPE :: basics_t + INTEGER :: i = 42 + REAL :: r = 1.5 + END TYPE basics_t + + TYPE(basics_t) :: basics + + ! This is ok in F95 + basics = basics_t (1, 2.) + + ! No argument naming in F95 + basics = basics_t (1, r = 4.2) ! { dg-error "Fortran 2003" } + + ! No optional arguments in F95 + basics = basics_t () ! { dg-error "Fortran 2003" } + basics = basics_t (5) ! { dg-error "Fortran 2003" } + +END PROGRAM test Index: Fortran/gfortran/regression/submodule_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_1.f08 @@ -0,0 +1,172 @@ +! { dg-do run } +! +! Basic test of submodule functionality. +! +! Contributed by Paul Thomas +! + module foo_interface + implicit none + character(len = 100) :: message + character(len = 100) :: message2 + + type foo + character(len=15) :: greeting = "Hello, world! " + character(len=15), private :: byebye = "adieu, world! " + contains + procedure :: greet => say_hello + procedure :: farewell => bye + procedure, private :: adieu => byebye + end type foo + + interface + module subroutine say_hello(this) + class(foo), intent(in) :: this + end subroutine + + module subroutine bye(this) + class(foo), intent(in) :: this + end subroutine + + module subroutine byebye(this, that) + class(foo), intent(in) :: this + class(foo), intent(inOUT), allocatable :: that + end subroutine + + module function realf (arg) result (res) + real :: arg, res + end function + + integer module function intf (arg) + integer :: arg + end function + + real module function realg (arg) + real :: arg + end function + + integer module function intg (arg) + integer :: arg + end function + + end interface + + integer :: factor = 5 + + contains + + subroutine smurf + class(foo), allocatable :: this + allocate (this) + message = "say_hello from SMURF --->" + call say_hello (this) + end subroutine + end module + +! + SUBMODULE (foo_interface) foo_interface_son +! + contains +! Test module procedure with conventional specification part for dummies + module subroutine say_hello(this) + class(foo), intent(in) :: this + class(foo), allocatable :: that + allocate (that, source = this) +! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time +! due to recursion through the call to this procedure from +! say hello. + message = that%greeting + +! Check that descendant module procedure is correctly processed + if (intf (77) .ne. factor*77) STOP 1 + end subroutine + + module function realf (arg) result (res) + real :: arg, res + res = 2*arg + end function + + end SUBMODULE foo_interface_son + +! +! Check that multiple generations of submodules are OK + SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson +! + contains + + module procedure intf + intf = factor*arg + end PROCEDURE + + end SUBMODULE foo_interface_grandson + +! + SUBMODULE (foo_interface) foo_interface_daughter +! + contains +! Test module procedure with abbreviated declaration and no specification of dummies + module procedure bye + class(foo), allocatable :: that + call say_hello (this) +! check access to a PRIVATE procedure pointer that accesses a private component + call this%adieu (that) + message2 = that%greeting + end PROCEDURE + +! Test module procedure pointed to by PRIVATE component of foo + module procedure byebye + allocate (that, source = this) +! Access a PRIVATE component of foo + that%greeting = that%byebye + end PROCEDURE + + module procedure intg + intg = 3*arg + end PROCEDURE + + module procedure realg + realg = 3*arg + end PROCEDURE + + end SUBMODULE foo_interface_daughter + +! + program try + use foo_interface + implicit none + type(foo) :: bar + + call clear_messages + call bar%greet ! typebound call + if (trim (message) .ne. "Hello, world!") STOP 2 + + call clear_messages + bar%greeting = "G'day, world!" + call say_hello(bar) ! Checks use association of 'say_hello' + if (trim (message) .ne. "G'day, world!") STOP 3 + + call clear_messages + bar%greeting = "Hi, world!" + call bye(bar) ! Checks use association in another submodule + if (trim (message) .ne. "Hi, world!") STOP 4 + if (trim (message2) .ne. "adieu, world!") STOP 5 + + call clear_messages + call smurf ! Checks host association of 'say_hello' + if (trim (message) .ne. "Hello, world!") STOP 6 + + call clear_messages + bar%greeting = "farewell " + call bar%farewell + if (trim (message) .ne. "farewell") STOP 7 + if (trim (message2) .ne. "adieu, world!") STOP 8 + + if (realf(2.0) .ne. 4.0) STOP 9! Check module procedure with explicit result + if (intf(2) .ne. 10) STOP 10! ditto + if (realg(3.0) .ne. 9.0) STOP 11! Check module procedure with function declaration result + if (intg(3) .ne. 9) STOP 12! ditto + contains + subroutine clear_messages + message = "" + message2 = "" + end subroutine + end program Index: Fortran/gfortran/regression/submodule_10.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_10.f08 @@ -0,0 +1,169 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! Checks that PRIVATE enities are visible to submodules. +! +! Contributed by Salvatore Filippone +! +module const_mod + integer, parameter :: ndig=8 + integer, parameter :: ipk_ = selected_int_kind(ndig) + integer, parameter :: longndig=12 + integer, parameter :: long_int_k_ = selected_int_kind(longndig) + integer, parameter :: mpik_ = kind(1) + + integer(ipk_), parameter, public :: success_=0 + +end module const_mod + + +module error_mod + use const_mod + + integer(ipk_), parameter, public :: act_ret_=0 + integer(ipk_), parameter, public :: act_print_=1 + integer(ipk_), parameter, public :: act_abort_=2 + + integer(ipk_), parameter, public :: no_err_ = 0 + + public error, errcomm, get_numerr, & + & error_handler, & + & ser_error_handler, par_error_handler + + + interface error_handler + module subroutine ser_error_handler(err_act) + integer(ipk_), intent(inout) :: err_act + end subroutine ser_error_handler + module subroutine par_error_handler(ictxt,err_act) + integer(mpik_), intent(in) :: ictxt + integer(ipk_), intent(in) :: err_act + end subroutine par_error_handler + end interface + + interface error + module subroutine serror() + end subroutine serror + module subroutine perror(ictxt,abrt) + integer(mpik_), intent(in) :: ictxt + logical, intent(in), optional :: abrt + end subroutine perror + end interface + + + interface error_print_stack + module subroutine par_error_print_stack(ictxt) + integer(mpik_), intent(in) :: ictxt + end subroutine par_error_print_stack + module subroutine ser_error_print_stack() + end subroutine ser_error_print_stack + end interface + + interface errcomm + module subroutine errcomm(ictxt, err) + integer(mpik_), intent(in) :: ictxt + integer(ipk_), intent(inout):: err + end subroutine errcomm + end interface errcomm + + + private + + type errstack_node + + integer(ipk_) :: err_code=0 + character(len=20) :: routine='' + integer(ipk_),dimension(5) :: i_err_data=0 + character(len=40) :: a_err_data='' + type(errstack_node), pointer :: next + + end type errstack_node + + + type errstack + type(errstack_node), pointer :: top => null() + integer(ipk_) :: n_elems=0 + end type errstack + + + type(errstack), save :: error_stack + integer(ipk_), save :: error_status = no_err_ + integer(ipk_), save :: verbosity_level = 1 + integer(ipk_), save :: err_action = act_abort_ + integer(ipk_), save :: debug_level = 0, debug_unit, serial_debug_level=0 + +contains +end module error_mod + +submodule (error_mod) error_impl_mod + use const_mod +contains + ! checks whether an error has occurred on one of the processes in the execution pool + subroutine errcomm(ictxt, err) + integer(mpik_), intent(in) :: ictxt + integer(ipk_), intent(inout):: err + + + end subroutine errcomm + + subroutine ser_error_handler(err_act) + implicit none + integer(ipk_), intent(inout) :: err_act + + if (err_act /= act_ret_) & + & call error() + if (err_act == act_abort_) stop + + return + end subroutine ser_error_handler + + subroutine par_error_handler(ictxt,err_act) + implicit none + integer(mpik_), intent(in) :: ictxt + integer(ipk_), intent(in) :: err_act + + if (err_act == act_print_) & + & call error(ictxt, abrt=.false.) + if (err_act == act_abort_) & + & call error(ictxt, abrt=.true.) + + return + + end subroutine par_error_handler + + subroutine par_error_print_stack(ictxt) + integer(mpik_), intent(in) :: ictxt + + call error(ictxt, abrt=.false.) + + end subroutine par_error_print_stack + + subroutine ser_error_print_stack() + + call error() + end subroutine ser_error_print_stack + + subroutine serror() + + implicit none + + end subroutine serror + + subroutine perror(ictxt,abrt) + use const_mod + implicit none + integer(mpik_), intent(in) :: ictxt + logical, intent(in), optional :: abrt + + end subroutine perror + +end submodule error_impl_mod + +program testlk + use error_mod + implicit none + + call error() + + stop +end program testlk Index: Fortran/gfortran/regression/submodule_11.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_11.f08 @@ -0,0 +1,45 @@ +! { dg-do run } +! Test the fix for PR66993, in which the use associated version of 'i' +! was incorrectly determined to be ambiguous with the 'i', host associated +! in submodule 'sm' from the module 'm'. The principle has been tested with +! the function 'time_two' in addition. +! +! Contributed by Mikael Morin +! +module m + integer, parameter :: i = -1 + interface + module subroutine show_i + end subroutine show_i + end interface +contains + integer function times_two (arg) + integer :: arg + times_two = -2*arg + end function +end module m + +module n + integer, parameter :: i = 2 +contains + integer function times_two (arg) + integer :: arg + times_two = 2*arg + end function +end module n + +submodule (m) sm + use n +contains + module subroutine show_i + if (i .ne. 2) STOP 1 + if (times_two (i) .ne. 4) STOP 2 + end subroutine show_i +end submodule sm + +program p + use m + call show_i + if (i .ne. -1) STOP 3 + if (times_two (i) .ne. 2) STOP 4 +end program Index: Fortran/gfortran/regression/submodule_12.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_12.f08 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Test the fix for PR68237 in which 'foo' caused a seg fault rather than an error. +! +! Contributed by Martin Reinecke +! +module m1 + interface + module subroutine bar + end subroutine + end interface +end module m1 + +submodule (m1) m2 +contains + module procedure foo ! { dg-error "must be in a generic module interface" } + end procedure ! { dg-error "Expecting END SUBMODULE statement" } +end submodule Index: Fortran/gfortran/regression/submodule_13.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_13.f08 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! Checks the fix for PR68534 in which checks for the number +! failed if either the interface or the module procedure had +! no dummies. +! +! Reported on clf at: +! https://groups.google.com/forum/#!topic/comp.lang.fortran/-ZgbM5qkFmc +! +module m + implicit none + interface + module subroutine foo() + end subroutine foo + + module subroutine bar(i) + integer, intent(inout) :: i + end subroutine bar + end interface +end module m + +submodule(m) sm +contains + module subroutine foo(i) ! { dg-error "Mismatch in number of MODULE PROCEDURE formal" } + integer, intent(inout) :: i + i = 42 + end subroutine foo + + module subroutine bar ! { dg-error "Mismatch in number of MODULE PROCEDURE formal" } + print *, "bar" + end subroutine bar +end submodule sm Index: Fortran/gfortran/regression/submodule_14.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_14.f08 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! Check the fix for PR70031, where the 'module' prefix had to preceed +! 'function/subroutine' in the interface (or in the CONTAINS section. +! +! As reported by "Bulova" on +! https://groups.google.com/forum/#!topic/comp.lang.fortran/hE8LkVMhghQ +! +module test + Interface + Module Recursive Subroutine sub1 (x) + Integer, Intent (InOut) :: x + End Subroutine sub1 + module recursive function fcn1 (x) result(res) + integer, intent (inout) :: x + integer :: res + end function + End Interface +end module test + +submodule(test) testson + integer :: n = 10 +contains + Module Procedure sub1 + If (x < n) Then + x = x + 1 + Call sub1 (x) + End If + End Procedure sub1 + recursive module function fcn1 (x) result(res) + integer, intent (inout) :: x + integer :: res + res = x - 1 + if (x > 0) then + x = fcn1 (res) + else + res = x + end if + end function +end submodule testson + + use test + integer :: x = 5 + call sub1(x) + if (x .ne. 10) STOP 1 + x = 10 + if (fcn1 (x) .ne. 0) STOP 2 +end Index: Fortran/gfortran/regression/submodule_15.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_15.f08 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Check the fix for PR69524, where module procedures were not permitted +! in a module CONTAINS section. +! +! Reorted by Kirill Yukhin +! +module A + implicit none + interface + module subroutine A1(i) + integer, intent(inout) :: i + end subroutine A1 + module subroutine A2(i) + integer, intent(inout) :: i + end subroutine A2 + integer module function A3(i) + integer, intent(inout) :: i + end function A3 + module subroutine B1(i) + integer, intent(inout) :: i + end subroutine B1 + end interface + integer :: incr ! Make sure that everybody can access a module variable +contains + module subroutine A1(i) ! Full declaration + integer, intent(inout) :: i + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + end subroutine A1 + + module PROCEDURE A2 ! Abreviated declaration + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + end procedure A2 + + module PROCEDURE A3 ! Abreviated declaration + call a1 (i) ! Call the module procedure in the module + call a2 (i) ! ditto + call b1 (i) ! Call the submodule procedure + incr = incr + 1 + a3 = i + incr + end procedure A3 +end module A + +submodule (A) a_son + implicit none +contains + module procedure b1 + i = i + incr + end procedure +end submodule + + use A + integer :: i = 1 + incr = 1 + if (a3(i) .ne. 11) STOP 1 +end Index: Fortran/gfortran/regression/submodule_16.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_16.f08 @@ -0,0 +1,53 @@ +! { dg-do compile } +! +! Tests the fix for PR71156 in which the valid code (f7, f8 and f9 below) +! triggered an error, while the invalid code (f1 to f6) compiled. +! +! Contributed by Damian Rousn +! +module my_interface + implicit none + interface + module subroutine f1 + end subroutine + module subroutine f2 + end subroutine + module subroutine f3 + end subroutine + elemental module subroutine f4 + end subroutine + pure module subroutine f5 + end subroutine + recursive module subroutine f6 + end subroutine + elemental module subroutine f7 + end subroutine + pure module subroutine f8 + end subroutine + recursive module subroutine f9 + end subroutine + end interface +end module + +submodule(my_interface) my_implementation + implicit none +contains + elemental module subroutine f1 ! { dg-error "Mismatch in ELEMENTAL attribute" } + end subroutine + pure module subroutine f2 ! { dg-error "Mismatch in PURE attribute" } + end subroutine + recursive module subroutine f3 ! { dg-error "Mismatch in RECURSIVE attribute" } + end subroutine + module subroutine f4 ! { dg-error "ELEMENTAL prefix" } + end subroutine + module subroutine f5 ! { dg-error "PURE prefix" } + end subroutine + module subroutine f6 ! { dg-error "RECURSIVE prefix" } + end subroutine + elemental module subroutine f7 + end subroutine + pure module subroutine f8 + end subroutine + recursive module subroutine f9 + end subroutine +end submodule Index: Fortran/gfortran/regression/submodule_17.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_17.f08 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Tests the fix for PR77358, in which the wrong gfc_charlen was +! being used for the result of 'get'. +! +! Contributed by Damian Rouson +! +module hello_interface + character(len=13) :: string="Hello, world!" + interface + module function get() result(result_string) + character(:), allocatable :: result_string + end function + end interface +end module + +submodule(hello_interface) hello_implementation +contains + module function get() result(result_string) + character(:), allocatable :: result_string + result_string = string + end function +end submodule + + use hello_interface + if (get() .ne. string) STOP 1 +end Index: Fortran/gfortran/regression/submodule_18.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_18.f08 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Tests the fix for PR78108 in which an error was +! triggered by the module procedures being added twice +! to the operator interfaces. +! +! Contributed by Damian Rouson +! +module foo_interface + implicit none + type foo + integer :: x + contains + procedure :: add + generic :: operator(+) => add + procedure :: mult + generic :: operator(*) => mult + end type + interface + integer module function add(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + end function + integer module function mult(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + end function + end interface +end module +submodule(foo_interface) foo_implementation +contains + integer module function add(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + add = lhs % x + rhs % x + end function + integer module function mult(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + mult = lhs % x * rhs % x + end function +end submodule + + use foo_interface + type(foo) :: a = foo (42) + type(foo) :: b = foo (99) + if (a + b .ne. 141) STOP 1 + if (a * b .ne. 4158) STOP 2 +end Index: Fortran/gfortran/regression/submodule_19.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_19.f08 @@ -0,0 +1,59 @@ +! { dg-do compile } +! +! Tests the fix for PR78108 in which an error was triggered by the +! generic operator being resolved more than once in submodules. This +! test checks that the error is triggered when the specific procedure +! really is inserted more than once in the interface. +! +! Note that adding the extra interface to the module produces two +! errors; the one below and 'Duplicate EXTERNAL attribute specified at (1)' +! +! Contributed by Damian Rouson +! +module foo_interface + implicit none + type foo + integer :: x + contains + procedure :: add + generic :: operator(+) => add + procedure :: mult + generic :: operator(*) => mult + end type + interface + integer module function add(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + end function + integer module function mult(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + end function + end interface +end module +submodule(foo_interface) foo_implementation + interface operator (+) + integer module function add(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + end function ! { dg-error "is already present in the interface" } + end interface +contains + integer module function add(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + add = lhs % x + rhs % x + end function + integer module function mult(lhs,rhs) + implicit none + class(foo), intent(in) :: lhs,rhs + mult = lhs % x * rhs % x + end function +end submodule + + use foo_interface + type(foo) :: a = foo (42) + type(foo) :: b = foo (99) + if (a + b .ne. 141) STOP 1 + if (a * b .ne. 4158) STOP 2 +end Index: Fortran/gfortran/regression/submodule_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_2.f08 @@ -0,0 +1,100 @@ +! { dg-do run } +! +! Test dummy and result arrays in module procedures +! +! Contributed by Paul Thomas +! + module foo_interface + implicit none + type foo + character(len=16) :: greeting = "Hello, world! " + character(len=16), private :: byebye = "adieu, world! " + end type foo + + interface + module function array1(this) result (that) + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + end function + character(16) module function array2(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + end function + module subroutine array3(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + end subroutine + module subroutine array4(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + end subroutine + end interface + end module + +! + SUBMODULE (foo_interface) foo_interface_son +! + contains + +! Test array characteristics for dummy and result are OK + module function array1 (this) result(that) + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + allocate (that(size(this)), source = this) + that%greeting = that%byebye + end function + +! Test array characteristics for dummy and result are OK for +! abbreviated module procedure declaration. + module procedure array2 + allocate (that(size(this)), source = this) + that%greeting = that%byebye + array2 = trim (that(size (that))%greeting(1:5))//", people!" + end PROCEDURE + + end SUBMODULE foo_interface_son + +! + SUBMODULE (foo_interface) foo_interface_daughter +! + contains + +! Test array characteristics for dummies are OK + module subroutine array3(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + allocate (that(size(this)), source = this) + that%greeting = that%byebye + end subroutine + +! Test array characteristics for dummies are OK for +! abbreviated module procedure declaration. + module procedure array4 + integer :: i + allocate (that(size(this)), source = this) + that%greeting = that%byebye + do i = 1, size (that) + that(i)%greeting = trim (that(i)%greeting(1:5))//", people!" + end do + end PROCEDURE + end SUBMODULE foo_interface_daughter + +! + program try + use foo_interface + implicit none + type(foo), dimension(2) :: bar + type (foo), dimension(:), allocatable :: arg + + arg = array1(bar) ! typebound call + if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 1 + deallocate (arg) + if (trim (array2 (bar, arg)) .ne. "adieu, people!") STOP 2 + deallocate (arg) + call array3 (bar, arg) ! typebound call + if (any (arg%greeting .ne. ["adieu, world! ", "adieu, world! "])) STOP 3 + deallocate (arg) + call array4 (bar, arg) ! typebound call + if (any (arg%greeting .ne. ["adieu, people!", "adieu, people!"])) STOP 4 + contains + end program Index: Fortran/gfortran/regression/submodule_20.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_20.f08 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Test the fix for PR77903 +! +! Contributed by Damian Rouson +! +module one_module + implicit none + interface + module function one() + end function + integer module function two() + end function + end interface +end module + +submodule(one_module) one_submodule + implicit none +contains + integer module function one() ! { dg-error "Type mismatch" } + one = 1 + end function + integer(8) module function two() ! { dg-error "Type mismatch" } + two = 2 + end function +end submodule + Index: Fortran/gfortran/regression/submodule_21.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_21.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Test the fix for PR78331. +! +! Reported on https://groups.google.com/forum/#!topic/comp.lang.fortran/NFCF9brKksg +! +MODULE MainModule +END MODULE MainModule + +SUBMODULE (MainModule) MySub1 + IMPLICIT NONE + INTEGER, PARAMETER :: a = 17 +END SUBMODULE MySub1 + +PROGRAM MyProg + USE MainModule + WRITE(*,*) a +END PROGRAM MyProg +! { dg-error "does not contain a MODULE PROCEDURE" "" { target "*-*-*" } 0 } +! { dg-prune-output "compilation terminated" } Index: Fortran/gfortran/regression/submodule_22.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_22.f08 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! Test the fix for PR78474. +! +! Contributed by Nicholas Brearly +! +module mtop + implicit none + real :: r + interface + module subroutine sub1() + end subroutine + end interface + interface + module subroutine sub2() + end subroutine + end interface + interface + module subroutine sub3() + end subroutine + end interface +end module mtop + +submodule (mtop) submod + implicit none + real :: s +contains + module subroutine sub1 + r = 0.0 + end subroutine sub1 +end + +submodule (mtop:submod) subsubmod +contains + module subroutine sub2 + r = 1.0 + s = 1.0 + end subroutine sub2 +end + +submodule (mtop:submod:subsubmod) subsubsubmod ! { dg-error "Syntax error in SUBMODULE statement" } +contains + module subroutine sub3 ! { dg-error "found outside of a module" } + r = 2.0 ! { dg-error "Unexpected assignment" } + s = 2.0 ! { dg-error "Unexpected assignment" } + end subroutine sub3 ! { dg-error "Expecting END PROGRAM statement" } +end Index: Fortran/gfortran/regression/submodule_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_23.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! Test the fix for PR79402, in which the module procedure 'fun1' picked +! up a spurious symbol for the dummy 'n' in the specification expression +! for the result 'y'. +! +! Contributed by Chris Coutinho +! +module mod + interface myfun + module function fun1(n) result(y) + integer, intent(in) :: n + real, dimension(n) :: y + end function fun1 + end interface myfun + +end module mod + +submodule (mod) submod +contains + module procedure fun1 + integer :: i + y = [(float (i), i = 1, n)] + end procedure fun1 +end submodule + + use mod + print *, fun1(10) +end Index: Fortran/gfortran/regression/submodule_24.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_24.f08 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Test the fix for PR79447, in which the END PROCEDURE statement +! for MODULE PROCEDURE foo was not accepted. +! +! Contributed by Damian Rouson +! +module foo_interface + implicit none + interface + module subroutine foo() + end subroutine + end interface +end module foo_interface + +submodule(foo_interface) foo_implementation +contains + module procedure foo + contains + module subroutine bar() + end subroutine + end procedure + !end subroutine ! gfortran accepted this invalid workaround +end submodule Index: Fortran/gfortran/regression/submodule_25.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_25.f08 @@ -0,0 +1,43 @@ +! { dg-do compile } +! Test the fix for PR79434 in which the PRIVATE attribute of the +! component 'i' of the derived type 't' was not respected in the +! submodule 's_u'. +! +! Contributed by Reinhold Bader +! +module mod_encap_t + implicit none + type, public :: t + private + integer :: i + end type +end module +module mod_encap_u + use mod_encap_t + type, public, extends(t) :: u + private + integer :: j + end type + interface + module subroutine fu(this) + type(u), intent(inout) :: this + end subroutine + end interface +end module +submodule (mod_encap_u) s_u +contains + module procedure fu +! the following statement should cause the compiler to +! abort, pointing out a private component defined in +! a USED module is being accessed + this%i = 2 ! { dg-error "is a PRIVATE component" } + this%j = 1 + write(*, *) 'FAIL' + end procedure +end submodule +program p + use mod_encap_u + implicit none + type(u) :: x + call fu(x) +end program Index: Fortran/gfortran/regression/submodule_26.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_26.f08 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Tests the fix for PR71838 in which the PROCEDURE dummy argument caused +! an ICE in the submodule. This is the reduced test in comment #9. +! +! Contributed by Anton Shterenlikht +! Test reduced by Dominique d'Humieres +! +module cgca_m3clvg + abstract interface + subroutine cgca_clvgs_abstract( farr, marr, n, cstate, debug, & + newstate ) + integer, parameter :: iarr = 4, idef = 4, rdef = 4, ldef = 4 + integer, parameter :: l=-1, centre=l+1, u=centre+1 + integer( kind=iarr ), intent(in) :: farr(l:u,l:u,l:u), & + marr(l:u,l:u,l:u), cstate + real( kind=rdef ), intent(in) :: n(3) + logical( kind=ldef ), intent(in) :: debug + integer( kind=iarr ), intent(out) :: newstate + end subroutine cgca_clvgs_abstract + end interface + + interface + module subroutine cgca_clvgp( coarray, rt, t, scrit, sub, gcus, & + periodicbc, iter, heartbeat, debug ) + integer, parameter :: iarr = 4, idef = 4, rdef = 4, ldef = 4 + integer( kind=iarr ), allocatable, intent(inout) :: & + coarray(:,:,:,:)[:,:,:] + real( kind=rdef ), allocatable, intent(inout) :: rt(:,:,:)[:,:,:] + real( kind=rdef ), intent(in) :: t(3,3), scrit(3) + procedure( cgca_clvgs_abstract ) :: sub + logical( kind=ldef ), intent(in) :: periodicbc + integer( kind=idef ), intent(in) :: iter, heartbeat + logical( kind=ldef ), intent(in) :: debug + end subroutine cgca_clvgp + end interface +end module cgca_m3clvg + + +submodule ( cgca_m3clvg ) m3clvg_sm3 + implicit none +contains + module procedure cgca_clvgp + end procedure cgca_clvgp +end submodule m3clvg_sm3 Index: Fortran/gfortran/regression/submodule_27.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_27.f08 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Tests the fix for PR71838 in which the PROCEDURE dummy argument caused +! an ICE in the submodule. This an executable version of the reduced test +! in comment #11. +! +! Contributed by Anton Shterenlikht +! Test reduced by Dominique d'Humieres +! +subroutine hello (message) + character (7), intent(inout) :: message + message = "hello " +end + +module cgca_m3clvg + interface + subroutine cgca_clvgs_abstract(message) + character (7), intent(inout) :: message + end subroutine cgca_clvgs_abstract + end interface + + interface + module subroutine cgca_clvgp(sub) + procedure( cgca_clvgs_abstract ) :: sub + end subroutine cgca_clvgp + end interface + + character (7) :: greeting +end module cgca_m3clvg + +submodule ( cgca_m3clvg ) m3clvg_sm3 + implicit none +contains + module procedure cgca_clvgp + call sub (greeting) + end procedure cgca_clvgp +end submodule m3clvg_sm3 + + use cgca_m3clvg + external hello + greeting = "goodbye" + call cgca_clvgp (hello) + if (trim (greeting) .ne. "hello") STOP 1 +end Index: Fortran/gfortran/regression/submodule_28.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_28.f08 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Tests the fix for PR79676 in which submod_test was private even to the +! submodule 'my_submod'. +! +! Contributed by Adam Hirst +! +module my_mod + private ! This hid 'submod_test'. + interface + module subroutine submod_test(x) + integer :: x + end subroutine + end interface + integer answer + public routine1, print_two, answer +contains + subroutine routine1(x) + integer :: x + call submod_test(x) + end subroutine + subroutine print_two() + integer, parameter :: two = 2 + answer = answer * two + end subroutine +end module + +module my_mod_2 + use my_mod +contains + subroutine circular_dependency() + call print_two() + end subroutine +end module + +submodule (my_mod) my_submod + use my_mod_2 +contains +module subroutine submod_test(x) + integer :: x + answer = x + call circular_dependency() +end subroutine + +end submodule + +program hello + use my_mod + implicit none + call routine1(2) + if (answer .ne. 4) STOP 1 +end program Index: Fortran/gfortran/regression/submodule_29.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_29.f08 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! Test the fix for PR80554 in which it was not recognised that the symbol 'i' +! is host associated in the submodule 's' so that the new declaration in the +! submodule was rejected. +! +! Contributed by Tamas Bela Feher +! +module M + implicit none + integer :: i = 0 + character (100) :: buffer + interface + module subroutine write_i() + end subroutine + end interface + interface + module subroutine write_i_2() + end subroutine + end interface +contains + subroutine foo + integer :: i + end +end module + +submodule (M) S + integer :: i = 137 + contains + module subroutine write_i() + write (buffer,*) i + end subroutine +end submodule + +submodule (M:S) S2 + integer :: i = 1037 + contains + module subroutine write_i_2() + write (buffer,*) i + end subroutine +end submodule + +program test_submod_variable + use M + implicit none + integer :: j + i = 42 + call write_i + read (buffer, *) j + if (i .ne. 42) STOP 1 + if (j .ne. 137) STOP 2 + call write_i_2 + read (buffer, *) j + if (i .ne. 42) STOP 3 + if (j .ne. 1037) STOP 4 +end program Index: Fortran/gfortran/regression/submodule_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_3.f08 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Check enforcement of F2008 standard for MODULE PROCEDURES and SUBMODULES +! This is rather bare-bones to reduce the number of error messages too the +! essential minimum. +! +! Contributed by Paul Thomas +! + module foo_interface + implicit none + + interface + module function array1(this) result (that) ! { dg-error "MODULE prefix" } + end function ! { dg-error "Expecting END INTERFACE" } + character(16) module function array2(this, that) ! { dg-error "MODULE prefix" } + end function ! { dg-error "Expecting END INTERFACE" } + end interface + end module + +! + SUBMODULE (foo_interface) foo_interface_son ! { dg-error "SUBMODULE declaration" } +! + contains ! { dg-error "CONTAINS statement without FUNCTION or SUBROUTINE" } + + module function array1 (this) result(that) ! { dg-error "MODULE prefix" } + end function ! { dg-error "Expecting END PROGRAM" } + +! Test array characteristics for dummy and result are OK for +! abbreviated module procedure declaration. + module procedure array2 ! { dg-error "must be in a generic module interface" } + end PROCEDURE ! { dg-error "Expecting END PROGRAM" } + + end SUBMODULE foo_interface_son ! { dg-error "Expecting END PROGRAM" } + +end + Index: Fortran/gfortran/regression/submodule_30.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_30.f08 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR82550 in which the reference to 'p' in 'foo' +! was not being correctly handled. +! +! Contributed by Reinhold Bader +! +module m_subm_18_pos + implicit none + integer :: i = 0 + interface + module subroutine foo(fun_ptr) + procedure(p), pointer, intent(out) :: fun_ptr + end subroutine + end interface +contains + subroutine p() + i = 1 + end subroutine p +end module m_subm_18_pos +submodule (m_subm_18_pos) subm_18_pos + implicit none +contains + module subroutine foo(fun_ptr) + procedure(p), pointer, intent(out) :: fun_ptr + fun_ptr => p + end subroutine +end submodule +program p_18_pos + use m_subm_18_pos + implicit none + procedure(), pointer :: x + call foo(x) + call x() + if (i == 1) then + write(*,*) 'OK' + else + write(*,*) 'FAIL' + STOP 1 + end if +end program p_18_pos + Index: Fortran/gfortran/regression/submodule_31.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_31.f08 @@ -0,0 +1,54 @@ +! { dg-do run } +! +! Test the fix for PR82814 in which an ICE occurred for the submodule allocation. +! +! Contributed by "Werner Blokbuster" +! +module u + + implicit none + + interface unique + module function uniq_char(input) result(uniq) + character(*), intent(in) :: input(:) + character(size(input)), allocatable :: uniq(:) + end function uniq_char + end interface unique + +contains + + module function uniq2(input) result(uniq) + character(*), intent(in) :: input(:) + character(size(input)), allocatable :: uniq(:) + allocate(uniq(1)) + uniq = 'A' + end function uniq2 + +end module u + + +submodule (u) z + + implicit none + +contains + + module function uniq_char(input) result(uniq) + character(*), intent(in) :: input(:) + character(size(input)), allocatable :: uniq(:) + allocate(uniq(1)) ! This used to ICE + uniq = 'A' + end function uniq_char + +end submodule z + + +program test_uniq + use u + implicit none + character(1), dimension(4) :: chr = ['1','2','1','2'] + + write(*,*) unique(chr) + write(*,*) uniq2(chr) + +end program test_uniq Index: Fortran/gfortran/regression/submodule_32.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_32.f08 @@ -0,0 +1,62 @@ +! { dg-do run } +! +! Test the fix for PR86863, where the Type Bound Procedures were +! not flagged as subroutines thereby causing an error at the call +! statements. +! +! Contributed by Damian Rouson +! +module foo + implicit none + integer :: flag = 0 + type bar + contains + procedure, nopass :: foobar + procedure, nopass :: barfoo + end type +contains + subroutine foobar + flag = 1 + end subroutine + subroutine barfoo + flag = 0 + end subroutine +end module + +module foobartoo + implicit none + interface + module subroutine set(object) + use foo + implicit none + type(bar) object + end subroutine + module subroutine unset(object) + use foo + implicit none + type(bar) object + end subroutine + end interface +contains + module procedure unset + use foo, only : bar + call object%barfoo + end procedure +end module + +submodule(foobartoo) subfoobar +contains + module procedure set + use foo, only : bar + call object%foobar + end procedure +end submodule + + use foo + use foobartoo + type(bar) :: obj + call set(obj) + if (flag .ne. 1) stop 1 + call unset(obj) + if (flag .ne. 0) stop 2 +end Index: Fortran/gfortran/regression/submodule_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_4.f08 @@ -0,0 +1,140 @@ +! { dg-do compile } +! +! Tests comparisons of MODULE PROCEDURE characteristics and +! the characteristics of their dummies. Also tests the error +! arising from redefining dummies and results in MODULE +! procedures. +! +! Contributed by Paul Thomas +! + module foo_interface + implicit none + type foo + character(len=16) :: greeting = "Hello, world! " + character(len=16), private :: byebye = "adieu, world! " + end type foo + + interface + module function array1(this) result (that) + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + end function + character(16) module function array2(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + end function + module subroutine array3(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + end subroutine + module subroutine array4(this, that) + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + end subroutine + integer module function scalar1 (arg) + real, intent(in) :: arg + end function + module function scalar2 (arg) result(res) + real, intent(in) :: arg + real :: res + end function + module function scalar3 (arg) result(res) + real, intent(in) :: arg + real :: res + end function + module function scalar4 (arg) result(res) + real, intent(in) :: arg + complex :: res + end function + module function scalar5 (arg) result(res) + real, intent(in) :: arg + real, allocatable :: res + end function + module function scalar6 (arg) result(res) + real, intent(in) :: arg + real, allocatable :: res + end function + module function scalar7 (arg) result(res) + real, intent(in) :: arg + real, allocatable :: res + end function + end interface + end module + +! + SUBMODULE (foo_interface) foo_interface_son +! + contains + + module function array1 (this) result(that) ! { dg-error "Rank mismatch in function result" } + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable :: that + end function + + character(16) module function array2(this) ! { dg-error "Mismatch in number of MODULE PROCEDURE formal arguments" } + type(foo), intent(in), dimension(:) :: this + type(foo), allocatable, dimension(:) :: that + allocate (that(2), source = this(1)) + that%greeting = that%byebye + array2 = trim (that(size (that))%greeting(1:5))//", people!" + end function + + module subroutine array3(thiss, that) ! { dg-error "Mismatch in MODULE PROCEDURE formal argument names" } + type(foo), intent(in), dimension(:) :: thiss + type(foo), intent(inOUT), allocatable, dimension(:) :: that + allocate (that(size(thiss)), source = thiss) + that%greeting = that%byebye + end subroutine + + module subroutine array4(this, that, the_other) ! { dg-error "Mismatch in number of MODULE PROCEDURE formal arguments" } + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that, the_other + integer :: i + allocate (that(size(this)), source = this) + that%greeting = that%byebye + do i = 1, size (that) + that(i)%greeting = trim (that(i)%greeting(1:5))//", people!" + end do + end subroutine + + recursive module function scalar1 (arg) ! { dg-error "Mismatch in RECURSIVE" } + real, intent(in) :: arg + end function + + pure module function scalar2 (arg) result(res) ! { dg-error "Mismatch in PURE" } + real, intent(in) :: arg + real :: res + end function + + module procedure scalar7 + real, intent(in) :: arg ! { dg-error "redefinition of the declaration" } + real, allocatable :: res ! { dg-error "redefinition of the declaration" } + end function ! { dg-error "Expecting END PROCEDURE statement" } + end procedure ! This prevents a cascade of errors. + end SUBMODULE foo_interface_son + +! + SUBMODULE (foo_interface) foo_interface_daughter +! + contains + + module function scalar3 (arg) result(res) ! { dg-error "Type mismatch in argument" } + integer, intent(in) :: arg + real :: res + end function + + module function scalar4 (arg) result(res) ! { dg-error "Type mismatch in function result" } + real, intent(in) :: arg + real :: res + end function + + module function scalar5 (arg) result(res) ! { dg-error "ALLOCATABLE attribute mismatch in function result " } + real, intent(in) :: arg + real :: res + end function + + module function scalar6 (arg) result(res) ! { dg-error "Rank mismatch in argument" } + real, intent(in), dimension(2) :: arg + real, allocatable :: res + end function + end SUBMODULE foo_interface_daughter Index: Fortran/gfortran/regression/submodule_5.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_5.f08 @@ -0,0 +1,59 @@ +! { dg-do compile } +! +! Checks that PRIVATE/PUBLIC not allowed in submodules. Also, IMPORT +! is not allowed in a module procedure interface body. +! +! Contributed by Paul Thomas +! +module foo_interface + implicit none + type foo + character(len=16), private :: byebye = "adieu, world! " + end type foo + +! This interface is required to trigger the output of an .smod file. +! See http://j3-fortran.org/doc/meeting/207/15-209.txt + interface + integer module function trigger_smod () + end function + end interface + +end module + +module foo_interface_brother + use foo_interface + implicit none + interface + module subroutine array3(this, that) + import ! { dg-error "not permitted in a module procedure interface body" } + type(foo), intent(in), dimension(:) :: this + type(foo), intent(inOUT), allocatable, dimension(:) :: that + end subroutine + end interface +end module + +SUBMODULE (foo_interface) foo_interface_son + private ! { dg-error "PRIVATE statement" } + public ! { dg-error "PUBLIC statement" } + integer, public :: i ! { dg-error "PUBLIC attribute" } + integer, private :: j ! { dg-error "PRIVATE attribute" } + type :: bar + private ! { dg-error "PRIVATE statement" } + public ! { dg-error "PUBLIC statement" } + integer, private :: i ! { dg-error "PRIVATE attribute" } + integer, public :: j ! { dg-error "PUBLIC attribute" } + end type bar +contains +! +end submodule foo_interface_son + +SUBMODULE (foo_interface) foo_interface_daughter +! +contains + subroutine foobar (arg) + type(foo) :: arg + arg%byebye = "hello, world! " ! Access to private component is OK + end subroutine +end SUBMODULE foo_interface_daughter + +end Index: Fortran/gfortran/regression/submodule_6.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_6.f08 @@ -0,0 +1,94 @@ +! { dg-do run } +! { dg-require-effective-target lto } +! { dg-options "-flto" } +! +! Checks that the results of module procedures have the correct characteristics +! and that submodules use the module version of vtables (PR66762). This latter +! requires the -flto compile option. +! +! Contributed by Reinhold Bader +! +module mod_a + implicit none + type, abstract :: t_a + end type t_a + interface + module subroutine p_a(this, q) + class(t_a), intent(inout) :: this + class(*), intent(in) :: q + end subroutine + module function create_a() result(r) + class(t_a), allocatable :: r + end function + module subroutine print(this) + class(t_a), intent(in) :: this + end subroutine + end interface +end module mod_a + +module mod_b + implicit none + type t_b + integer, allocatable :: I(:) + end type t_b + interface + module function create_b(i) result(r) + type(t_b) :: r + integer :: i(:) + end function + end interface +end module mod_b + +submodule(mod_b) imp_create +contains + module procedure create_b + if (allocated(r%i)) deallocate(r%i) + allocate(r%i, source=i) + end procedure +end submodule imp_create + +submodule(mod_a) imp_p_a + use mod_b + type, extends(t_a) :: t_imp + type(t_b) :: b + end type t_imp + integer, parameter :: ii(2) = [1,2] +contains + module procedure create_a + type(t_b) :: b + b = create_b(ii) + allocate(r, source=t_imp(b)) + end procedure + + module procedure p_a + select type (this) + type is (t_imp) + select type (q) + type is (t_b) + this%b = q + class default + STOP 1 + end select + class default + STOP 2 + end select + end procedure p_a + module procedure print + select type (this) + type is (t_imp) + if (any (this%b%i .ne. [3,4,5])) STOP 3 + class default + STOP 4 + end select + end procedure +end submodule imp_p_a + +program p + use mod_a + use mod_b + implicit none + class(t_a), allocatable :: a + allocate(a, source=create_a()) + call p_a(a, create_b([3,4,5])) + call print(a) +end program p Index: Fortran/gfortran/regression/submodule_7.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_7.f08 @@ -0,0 +1,147 @@ +! { dg-do run } +! +! Example in F2008 C.8.4 to demonstrate submodules +! +module color_points + type color_point + private + real :: x, y + integer :: color + end type color_point + + interface +! Interfaces for procedures with separate +! bodies in the submodule color_points_a + module subroutine color_point_del ( p ) ! Destroy a color_point object + type(color_point), allocatable :: p + end subroutine color_point_del +! Distance between two color_point objects + real module function color_point_dist ( a, b ) + type(color_point), intent(in) :: a, b + end function color_point_dist + module subroutine color_point_draw ( p ) ! Draw a color_point object + type(color_point), intent(in) :: p + end subroutine color_point_draw + module subroutine color_point_new ( p ) ! Create a color_point object + type(color_point), allocatable :: p + end subroutine color_point_new + module subroutine verify_cleanup ( p1, p2 ) ! Check cleanup of color_point objects + type(color_point), allocatable :: p1, p2 + end subroutine verify_cleanup + end interface +end module color_points + +module palette_stuff + type :: palette ; +!... + end type palette +contains + subroutine test_palette ( p ) +! Draw a color wheel using procedures from the color_points module + use color_points ! This does not cause a circular dependency because +! the "use palette_stuff" that is logically within +! color_points is in the color_points_a submodule. + type(palette), intent(in) :: p + end subroutine test_palette +end module palette_stuff + + +submodule ( color_points ) color_points_a ! Submodule of color_points + integer :: instance_count = 0 + interface +! Interface for a procedure with a separate +! body in submodule color_points_b + module subroutine inquire_palette ( pt, pal ) + use palette_stuff +! palette_stuff, especially submodules +! thereof, can reference color_points by use +! association without causing a circular +! dependence during translation because this +! use is not in the module. Furthermore, +! changes in the module palette_stuff do not +! affect the translation of color_points. + type(color_point), intent(in) :: pt + type(palette), intent(out) :: pal + end subroutine inquire_palette + end interface +contains +! Invisible bodies for public separate module procedures +! declared in the module + module subroutine color_point_del ( p ) + type(color_point), allocatable :: p + instance_count = instance_count - 1 + deallocate ( p ) + end subroutine color_point_del + real module function color_point_dist ( a, b ) result ( dist ) + type(color_point), intent(in) :: a, b + dist = sqrt( (b%x - a%x)**2 + (b%y - a%y)**2 ) + end function color_point_dist + module subroutine color_point_new ( p ) + type(color_point), allocatable :: p + instance_count = instance_count + 1 + allocate ( p ) +! Added to example so that it does something. + p%x = real (instance_count) * 1.0 + p%y = real (instance_count) * 2.0 + p%color = instance_count + end subroutine color_point_new +end submodule color_points_a + + +submodule ( color_points:color_points_a ) color_points_b ! Subsidiary**2 submodule + +contains +! Invisible body for interface declared in the ancestor module + module subroutine color_point_draw ( p ) + use palette_stuff, only: palette + type(color_point), intent(in) :: p + type(palette) :: MyPalette + call inquire_palette ( p, MyPalette ) +! Added to example so that it does something. + if (abs (p%x - real (p%color) * 1.0) .gt. 1.0e-6) STOP 1 + if (abs (p%y - real (p%color) * 2.0) .gt. 1.0e-6) STOP 2 + end subroutine color_point_draw +! Invisible body for interface declared in the parent submodule + module procedure inquire_palette +!... implementation of inquire_palette + end procedure inquire_palette + module procedure verify_cleanup + if (allocated (p1) .or. allocated (p2)) STOP 3 + if (instance_count .ne. 0) STOP 4 + end procedure + subroutine private_stuff ! not accessible from color_points_a +!... + end subroutine private_stuff +end submodule color_points_b + + +program main + use color_points +! "instance_count" and "inquire_palette" are not accessible here +! because they are not declared in the "color_points" module. +! "color_points_a" and "color_points_b" cannot be referenced by +! use association. + interface draw +! just to demonstrate it’s possible + module procedure color_point_draw + end interface + type(color_point), allocatable :: C_1, C_2 + real :: RC +!... + call color_point_new (c_1) + call color_point_new (c_2) +! body in color_points_a, interface in color_points +!... + call draw (c_1) +! body in color_points_b, specific interface +! in color_points, generic interface here. +!... + rc = color_point_dist (c_1, c_2) ! body in color_points_a, interface in color_points + if (abs (rc - 2.23606801) .gt. 1.0e-6) STOP 5 +!... + call color_point_del (c_1) + call color_point_del (c_2) +! body in color_points_a, interface in color_points + call verify_cleanup (c_1, c_2) +!... +end program main Index: Fortran/gfortran/regression/submodule_8.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_8.f08 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Checks that F2008:11.2.3 para 2 is correctly implemented so that +! no error results from using 'mod_s' for both a module name and +! a submodule name. The submodule is now identified as 'mod_a.mod_s' +! internally and the submodule file as 'mod_a@mod_s.smod'. +! +! Contributed by Reinhold Bader +! +module mod_a + implicit none + interface + module subroutine p() + end subroutine + end interface +end module + +submodule (mod_a) mod_s + implicit none + integer :: i=-2 +contains + module procedure p + if (i .ne. -2) then + STOP 1 + end if + end procedure +end submodule + +module mod_s + use mod_a + implicit none + integer :: i=2 +end module + +program a_s + use mod_s + implicit none + if (i==2) then + call p() + else + STOP 2 + end if +end program Index: Fortran/gfortran/regression/submodule_9.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_9.f08 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! Checks that the name clash between the two submodules 'mod_s' is an error. +! +! Contributed by Reinhold Bader +! +module mod_a + implicit none + interface + module subroutine p() + end subroutine + end interface +end module + +submodule (mod_a) mod_s ! { dg-error "already being used as a MODULE" } +end submodule + +submodule (mod_a:mod_s) b +end submodule + +submodule (mod_a:b) mod_s ! { dg-error "already being used as a MODULE" } + implicit none + integer :: i=-2 +contains + module procedure p + write(*,*) 'FAIL' + end procedure +end submodule + +module mod_s + use mod_a + implicit none + integer :: i=2 +end module + +program a_s + use mod_s + implicit none + call p() +end program Index: Fortran/gfortran/regression/submodule_twice.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_twice.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/69498 +! This used to ICE +program main + submodule (m) sm ! { dg-error "SUBMODULE declaration at" } + submodule (m2) sm2 ! { dg-error "SUBMODULE declaration at" } +end program Index: Fortran/gfortran/regression/submodule_unexp.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/submodule_unexp.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/69498 +! This used to ICE +program p + type t + submodule (m) sm ! { dg-error "SUBMODULE declaration at" } + end type +end Index: Fortran/gfortran/regression/subnormal_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subnormal_1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-Wno-underflow" } +! Check that the chopping of bits of subnormal numbers works. +! +program chop + real x + x = 1. + if (tiny(x)/2. /= tiny(x)/2. - (nearest(tiny(x),1.) - tiny(x))/2.) then + STOP 1 + end if +end program chop Index: Fortran/gfortran/regression/subref_array_pointer_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subref_array_pointer_1.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers +! to arrays with subreferences did not work. +! + call pr29396 + call pr29606 + call pr30625 + call pr30871 +contains + subroutine pr29396 +! Contributed by Francois-Xavier Coudert + CHARACTER(LEN=2), DIMENSION(:), POINTER :: a + CHARACTER(LEN=4), DIMENSION(3), TARGET :: b + b=(/"bbbb","bbbb","bbbb"/) + a=>b(:)(2:3) + a="aa" + IF (ANY(b.NE.(/"baab","baab","baab"/))) STOP 1 + END subroutine + + subroutine pr29606 +! Contributed by Daniel Franke + TYPE foo + INTEGER :: value + END TYPE + TYPE foo_array + TYPE(foo), DIMENSION(:), POINTER :: array + END TYPE + TYPE(foo_array) :: array_holder + INTEGER, DIMENSION(:), POINTER :: array_ptr + ALLOCATE( array_holder%array(3) ) + array_holder%array = (/ foo(1), foo(2), foo(3) /) + array_ptr => array_holder%array%value + if (any (array_ptr .ne. (/1,2,3/))) STOP 2 + END subroutine + + subroutine pr30625 +! Contributed by Paul Thomas + type :: a + real :: r = 3.14159 + integer :: i = 42 + end type a + type(a), target :: dt(2) + integer, pointer :: ip(:) + ip => dt%i + if (any (ip .ne. 42)) STOP 3 + end subroutine + + subroutine pr30871 +! Contributed by Joost VandeVondele + TYPE data + CHARACTER(LEN=3) :: A + END TYPE + TYPE(data), DIMENSION(10), TARGET :: Z + CHARACTER(LEN=1), DIMENSION(:), POINTER :: ptr + Z(:)%A="123" + ptr=>Z(:)%A(2:2) + if (any (ptr .ne. "2")) STOP 4 + END subroutine +end Index: Fortran/gfortran/regression/subref_array_pointer_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subref_array_pointer_2.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers +! to arrays with subreferences did not work. +! + type :: t + real :: r + integer :: i + character(3) :: chr + end type t + + type :: t2 + real :: r(2, 2) + integer :: i + character(3) :: chr + end type t2 + + type :: s + type(t), pointer :: t(:) + end type s + + integer, parameter :: sh(2) = (/2,2/) + real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh) + real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh) + + type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/) + character(4), target :: tar2(2) = (/"abcd","efgh"/) + type(s), target :: tar3 + character(2), target :: tar4(2) = (/"ab","cd"/) + type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/) + + integer, pointer :: ptr(:) + character(2), pointer :: ptr2(:) + real, pointer :: ptr3(:) + +!_______________component subreference___________ + ptr => tar1%i + ptr = ptr + 1 ! check the scalarizer is OK + + if (any (ptr .ne. (/3, 5/))) STOP 1 + if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) STOP 2 + if (any (tar1%i .ne. (/3, 5/))) STOP 3 + +! Make sure that the other components are not touched. + if (any (tar1%r .ne. (/1.0, 3.0/))) STOP 4 + if (any (tar1%chr .ne. (/"abc", "efg"/))) STOP 5 + +! Check that the pointer is passed correctly as an actual argument. + call foo (ptr) + if (any (tar1%i .ne. (/2, 4/))) STOP 6 + +! And that dummy pointers are OK too. + call bar (ptr) + if (any (tar1%i .ne. (/101, 103/))) STOP 7 + +!_______________substring subreference___________ + ptr2 => tar2(:)(2:3) + ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer + + if (any (ptr2 .ne. (/"cz", "gz"/))) STOP 8 + if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) STOP 9 + if (any (tar2 .ne. (/"aczd", "egzh"/))) STOP 10 + +!_______________substring component subreference___________ + ptr2 => tar1(:)%chr(1:2) + ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer + if (any (ptr2 .ne. (/"bq","fq"/))) STOP 11 + if (any (tar1%chr .ne. (/"bqc","fqg"/))) STOP 12 + +!_______________trailing array element subreference___________ + ptr3 => tar5%r(1,2) + ptr3 = (/99.0, 999.0/) + if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) STOP 13 + if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) STOP 14 + +!_______________forall assignment___________ + ptr2 => tar2(:)(1:2) + forall (i = 1:2) ptr2(i)(1:1) = "z" + if (any (tar2 .ne. (/"zczd", "zgzh"/))) STOP 15 + +!_______________something more complicated___________ + tar3%t => tar1 + ptr3 => tar3%t%r + ptr3 = cos (ptr3) + if (any (abs(ptr3 - (/cos(1.0_4), cos(3.0_4)/)) >= epsilon(1.0_4))) STOP 16 + + ptr2 => tar3%t(:)%chr(2:3) + ptr2 = " x" + if (any (tar1%chr .ne. (/"b x", "f x"/))) STOP 17 + +!_______________check non-subref works still___________ + ptr2 => tar4 + if (any (ptr2 .ne. (/"ab","cd"/))) STOP 18 + +contains + subroutine foo (arg) + integer :: arg(:) + arg = arg - 1 + end subroutine + subroutine bar (arg) + integer, pointer :: arg(:) + arg = arg + 99 + end subroutine +end Index: Fortran/gfortran/regression/subref_array_pointer_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subref_array_pointer_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests the fix for PR35470, in which the pointer assignment would fail +! because the assumed size 'arr' would get mixed up with the component +! 'p' in the check for the upper bound of an assumed size array. +! +! Contributed by Antony Lewis +! +subroutine sub(arr) + type real_pointer + real, pointer :: p(:) + end type real_pointer + type(real_pointer), dimension(*) :: arr + real, pointer :: p(:) + p => arr(1)%p +end subroutine Index: Fortran/gfortran/regression/subref_array_pointer_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subref_array_pointer_4.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Tests the fix for PR42309, in which the indexing of 'Q' +! was off by one. +! +! Contributed by Gilbert Scott +! +PROGRAM X + TYPE T + INTEGER :: I + REAL :: X + END TYPE T + TYPE(T), TARGET :: T1(0:3) + INTEGER, POINTER :: P(:) + REAL :: SOURCE(4) = [10., 20., 30., 40.] + + T1%I = [1, 2, 3, 4] + T1%X = SOURCE + P => T1%I + CALL Z(P) + IF (ANY (T1%I .NE. [999, 2, 999, 4])) STOP 1 + IF (ANY (T1%X .NE. SOURCE)) STOP 2 +CONTAINS + SUBROUTINE Z(Q) + INTEGER, POINTER :: Q(:) + Q(1:3:2) = 999 + END SUBROUTINE Z +END PROGRAM X + Index: Fortran/gfortran/regression/subroutine_as_type.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/subroutine_as_type.f90 @@ -0,0 +1,7 @@ + +subroutine t() + type t ! { dg-error "FUNCTION attribute conflicts with SUBROUTINE attribute" } + end type t ! { dg-error "Expecting END SUBROUTINE statement" } + type, extends(t) :: t2 ! { dg-error "has not been previously defined" } + end type t2 ! { dg-error "Expecting END SUBROUTINE statement" } +end Index: Fortran/gfortran/regression/substr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! we used to save the wrong components of a gfc_expr describing a +! substring of a constant string. This yielded a segfault on +! translating the expressions read from the module. +module m + character (*), parameter :: a = "AABBCC"(1:4) +end module m + +use m +character(4) :: b +b = a +end Index: Fortran/gfortran/regression/substr_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_10.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR93340 - test error handling of substring simplification + +subroutine p + integer,parameter :: k = len ('a'(:0)) + integer,parameter :: m = len ('a'(0:)) ! { dg-error "Substring start index" } + call foo ('bcd'(-8:-9)) + call foo ('bcd'(-9:-8)) ! { dg-error "Substring start index" } + call foo ('bcd'(:12)) ! { dg-error "Substring end index" } + call foo ('bcd'(-12:)) ! { dg-error "Substring start index" } +end Index: Fortran/gfortran/regression/substr_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_2.f @@ -0,0 +1,24 @@ +! { dg-do run } +! Check that substrings behave correctly even when zero-sized + implicit none + character(len=10) :: s, t + integer :: i, j + + s = "abcdefghij" + t(:10) = s(1:) + s(6:5) = "foo" + if (s /= t) STOP 1 + i = 2 + j = -1 + s(i:i+j) = "foo" + if (s /= t) STOP 2 + i = 20 + s(i+1:i) = "foo" + if (s /= t) STOP 3 + s(6:5) = s(7:5) + if (s /= t) STOP 4 + s = t(7:6) + if (len(trim(s)) /= 0) STOP 5 + if (len(t(8:4)) /= 0) STOP 6 + if (len(trim(t(8:4))) /= 0) STOP 7 + end Index: Fortran/gfortran/regression/substr_3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_3.f @@ -0,0 +1,12 @@ +! { dg-do run } +! Check that substrings behave correctly even when zero-sized + implicit none + character(len=10) :: s, t + integer :: i, j + + s = "abcdefghij" + t(:10) = s(1:) + s(16:15) = "foo" + s(0:-1) = "foo" + if (s /= t) STOP 1 + end Index: Fortran/gfortran/regression/substr_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_4.f @@ -0,0 +1,69 @@ +! { dg-do run } + subroutine test_lower + implicit none + character(3), dimension(3) :: zsymel,zsymelr + common /xx/ zsymel, zsymelr + integer :: znsymelr + zsymel = (/ 'X', 'Y', ' ' /) + zsymelr= (/ 'X', 'Y', ' ' /) + znsymelr=2 + call check_zsymel(zsymel,zsymelr,znsymelr) + + contains + + subroutine check_zsymel(zsymel,zsymelr,znsymelr) + implicit none + integer znsymelr, isym + character(*) zsymel(*),zsymelr(*) + character(len=80) buf + zsymel(3)(lenstr(zsymel(3))+1:)='X' + write (buf,10) (trim(zsymelr(isym)),isym=1,znsymelr) +10 format(3(a,:,',')) + if (trim(buf) /= 'X,Y') STOP 1 + end subroutine check_zsymel + + function lenstr(s) + character(len=*),intent(in) :: s + integer :: lenstr + if (len_trim(s) /= 0) STOP 2 + lenstr = len_trim(s) + end function lenstr + + end subroutine test_lower + + subroutine test_upper + implicit none + character(3), dimension(3) :: zsymel,zsymelr + common /xx/ zsymel, zsymelr + integer :: znsymelr + zsymel = (/ 'X', 'Y', ' ' /) + zsymelr= (/ 'X', 'Y', ' ' /) + znsymelr=2 + call check_zsymel(zsymel,zsymelr,znsymelr) + + contains + + subroutine check_zsymel(zsymel,zsymelr,znsymelr) + implicit none + integer znsymelr, isym + character(*) zsymel(*),zsymelr(*) + character(len=80) buf + zsymel(3)(:lenstr(zsymel(3))+1)='X' + write (buf,20) (trim(zsymelr(isym)),isym=1,znsymelr) +20 format(3(a,:,',')) + if (trim(buf) /= 'X,Y') STOP 3 + end subroutine check_zsymel + + function lenstr(s) + character(len=*),intent(in) :: s + integer :: lenstr + if (len_trim(s) /= 0) STOP 4 + lenstr = len_trim(s) + end function lenstr + + end subroutine test_upper + + program test + call test_lower + call test_upper + end program test Index: Fortran/gfortran/regression/substr_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_5.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! + character(*), parameter :: chrs = '-+.0123456789eEdD' + character(*), parameter :: expr = '-+.0123456789eEdD' + integer :: i + + if (index(chrs(:), expr) /= 1) STOP 1 + if (index(chrs(14:), expr) /= 0) STOP 2 + if (index(chrs(:12), expr) /= 0) STOP 3 + if (index(chrs, expr(:)) /= 1) STOP 4 + if (index(chrs, expr(1:)) /= 1) STOP 5 + if (index(chrs, expr(:1)) /= 1) STOP 6 + + if (foo(expr) /= 1) STOP 7 + if (foo(expr) /= 1) STOP 8 + if (foo(expr) /= 1) STOP 9 + if (foo(expr(:)) /= 1) STOP 10 + if (foo(expr(1:)) /= 1) STOP 11 + if (foo(expr(:1)) /= 1) STOP 12 + + call bar(expr) + +contains + subroutine bar(expr) + character(*), intent(in) :: expr + character(*), parameter :: chrs = '-+.0123456789eEdD' + integer :: foo + + if (index(chrs(:), expr) /= 1) STOP 13 + if (index(chrs(14:), expr) /= 0) STOP 14 + if (index(chrs(:12), expr) /= 0) STOP 15 + if (index(chrs, expr(:)) /= 1) STOP 16 + if (index(chrs, expr(1:)) /= 1) STOP 17 + if (index(chrs, expr(:1)) /= 1) STOP 18 + end subroutine bar + + integer function foo(expr) + character(*), intent(in) :: expr + character(*), parameter :: chrs = '-+.0123456789eEdD' + + foo = index(chrs, expr) + end function foo + +end Index: Fortran/gfortran/regression/substr_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_6.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Check that NULs don't mess up constant substring simplification +CHARACTER(5), parameter :: c0(1) = (/ "123" // ACHAR(0) // "5" /) +CHARACTER*5 c(1) +CHARACTER(1), parameter :: c1(5) = (/ "1", "2", "3", ACHAR(0), "5" /) + +c = c0(1)(-5:-8) +if (c(1) /= " ") STOP 1 +c = (/ c0(1)(1:5) /) +do i=1,5 + if (c(1)(i:i) /= c1(i)) STOP 2 + + ! Make NULs visible (and avoid corrupting text output). + if (c(1)(i:i) == ACHAR(0)) then + print "(a,$)", "" + else + print "(a,$)", c(1)(i:i) + end if +end do + +print *, "" + +end Index: Fortran/gfortran/regression/substr_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_7.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 70068 - used to allocate too much memory +! Original test cases by Gerhard Steinmetz +program p + integer :: i + character(3), parameter :: x(3) = ['abc', 'ijk', 'xyz'] + character(3) :: y(2) + character(99), parameter :: x2(2) = ' ' + character(99), parameter :: y2=x(2)(99:1) + y = [(x(i)(i:1), i=2,3)] + if (any(y /= '')) stop 1 + if (y2 /= '') stop 2 +end Index: Fortran/gfortran/regression/substr_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_8.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR fortran/71203 - used to ICE on zero-length arrays or substrings +! Derived from original test cases by Gerhard Steinmetz + +program p + implicit none + character(3), parameter :: a(4) = ' ' + character(*), parameter :: b(4) = 'abc' + character(*), parameter :: x(*) = a(2:2)(3:1) + character(*), parameter :: y(*) = a(2:1)(3:1) + character(*), parameter :: z(*) = b(2:1)(2:3) + if (size (x) /= 1 .or. len(x) /= 0) stop 1 + if (size (y) /= 0 .or. len(y) /= 0) stop 2 + if (size (z) /= 0 .or. len(z) /= 2) stop 3 +end Index: Fortran/gfortran/regression/substr_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_9.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-std=gnu -fdump-tree-original" } +! PR93340 - issues with substrings in initializers + +program p + implicit none + integer, parameter :: m = 1 + character b(2) /'a', 'b' (1:1)/ + character c(2) /'a', 'bc' (1:1)/ + character d(2) /'a', 'bxyz'(m:m)/ + character e(2) + character f(2) + data e /'a', 'bxyz'( :1)/ + data f /'a', 'xyzb'(4:4)/ + character :: g(2) = [ 'a', 'b' (1:1) ] + character :: h(2) = [ 'a', 'bc'(1:1) ] + character :: k(2) = [ 'a', 'bc'(m:1) ] + if (b(2) /= "b") stop 1 + if (c(2) /= "b") stop 2 + if (d(2) /= "b") stop 3 + if (e(2) /= "b") stop 4 + if (f(2) /= "b") stop 5 + if (g(2) /= "b") stop 6 + if (h(2) /= "b") stop 7 + if (k(2) /= "b") stop 8 +end + +! { dg-final { scan-tree-dump-times "xyz" 0 "original" } } Index: Fortran/gfortran/regression/substr_alloc_string_comp_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_alloc_string_comp_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR fortran/65766 +! Substrings of allocatable string components of derived types +program substr_derived_alloc_comp + implicit none + + type t1 + character(len=:), allocatable :: s + end type t1 + + character(len=*), parameter :: c = & + "0123456789abcdefghijklmnopqrstuvwxyz" + + type(t1) x1 + + integer i + + x1%s = c + + do i = 1, 36 + if (x1%s(i:) .ne. c(i:)) STOP 1 + end do +end program Index: Fortran/gfortran/regression/substr_simplify.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substr_simplify.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Test fixes for substring simplications derived from +! PR fortran/89077 - ICE using * as len specifier for character parameter + +program test + implicit none + integer :: i + character(*), parameter :: s = 'abcdef', y = 'efcdab' + character(6), save :: t = transfer ([(s(i:i), i=1,len(s) )], s) + character(*), parameter :: u = transfer ([(s(i:i+2),i=1,len(s),3)], s) + character(6), save :: v = transfer ([(s(i:i+2),i=1,len(s),3)], s) + character(*), parameter :: w = transfer ([(y(i:i+1),i=len(s)-1,1,-2)], s) + character(6), save :: x = transfer ([(y(i:i+1),i=len(s)-1,1,-2)], s) + if (len (t) /= len (s) .or. t /= s) stop 1 + if (len (u) /= len (s) .or. u /= s) stop 2 + if (len (v) /= len (s) .or. v /= s) stop 3 + if (len (w) /= len (s) .or. w /= s) stop 4 + if (len (x) /= len (s) .or. x /= s) stop 5 +end Index: Fortran/gfortran/regression/substring_equivalence.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substring_equivalence.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Tests fix for PR24223 - ICE on equivalence statement. +! +module FLAGS + character(len=5) :: Encodings + character :: at, dev + equivalence ( encodings(1:1),at ), ( encodings(2:2),dev) +end module FLAGS Index: Fortran/gfortran/regression/substring_integer_index.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/substring_integer_index.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/50524 +! +program foo + print *, 'abc'(2.e0:3) ! { dg-error "must be of type INTEGER" } + print *,'qwe'(1:1e0) ! { dg-error "must be of type INTEGER" } +end program foo + Index: Fortran/gfortran/regression/sum_init_expr.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sum_init_expr.f03 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options "-fno-inline" } +! +! SUM as initialization expression. +! +! This test compares results of simplifier of SUM +! 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_sum = SUM (imatrix) + INTEGER, PARAMETER :: imatrix_sum_d1(4) = SUM (imatrix, dim=1) + INTEGER, PARAMETER :: imatrix_sum_d2(2) = SUM (imatrix, dim=2) + LOGICAL, PARAMETER :: i_equal_sum = ALL ([SUM( imatrix_sum_d1 ) == SUM ( imatrix_sum_d2 ), & + SUM( imatrix_sum_d1 ) == imatrix_sum]) + LOGICAL, PARAMETER :: i_empty_sum = SUM(imatrix, mask=.FALSE.) == 0 + + REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 ], [2, 4] ) + REAL, PARAMETER :: rmatrix_sum = SUM (rmatrix) + REAL, PARAMETER :: rmatrix_sum_d1(4) = SUM (rmatrix, dim=1) + REAL, PARAMETER :: rmatrix_sum_d2(2) = SUM (rmatrix, dim=2) + LOGICAL, PARAMETER :: r_equal_sum = ALL ([SUM( rmatrix_sum_d1 ) == SUM ( rmatrix_sum_d2 ), & + SUM( rmatrix_sum_d1 ) == rmatrix_sum]) + LOGICAL, PARAMETER :: r_empty_sum = SUM(rmatrix, mask=.FALSE.) == 0.0 + + IF (.NOT. ALL ([i_equal_sum, i_empty_sum])) STOP 1 + IF (.NOT. ALL ([r_equal_sum, r_empty_sum])) STOP 2 + + CALL ilib (imatrix, imatrix_sum) + CALL ilib_with_dim (imatrix, 1, imatrix_sum_d1) + CALL ilib_with_dim (imatrix, 2, imatrix_sum_d2) + CALL rlib (rmatrix, rmatrix_sum) + CALL rlib_with_dim (rmatrix, 1, rmatrix_sum_d1) + CALL rlib_with_dim (rmatrix, 2, rmatrix_sum_d2) + +CONTAINS + SUBROUTINE ilib (array, result) + INTEGER, DIMENSION(:,:), INTENT(in) :: array + INTEGER, INTENT(in) :: result + IF (SUM(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 (SUM (array, dim=dim) /= result)) STOP 4 + END SUBROUTINE + + SUBROUTINE rlib (array, result) + REAL, DIMENSION(:,:), INTENT(in) :: array + REAL, INTENT(in) :: result + IF (ABS(SUM(array) - result) > 4e-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(SUM (array, dim=dim) - result) > 4e-6)) STOP 6 + END SUBROUTINE +END + + Index: Fortran/gfortran/regression/sum_zero_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/sum_zero_array_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 30321: This used to segfault. +program xzero + implicit none + integer :: ii(1,0) + logical :: ll(1,0) + character (len=80) line + ll = .true. + write (unit=line, fmt="(I6)") sum(ii,dim=1) + if (line /= " ") STOP 1 + write (unit=line, fmt="(I6)") sum(ii,dim=1,mask=ll) + if (line /= " ") STOP 2 +end program xzero Index: Fortran/gfortran/regression/system_clock_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/system_clock_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } + + integer :: i, j, k + integer(kind=8) :: i8, j8, k8 + real :: x + double precision :: z + + call system_clock(i, j, k) + call system_clock(i, j, k8) + call system_clock(i, j8, k) + call system_clock(i, j8, k8) + call system_clock(i8, j, k) + call system_clock(i8, j, k8) + call system_clock(i8, j8, k) + call system_clock(i8, j8, k8) + + call system_clock(i, x, k) + call system_clock(i, x, k8) + call system_clock(i, x, k) + call system_clock(i, x, k8) + call system_clock(i8, x, k) + call system_clock(i8, x, k8) + call system_clock(i8, x, k) + call system_clock(i8, x, k8) + + call system_clock(i, z, k) + call system_clock(i, z, k8) + call system_clock(i, z, k) + call system_clock(i, z, k8) + call system_clock(i8, z, k) + call system_clock(i8, z, k8) + call system_clock(i8, z, k) + call system_clock(i8, z, k8) + + end Index: Fortran/gfortran/regression/system_clock_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/system_clock_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + + integer :: i, j, k + integer(kind=8) :: i8, j8, k8 + real :: x + double precision :: z + + call system_clock(i, j, k) + call system_clock(i, j, k8) ! { dg-error "has non-default kind" } + call system_clock(i, j8, k) ! { dg-error "has non-default kind" } + call system_clock(i8, j, k) ! { dg-error "has non-default kind" } + + call system_clock(i, x, k) ! { dg-error "Real COUNT_RATE argument" } + + call system_clock(i, z, k) ! { dg-error "Real COUNT_RATE argument" } + + end Index: Fortran/gfortran/regression/system_clock_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/system_clock_3.f08 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR64432 +program countem + implicit none + integer(1) :: count1, irate1, mymax1 + integer(2) :: count2, irate2, mymax2 + integer(4) :: count4, irate4, mymax4 + real(4) :: rrate4 + + call system_clock(count=count1, count_rate=irate4, count_max=mymax4) + if (count1.ne.-127.or.irate4.ne.0.or.mymax4.ne.0) STOP 1 + call system_clock(count=count1, count_rate=rrate4, count_max=mymax1) + if (count1.ne.-127.or.rrate4.ne.0.0.or.mymax4.ne.0) STOP 2 + call system_clock(count=count2, count_rate=irate2, count_max=mymax2) + if (count2.ne.-32767.or.irate2.ne.0.or.mymax2.ne.0) STOP 3 + call system_clock(count=count2, count_rate=rrate4, count_max=mymax2) + if (count2.ne.-32767.or.rrate4.ne.0.0.or.mymax2.ne.0) STOP 4 + call system_clock(count=count4, count_rate=irate4, count_max=mymax4) + if (irate4.ne.1000.or.mymax4.ne.huge(0_4)) STOP 5 + call system_clock(count=count4, count_rate=rrate4, count_max=mymax4) + if (rrate4.ne.1000.0.or.mymax4.ne.huge(0_4)) STOP 6 +end program countem Index: Fortran/gfortran/regression/t_editing.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/t_editing.f @@ -0,0 +1,8 @@ +! { dg-do run } +! PR25349 Check T editing. Test case from PR submitted by Thomas Koenig +! Contributed by Jerry DeLisle + program main + character(len=10) line + write (line,'(1X,A,T1,A)') 'A','B' + if (line.ne.'BA') STOP 1 + end Index: Fortran/gfortran/regression/tab_continuation.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/tab_continuation.f @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/34899 +! +! Allow 1 to 9 as continuation marker, which is a very common +! vendor extension. +! +! Note: The test suite is run with -pedantic-errors, which both enables +! the tab warning (-pedantic implies -Wtabs) and turns it into errors +! (-pedantic-errors hence implies -Werror=tabs). +! + PARAMETER (LUMIN=11,LUMAX=20,MAPMAX=256,NPLANEMAX=999) + INTEGER NAXIS(0:MAPMAX,LUMIN:LUMAX),NAXIS1(0:MAPMAX,LUMIN:LUMAX), + 1NAXIS2(0:MAPMAX,LUMIN:LUMAX),NAXIS3(0:MAPMAX,LUMIN:LUMAX) + end +! { dg-error "Nonconforming tab character in column 1 of line 12" "Nonconforming tab" { target *-*-* } 0 } +! { dg-error "Nonconforming tab character in column 1 of line 13" "Nonconforming tab" { target *-*-* } 0 } +! { dg-error "Nonconforming tab character in column 1 of line 14" "Nonconforming tab" { target *-*-* } 0 } +! { dg-error "Nonconforming tab character in column 1 of line 15" "Nonconforming tab" { target *-*-* } 0 } +! { dg-prune-output "some warnings being treated as errors" } Index: Fortran/gfortran/regression/team_change_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/team_change_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Tests if change team worked +! + use iso_fortran_env, only : team_type + 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 + +end Index: Fortran/gfortran/regression/team_end_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/team_end_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Tests if team_number intrinsic fucntion works +! + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer, parameter :: standard_initial_value=-1 + + associate(new_team => mod(this_image(),2)+1) + form team (new_team,team) + change team (team) + end team + end associate + + if (team_number()/=standard_initial_value) STOP 1 +end Index: Fortran/gfortran/regression/team_form_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/team_form_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Tests if form team works +! + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + + form team (mod(this_image(),2)+1,team) + +end Index: Fortran/gfortran/regression/team_number_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/team_number_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Tests if team_number intrinsic fucntion works +! + use iso_fortran_env, only : team_type + implicit none + type(team_type) team + integer, parameter :: standard_initial_value=-1 + integer new_team + + if (team_number()/=standard_initial_value) STOP 1 + + new_team = mod(this_image(),2)+1 + form team (new_team,team) + change team (team) + if (team_number()/=new_team) STOP 2 + end team + + if (team_number()/=standard_initial_value) STOP 3 + +end Index: Fortran/gfortran/regression/temporary_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/temporary_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! 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/temporary_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/temporary_2.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! Tests the fix for PR70864 in which compiler generated temporaries received +! the attributes of a dummy argument. This is the original testcase. +! The simplified version by Gerhard Steinmetz is gratefully acknowledged. +! +! Contributed by Weiqun Zhang +! +module boxarray_module + implicit none + type :: BoxArray + integer :: i = 0 + contains + procedure :: boxarray_assign + generic :: assignment(=) => boxarray_assign + end type BoxArray +contains + subroutine boxarray_assign (dst, src) + class(BoxArray), intent(inout) :: dst + type (BoxArray), intent(in ) :: src + dst%i =src%i + end subroutine boxarray_assign +end module boxarray_module + +module multifab_module + use boxarray_module + implicit none + type, public :: MultiFab + type(BoxArray) :: ba + end type MultiFab +contains + subroutine multifab_swap(mf1, mf2) + type(MultiFab), intent(inout) :: mf1, mf2 + type(MultiFab) :: tmp + tmp = mf1 + mf1 = mf2 ! Generated an ICE in trans-decl.c. + mf2 = tmp + end subroutine multifab_swap +end module multifab_module Index: Fortran/gfortran/regression/temporary_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/temporary_3.f90 @@ -0,0 +1,122 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! Tests the fix for PR68846 in which compiler generated temporaries were +! receiving the attributes of dummy arguments. This test is the original. +! The simplified versions by Gerhard Steinmetz are gratefully acknowledged. +! +! Contributed by Mirco Valentini +! +MODULE grid + IMPLICIT NONE + PRIVATE + REAL(KIND=8), DIMENSION(100,100), TARGET :: WORKSPACE + TYPE, PUBLIC :: grid_t + REAL(KIND=8), DIMENSION(:,:), POINTER :: P => NULL () + END TYPE + PUBLIC :: INIT +CONTAINS + SUBROUTINE INIT (DAT) + IMPLICIT NONE + TYPE(grid_t), INTENT(INOUT) :: DAT + INTEGER :: I, J + DAT%P => WORKSPACE + DO I = 1, 100 + DO J = 1, 100 + DAT%P(I,J) = REAL ((I-1)*100+J-1) + END DO + ENDDO + END SUBROUTINE INIT +END MODULE grid + +MODULE subgrid + USE :: grid, ONLY: grid_t + IMPLICIT NONE + PRIVATE + TYPE, PUBLIC :: subgrid_t + INTEGER, DIMENSION(4) :: range + CLASS(grid_t), POINTER :: grd => NULL () + CONTAINS + PROCEDURE, PASS :: INIT => LVALUE_INIT + PROCEDURE, PASS :: JMP => LVALUE_JMP + END TYPE +CONTAINS + SUBROUTINE LVALUE_INIT (HOBJ, P, D) + IMPLICIT NONE + CLASS(subgrid_t), INTENT(INOUT) :: HOBJ + TYPE(grid_t), POINTER, INTENT(INOUT) :: P + INTEGER, DIMENSION(4), INTENT(IN) :: D + HOBJ%range = D + HOBJ%grd => P + END SUBROUTINE LVALUE_INIT + + FUNCTION LVALUE_JMP(HOBJ, I, J) RESULT(P) + IMPLICIT NONE + CLASS(subgrid_t), INTENT(INOUT) :: HOBJ + INTEGER, INTENT(IN) :: I, J + REAL(KIND=8), POINTER :: P + P => HOBJ%grd%P(HOBJ%range(1)+I-1, HOBJ%range(3)+J-1) + END FUNCTION LVALUE_JMP +END MODULE subgrid + +MODULE geom + IMPLICIT NONE +CONTAINS + SUBROUTINE fillgeom_03( subgrid, value ) + USE :: subgrid, ONLY: subgrid_t + IMPLICIT NONE + TYPE(subgrid_T), intent(inout) :: subgrid + REAL(kind=8), intent(in) :: value + INTEGER :: I, J + DO i = 1, 3 + DO J = 1, 4 + subgrid%jmp(i,j) = value ! Dummy argument '_F.DA0' with INTENT(IN) + ! in pointer association context or ICE + ! in trans_decl.c, depending on INTENT of + ! 'VALUE' + ENDDO + ENDDO + END SUBROUTINE fillgeom_03 +END MODULE geom + +PROGRAM test_lvalue + USE :: grid + USE :: subgrid + USE :: geom + IMPLICIT NONE + TYPE(grid_t), POINTER :: GRD => NULL() + TYPE(subgrid_t) :: STENCIL + REAL(KIND=8), POINTER :: real_tmp_ptr + REAL(KIND=8), DIMENSION(10,10), TARGET :: AA + REAL(KIND=8), DIMENSION(3,4) :: VAL + INTEGER :: I, J, chksum + integer, parameter :: r1 = 50 + integer, parameter :: r2 = 52 + integer, parameter :: r3 = 50 + integer, parameter :: r4 = 53 + DO I = 1, 3 + DO J = 1, 4 + VAL(I,J) = dble(I)*dble(J) + ENDDO + ENDDO + + ALLOCATE (GRD) + CALL INIT (GRD) + chksum = sum([([((i-1)*100 + j -1, j=1,100)], i = 1,100)]) + if (int(sum(grd%p)) .ne. chksum) stop 1 + + CALL STENCIL%INIT (GRD, [r1, r2, r3, r4]) + if (.not.associated (stencil%grd, grd)) stop 2 + if (int(sum(grd%p)) .ne. chksum) stop 3 + + CALL fillgeom_03(stencil, 42.0_8) + if (any (int (grd%p(r1:r2,r3:r4)) .ne. 42)) stop 4 + + chksum = chksum - sum([([((i - 1) * 100 + j -1, j=r3,r4)], i = r1,r2)]) & + + (r4 - r3 + 1) * (r2 - r1 +1) * 42 + if (int(sum(grd%p)) .ne. chksum) stop 5 + + deallocate (grd) +END PROGRAM test_lvalue + + Index: Fortran/gfortran/regression/test_bind_c_parens.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_bind_c_parens.f03 @@ -0,0 +1,7 @@ +! { dg-do compile } +module test_bind_c_parens + interface + subroutine sub bind(c) ! { dg-error "Missing required parentheses" } + end subroutine sub ! { dg-error "Expecting END INTERFACE" } + end interface +end module test_bind_c_parens Index: Fortran/gfortran/regression/test_c_assoc.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_c_assoc.c @@ -0,0 +1,55 @@ +/* use 0 for NULL so no need for system header */ + +int test_c_assoc_0(void *my_c_ptr); +int test_c_assoc_1(void *my_c_ptr_1, void *my_c_ptr_2); +int test_c_assoc_2(void *my_c_ptr_1, void *my_c_ptr_2, int num_ptrs); +void verify_assoc(void *my_c_ptr_1, void *my_c_ptr_2); + +extern void abort(void); + +int main(int argc, char **argv) +{ + int i; + int j; + + if(test_c_assoc_0(0) != 0) + abort(); + + if(test_c_assoc_0(&i) != 1) + abort(); + + if(test_c_assoc_1(0, 0) != 0) + abort(); + + if(test_c_assoc_1(0, &i) != 0) + abort(); + + if(test_c_assoc_1(&i, &i) != 1) + abort(); + + if(test_c_assoc_1(&i, 0) != 0) + abort(); + + if(test_c_assoc_1(&i, &j) != 0) + abort(); + + /* this should be associated, cause only testing 1 ptr (i) */ + if(test_c_assoc_2(&i, 0, 1) != 1) + abort(); + + /* this should be associated */ + if(test_c_assoc_2(&i, &i, 2) != 1) + abort(); + + /* this should not be associated (i) */ + if(test_c_assoc_2(&i, &j, 2) != 0) + abort(); + + /* this should be associated, cause only testing 1 ptr (i) */ + if(test_c_assoc_2(&i, &j, 1) != 1) + abort(); + + verify_assoc(&i, &i); + + return 0; +}/* end main() */ Index: Fortran/gfortran/regression/test_com_block.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_com_block.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +module nonF03ComBlock + common /NONF03COM/ r, s + real :: r + real :: s + + contains + + subroutine hello(myArray) + integer, dimension(:) :: myArray + + r = 1.0 + s = 2.0 + end subroutine hello +end module nonF03ComBlock + +program testComBlock + use nonF03ComBlock + integer, dimension(1:10) :: myArray + + call hello(myArray) + + ! these are set in the call to hello() above + ! r and s are reals (default size) in com block, set to + ! 1.0 and 2.0, respectively, in hello() + if(r .ne. 1.0) then + STOP 1 + endif + if(s .ne. 2.0) then + STOP 2 + endif +end program testComBlock Index: Fortran/gfortran/regression/test_common_binding_labels.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_common_binding_labels.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +module x + use, intrinsic :: iso_c_binding, only: c_double + implicit none + + common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block vs .blank.|In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block_2 vs .blank." } + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ +end module x + +module y + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block vs .blank." } + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ + + common /com2/ i ! { dg-error " In Fortran 2003 COMMON 'com2' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: mycom2 vs .blank." } + integer(c_int) :: i + bind(c, name="") /com2/ +end module y + +module z + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s ! { dg-error "In Fortran 2003 COMMON 'mycom' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: my_common_block_2 vs .blank." } + real(c_double) :: r + real(c_double) :: s + ! this next line is an error; if a common block is bind(c), the binding label + ! for it must match across all scoping units that declare it. + bind(c, name="my_common_block_2") :: /mycom/ + + common /com2/ i ! { dg-error " In Fortran 2003 COMMON 'com2' block at .1. is a global identifier and must thus have the same binding name as the same-named COMMON block at .2.: mycom2 vs .blank." } + integer(c_int) :: i + bind(c, name="mycom2") /com2/ +end module z Index: Fortran/gfortran/regression/test_common_binding_labels_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_common_binding_labels_2.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +module test_common_binding_labels_2 + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ + + common /com2/ i + integer(c_int) :: i + bind(c, name="") /com2/ +end module test_common_binding_labels_2 Index: Fortran/gfortran/regression/test_common_binding_labels_2_main.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_common_binding_labels_2_main.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! { dg-compile-aux-modules "test_common_binding_labels_2.f03" } +! +module test_common_binding_labels_2_main + use, intrinsic :: iso_c_binding, only: c_double, c_int + implicit none + + common /mycom/ r, s ! { dg-error "same binding name" } + real(c_double) :: r + real(c_double) :: s + ! this next line is an error; if a common block is bind(c), the binding label + ! for it must match across all scoping units that declare it. + bind(c, name="my_common_block_2") :: /mycom/ + + common /com2/ i ! { dg-error "same binding name" } + integer(c_int) :: i + bind(c, name="mycom2") /com2/ +end module test_common_binding_labels_2_main + +program main + use test_common_binding_labels_2 ! { dg-error "same binding name" } + use test_common_binding_labels_2_main ! { dg-error "same binding name" } +end program main +! { dg-final { cleanup-modules "test_common_binding_labels_2" } } Index: Fortran/gfortran/regression/test_common_binding_labels_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_common_binding_labels_3.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module test_common_binding_labels_3 + use, intrinsic :: iso_c_binding, only: c_double + implicit none + + common /mycom/ r, s + real(c_double) :: r + real(c_double) :: s + bind(c, name="my_common_block") :: /mycom/ +end module test_common_binding_labels_3 Index: Fortran/gfortran/regression/test_common_binding_labels_3_main.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_common_binding_labels_3_main.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-compile-aux-modules "test_common_binding_labels_3.f03" } +module test_common_binding_labels_3_main + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "COMMON block at .1. with binding label 'my_common_block' uses the same global identifier as entity at .2." } +end module test_common_binding_labels_3_main + +program main + use test_common_binding_labels_3_main + use test_common_binding_labels_3 ! { dg-error "COMMON block at .1. with binding label 'my_common_block' uses the same global identifier as entity at .2." } +end program main Index: Fortran/gfortran/regression/test_only_clause.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/test_only_clause.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-additional-sources only_clause_main.c } +module testOnlyClause + + contains + subroutine testOnly(cIntPtr) bind(c, name="testOnly") + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_f_pointer + implicit none + type(c_ptr), value :: cIntPtr + integer(c_int), pointer :: f90IntPtr + + call c_f_pointer(cIntPtr, f90IntPtr) + + ! f90IntPtr coming in has value of -11; this will make it -12 + f90IntPtr = f90IntPtr - 1 + if(f90IntPtr .ne. -12) then + STOP 1 + endif + end subroutine testOnly +end module testOnlyClause Index: Fortran/gfortran/regression/tiny_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/tiny_1.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! Test program inspired by bug report from Walt Brainerd. +! http://gcc.gnu.org/ml/fortran/2005-04/msg00132.html +program tiny1 + real(4) x4 + real(8) x8 + if (minexponent(x4) /= exponent(tiny(x4))) STOP 1 + if (minexponent(x8) /= exponent(tiny(x8))) STOP 2 +end program tiny1 Index: Fortran/gfortran/regression/tiny_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/tiny_2.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +program tiny2 + real(4) x4 + real(8) x8 + x4 = tiny(x4) + x8 = tiny(x8) + if (minexponent(x4) /= exponent(x4)) STOP 1 + if (minexponent(x8) /= exponent(x8)) STOP 2 +end program tiny2 Index: Fortran/gfortran/regression/tl_editing.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/tl_editing.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test of fix to bug triggered by NIST fm908.for. +! Left tabbing, followed by X or T-tabbing to the right would +! cause spaces to be overwritten on output data. +! Contributed by Paul Thomas +! PR25349 Revised by Jerry DeLisle +program tl_editting + character*10 :: line, many(5), s + character*10 :: aline = "abcdefxyij" + character*2 :: bline = "gh" + character*10 :: cline = "abcdefghij" + +! Character unit test + write (line, '(a10,tl6,2x,a2)') aline, bline + if (line.ne.cline) STOP 1 + +! Character array unit test + many = "0123456789" + write(many(1:5:2), '(a10,tl6,2x,a2)') aline, bline, aline, bline, aline,& + &bline + if (many(1).ne.cline) STOP 2 + if (many(3).ne.cline) STOP 3 + if (many(5).ne.cline) STOP 4 + +! File unit test + write (10, '(a10,tl6,2x,a2)') aline, bline + rewind(10) + read(10, '(a)') s + if (s.ne.cline) STOP 1 + close(10, status='delete') + +end program tl_editting + Index: Fortran/gfortran/regression/trans-mem-skel.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trans-mem-skel.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fgnu-tm" } +! { dg-require-effective-target fgnu_tm } +program foo + real x +end program foo Index: Fortran/gfortran/regression/transfer_array_intrinsic_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_array_intrinsic_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! Tests the patch to implement the array version of the TRANSFER +! intrinsic (PR17298). + +! test the PR is fixed. + + call test1 () + +contains + + subroutine test1 () + complex(4) :: z = (1.0, 2.0) + real(4) :: cmp(2), a(4, 4) + integer(2) :: it(4, 2, 4), jt(32) + +! The PR testcase. + + cmp = transfer (z, cmp) * 2.0 + if (any (cmp .ne. (/2.0, 4.0/))) STOP 1 + + end subroutine test1 + +end Index: Fortran/gfortran/regression/transfer_array_intrinsic_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_array_intrinsic_2.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! Tests the patch to implement the array version of the TRANSFER +! intrinsic (PR17298). +! Contributed by Paul Thomas + +! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005. +! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0 + + LOGICAL :: bigend + integer :: icheck = 1 + + character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) + + bigend = IACHAR(TRANSFER(icheck,"a")) == 0 + +! tests numeric transfers other than original testscase. + + call test1 () + +! tests numeric/character transfers. + + call test2 () + +! Test dummies, automatic objects and assumed character length. + + call test3 (ch, ch, ch, 8) + +contains + + subroutine test1 () + real(4) :: a(4, 4) + integer(2) :: it(4, 2, 4), jt(32) + +! Check multi-dimensional sources and that transfer works as an actual +! argument of reshape. + + a = reshape ((/(rand (), i = 1, 16)/), (/4,4/)) + jt = transfer (a, it) + it = reshape (jt, (/4, 2, 4/)) + if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) STOP 1 + + end subroutine test1 + + subroutine test2 () + integer(4) :: y(4), z(2) + character(4) :: ch(4) + +! Allow for endian-ness + if (bigend) then + y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) & + + ishft (i, 24), i = 65, 80 , 4)/) + else + y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) & + + ishft (i + 3, 24), i = 65, 80 , 4)/) + end if + +! Check source array sections in both directions. + + ch = "wxyz" + ch(1:2) = transfer (y(2:4:2), ch) + if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) STOP 2 + ch = "wxyz" + ch(1:2) = transfer (y(4:2:-2), ch) + if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) STOP 3 + +! Check that a complete array transfers with size absent. + + ch = transfer (y, ch) + if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) STOP 4 + +! Check that a character array section is OK + + z = transfer (ch(2:3), y) + if (any (z .ne. y(2:3))) STOP 5 + +! Check dest array sections in both directions. + + ch = "wxyz" + ch(3:4) = transfer (y, ch, 2) + if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) STOP 6 + ch = "wxyz" + ch(3:2:-1) = transfer (y, ch, 2) + if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) STOP 7 + +! Make sure that character to numeric is OK. + + ch = "wxyz" + ch(1:2) = transfer (y, ch, 2) + if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) STOP 8 + + z = transfer (ch, y, 2) + if (any (y(1:2) .ne. z)) STOP 9 + + end subroutine test2 + + subroutine test3 (ch1, ch2, ch3, clen) + integer clen + character(8) :: ch1(:) + character(*) :: ch2(2) + character(clen) :: ch3(2) + character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/) + integer(8) :: ic(2) + ic = transfer (cntrl, ic) + +! Check assumed shape. + + if (any (ic .ne. transfer (ch1, ic))) STOP 10 + +! Check assumed character length. + + if (any (ic .ne. transfer (ch2, ic))) STOP 11 + +! Check automatic character length. + + if (any (ic .ne. transfer (ch3, ic))) STOP 12 + + end subroutine test3 + +end Index: Fortran/gfortran/regression/transfer_array_intrinsic_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_array_intrinsic_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests fix for PR31193, in which the character length for MOLD in +! case 1 below was not being translated correctly for character +! constants and an ICE ensued. The further cases are either checks +! or new bugs that were found in the course of development cases 3 & 5. +! +! Contributed by Brooks Moses +! +function NumOccurances (string, chr, isel) result(n) + character(*),intent(in) :: string + character(1),intent(in) :: chr + integer :: isel +! +! return number of occurances of character in given string +! + select case (isel) + case (1) + n=count(transfer(string, char(1), len(string))==chr) + case (2) + n=count(transfer(string, chr, len(string))==chr) + case (3) + n=count(transfer(string, "a", len(string))==chr) + case (4) + n=count(transfer(string, (/"a","b"/), len(string))==chr) + case (5) + n=count(transfer(string, string(1:1), len(string))==chr) + end select + return +end + + if (NumOccurances("abacadae", "a", 1) .ne. 4) STOP 1 + if (NumOccurances("abacadae", "a", 2) .ne. 4) STOP 2 + if (NumOccurances("abacadae", "a", 3) .ne. 4) STOP 3 + if (NumOccurances("abacadae", "a", 4) .ne. 4) STOP 4 + if (NumOccurances("abacadae", "a", 5) .ne. 4) STOP 5 +end Index: Fortran/gfortran/regression/transfer_array_intrinsic_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_array_intrinsic_4.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Tests patch for pr27155, where character scalar string_lengths +! were not correctly translated by the array transfer intrinsic. +! +! Contributed by Bo Berggren +! +program trf_test + implicit none + character(11) :: s1, s2 + integer(4) :: ia(3) + integer(1) :: ba(12) + equivalence (ia, ba) + + s1 = 'ABCDEFGHIJK' + ia = TRANSFER (s1, (/ 0_4 /)) + s2 = TRANSFER(ba + 32_1, s2) + + if (s2 .ne. 'abcdefghijk') STOP 1 + + s1 = 'AB' + ba = TRANSFER (trim (s1)//' JK' , (/ 0_1 /)) + s2 = TRANSFER(ia, s2) + + if (trim (s1)//' JK' .ne. s2) STOP 2 + +end program trf_test Index: Fortran/gfortran/regression/transfer_array_intrinsic_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_array_intrinsic_5.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR35680 - used to ICE because the argument of SIZE, being in a restricted +! expression, was not checked if it too is restricted or is a variable. Since +! it is neither, an error should be produced. +! +! Contributed by Francois-Xavier Coudert +! +program main + print *, foo (), bar (), foobar () +contains + function foo () + integer foo(size (transfer (x, [1]))) ! { dg-error "cannot appear" } + real x + end function + function bar() + real x + integer bar(size (transfer (x, [1]))) ! { dg-error "cannot appear" } + end function + function foobar() ! { dg-error "no IMPLICIT" } + implicit none + integer foobar(size (transfer (x, [1]))) ! { dg-error "used before" } + real x + end function +end program Index: Fortran/gfortran/regression/transfer_assumed_size_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_assumed_size_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! Tests the fix for the regression PR34080, in which the character +! length of the assumed length arguments to TRANSFER were getting +! lost. +! +! Drew McCormack +! +module TransferBug + type ByteType + private + character(len=1) :: singleByte + end type + + type (ByteType), save :: BytesPrototype(1) + +contains + + function StringToBytes(v) result (bytes) + character(len=*), intent(in) :: v + type (ByteType) :: bytes(size(transfer(v, BytesPrototype))) + bytes = transfer(v, BytesPrototype) + end function + + subroutine BytesToString(bytes, string) + type (ByteType), intent(in) :: bytes(:) + character(len=*), intent(out) :: string + character(len=1) :: singleChar(1) + integer :: numChars + numChars = size(transfer(bytes,singleChar)) + string = '' + string = transfer(bytes, string) + string(numChars+1:) = '' + end subroutine + +end module + + +program main + use TransferBug + character(len=100) :: str + call BytesToString( StringToBytes('Hi'), str ) + if (trim(str) .ne. "Hi") STOP 1 +end program Index: Fortran/gfortran/regression/transfer_char_kind4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_char_kind4.f90 @@ -0,0 +1,115 @@ +! { dg-do run } +! PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4) +! Exercise TRANSFER intrinsic to check character result length and shape + +program p + implicit none + character(len=*,kind=4), parameter :: a = 4_'ABCDEF' + character(len=6,kind=4) :: b = 4_'abcdef' + character(len=*,kind=4), parameter :: c = 4_'XY' + character(len=2,kind=4) :: d = 4_'xy' + integer :: k, l + k = len (a) + l = len (c) + +! print *, transfer(4_'xy', [4_'a']) + + ! TRANSFER with rank-0 result + call chk0 (transfer (4_'ABCD', 4_'XY'), 2, 1) + call chk0 (transfer (4_'ABCD', c ), l, 2) + call chk0 (transfer (4_'ABCD', d ), l, 3) + call chk0 (transfer (a , 4_'XY'), 2, 4) + call chk0 (transfer (a , c ), l, 5) + call chk0 (transfer (a , d ), l, 6) + call chk0 (transfer (b , 4_'XY'), 2, 7) + call chk0 (transfer (b , c ), l, 8) + call chk0 (transfer (b , d ), l, 9) + + call chk0 (transfer ([4_'ABCD'], 4_'XY'), 2, 11) + call chk0 (transfer ([4_'ABCD'], c ), l, 12) + call chk0 (transfer ([4_'ABCD'], d ), l, 13) + call chk0 (transfer ([a ], 4_'XY'), 2, 14) + call chk0 (transfer ([a ], c ), l, 15) + call chk0 (transfer ([a ], d ), l, 16) + call chk0 (transfer ([b ], 4_'XY'), 2, 17) + call chk0 (transfer ([b ], c ), l, 18) + call chk0 (transfer ([b ], d ), l, 19) + + ! TRANSFER with rank-1 result + call chk1 (transfer (4_'ABCD', [4_'XY']), 2, 2, 21) + call chk1 (transfer (4_'ABCD', [c] ), 2, 2, 22) + call chk1 (transfer (4_'ABCD', [d] ), 2, 2, 23) + call chk1 (transfer (a , [4_'XY']), 2, k/2, 24) + call chk1 (transfer (a , [c] ), l, k/l, 25) + call chk1 (transfer (a , [d] ), l, k/l, 26) + call chk1 (transfer (b , [4_'XY']), 2, k/2, 27) + call chk1 (transfer (b , [c] ), l, k/l, 28) + call chk1 (transfer (b , [d] ), l, k/l, 29) + + call chk1 (transfer (4_'ABCD', 4_'XY',size=2), 2, 2, 31) + call chk1 (transfer (4_'ABCD', c ,size=2), 2, 2, 32) + call chk1 (transfer (4_'ABCD', d ,size=2), 2, 2, 33) + call chk1 (transfer (a , 4_'XY',size=3), 2, 3, 34) + call chk1 (transfer (a , c ,size=3), l, 3, 35) + call chk1 (transfer (a , d ,size=3), l, 3, 36) + call chk1 (transfer (b , 4_'XY',size=3), 2, 3, 37) + call chk1 (transfer (b , c ,size=3), l, 3, 38) + call chk1 (transfer (b , d ,size=3), l, 3, 39) + + call chk1 (transfer (4_'ABCD', [4_'XY'],size=2), 2, 2, 41) + call chk1 (transfer (4_'ABCD', [c] ,size=2), 2, 2, 42) + call chk1 (transfer (4_'ABCD', [d] ,size=2), 2, 2, 43) + call chk1 (transfer (a , [4_'XY'],size=3), 2, 3, 44) + call chk1 (transfer (a , [c] ,size=3), l, 3, 45) + call chk1 (transfer (a , [d] ,size=3), l, 3, 46) + call chk1 (transfer (b , [4_'XY'],size=3), 2, 3, 47) + call chk1 (transfer (b , [c] ,size=3), l, 3, 48) + call chk1 (transfer (b , [d] ,size=3), l, 3, 49) + + call chk1 (transfer ([4_'ABCD'], [4_'XY']), 2, 2, 51) + call chk1 (transfer ([4_'ABCD'], [c] ), 2, 2, 52) + call chk1 (transfer ([4_'ABCD'], [d] ), 2, 2, 53) + call chk1 (transfer ([a ], [4_'XY']), 2, k/2, 54) + call chk1 (transfer ([a ], [c] ), l, k/l, 55) + call chk1 (transfer ([a ], [d] ), l, k/l, 56) + call chk1 (transfer ([b ], [4_'XY']), 2, k/2, 57) + call chk1 (transfer ([b ], [c] ), l, k/l, 58) + call chk1 (transfer ([b ], [d] ), l, k/l, 59) + + call chk1 (transfer (4_'ABCD', c ,size=4/l), l, 4/l, 62) + call chk1 (transfer (4_'ABCD', d ,size=4/l), l, 4/l, 63) + call chk1 (transfer (a , 4_'XY',size=k/2), 2, k/2, 64) + call chk1 (transfer (a , c ,size=k/l), l, k/l, 65) + call chk1 (transfer (a , d ,size=k/l), l, k/l, 66) + call chk1 (transfer (b , 4_'XY',size=k/2), 2, k/2, 67) + call chk1 (transfer (b , c ,size=k/l), l, k/l, 68) + call chk1 (transfer (b , d ,size=k/l), l, k/l, 69) + +contains + ! Validate rank-0 result + subroutine chk0 (str, l, stopcode) + character(kind=4,len=*), intent(in) :: str + integer, intent(in) :: l, stopcode + integer :: i, p + i = len (str) + p = verify (str, a // b) ! Check for junk characters + if (i /= l .or. p > 0) then + print *, stopcode, "len=", i, i == l, ">", str, "<" + stop stopcode + end if + end subroutine chk0 + + ! Validate rank-1 result + subroutine chk1 (str, l, m, stopcode) + character(kind=4,len=*), intent(in) :: str(:) + integer, intent(in) :: l, m, stopcode + integer :: i, j, p + i = len (str) + j = size (str) + p = maxval (verify (str, a // b)) ! Check for junk characters + if (i /= l .or. j /= m .or. p > 0) then + print *, stopcode, "len=", i, i == l, "size=", j, j == m, ">", str, "<" + stop stopcode + end if + end subroutine chk1 +end Index: Fortran/gfortran/regression/transfer_check_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options -Wsurprising } +! PR fortran/33037 +! +print *, transfer('x', 0, 20) ! { dg-warning "has partly undefined result" } +print *, transfer(1_1, 0) ! { dg-warning "has partly undefined result" } +print *, transfer([1_2,2_2], 0) +print *, transfer([1_2,2_2], 0_8) ! { dg-warning "has partly undefined result" } +end Index: Fortran/gfortran/regression/transfer_check_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! PR 37221 - also warn about too-long MOLD for TRANSFER if not simplifying. +! Test case based on contribution by Tobias Burnus. +program main + character(len=10) :: str + integer :: i + str = transfer(65+66*2**8+67*2**16+68*2**24,str) ! { dg-warning "has partly undefined result" } + write (*,*) str(1:4) + i = 65+66*2**8+67*2**16+68*2**24 + str = transfer(i,str) ! { dg-warning "has partly undefined result" } + write (*,*) str(1:4) + str = transfer(i,str(1:4)) + write (*,*) str(1:4) +end program + Index: Fortran/gfortran/regression/transfer_check_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_3.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR fortran/53691 +! PR fortran/53685 +! +! TRANSFER checks + + +! (a) PR 53691 +! Failed for -Wsurprising with an ICE as SIZE was assumed to be constant + + SUBROUTINE CGBRFSX(N, RWORK) + INTEGER N + REAL RWORK(*) + REAL ZERO + PARAMETER (ZERO = 0.0E+0) + call foo(TRANSFER (RWORK(1:2*N), (/ (ZERO, ZERO) /), N)) + end + +! (b) PR 53685 +! Failed with a bogus size warning if the source's size is not known at compile +! time (for substrings, the length wasn't set) + + subroutine test(j) + implicit none + character(len=4) :: record_type + integer :: i, j + + i = transfer (record_type, i) ! no warning + i = transfer (record_type(1:4), i) ! gave a warning + i = transfer (record_type(1:j), i) ! gave a warning + end Index: Fortran/gfortran/regression/transfer_check_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_4.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-Wall" } + +! PR 57022: [4.7/4.8/4.9 Regression] Inappropriate warning for use of TRANSFER with arrays +! Contributed by William Clodius + +subroutine transfers (test) + + use, intrinsic :: iso_fortran_env + + integer, intent(in) :: test + + integer(int8) :: test8(8) = 0 + integer(int16) :: test16(4) = 0 + integer(int32) :: test32(2) = 0 + integer(int64) :: test64 = 0 + + select case(test) + case(0) + test64 = transfer(test8, test64) + case(1) + test64 = transfer(test16, test64) + case(2) + test64 = transfer(test32, test64) + case(3) + test8 = transfer(test64, test8, 8) + case(4) + test16 = transfer(test64, test16, 4) + case(5) + test32 = transfer(test64, test32, 2) + end select + +end subroutine + + +! PR 53685: surprising warns about transfer with explicit character range +! Contributed by Jos de Kloe + +subroutine mytest(byte_array,val) + integer, parameter :: r8_ = Selected_Real_Kind(15,307) ! = real*8 + character(len=1), dimension(16), intent(in) :: byte_array + real(r8_),intent(out) :: val + val = transfer(byte_array(1:8),val) +end subroutine Index: Fortran/gfortran/regression/transfer_check_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR fortran/89516 - ICE in gfc_calculate_transfer_sizes at gcc/fortran/check.c:5506 +! Found by Martin Liška + +program test + character(*), parameter :: n = '' + character(*), parameter :: o = transfer ([''], n) + print *, transfer(1,'',size=0) ! No warning + print *, transfer(1,'',size=1) ! No warning + print *, transfer('',1,size=0) ! No warning + print *, transfer('',1,size=1) ! { dg-warning "has partly undefined result" } +end program test Index: Fortran/gfortran/regression/transfer_check_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_check_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/104227 - ICE virtual memory exhausted +! Contributed by G.Steinmetz + +program p + type t + end type + type(t) :: x(2) + print *, transfer(1, x) ! { dg-error "shall not have storage size 0" } + x = transfer(1, x) ! { dg-error "shall not have storage size 0" } +end Index: Fortran/gfortran/regression/transfer_class_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_class_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR 54917: [4.7/4.8 Regression] [OOP] TRANSFER on polymorphic variable causes ICE +! +! Contributed by Sean Santos + +subroutine test_routine1(arg) + implicit none + type test_type + integer :: test_comp + end type + class(test_type) :: arg + integer :: i + i = transfer(arg, 1) +end subroutine Index: Fortran/gfortran/regression/transfer_class_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_class_2.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! PR 54917: [OOP] TRANSFER on polymorphic variable causes ICE +! +! Contributed by Janus Weil + +module m + implicit none + type test_type + integer :: i = 0 + contains + procedure :: ass + generic :: assignment(=) => ass + end type +contains + subroutine ass (a, b) + class(test_type), intent(out) :: a + class(test_type), intent(in) :: b + a%i = b%i + end subroutine +end module + + +program p + use m + implicit none + + class(test_type), allocatable :: c + type(test_type) :: t + + allocate(c) + + ! (1) check CLASS-to-TYPE transfer + c%i=3 + t = transfer(c, t) + if (t%i /= 3) STOP 1 + + ! (2) check TYPE-to-CLASS transfer + t%i=4 + c = transfer(t, c) + if (c%i /= 4) STOP 2 + +end Index: Fortran/gfortran/regression/transfer_class_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_class_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! Test the fix for PR66679. +! +! Contributed by Miha Polajnar +! +program main + implicit none + class(*), allocatable :: vec(:) + integer :: var, ans(2) + allocate(vec(2),source=[1_4, 2_4]) + +! This worked correctly. + if (any (transfer(vec,[var],2) .ne. [1_4, 2_4])) stop 1 + +! This caused an ICE. + if (any ([transfer(vec(1),[var]), transfer(vec(2),[var])] .ne. [1_4, 2_4])) stop 2 +end program main Index: Fortran/gfortran/regression/transfer_hollerith_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_hollerith_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O2" } +! PR 31972, ICE in transfer of Hollerith constant + integer, dimension(1) :: i + integer :: j + i = (/ transfer(4HSOLR, 0) /) + + j = transfer(0, 4HSOLR) ! { dg-error "must not be HOLLERITH" } +end + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 8 } + Index: Fortran/gfortran/regression/transfer_intrinsic_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Check the fix for PR34955 in which three bytes would be copied +! from bytes by TRANSFER, instead of the required two. +! +! Contributed by Tobias Burnus +! +subroutine BytesToString(bytes, string) + type ByteType + integer(kind=1) :: singleByte + end type + type (ByteType) :: bytes(2) + character(len=*) :: string + string = transfer(bytes, string) + end subroutine +! { dg-final { scan-tree-dump-times "MIN_EXPR" 1 "original" } } Index: Fortran/gfortran/regression/transfer_intrinsic_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_2.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Check the fix for PR34955 in which three bytes would be copied +! from bytes by TRANSFER, instead of the required two and the +! resulting string length would be incorrect. +! +! Contributed by Dominique Dhumieres +! + character(len = 1) :: string = "z" + character(len = 20) :: tmp = "" + tmp = Upper ("abcdefgh") + if (trim(tmp) .ne. "ab") STOP 1 +contains + Character (len = 20) Function Upper (string) + Character(len = *) string + integer :: ij + i = size (transfer (string,"xy",len (string))) + if (i /= len (string)) STOP 2 + Upper = "" + Upper(1:2) = & + transfer (merge (transfer (string,"xy",len (string)), & + string(1:2), .true.), "xy") + return + end function Upper +end Index: Fortran/gfortran/regression/transfer_intrinsic_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_3.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR41772 in which the empty array reference +! 'qname(1:n-1)' was not handled correctly in TRANSFER. +! +! Contributed by Tobias Burnus +! +module m + implicit none +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 + subroutine has_key_ns(uri, localname, n) + character(len=*), intent(in) :: uri, localname + integer, intent(in) :: n + if ((n .lt. 2) .and. (len (uri) .ne. 0)) then + STOP 1 + else IF ((n .ge. 2) .and. (len (uri) .ne. n - 1)) then + STOP 2 + end if + end subroutine +end module m + + use m + implicit none + character, dimension(:), pointer :: QName + integer :: n + allocate(qname(6)) + qname = (/ 'a','b','c','d','e','f' /) + + do n = 0, 3 + call has_key_ns(str_vs(qname(1:n-1)),"", n) + end do + deallocate(qname) +end Index: Fortran/gfortran/regression/transfer_intrinsic_4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_4.f @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/54818 +! +! Contributed by Scott Pakin +! + subroutine broken ( name1, name2, bmix ) + + implicit none + + integer, parameter :: i_knd = kind( 1 ) + integer, parameter :: r_knd = selected_real_kind( 13 ) + + character(len=8) :: dum + character(len=8) :: blk + real(r_knd), dimension(*) :: bmix, name1, name2 + integer(i_knd) :: j, idx1, n, i + integer(i_knd), external :: nafix + + write (*, 99002) name1(j), + & ( adjustl( + & transfer(name2(nafix(bmix(idx1+i),1)),dum)//blk + & //blk), bmix(idx1+i+1), i = 1, n, 2 ) + +99002 format (' *', 10x, a8, 8x, 3(a24,1pe12.5,',',6x)) + + end subroutine broken Index: Fortran/gfortran/regression/transfer_intrinsic_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_5.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! PR fortran/56615 +! +! Contributed by Harald Anlauf +! +! +program gfcbug + implicit none + integer, parameter :: n = 8 + integer :: i + character(len=1), dimension(n) :: a, b + character(len=n) :: s, t + character(len=n/2) :: u + + do i = 1, n + a(i) = achar (i-1 + iachar("a")) + end do +! print *, "# Forward:" +! print *, "a=", a + s = transfer (a, s) +! print *, "s=", s + call cmp (a, s) +! print *, " stride = +2:" + do i = 1, n/2 + u(i:i) = a(2*i-1) + end do +! print *, "u=", u + call cmp (a(1:n:2), u) +! print * +! print *, "# Backward:" + b = a(n:1:-1) +! print *, "b=", b + t = transfer (b, t) +! print *, "t=", t + call cmp (b, t) +! print *, " stride = -1:" + call cmp (a(n:1:-1), t) +contains + subroutine cmp (b, s) + character(len=1), dimension(:), intent(in) :: b + character(len=*), intent(in) :: s + character(len=size(b)) :: c + c = transfer (b, c) + if (c /= s) then + print *, "c=", c, " ", merge (" ok","BUG!", c == s) + STOP 1 + end if + end subroutine cmp +end program gfcbug Index: Fortran/gfortran/regression/transfer_intrinsic_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_intrinsic_6.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 58058: [4.7/4.8/4.9 Regression] Memory leak with transfer function +! +! Contributed by Thomas Jourdan + + implicit none + + integer, dimension(3) :: t1 + character(len=64) :: str + + t1 = (/1,2,3/) + + str = transfer(t1,str) + +end + +! { dg-final { scan-tree-dump-times "__builtin_free" 1 "original" } } Index: Fortran/gfortran/regression/transfer_null_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_null_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Test fix for pr38763, where NULL was not being encoded. +! +! Contributed by Steve Kargl from a +! posting by James van Buskirk on clf. +! +program sizetest + use ISO_C_BINDING + implicit none + integer, parameter :: ik1 = selected_int_kind(2) + TYPE vehicle_t1 + INTEGER(C_INT), DIMENSION(:), ALLOCATABLE :: sensors + END TYPE vehicle_t1 + type(vehicle_t1) gfortran_bug_workaround + integer i + i = size(transfer(vehicle_t1(NULL()),[0_ik1])) + print *, i + i = size(transfer(vehicle_t1([i]),[0_ik1])) + print *, i +end program sizetest Index: Fortran/gfortran/regression/transfer_resolve_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_resolve_1.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR40847 - an error in gfc_resolve_transfer caused the character length +! of 'mold' to be set incorrectly. +! +! Contributed by Joost VandeVondele +! +program test_elemental + +if (any (transfer_size((/0.,0./),(/'a','b'/)) .ne. [4 ,4])) STOP 1 + +contains + + elemental function transfer_size (source, mold) + real, intent(in) :: source + character(*), intent(in) :: mold + integer :: transfer_size + transfer_size = SIZE(TRANSFER(source, (/mold/))) + return + end function transfer_size + +end program test_elemental Index: Fortran/gfortran/regression/transfer_resolve_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_resolve_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/56079 +! +! Contributed by Thomas Koenig +! +program gar_nichts + use ISO_C_BINDING + use ISO_C_BINDING, only: C_PTR + use ISO_C_BINDING, only: abc => C_PTR + use ISO_C_BINDING, only: xyz => C_PTR + type(xyz) nada + nada = transfer(C_NULL_PTR,nada) +end program gar_nichts Index: Fortran/gfortran/regression/transfer_resolve_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_resolve_3.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/56079 +! +use iso_c_binding +implicit none +type t + type(c_ptr) :: ptr = c_null_ptr +end type t + +type(t), parameter :: para = t() +integer(c_intptr_t) :: intg +intg = transfer (para, intg) +intg = transfer (para%ptr, intg) +end + +! { dg-final { scan-tree-dump-times "intg = 0;" 2 "original" } } + Index: Fortran/gfortran/regression/transfer_resolve_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_resolve_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/47034 +! +! Contributed by James Van Buskirk +! +subroutine james + use iso_c_binding + type(C_PTR), parameter :: p1 = & + transfer(32512_C_INTPTR_T,C_NULL_PTR) + integer(C_INTPTR_T), parameter :: n1 = transfer(p1,0_C_INTPTR_T) +end Index: Fortran/gfortran/regression/transfer_simplify_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_1.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! { dg-options "-O2" } +! Tests that the PRs caused by the lack of gfc_simplify_transfer are +! now fixed. These were brought together in the meta-bug PR31237 +! (TRANSFER intrinsic). +! Remaining PRs on 20070409 :-18769 30881 31194 31216 31424 31427 +! +program simplify_transfer + CHARACTER(LEN=100) :: buffer="1.0 3.0" + call pr18769 () + call pr30881 () + call pr31194 () + call pr31216 () + call pr31427 () +contains + subroutine pr18769 () +! +! Contributed by Joost VandeVondele +! + implicit none + type t + integer :: i + end type t + type (t), parameter :: u = t (42) + integer, parameter :: idx_list(1) = (/ 1 /) + integer :: j(1) = transfer (u, idx_list) + if (j(1) .ne. 42) STOP 1 + end subroutine pr18769 + + subroutine pr30881 () +! +! Contributed by Joost VandeVondele +! + INTEGER, PARAMETER :: K=1 + INTEGER :: I + I=TRANSFER(.TRUE.,K) + SELECT CASE(I) + CASE(TRANSFER(.TRUE.,K)) + CASE(TRANSFER(.FALSE.,K)) + STOP 2 + CASE DEFAULT + STOP 3 + END SELECT + I=TRANSFER(.FALSE.,K) + SELECT CASE(I) + CASE(TRANSFER(.TRUE.,K)) + STOP 4 + CASE(TRANSFER(.FALSE.,K)) + CASE DEFAULT + STOP 5 + END SELECT + END subroutine pr30881 + + subroutine pr31194 () +! +! Contributed by Tobias Burnus +! + real(kind(0d0)) :: NaN = transfer(ishft(int(z'FFF80000',8),32),0d0) + write (buffer,'(e12.5)') NaN + if (buffer(10:12) .ne. "NaN") STOP 6 + end subroutine pr31194 + + subroutine pr31216 () +! +! Contributed by Joost VandeVondele +! + INTEGER :: I + REAL :: C,D + buffer = " 1.0 3.0" + READ(buffer,*) C,D + I=TRANSFER(C/D,I) + SELECT CASE(I) + CASE (TRANSFER(1.0/3.0,1)) + CASE DEFAULT + STOP 7 + END SELECT + END subroutine pr31216 + + subroutine pr31427 () +! +! Contributed by Michael Richmond +! + INTEGER(KIND=1) :: i(1) + i = (/ TRANSFER("a", 0_1) /) + if (i(1) .ne. ichar ("a")) STOP 8 + END subroutine pr31427 +end program simplify_transfer Index: Fortran/gfortran/regression/transfer_simplify_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_10.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR fortran/46638 +! +! Contributed by James Van Buskirk +! +program test5 + use ISO_C_BINDING + implicit none + type, bind(C) :: CPUID_type + integer(C_INT32_T) eax + integer(C_INT32_T) ebx + integer(C_INT32_T) edx + integer(C_INT32_T) ecx + integer(C_INT32_T) bbb + end type CPUID_type + type(CPUID_TYPE) result + result = transfer(achar(10)//achar(0)//achar(0)//achar(0)//'GenuineIntel'//'abcd',result) + + if(( int(z'0000000A') /= result%eax & + .or. int(z'756E6547') /= result%ebx & + .or. int(z'49656E69') /= result%edx & + .or. int(z'6C65746E') /= result%ecx & + .or. int(z'64636261') /= result%bbb) & + .and. & ! Big endian + ( int(z'0A000000') /= result%eax & + .or. int(z'47656E75') /= result%ebx & + .or. int(z'696E6549') /= result%edx & + .or. int(z'6E74656C') /= result%ecx & + .or. int(z'61626364') /= result%bbb)) then + write(*,'(5(z8.8:1x))') result + STOP 1 + end if +end program test5 Index: Fortran/gfortran/regression/transfer_simplify_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_11.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR Fortran/82841 +! + integer, parameter :: N = 2 + character(len=1) :: chr(N) + chr = transfer(repeat("x",ncopies=N),[character(len=1) ::], N) + if (chr(1) /= 'x' .or. chr(2) /= 'x') STOP 1 +end Index: Fortran/gfortran/regression/transfer_simplify_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_12.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-O -std=legacy" } +! +! Test fixes for some findings while resolving PR fortran/89077 + +program test + implicit none + integer :: i + character(*) ,parameter :: s = 'abcdef' ! Length will be 6 + character(*) ,parameter :: h = 6Habcdef ! Length will be 8 (Hollerith!) + character(10) ,parameter :: k = 6Habcdef + character(10) ,parameter :: t = transfer (s, s) + character(10) ,save :: u = transfer (s, s) + character(10) ,parameter :: v = transfer (h, h) + character(10) ,save :: w = transfer (h, h) + character(10) ,parameter :: x = transfer ([(s(i:i),i=len(s),1,-1)], s) + character(10) ,save :: y = transfer ([(s(i:i),i=len(s),1,-1)], s) + if (len (h) /= 8) stop 1 + if (h /= s) stop 2 + if (k /= s) stop 3 + if (t /= s) stop 4 + if (u /= s) stop 5 + if (v /= s) stop 6 + if (w /= s) stop 7 + if (x /= "fedcba") stop 8 + if (y /= x) stop 9 +end program test Index: Fortran/gfortran/regression/transfer_simplify_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_13.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/104127 - ICE in get_array_charlen +! Contributed by G.Steinmetz + +program p + character(4) :: mold = "XYZ" + integer :: i = 0 + integer, parameter :: l1 = len (transfer('ab', 'xyz', size=0)) + integer, parameter :: s1 = size (transfer('ab', 'xyz', size=0)) + integer, parameter :: l4 = len (transfer(4_'abcd', 4_'xy', size=0)) + integer, parameter :: s4 = size (transfer(4_'abcd', 4_'xy', size=0)) + integer, parameter :: l2 = len (transfer('ab', mold, size=0)) + integer, parameter :: l3 = len (transfer('ab', mold, size=1)) + integer, parameter :: l5 = len (transfer('ab',['xyz'], size=0)) + integer, parameter :: s5 = size (transfer('ab',['xyz'], size=0)) + call sub0 ( transfer('a', 'y', size=0) ) + call sub1 ([transfer('a', 'y', size=0)]) + call sub2 ([transfer('a',['y'],size=0)]) + call sub3 ( transfer('a', 'y', size=1) ) + call sub4 ([transfer('a', 'y', size=1)]) + call sub5 ( transfer('a', 'y', size=i) ) + call sub6 ( transfer(1_'abcd', 1_'xy' , size=0)) + call sub7 ( transfer(1_'abcd',[1_'xy'], size=0)) + call sub8 ( transfer(4_'abcd', 4_'xy' , size=0)) + call sub9 ( transfer(4_'abcd',[4_'xy'], size=0)) + print *, transfer('abcd', 'xy', size=0) + if (l1 /= 3 .or. s1 /= 0) stop 1 + if (l4 /= 2 .or. s4 /= 0) stop 2 + if (l2 /= 4 .or. l3 /= 4) stop 3 + if (l5 /= 3 .or. s5 /= 0) stop 4 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } Index: Fortran/gfortran/regression/transfer_simplify_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_14.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/104128 - ICE in gfc_widechar_to_char +! Contributed by G.Steinmetz + +program p + implicit none + integer, parameter :: k = 4 + character(*), parameter :: a = 'abc' + character(*,kind=4), parameter :: b = 'abc' + character(2,kind=k), parameter :: s = k_"FG" + character(*,kind=1), parameter :: x = transfer (s, 'abcdefgh') + character(2,kind=k), parameter :: t = transfer (x, s) + character(2,kind=k) :: u = transfer (x, s) + logical, parameter :: l = (s == t) + print *, transfer (a , 4_'xy', size=2) + print *, transfer ('xyz', [b], size=2) + print *, s + print *, t + print *, u + if (.not. l) stop 1 + if (t /= s) stop 2 + if (u /= s) stop 3 ! not optimized away +end + +! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 1 "original" } } +! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(3, 0\\);" "original" } } Index: Fortran/gfortran/regression/transfer_simplify_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_15.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/104311 - ICE out of memory +! Contributed by G.Steinmetz + +program p + type t + end type + type(t) :: x(2) + print *, transfer(1,x,2) ! { dg-error "shall not have storage size 0" } + print *, transfer(1,x,huge(1)) ! { dg-error "shall not have storage size 0" } +end Index: Fortran/gfortran/regression/transfer_simplify_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_2.f90 @@ -0,0 +1,156 @@ +! { dg-do run } +! { dg-options "-O2" } +! { dg-add-options ieee } +! Tests the fix for the meta-bug PR31237 (TRANSFER intrinsic) +! Exercises gfc_simplify_transfer a random walk through types and shapes +! and compares its results with the middle-end version that operates on +! variables. +! + implicit none + call integer4_to_real4 + call real4_to_integer8 + call integer4_to_integer8 + call logical4_to_real8 + call real8_to_integer4 + call integer8_to_real4 + call integer8_to_complex4 + call character16_to_complex8 + call character16_to_real8 + call real8_to_character2 + call dt_to_integer1 + call character16_to_dt +contains + subroutine integer4_to_real4 + integer(4), parameter :: i1 = 11111_4 + integer(4) :: i2 = i1 + real(4), parameter :: r1 = transfer (i1, 1.0_4) + real(4) :: r2 + + r2 = transfer (i2, r2); + if (r1 .ne. r2) STOP 1 + end subroutine integer4_to_real4 + + subroutine real4_to_integer8 + real(4), parameter :: r1(2) = (/3.14159_4, 0.0_4/) + real(4) :: r2(2) = r1 + integer(8), parameter :: i1 = transfer (r1, 1_8) + integer(8) :: i2 + + i2 = transfer (r2, 1_8); + if (i1 .ne. i2) STOP 2 + end subroutine real4_to_integer8 + + subroutine integer4_to_integer8 + integer(4), parameter :: i1(2) = (/11111_4, 22222_4/) + integer(4) :: i2(2) = i1 + integer(8), parameter :: i3 = transfer (i1, 1_8) + integer(8) :: i4 + + i4 = transfer (i2, 1_8); + if (i3 .ne. i4) STOP 3 + end subroutine integer4_to_integer8 + + subroutine logical4_to_real8 + logical(4), parameter :: l1(2) = (/.false., .true./) + logical(4) :: l2(2) = l1 + real(8), parameter :: r1 = transfer (l1, 1_8) + real(8) :: r2 + + r2 = transfer (l2, 1_8); + if (r1 .ne. r2) STOP 4 + end subroutine logical4_to_real8 + + subroutine real8_to_integer4 + real(8), parameter :: r1 = 3.14159_8 + real(8) :: r2 = r1 + integer(4), parameter :: i1(2) = transfer (r1, 1_4, 2) + integer(4) :: i2(2) + + i2 = transfer (r2, i2, 2); + if (any (i1 .ne. i2)) STOP 5 + end subroutine real8_to_integer4 + + subroutine integer8_to_real4 + integer :: k + integer(8), parameter :: i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8) + integer(8) :: i2(2) = i1 + real(4), parameter :: r1(4) = transfer (i1, (/(1.0_4,k=1,4)/)) + real(4) :: r2(4) + + r2 = transfer (i2, r2); + if (any (r1 .ne. r2)) STOP 6 + end subroutine integer8_to_real4 + + subroutine integer8_to_complex4 + integer :: k + integer(8), parameter :: i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8) + integer(8) :: i2(2) = i1 + complex(4), parameter :: z1(2) = transfer (i1, (/((1.0_4,2.0_4),k=1,2)/)) + complex(4) :: z2(2) + + z2 = transfer (i2, z2); + if (any (z1 .ne. z2)) STOP 7 + end subroutine integer8_to_complex4 + + subroutine character16_to_complex8 + character(16), parameter :: c1(2) = (/"abcdefghijklmnop","qrstuvwxyz123456"/) + character(16) :: c2(2) = c1 + complex(8), parameter :: z1(2) = transfer (c1, (1.0_8,1.0_8), 2) + complex(8) :: z2(2) + + z2 = transfer (c2, z2, 2); + if (any (z1 .ne. z2)) STOP 8 + end subroutine character16_to_complex8 + + subroutine character16_to_real8 + character(16), parameter :: c1 = "abcdefghijklmnop" + character(16) :: c2 = c1 + real(8), parameter :: r1(2) = transfer (c1, 1.0_8, 2) + real(8) :: r2(2) + + r2 = transfer (c2, r2, 2); + if (any (r1 .ne. r2)) STOP 9 + end subroutine character16_to_real8 + + subroutine real8_to_character2 + real(8), parameter :: r1 = 3.14159_8 + real(8) :: r2 = r1 + character(2), parameter :: c1(4) = transfer (r1, "ab", 4) + character(2) :: c2(4) + + c2 = transfer (r2, "ab", 4); + if (any (c1 .ne. c2)) STOP 10 + end subroutine real8_to_character2 + + subroutine dt_to_integer1 + integer, parameter :: i1(4) = (/1_4,2_4,3_4,4_4/) + real, parameter :: r1(4) = (/1.0_4,2.0_4,3.0_4,4.0_4/) + type :: mytype + integer(4) :: i(4) + real(4) :: x(4) + end type mytype + type (mytype), parameter :: dt1 = mytype (i1, r1) + type (mytype) :: dt2 = dt1 + integer(1), parameter :: i2(32) = transfer (dt1, 1_1, 32) + integer(1) :: i3(32) + + i3 = transfer (dt2, 1_1, 32); + if (any (i2 .ne. i3)) STOP 11 + end subroutine dt_to_integer1 + + subroutine character16_to_dt + character(16), parameter :: c1 = "abcdefghijklmnop" + character(16) :: c2 = c1 + type :: mytype + real(4) :: x(2) + end type mytype + + type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0/)), 2) + type (mytype) :: dt2(2) + + dt2 = transfer (c2, dt2); + if (any (dt1(1)%x .ne. dt2(1)%x)) STOP 12 + if (any (dt1(2)%x .ne. dt2(2)%x)) STOP 13 + end subroutine character16_to_dt + +end Index: Fortran/gfortran/regression/transfer_simplify_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_3.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! PR fortran/32083 +! +! Test transfers of +Inf and -Inf +! Testcase contributed by Jos de Kloe +! + +PROGRAM TestInfinite + IMPLICIT NONE + integer, parameter :: i8_ = Selected_Int_Kind(18) ! = integer*8 + integer, parameter :: r8_ = Selected_Real_Kind(15,307) ! = real*8 + + integer(i8_), parameter :: bit_pattern_PosInf_i8_p = 9218868437227405312_i8_ + integer(i8_), parameter :: bit_pattern_NegInf_i8_p = -4503599627370496_i8_ + + integer(i8_) :: bit_pattern_PosInf_i8 = 9218868437227405312_i8_ + integer(i8_) :: bit_pattern_NegInf_i8 = -4503599627370496_i8_ + + integer(i8_) :: bit_pattern_PosInf_i8_hex + integer(i8_) :: bit_pattern_NegInf_i8_hex + + integer(i8_) :: i + real(r8_) :: r + + data bit_pattern_PosInf_i8_hex /z'7FF0000000000000'/ + !data bit_pattern_NegInf_i8_hex /z'FFF0000000000000'/ + ! not portable, replaced by: + bit_pattern_NegInf_i8_hex = ibset(bit_pattern_PosInf_i8_hex,63) + + if (bit_pattern_NegInf_i8_hex /= bit_pattern_NegInf_i8) STOP 1 + if (bit_pattern_PosInf_i8_hex /= bit_pattern_PosInf_i8) STOP 2 + + r = transfer(bit_pattern_PosInf_i8,r) + if (r /= 1.0_r8_/0.0_r8_) STOP 3 + i = transfer(r,i) + if (bit_pattern_PosInf_i8 /= i) STOP 4 + + r = transfer(bit_pattern_NegInf_i8,r) + if (r /= -1.0_r8_/0.0_r8_) STOP 5 + i = transfer(r,i) + if (bit_pattern_NegInf_i8 /= i) STOP 6 + + r = transfer(bit_pattern_PosInf_i8_p,r) + if (r /= 1.0_r8_/0.0_r8_) STOP 7 + i = transfer(r,i) + if (bit_pattern_PosInf_i8_p /= i) STOP 8 + + r = transfer(bit_pattern_NegInf_i8_p,r) + if (r /= -1.0_r8_/0.0_r8_) STOP 9 + i = transfer(r,i) + if (bit_pattern_NegInf_i8_p /= i) STOP 10 +END PROGRAM TestInfinite Index: Fortran/gfortran/regression/transfer_simplify_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_4.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Tests that the in-memory representation of a transferred variable +! propagates properly. +! + implicit none + + integer, parameter :: ip1 = 42 + integer, parameter :: ip2 = transfer(transfer(ip1, .true.), 0) + integer :: i, ai(4) + logical :: b + + if (ip2 .ne. ip1) STOP 1 + + i = transfer(transfer(ip1, .true.), 0) + if (i .ne. ip1) STOP 2 + + i = 42 + i = transfer(transfer(i, .true.), 0) + if (i .ne. ip1) STOP 3 + + b = transfer(transfer(.true., 3.1415), .true.) + if (.not.b) STOP 4 + + b = transfer(transfer(.false., 3.1415), .true.) + if (b) STOP 5 + + i = 0 + b = transfer(i, .true.) + ! The standard doesn't guarantee here that b will be .false., + ! though in gfortran for all targets it will. + + ai = (/ 42, 42, 42, 42 /) + ai = transfer (transfer (ai, .false., 4), ai) + if (any(ai .ne. 42)) STOP 1 + + ai = transfer (transfer ((/ 42, 42, 42, 42 /), & +& (/ .false., .false., .false., .false. /)), ai) + if (any(ai .ne. 42)) STOP 2 +end Index: Fortran/gfortran/regression/transfer_simplify_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Tests the fix for PR32689, in which the TRANSFER with MOLD +! an array variable, as below, did not simplify. +! +! Contributed by Harald Anlauf +! +program gfcbug67 + implicit none + + type mytype + integer, pointer :: i(:) => NULL () + end type mytype + type(mytype) :: t + + print *, size (transfer (1, t% i)) +end program gfcbug67 Index: Fortran/gfortran/regression/transfer_simplify_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_6.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Checks the fix for PR33733, in which the functions of arrays +! for the 'source' argument would cause an ICE. +! +! Contributed by FX Coudert +! + print *, transfer(sqrt([100.]), 0_1) + print *, transfer(achar([100]), 0_1) +end Index: Fortran/gfortran/regression/transfer_simplify_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_7.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! PR fortran/34495 - accepts invalid init-expr with TRANSFER + +! 'b' is implicitly typed +real :: a = transfer(1234, b) ! { dg-error "does not reduce to a constant" } + +! 'c' is used on lhs and rhs +real :: c = transfer(1234, c) ! { dg-error "does not reduce to a constant" } + +! 'bp' is implicitly typed +real, parameter :: ap = transfer(1234, bp) ! { dg-error "does not reduce to a constant" } + +! 'yp' is used on lhs and rhs +real, parameter :: cp = transfer(1234, cp) ! { dg-error "before its definition is complete" } + + +! same with arrays +real, dimension(2) :: a2 = transfer([1, 2], b2) ! { dg-error "does not reduce to a constant" } + +real, dimension(2) :: a2 = transfer([1, 2], b2) ! { dg-error "does not reduce to a constant" } + +dimension :: bp(2) +real, parameter, dimension(2) :: ap2 = transfer([1, 2], bp2) ! { dg-error "does not reduce to a constant" } + +real, parameter, dimension(2) :: cp2 = transfer([1, 2], cp2) ! { dg-error "before its definition is complete" } + + +! same with matrices +real, dimension(2,2) :: a3 = transfer([1, 2, 3, 4], b3) ! { dg-error "does not reduce to a constant" } + +real, dimension(2,2) :: a3 = transfer([1, 2, 3, 4], b3) ! { dg-error "does not reduce to a constant" } + +dimension :: bp3(2,2) +real, parameter, dimension(2,2) :: ap3 = transfer([1, 2, 3, 4], bp3) ! { dg-error "does not reduce to a constant" } + +real, parameter, dimension(2,2) :: cp3 = transfer([1, 2, 3, 4], cp3) ! { dg-error "before its definition is complete" } + +end Index: Fortran/gfortran/regression/transfer_simplify_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_8.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-O0" } +! PR fortran/34537 +! simplify_transfer used to ICE on divide by zero for cases like this, +! where the mold expression is a non-constant character expression. +! +! Testcase contributed by Tobias Burnus +! + character, pointer :: ptr(:) + character(8) :: a + allocate(ptr(9)) + ptr = transfer('Sample#0'//achar(0),ptr) ! Causes ICE + if (any (ptr .ne. ['S','a','m','p','l','e','#','0',achar(0)])) STOP 1 + call test(a) + if (a .ne. 'Sample#2') STOP 2 +contains + subroutine test(a) + character(len=*) :: a + a = transfer('Sample#2',a) + end subroutine test +end Index: Fortran/gfortran/regression/transfer_simplify_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transfer_simplify_9.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Various checks on simplification of TRANSFER of substrings + character(len=4), parameter :: t = "xyzt" + integer, parameter :: w = transfer(t,0) + integer :: i = 1 + if (transfer(t,0) /= w) STOP 1 + if (transfer(t(:),0) /= w) STOP 2 + if (transfer(t(1:4),0) /= w) STOP 3 + if (transfer(t(i:i+3),0) /= w) STOP 4 + + if (transfer(t(1:1), 0_1) /= transfer("x", 0_1)) STOP 5 + if (transfer(t(2:2), 0_1) /= transfer("y", 0_1)) STOP 6 + if (transfer(t(i:i), 0_1) /= transfer("x", 0_1)) STOP 7 + if (transfer(t(i+1:i+1), 0_1) /= transfer("y", 0_1)) STOP 8 + if (transfer(t(1:2), 0_2) /= transfer("xy", 0_2)) STOP 9 + if (transfer(t(3:4), 0_2) /= transfer("zt", 0_2)) STOP 10 + + if (transfer(transfer(-1, t), 0) /= -1) STOP 11 + if (transfer(transfer(-1, t(:)), 0) /= -1) STOP 12 + if (any (transfer(transfer(-1, (/t(1:1)/)), (/0_1/)) /= -1)) STOP 13 + if (transfer(transfer(-1, t(1:1)), 0_1) /= -1) STOP 14 + end Index: Fortran/gfortran/regression/transpose_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Tests the fix for PR32962, in which the result of TRANSPOSE, when +! an actual argument of an elemental intrinsic would receive the +! wrong offset. +! +! Contributed by Wirawan Purwanto +! + real(kind=8), allocatable :: b(:,:) + real(kind=8) :: a(2,2), c(2,2) + i = 2 + allocate (b(i,i)) + a(1,1) = 2 + a(2,1) = 3 + a(1,2) = 7 + a(2,2) = 11 + call foo + call bar + if (any (c .ne. b)) STOP 1 +contains + subroutine foo + b = cos(transpose(a)) + end subroutine + subroutine bar + c = transpose(a) + c = cos(c) + end subroutine +end program Index: Fortran/gfortran/regression/transpose_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" } +program main + implicit none + character(len=10) :: in + real, dimension(:,:), allocatable :: a,b + integer :: ax, ay, bx, by + + in = "2 2 3 2" + read (unit=in,fmt='(4I2)') ax, ay, bx, by + allocate (a(ax,ay)) + allocate (b(bx,by)) + a = 1.0 + b = 2.1 + b = transpose(a) +end program main +! { dg-output "Fortran runtime error: Array bound mismatch for dimension 1 of array 'b' \\(3/2\\)" } Index: Fortran/gfortran/regression/transpose_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_3.f03 @@ -0,0 +1,10 @@ +! { dg-do run } +! Transformational intrinsic TRANSPOSE as initialization expression. + + INTEGER, PARAMETER :: n = 10 + INTEGER, PARAMETER :: a(n,1) = RESHAPE([ (i, i = 1, n) ], [n, 1]) + INTEGER, PARAMETER :: b(1,n) = TRANSPOSE(a) + INTEGER, PARAMETER :: c(n,1) = TRANSPOSE(b) + + IF (ANY(c /= a)) STOP 1 +END Index: Fortran/gfortran/regression/transpose_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_4.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! PR fortran/60392 +! In the transposed case call to my_mul_cont, the compiler used to (wrongly) +! reuse a transposed descriptor for an array that was not transposed as a result +! of packing. +! +! Original test case from Alexander Vogt . + +program test + implicit none + + integer, dimension(2,2) :: A, R, RT + integer, dimension(2,2) :: B1, B2 + + ! + ! A = [ 2 17 ] + ! [ 82 257 ] + ! + ! matmul(a,a) = [ 1398 4403 ] + ! [ 21238 67443 ] + ! + ! matmul(transpose(a), a) = [ 6728 21108 ] + ! [ 21108 66338 ] + A(1,1) = 2 + A(1,2) = 17 + A(2,1) = 82 + A(2,2) = 257 + + R(1,1) = 1398 + R(1,2) = 4403 + R(2,1) = 21238 + R(2,2) = 67443 + + RT(1,1) = 6728 + RT(1,2) = 21108 + RT(2,1) = 21108 + RT(2,2) = 66338 + + ! Normal argument + B1 = 0 + B2 = 0 + B1 = my_mul(A,A) + B2 = my_mul_cont(A,A) +! print *,'Normal: ',maxval(abs(B1-B2)) +! print *,B1 +! print *,B2 + if (any(B1 /= R)) STOP 1 + if (any(B2 /= R)) STOP 2 + + ! Transposed argument + B1 = 0 + B2 = 0 + B1 = my_mul(transpose(A),A) + B2 = my_mul_cont(transpose(A),A) +! print *,'Transposed:',maxval(abs(B1-B2)) +! print *,B1 +! print *,B2 + if (any(B1 /= RT)) STOP 3 + if (any(B2 /= RT)) STOP 4 + +contains + + function my_mul(A,C) result (B) + use, intrinsic :: ISO_Fortran_env + integer, intent(in) :: A(2,2), C(2,2) + integer :: B(2,2) + B = matmul(A, C) + end function + + function my_mul_cont(A,C) result (B) + use, intrinsic :: ISO_Fortran_env + integer, intent(in), contiguous :: A(:,:), C(:,:) + integer :: B(2,2) + B = matmul(A, C) + end function + +end program Index: Fortran/gfortran/regression/transpose_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_5.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-O2" } +! PR fortran/99840 - ICE in gfc_simplify_matmul, at fortran/simplify.c:4777 +program p + integer, parameter :: x(0,0) = 0 + integer :: y(0,0) + y = matmul (x, transpose(x)) +end Index: Fortran/gfortran/regression/transpose_conjg_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_conjg_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR35740, where the trick of interchanging the descriptor +! dimensions to implement TRANSPOSE did not work if it is an argument of +! an elemental function - eg. CONJG. The fix forces a library call for such +! cases. During the diagnosis of the PR, it was found that the scalarizer was +! completely thrown if the argument of TRANSPOSE was a non-variable +! expression; eg a + c below. This is also fixed by the library call. +! +! Contributed by Dominik Muth +! +program main + implicit none + complex, dimension(2,2) :: a,b,c,d + a(1,1) = (1.,1.) + a(2,1) = (2.,2.) + a(1,2) = (3.,3.) + a(2,2) = (4.,4.) +! + b = a + b = conjg(transpose(b)) + d = a + d = transpose(conjg(d)) + if (any (b /= d)) STOP 1 +! + d = matmul (b, a ) + if (any (d /= matmul (transpose(conjg(a)), a))) STOP 2 + if (any (d /= matmul (conjg(transpose(a)), a))) STOP 3 +! + c = (0.0,1.0) + b = conjg(transpose(a + c)) + d = transpose(conjg(a + c)) + if (any (b /= d)) STOP 4 +! + d = matmul (b, a + c) + if (any (d /= matmul (transpose(conjg(a + c)), a + c))) STOP 5 + if (any (d /= matmul (conjg(transpose(a + c)), a + c))) STOP 6 + END program main Index: Fortran/gfortran/regression/transpose_intrinsic_func_call_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_intrinsic_func_call_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/46978 +! The coor assignment was using the wrong loop bounds if the argument to +! transpose was an intrinsic function call +! +! Original testcase by Martien Huelsen +! Reduced by Tobias Burnus + +program elastic2 + implicit none + real, allocatable, dimension(:,:) :: coor + real, allocatable, dimension(:) :: a + integer :: nno + nno = 3 + allocate(a(2*nno)) + call two() + coor = transpose ( reshape ( a, (/2,nno/) ) ) + if (any(coor /= 12)) STOP 1 +contains + subroutine two() + allocate(coor(3,2)) + coor = 99 + a = 12 + end subroutine +end program elastic2 Index: Fortran/gfortran/regression/transpose_optimization_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_optimization_1.f90 @@ -0,0 +1,105 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -fdump-tree-original -finline-matmul-limit=0" } +! +! PR fortran/45648 +! Non-copying descriptor transpose optimization (for function call args). +! +! Contributed by Richard Sandiford + +module foo + interface + subroutine ext1 (a, b) + real, intent (in), dimension (:, :) :: a, b + end subroutine ext1 + subroutine ext2 (a, b) + real, intent (in), dimension (:, :) :: a + real, intent (out), dimension (:, :) :: b + end subroutine ext2 + subroutine ext3 (a, b) + real, dimension (:, :) :: a, b + end subroutine ext3 + end interface +contains + ! No temporary needed here. + subroutine test1 (n, a, b, c) + integer :: n + real, dimension (n, n) :: a, b, c + a = matmul (transpose (b), c) + end subroutine test1 + + ! No temporary either, as we know the arguments to matmul are intent(in) + subroutine test2 (n, a, b) + integer :: n + real, dimension (n, n) :: a, b + a = matmul (transpose (b), b) + end subroutine test2 + + ! No temporary needed. + subroutine test3 (n, a, b, c) + integer :: n + real, dimension (n, n) :: a, c + real, dimension (n+4, n+4) :: b + a = matmul (transpose (b (2:n+1, 3:n+2)), c) + end subroutine test3 + + ! A temporary is needed for the result of either the transpose or matmul. + subroutine test4 (n, a, b) + integer :: n + real, dimension (n, n) :: a, b + a = matmul (transpose (a), b) ! { dg-warning "Creating array temporary" } + end subroutine test4 + + ! The temporary is needed here since the second argument to imp1 + ! has unknown intent. + subroutine test5 (n, a) + integer :: n + real, dimension (n, n) :: a + call imp1 (transpose (a), a) ! { dg-warning "Creating array temporary" } + end subroutine test5 + + ! No temporaries are needed here; imp1 can't modify either argument. + ! We have to pack the arguments, however. + subroutine test6 (n, a, b) + integer :: n + real, dimension (n, n) :: a, b + call imp1 (transpose (a), transpose (b)) ! { dg-warning "Creating array temporary" } + end subroutine test6 + + ! No temporaries are needed here; imp1 can't modify either argument. + ! We don't have to pack the arguments. + subroutine test6_bis (n, a, b) + integer :: n + real, dimension (n, n) :: a, b + call ext3 (transpose (a), transpose (b)) + end subroutine test6_bis + + ! No temporary is neede here; the second argument is intent(in). + subroutine test7 (n, a) + integer :: n + real, dimension (n, n) :: a + call ext1 (transpose (a), a) + end subroutine test7 + + ! The temporary is needed here though. + subroutine test8 (n, a) + integer :: n + real, dimension (n, n) :: a + call ext2 (transpose (a), a) ! { dg-warning "Creating array temporary" } + end subroutine test8 + + ! Silly, but we don't need any temporaries here. + subroutine test9 (n, a) + integer :: n + real, dimension (n, n) :: a + call ext1 (transpose (transpose (a)), a) + end subroutine test9 + + ! The outer transpose needs a temporary; the inner one doesn't. + subroutine test10 (n, a) + integer :: n + real, dimension (n, n) :: a + call ext2 (transpose (transpose (a)), a) ! { dg-warning "Creating array temporary" } + end subroutine test10 +end module foo + +! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 4 "original" } } Index: Fortran/gfortran/regression/transpose_optimization_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_optimization_2.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original " } +! Checks the fix for PR46896, in which the optimization that passes +! the argument of TRANSPOSE directly missed the possible aliasing +! through host association. +! +! Contributed by Jerry DeLisle +! +module mod + integer :: b(2,3) = reshape([1,2,3,4,5,6], [2,3]) +contains + subroutine msub(x) + integer :: x(:,:) + b(1,:) = 99 + b(2,:) = x(:,1) + if (any (b(:,1) /= [99, 1]).or.any (b(:,2) /= [99, 3])) STOP 1 + end subroutine msub + subroutine pure_msub(x, y) + integer, intent(in) :: x(:,:) + integer, intent(OUT) :: y(size (x, 2), size (x, 1)) + y = transpose (x) + end subroutine pure_msub +end + + use mod + integer :: a(2,3) = reshape([1,2,3,4,5,6], [2,3]) + call impure + call purity +contains +! +! pure_sub and pure_msub could be PURE, if so declared. They do not +! need a temporary. +! + subroutine purity + integer :: c(2,3) + call pure_sub(transpose(a), c) + if (any (c .ne. a)) STOP 1 + call pure_msub(transpose(b), c) + if (any (c .ne. b)) STOP 2 + end subroutine purity +! +! sub and msub both need temporaries to avoid aliasing. +! + subroutine impure + call sub(transpose(a)) + end subroutine impure + + subroutine sub(x) + integer :: x(:,:) + a(1,:) = 88 + a(2,:) = x(:,1) + if (any (a(:,1) /= [88, 1]).or.any (a(:,2) /= [88, 3])) STOP 2 + end subroutine sub + subroutine pure_sub(x, y) + integer, intent(in) :: x(:,:) + integer, intent(OUT) :: y(size (x, 2), size (x, 1)) + y = transpose (x) + end subroutine pure_sub +end +! +! The check below for temporaries gave 14 and 33 for "parm" and "atmp". +! +! { dg-final { scan-tree-dump-times "parm" 76 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 13 "original" } } Index: Fortran/gfortran/regression/transpose_reshape_r10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/transpose_reshape_r10.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +program main + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + character(len=90) line + real(k) :: a(3,3) + real(k) :: b(9) + a = 1.0_k + a(1,3) = 0.0_k + write (line,'(9G10.6)') transpose(a) + write (line,'(9G10.6)') reshape(a,shape(b)) +end Index: Fortran/gfortran/regression/trim_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_1.f90 @@ -0,0 +1,41 @@ +! { dg-do run } + +! Torture-test TRIM and LEN_TRIM for correctness. + + +! Given a total string length and a trimmed length, construct an +! appropriate string and check gfortran gets it right. + +SUBROUTINE check_trim (full_len, trimmed_len) + IMPLICIT NONE + INTEGER, INTENT(IN) :: full_len, trimmed_len + CHARACTER(LEN=full_len) :: string + + string = "" + IF (trimmed_len > 0) THEN + string(trimmed_len:trimmed_len) = "x" + END IF + + IF (LEN (string) /= full_len & + .OR. LEN_TRIM (string) /= trimmed_len & + .OR. LEN (TRIM (string)) /= trimmed_len & + .OR. TRIM (string) /= string (1:trimmed_len)) THEN + PRINT *, full_len, trimmed_len + PRINT *, LEN (string), LEN_TRIM (string) + STOP 1 + END IF +END SUBROUTINE check_trim + + +! The main program, check with various combinations. + +PROGRAM main + IMPLICIT NONE + INTEGER :: i, j + + DO i = 0, 20 + DO j = 0, i + CALL check_trim (i, j) + END DO + END DO +END PROGRAM main Index: Fortran/gfortran/regression/trim_optimize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! PR 40628 - optimize unnecessary TRIMs on assignment +program main + character(len=3) :: a + character(len=4) :: b,c + b = 'abcd' + a = trim(b) + c = trim(trim(a)) + if (a /= 'abc') STOP 1 + if (c /= 'abc') STOP 2 +end program main + +! { dg-final { scan-tree-dump-times "memmove" 3 "original" } } +! { dg-final { scan-tree-dump-times "string_trim" 0 "original" } } Index: Fortran/gfortran/regression/trim_optimize_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! Optimize unnecessary TRIMs in contained namespaces too. +module faz + implicit none +contains + subroutine bar + character(len=3) :: a + character(len=4) :: b,c + b = 'abcd' + a = trim(b) + c = trim(trim(a)) + if (a /= 'abc') STOP 1 + if (c /= 'abc') STOP 2 + end subroutine bar +end module faz + +program main + use faz + implicit none + call foo + call bar +contains + subroutine foo + character(len=3) :: a + character(len=4) :: b,c + b = 'abcd' + a = trim(b) + c = trim(trim(a)) + if (a /= 'abc') STOP 3 + if (c /= 'abc') STOP 4 + end subroutine foo +end program main + +! { dg-final { scan-tree-dump-times "memmove" 6 "original" } } +! { dg-final { scan-tree-dump-times "string_trim" 0 "original" } } Index: Fortran/gfortran/regression/trim_optimize_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_3.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! PR 47065 - replace trim with substring expressions. +program main + character(len=10) :: a, b + character(kind=4,len=10) :: a4, b4 + character(len=100) :: line + a = 'bcd' + b = trim(a) // 'x' + if (b /= 'bcdx') STOP 1 + a4 = 4_"bcd" + b4 = trim(a4) // 4_'x' + if (b4 /= 4_'bcdx') STOP 2 +end +! { dg-final { scan-tree-dump-times "string_len_trim" 2 "original" } } Index: Fortran/gfortran/regression/trim_optimize_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR 47065 - make sure that trim optimization does not lead to +! wrong-code with aliasing. +! Test case provided by Tobias Burnus. +program main + character(len=12) :: str + str = '1234567890' + call sub(trim(str), str) + ! Should print '12345 ' + if (str /= '12345 ') STOP 1 + call two(trim(str)) + if (str /= '123 ') STOP 2 +contains + subroutine sub(a,b) + character(len=*), intent(in) :: a + character(len=*), intent(out) :: b + b = '' + b = a(1:5) + end subroutine sub + subroutine two(a) + character(len=*), intent(in) :: a + str = '' + str(1:3) = a(1:3) + end subroutine two +end program main Index: Fortran/gfortran/regression/trim_optimize_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_5.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! PR 47065 - replace trim with substring expressions even with references. +program main + implicit none + type t + character(len=2) :: x + end type t + type(t) :: a + character(len=3) :: b + character(len=10) :: line + a%x = 'a' + write(unit=line,fmt='(A,A)') trim(a%x),"X" + if (line /= 'aX ') STOP 1 + b = 'ab' + write (unit=line,fmt='(A,A)') trim(b),"Y" + if (line /= 'abY ') STOP 2 +end program main +! { dg-final { scan-tree-dump-times "string_len_trim" 2 "original" } } Index: Fortran/gfortran/regression/trim_optimize_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_6.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR 47065 - make sure that impure functions are not evaluated twice when +! replacing calls to trim with expression(1:len_trim) +module foo + implicit none +contains + function f() + integer :: f + integer :: s=0 + s = s + 1 + f = s + end function f +end module foo + +program main + use foo + implicit none + character(len=10) :: line + character(len=4) :: b(2) + b(1) = 'a' + b(2) = 'bc' + write(unit=line,fmt='(A,A)') trim(b(f())), "X" + if (line /= "aX ") STOP 1 + if (f() .ne. 2) STOP 2 +end program main Index: Fortran/gfortran/regression/trim_optimize_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_7.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! Check that trailing trims are also removed from assignment of +! expressions involving concatenations of strings . +program main + character(2) :: a,b,c + character(8) :: d + a = 'a ' + b = 'b ' + c = 'c ' + d = a // b // a // trim(c) ! This should be optimized away. + if (d /= 'a b a c ') STOP 1 + d = a // trim(b) // c // a ! This shouldn't. + if (d /= 'a bc a ') STOP 2 + d = a // b // a // trim(trim(c)) ! This should also be optimized away. + if (d /= 'a b a c ') STOP 3 +end +! { dg-final { scan-tree-dump-times "string_len_trim" 1 "original" } } Index: Fortran/gfortran/regression/trim_optimize_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/trim_optimize_8.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +! Check that trailing trims are also removed from assignment of +! expressions involving concatenations of strings . +program main + character(2) :: a,b + character(8) :: d + a = 'a ' + b = 'b ' + if (trim(a // trim(b)) /= 'a b ') STOP 1 + if (trim (trim(a) // trim(b)) /= 'ab ') STOP 2 +end +! { dg-final { scan-tree-dump-times "string_len_trim" 1 "original" } } Index: Fortran/gfortran/regression/type_decl_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_decl_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Fortran 2008: TYPE ( intrinsic-type-spec ) +! +implicit none +type(integer) :: a +type(real) :: b +type(logical ) :: c +type(character) :: d +type(double precision) :: e + +type(integer(8)) :: f +type(real(kind=4)) :: g +type(logical ( kind = 1 ) ) :: h +type(character (len=10,kind=1) ) :: i + +type(double complex) :: j ! { dg-error "Extension: DOUBLE COMPLEX" } +end + +module m + integer, parameter :: k4 = 4 +end module m + +type(integer (kind=k4)) function f() + use m + f = 42 +end Index: Fortran/gfortran/regression/type_decl_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_decl_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Fortran 2008: TYPE ( intrinsic-type-spec ) +! +implicit none +type(integer) :: a ! { dg-error "Fortran 2008" } +type(real) :: b ! { dg-error "Fortran 2008" } +type(logical) :: c ! { dg-error "Fortran 2008" } +type(character) :: d ! { dg-error "Fortran 2008" } +type(double precision) :: e ! { dg-error "Fortran 2008" } +end Index: Fortran/gfortran/regression/type_decl_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_decl_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! +! PR fortran/39427 +! + subroutine t(x) ! { dg-error "conflicts with previously declared entity" } + type(t) :: x ! { dg-error "conflicts with previously declared entity" } + end subroutine t Index: Fortran/gfortran/regression/type_decl_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_decl_4.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program main + type Xx ! { dg-error "Symbol 'xx' at .1. also declared as a type at .2." } + end type Xx + real :: Xx ! { dg-error "Symbol 'xx' at .1. also declared as a type at .2." } + +end program main Index: Fortran/gfortran/regression/type_is_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_is_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/66245 +! Original testcase by Gerhard Steinmetz +! +program p + type t; end type + class(t), allocatable :: x + call s + contains + subroutine s + select type ( x ) + type is ( ) ! { dg-error "error in TYPE IS" } + end select + end subroutine s +end program p Index: Fortran/gfortran/regression/type_to_class_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_to_class_1.f03 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Passing TYPE to CLASS +! +implicit none +type t + integer :: A + real, allocatable :: B(:) +end type t + +type(t), allocatable :: x(:) +type(t) :: y(10) +integer :: i + +allocate(x(10)) +if (size (x) /= 10) STOP 1 +x = [(t(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)] +do i = 1, 10 + if (x(i)%a /= -i .or. size (x(i)%b) /= 4 & + .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 2 + end if +end do + +y = x ! TODO: Segfaults in runtime without 'y' being set + +call class(x) +call classExplicit(x, size(x)) +call class(y) +call classExplicit(y, size(y)) + +contains + subroutine class(z) + class(t), intent(in) :: z(:) + select type(z) + type is(t) + if (size (z) /= 10) STOP 3 + do i = 1, 10 + if (z(i)%a /= -i .or. size (z(i)%b) /= 4 & + .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 4 + end if + end do + class default + STOP 5 + end select + end subroutine class + subroutine classExplicit(u, n) + integer, intent(in) :: n + class(t), intent(in) :: u(n) + select type(u) + type is(t) + if (size (u) /= 10) STOP 6 + do i = 1, 10 + if (u(i)%a /= -i .or. size (u(i)%b) /= 4 & + .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 7 + end if + end do + class default + STOP 8 + end select + end subroutine classExplicit +end + Index: Fortran/gfortran/regression/type_to_class_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_to_class_2.f03 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Test the fix for PR64757. +! +! Contributed by Michael Lee Rilee +! + type :: Test + integer :: i + end type + + type :: TestReference + class(Test), allocatable :: test + end type + + type(TestReference) :: testList + type(test) :: x + + testList = TestReference(Test(99)) ! ICE in fold_convert_loc was here + + x = testList%test + + select type (y => testList%test) ! Check vptr set + type is (Test) + if (x%i .ne. y%i) STOP 1 + class default + STOP 2 + end select +end + + Index: Fortran/gfortran/regression/type_to_class_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_to_class_3.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! Test the fix for the array version of PR64757. +! +! Based on by Michael Lee Rilee +! + type :: Test + integer :: i + end type + + type :: TestReference + class(Test), allocatable :: test(:) + end type + + type(TestReference) :: testList + type(test), allocatable :: x(:) + + testList = TestReference([Test(99), Test(199)]) ! Gave: The rank of the element in the + ! structure constructor at (1) does not + ! match that of the component (1/0) +! allocate (testList%test(2), source = [Test(99), Test(199)]) ! Works, of course + + x = testList%test + + select type (y => testList%test) ! Check vptr set + type is (Test) + if (any(x%i .ne. y%i)) STOP 1 + class default + STOP 2 + end select +end + + Index: Fortran/gfortran/regression/type_to_class_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_to_class_4.f03 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Test the fix for PR56691 comment #7 (and comment #0). +! +! Reduced from the original of Marco Restelli +! by Janus Weil +! +module m2 + implicit none + type :: t_stv + real :: f1 + end type +contains + subroutine lcb(y) + class(t_stv), intent(in) :: y(:) + integer :: k + do k=1,size(y) + if (int(y(k)%f1) .ne. k) STOP 1 + enddo + end subroutine +end module + +program test + use m2 + implicit none + + type(t_stv), allocatable :: work(:) + + allocate(work(4)) + work(:)%f1 = (/ 1.,2.,3.,4./) + + call lcb(work) + call lcb(work(:4)) ! Indexing used to be offset by 1. + +end program Index: Fortran/gfortran/regression/type_to_class_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/type_to_class_5.f03 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test the fix for PR84074 +! +! Contributed by Vladimir Fuka +! + type :: t + integer :: n + end type + + type(t) :: array(4) = [t(1),t(2),t(3),t(4)] + + call sub(array((/3,1/)), [3,1,0,0]) ! Does not increment any elements of 'array'. + call sub(array(1:3:2), [1,3,0,0]) + call sub(array(3:1:-2), [4,2,0,0]) + call sub(array, [3,2,5,4]) ! Elements 1 and 3 should have been incremented twice. + +contains + + subroutine sub(a, iarray) + class(t) :: a(:) + integer :: iarray(4) + integer :: i + do i=1,size(a) + if (a(i)%n .ne. iarray(i)) STOP 1 + a(i)%n = a(i)%n+1 + enddo + end subroutine +end program Index: Fortran/gfortran/regression/typebound_assignment_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_1.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 47463: [OOP] ICE in gfc_add_component_ref +! +! Contributed by Rich Townsend + +module hydro_state + type :: state_t + contains + procedure :: assign + generic :: assignment(=) => assign + end type state_t +contains + subroutine assign (this, that) + class(state_t), intent(inout) :: this + class(state_t), intent(in) :: that + end subroutine assign +end module hydro_state + +module hydro_flow + use hydro_state + type :: flow_t + class(state_t), allocatable :: st + end type flow_t +contains + subroutine init_comps (this, st) + class(flow_t), intent(out) :: this + class(state_t), intent(in) :: st + + allocate(state_t :: this%st) + this%st = st + end subroutine init_comps +end module hydro_flow Index: Fortran/gfortran/regression/typebound_assignment_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_2.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 47463: [OOP] ICE in gfc_add_component_ref +! +! Contributed by Rich Townsend + +module hydro_grid + type :: grid_t + contains + procedure :: assign + generic :: assignment(=) => assign + end type grid_t + public :: grid_t +contains + subroutine assign (this, that) + class(grid_t), intent(inout) :: this + class(grid_t), intent(in) :: that + end subroutine assign +end module hydro_grid + +module hydro_flow + use hydro_grid + type :: flow_t + class(grid_t), allocatable :: gr + end type flow_t +contains + subroutine init_params (this) + class(flow_t), intent(out) :: this + type(grid_t) :: gr + call init_comps(this, gr) + end subroutine init_params + subroutine init_comps (this, gr) + class(flow_t), intent(out) :: this + class(grid_t), intent(in) :: gr + this%gr = gr + end subroutine init_comps +end module hydro_flow Index: Fortran/gfortran/regression/typebound_assignment_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_3.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 49074: [OOP] Defined assignment w/ CLASS arrays: Incomplete error message +! +! Contribute by Jerry DeLisle + +module foo + + type bar + contains + generic :: assignment (=) => assgn + procedure :: assgn + end type + +contains + + elemental subroutine assgn (a, b) + class (bar), intent (inout) :: a + class (bar), intent (in) :: b + end subroutine + +end module + + + use foo + type (bar) :: foobar(2) + foobar = bar() ! There was a not-implemented error here +end Index: Fortran/gfortran/regression/typebound_assignment_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_4.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/54195 +! The compiler used to diagnose a duplicate entity in the assignment interface +! because NC was resolved twice. +! +! Contributed by Andrew Benson + +module gn + + implicit none + + type :: nc + contains + procedure :: assign => nca + generic :: assignment(=) => assign + end type + + type, extends(nc) :: ncb + contains + procedure , nopass :: tis => bf + end type + +contains + + subroutine nca(to,from) + class(nc), intent(out) :: to + type(nc), intent(in) :: from + end subroutine + + logical function bf() + bf=.false. + end function + +end module Index: Fortran/gfortran/regression/typebound_assignment_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_5.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/49074 +! ICE on defined assignment with class arrays. + + module foo + type bar + integer :: i + + contains + + generic :: assignment (=) => assgn_bar + procedure, private :: assgn_bar + end type bar + + contains + + elemental subroutine assgn_bar (a, b) + class (bar), intent (inout) :: a + class (bar), intent (in) :: b + + select type (b) + type is (bar) + a%i = b%i + end select + + return + end subroutine assgn_bar + end module foo + + program main + use foo + + type (bar), allocatable :: foobar(:) + + allocate (foobar(2)) + foobar = [bar(1), bar(2)] + if (any(foobar%i /= [1, 2])) STOP 1 + end program + +! { dg-final { scan-tree-dump-not "_gfortran_internal_pack" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_internal_unpack" "original" } } Index: Fortran/gfortran/regression/typebound_assignment_5a.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_5a.f03 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/49074 +! ICE on defined assignment with class arrays. + + module foo + type bar + integer :: i + + contains + + generic :: assignment (=) => assgn_bar + procedure, private :: assgn_bar + end type bar + + contains + + elemental subroutine assgn_bar (a, b) + class (bar), intent (inout) :: a + class (bar), intent (in) :: b + + select type (b) + type is (bar) + a%i = b%i + end select + + return + end subroutine assgn_bar + end module foo + + program main + use foo + + type (bar), allocatable :: foobar(:) + + allocate (foobar(2)) + foobar = [bar(1), bar(2)] + if (any(foobar%i /= [1, 2])) STOP 1 + end program Index: Fortran/gfortran/regression/typebound_assignment_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_6.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! PR fortran/56136 +! ICE on defined assignment with class arrays. +! +! Original testcase by Alipasha + + MODULE A_TEST_M + TYPE :: A_TYPE + INTEGER :: I + CONTAINS + GENERIC :: ASSIGNMENT (=) => ASGN_A + PROCEDURE, PRIVATE :: ASGN_A + END TYPE + + CONTAINS + + ELEMENTAL SUBROUTINE ASGN_A (A, B) + CLASS (A_TYPE), INTENT (INOUT) :: A + CLASS (A_TYPE), INTENT (IN) :: B + A%I = B%I + END SUBROUTINE + END MODULE A_TEST_M + + PROGRAM ASGN_REALLOC_TEST + USE A_TEST_M + TYPE (A_TYPE), ALLOCATABLE :: A(:) + INTEGER :: I, J + + ALLOCATE (A(100)) + A = (/ (A_TYPE(I), I=1,SIZE(A)) /) + A(1:50) = A(51:100) + IF (ANY(A%I /= (/ ((50+I, I=1,SIZE(A)/2), J=1,2) /))) STOP 1 + A(::2) = A(1:50) ! pack/unpack + IF (ANY(A( ::2)%I /= (/ (50+I, I=1,SIZE(A)/2) /))) STOP 2 + IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3 + END PROGRAM + Index: Fortran/gfortran/regression/typebound_assignment_6a.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_6a.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/56136 +! ICE on defined assignment with class arrays. +! +! Original testcase by Alipasha + + MODULE A_TEST_M + TYPE :: A_TYPE + INTEGER :: I + CONTAINS + GENERIC :: ASSIGNMENT (=) => ASGN_A + PROCEDURE, PRIVATE :: ASGN_A + END TYPE + + CONTAINS + + ELEMENTAL SUBROUTINE ASGN_A (A, B) + CLASS (A_TYPE), INTENT (INOUT) :: A + CLASS (A_TYPE), INTENT (IN) :: B + A%I = B%I + END SUBROUTINE + END MODULE A_TEST_M + + PROGRAM ASGN_REALLOC_TEST + USE A_TEST_M + TYPE (A_TYPE), ALLOCATABLE :: A(:) + INTEGER :: I, J + + ALLOCATE (A(100)) + A = (/ (A_TYPE(I), I=1,SIZE(A)) /) + A(1:50) = A(51:100) + IF (ANY(A%I /= (/ ((50+I, I=1,SIZE(A)/2), J=1,2) /))) STOP 1 + A(::2) = A(1:50) ! pack/unpack + IF (ANY(A( ::2)%I /= (/ (50+I, I=1,SIZE(A)/2) /))) STOP 2 + IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3 + END PROGRAM + +! { 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/typebound_assignment_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_7.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call +! +! Contributed by John + +module mod1 + implicit none + type :: itemType + contains + procedure :: the_assignment => assign_itemType + generic :: assignment(=) => the_assignment + end type +contains + subroutine assign_itemType(left, right) + class(itemType), intent(OUT) :: left + class(itemType), intent(IN) :: right + end subroutine +end module + +module mod2 + use mod1 + implicit none + type, extends(itemType) :: myItem + character(3) :: name = '' + contains + procedure :: the_assignment => assign_myItem + end type +contains + subroutine assign_myItem(left, right) + class(myItem), intent(OUT) :: left + class(itemType), intent(IN) :: right + select type (right) + type is (myItem) + left%name = right%name + end select + end subroutine +end module + + +program test_assign + + use mod2 + implicit none + + class(itemType), allocatable :: item1, item2 + + allocate (myItem :: item1) + select type (item1) + type is (myItem) + item1%name = 'abc' + end select + + allocate (myItem :: item2) + item2 = item1 + + select type (item2) + type is (myItem) + if (item2%name /= 'abc') STOP 1 + class default + STOP 2 + end select + +end Index: Fortran/gfortran/regression/typebound_assignment_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_assignment_8.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 60853: [OOP] Failure to disambiguate generic with unlimited polymorphic +! +! Contributed by tlcclt + +module foo_mod + implicit none + + type Vector + contains + procedure :: copyFromScalar + procedure :: copyFromArray + generic :: assignment(=) => copyFromScalar, copyFromArray + end type + +contains + + subroutine copyFromScalar(this, scalar) + class (Vector), intent(inout) :: this + type (Vector), intent(in) :: scalar + end subroutine + + subroutine copyFromArray(this, array) + class (Vector), intent(inout) :: this + class (*), intent(in) :: array(:) + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_call_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_1.f03 @@ -0,0 +1,96 @@ +! { dg-do run } + +! Type-bound procedures +! Check basic calls to NOPASS type-bound procedures. + +MODULE m + IMPLICIT NONE + + TYPE add + CONTAINS + PROCEDURE, NOPASS :: func => func_add + PROCEDURE, NOPASS :: sub => sub_add + PROCEDURE, NOPASS :: echo => echo_add + END TYPE add + + TYPE mul + CONTAINS + PROCEDURE, NOPASS :: func => func_mul + PROCEDURE, NOPASS :: sub => sub_mul + PROCEDURE, NOPASS :: echo => echo_mul + END TYPE mul + +CONTAINS + + INTEGER FUNCTION func_add (a, b) + IMPLICIT NONE + INTEGER :: a, b + func_add = a + b + END FUNCTION func_add + + INTEGER FUNCTION func_mul (a, b) + IMPLICIT NONE + INTEGER :: a, b + func_mul = a * b + END FUNCTION func_mul + + SUBROUTINE sub_add (a, b, c) + IMPLICIT NONE + INTEGER, INTENT(IN) :: a, b + INTEGER, INTENT(OUT) :: c + c = a + b + END SUBROUTINE sub_add + + SUBROUTINE sub_mul (a, b, c) + IMPLICIT NONE + INTEGER, INTENT(IN) :: a, b + INTEGER, INTENT(OUT) :: c + c = a * b + END SUBROUTINE sub_mul + + SUBROUTINE echo_add () + IMPLICIT NONE + WRITE (*,*) "Hi from adder!" + END SUBROUTINE echo_add + + INTEGER FUNCTION echo_mul () + IMPLICIT NONE + echo_mul = 5 + WRITE (*,*) "Hi from muler!" + END FUNCTION echo_mul + + ! Do the testing here, in the same module as the type is. + SUBROUTINE test () + IMPLICIT NONE + + TYPE(add) :: adder + TYPE(mul) :: muler + + INTEGER :: x + + IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN + STOP 1 + END IF + + CALL adder%sub (2, 3, x) + IF (x /= 5) THEN + STOP 2 + END IF + + CALL muler%sub (2, 3, x) + IF (x /= 6) THEN + STOP 3 + END IF + + ! Check procedures without arguments. + CALL adder%echo () + x = muler%echo () + CALL adder%echo + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE m, ONLY: test + CALL test () +END PROGRAM main Index: Fortran/gfortran/regression/typebound_call_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_10.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 39630: [F03] Procedure Pointer Components with PASS +! +! Contributed by Tobias Burnus + +module m + + type :: t + integer :: i + contains + procedure, pass(y) :: foo + end type t + +contains + + subroutine foo(x,y) + type(t),optional :: x + class(t) :: y + if(present(x)) then + print *, 'foo', x%i, y%i + else + print *, 'foo', y%i + end if + end subroutine foo + +end module m + +use m +type(t) :: t1, t2 +t1%i = 3 +t2%i = 4 +call t1%foo() +call t2%foo() +call t1%foo(t2) +end Index: Fortran/gfortran/regression/typebound_call_11.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_11.f03 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR 42048: [F03] Erroneous syntax error message on TBP call +! +! Contributed by Damian Rouson + +module grid_module + implicit none + type grid + contains + procedure :: new_grid + end type +contains + subroutine new_grid(this) + class(grid) :: this + end subroutine +end module + +module field_module + use grid_module + implicit none + + type field + type(grid) :: mesh + end type + +contains + + type(field) function new_field() + call new_field%mesh%new_grid() + end function + + function new_field2() result(new) + type(field) :: new + call new%mesh%new_grid() + end function + + type(field) function new_field3() + call g() + contains + subroutine g() + call new_field3%mesh%new_grid() + end subroutine g + end function new_field3 + +end module Index: Fortran/gfortran/regression/typebound_call_12.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_12.f03 @@ -0,0 +1,35 @@ +! { 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 + PRIVATE + TYPE, PUBLIC :: A + CONTAINS + PROCEDURE :: Proc => a_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 + CALL arr(i)%Proc(ierr) + END DO +END PROGRAM ProgA + Index: Fortran/gfortran/regression/typebound_call_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_13.f03 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR 43256: [OOP] TBP with missing optional arg +! +! Contributed by Janus Weil + +module module_myobj + + implicit none + + type :: myobj + contains + procedure, nopass :: myfunc + end type + +contains + + integer function myfunc(status) + integer, optional :: status + if (present(status)) then + myfunc = 1 + else + myfunc = 2 + end if + end function + +end module + + +program test_optional + + use :: module_myobj + implicit none + + integer :: res = 0 + type(myobj) :: myinstance + + res = myinstance%myfunc() + if (res /= 2) STOP 1 + +end program Index: Fortran/gfortran/regression/typebound_call_14.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_14.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 44211: [OOP] ICE with TBP of pointer component of derived type array +! +! Original test case by Hans-Werner Boschmann +! Modified by Janus Weil + +module ice_module + type::ice_type + class(ice_type),pointer::next + contains + procedure::ice_sub + procedure::ice_fun + end type ice_type +contains + subroutine ice_sub(this) + class(ice_type)::this + end subroutine + integer function ice_fun(this) + class(ice_type)::this + end function + subroutine ice() + type(ice_type),dimension(2)::ice_array + call ice_array(1)%next%ice_sub() + print *,ice_array(2)%next%ice_fun() + end subroutine +end module ice_module Index: Fortran/gfortran/regression/typebound_call_15.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_15.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 44558: [OOP] ICE on invalid code: called TBP subroutine as TBP function +! +! Contributed by Hans-Werner Boschmann + +module ice5 + type::a_type + contains + procedure::a_subroutine_1 + procedure::a_subroutine_2 + end type a_type +contains + real function a_subroutine_1(this) + class(a_type)::this + real::res + res=this%a_subroutine_2() ! { dg-error "should be a FUNCTION" } + end function + subroutine a_subroutine_2(this) + class(a_type)::this + call this%a_subroutine_1() ! { dg-error "should be a SUBROUTINE" } + end subroutine +end module ice5 + Index: Fortran/gfortran/regression/typebound_call_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_16.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 41685: [OOP] internal compiler error: verify_flow_info failed +! +! Contributed by Salvatore Filippone + +module base_mat_mod + + type :: base_sparse_mat + contains + procedure, pass(a) :: get_nrows + end type base_sparse_mat + +contains + + integer function get_nrows(a) + implicit none + class(base_sparse_mat), intent(in) :: a + end function get_nrows + +end module base_mat_mod + + + use base_mat_mod + + type, extends(base_sparse_mat) :: s_coo_sparse_mat + end type s_coo_sparse_mat + + class(s_coo_sparse_mat), pointer :: a + Integer :: m + m = a%get_nrows() + +end Index: Fortran/gfortran/regression/typebound_call_17.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_17.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! PR 44912: [OOP] Segmentation fault on TBP +! +! Contributed by Satish.BD + +module polynomial +implicit none + +private + +type, public :: polynom + complex, allocatable, dimension(:) :: a + integer :: n + contains + procedure :: init_from_coeff + procedure :: get_degree + procedure :: add_poly +end type polynom + +contains + subroutine init_from_coeff(self, coeff) + class(polynom), intent(inout) :: self + complex, dimension(:), intent(in) :: coeff + self%n = size(coeff) - 1 + allocate(self%a(self%n + 1)) + self%a = coeff + print *,"ifc:",self%a + end subroutine init_from_coeff + + function get_degree(self) result(n) + class(polynom), intent(in) :: self + integer :: n + print *,"gd" + n = self%n + end function get_degree + + subroutine add_poly(self) + class(polynom), intent(in) :: self + integer :: s + print *,"ap" + s = self%get_degree() !!!! fails here + end subroutine + +end module polynomial + +program test_poly + use polynomial, only: polynom + + type(polynom) :: p1 + + call p1%init_from_coeff([(1,0),(2,0),(3,0)]) + call p1%add_poly() + +end program test_poly Index: Fortran/gfortran/regression/typebound_call_18.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_18.f03 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR 45271: [OOP] Polymorphic code breaks when changing order of USE statements +! +! Contributed by Harald Anlauf + +module abstract_vector + implicit none + type, abstract :: vector_class + contains + procedure(op_assign_v_v), deferred :: assign + end type vector_class + abstract interface + subroutine op_assign_v_v(this,v) + import vector_class + class(vector_class), intent(inout) :: this + class(vector_class), intent(in) :: v + end subroutine + end interface +end module abstract_vector + +module concrete_vector + use abstract_vector + implicit none + type, extends(vector_class) :: trivial_vector_type + contains + procedure :: assign => my_assign + end type +contains + subroutine my_assign (this,v) + class(trivial_vector_type), intent(inout) :: this + class(vector_class), intent(in) :: v + write (*,*) 'Oops in concrete_vector::my_assign' + STOP 1 + end subroutine +end module concrete_vector + +module concrete_gradient + use abstract_vector + implicit none + type, extends(vector_class) :: trivial_gradient_type + contains + procedure :: assign => my_assign + end type +contains + subroutine my_assign (this,v) + class(trivial_gradient_type), intent(inout) :: this + class(vector_class), intent(in) :: v + write (*,*) 'concrete_gradient::my_assign' + end subroutine +end module concrete_gradient + +program main + !--- exchange these two lines to make the code work: + use concrete_vector ! (1) + use concrete_gradient ! (2) + !--- + implicit none + type(trivial_gradient_type) :: g_initial + class(vector_class), allocatable :: g + print *, "cg: before g%assign" + allocate(trivial_gradient_type :: g) + call g%assign (g_initial) + print *, "cg: after g%assign" +end program main Index: Fortran/gfortran/regression/typebound_call_19.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_19.f03 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! PR 47455: [4.6 Regression][OOP] internal compiler error: in fold_convert_loc, at fold-const.c:2028 +! +! Contributed by Thomas Henlich + +module class_t + type :: tx + integer :: i + end type + type :: t + type(tx) :: x + procedure(find_x), pointer :: ppc + contains + procedure :: find_x + end type + type(tx), target :: zero = tx(0) +contains + function find_x(this) + class(t), intent(in) :: this + type(tx), pointer :: find_x + find_x => zero + end function find_x +end module + +program test + use class_t + class(t),allocatable :: this + procedure(find_x), pointer :: pp + allocate(this) + ! (1) ordinary function call + zero = tx(1) + this%x = find_x(this) + if (this%x%i /= 1) STOP 1 + ! (2) procedure pointer + zero = tx(2) + pp => find_x + this%x = pp(this) + if (this%x%i /= 2) STOP 2 + ! (3) PPC + zero = tx(3) + this%ppc => find_x + this%x = this%ppc() + if (this%x%i /= 3) STOP 3 + ! (4) TBP + zero = tx(4) + this%x = this%find_x() + if (this%x%i /= 4) STOP 4 +end Index: Fortran/gfortran/regression/typebound_call_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_2.f03 @@ -0,0 +1,88 @@ +! { dg-do run } + +! Type-bound procedures +! Check calls with passed-objects. + +MODULE m + IMPLICIT NONE + + TYPE add + INTEGER :: wrong + INTEGER :: val + CONTAINS + PROCEDURE, PASS :: func => func_add + PROCEDURE, PASS(me) :: sub => sub_add + END TYPE add + + TYPE trueOrFalse + LOGICAL :: val + CONTAINS + PROCEDURE, PASS :: swap + END TYPE trueOrFalse + +CONTAINS + + INTEGER FUNCTION func_add (me, x) + IMPLICIT NONE + CLASS(add) :: me + INTEGER :: x + func_add = me%val + x + END FUNCTION func_add + + SUBROUTINE sub_add (res, me, x) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: res + CLASS(add), INTENT(IN) :: me + INTEGER, INTENT(IN) :: x + res = me%val + x + END SUBROUTINE sub_add + + SUBROUTINE swap (me1, me2) + IMPLICIT NONE + CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2 + + IF (.NOT. me1%val .OR. me2%val) THEN + STOP 1 + END IF + + me1%val = .FALSE. + me2%val = .TRUE. + END SUBROUTINE swap + + ! Do the testing here, in the same module as the type is. + SUBROUTINE test () + IMPLICIT NONE + + TYPE(add) :: adder + TYPE(trueOrFalse) :: t, f + + INTEGER :: x + + adder%wrong = 0 + adder%val = 42 + IF (adder%func (8) /= 50) THEN + STOP 2 + END IF + + CALL adder%sub (x, 8) + IF (x /= 50) THEN + STOP 3 + END IF + + t%val = .TRUE. + f%val = .FALSE. + + CALL t%swap (f) + CALL f%swap (t) + + IF (.NOT. t%val .OR. f%val) THEN + STOP 4 + END IF + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE m, ONLY: test + CALL test () +END PROGRAM main Index: Fortran/gfortran/regression/typebound_call_20.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_20.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! PR 47565: [4.6 Regression][OOP] Segfault with TBP +! +! Contributed by Tobias Burnus + +module class_t + type :: t + procedure(find_y), pointer, nopass :: ppc + contains + procedure, nopass :: find_y + end type + integer, private :: count = 0 +contains + function find_y() result(res) + integer, allocatable :: res + allocate(res) + count = count + 1 + res = count + end function +end module + +program p + use class_t + class(t), allocatable :: this + integer :: y + + allocate(this) + this%ppc => find_y + ! (1) ordinary procedure + y = find_y() + if (y/=1) STOP 1 + ! (2) procedure pointer component + y = this%ppc() + if (y/=2) STOP 2 + ! (3) type-bound procedure + y = this%find_y() + if (y/=3) STOP 3 +end Index: Fortran/gfortran/regression/typebound_call_21.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_21.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 50919: [OOP] Don't use vtable for NON_OVERRIDABLE TBP +! +! Contributed by Tobias Burnus + +module m + +type t +contains + procedure, nopass, NON_OVERRIDABLE :: testsub + procedure, nopass, NON_OVERRIDABLE :: testfun +end type t + +contains + + subroutine testsub() + print *, "t's test" + end subroutine + + integer function testfun() + testfun = 1 + end function + +end module m + + + use m + class(t), allocatable :: x + allocate(x) + call x%testsub() + print *,x%testfun() +end + +! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } } Index: Fortran/gfortran/regression/typebound_call_22.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_22.f03 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-optimized -O" } +! +! PR 50960: [OOP] vtables not marked as constant +! +! This test case checks whether the type-bound call to "x%bar" +! is optimized into a static call to "base". +! +! Contributed by Tobias Burnus + +module m + type t + contains + procedure, nopass :: bar => base + end type +contains + subroutine base() + write(*,*) 'base' + end subroutine +end module + +program test + use m + class(t), allocatable :: x + allocate (t :: x) + call x%bar () +end program + +! { dg-final { scan-tree-dump-times "base \\(\\);" 1 "optimized" { xfail *-*-* } } } Index: Fortran/gfortran/regression/typebound_call_23.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_23.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 52968: [OOP] Call to type-bound procedure wrongly rejected +! +! Contributed by Reuben Budiardja + +module SolverModule + + type :: SolverType + class ( EquationTemplate ), pointer :: Equation + end type + + type :: EquationTemplate + contains + procedure, nopass :: Evaluate + end type + +contains + + subroutine Evaluate () + end subroutine + + subroutine Solve + type ( SolverType ) :: S + call S % Equation % Evaluate () + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_call_24.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_24.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 54243: [OOP] ICE (segfault) in gfc_type_compatible for invalid BT_CLASS +! +! Contributed by Sylwester Arabas + +module aqq_m + type :: aqq_t + contains + procedure :: aqq_init + end type + contains + subroutine aqq_init(this) + class(aqq_t) :: this + end subroutine +end module + +program bug2 + use aqq_m + class(aqq_t) :: aqq ! { dg-error "must be dummy, allocatable or pointer" } + call aqq%aqq_init +end program Index: Fortran/gfortran/regression/typebound_call_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_25.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR 57966: [OOP] Using a TBP to specify the shape of a dummy argument +! +! Contributed by Stefan Mauerberger + +MODULE my_mod + IMPLICIT NONE + + TYPE config_cls + CONTAINS + PROCEDURE, NOPASS :: my_size + PROCEDURE, NOPASS :: my_sub + GENERIC :: sz => my_size + GENERIC :: sub => my_sub + END TYPE + + TYPE(config_cls) :: config + +CONTAINS + + PURE INTEGER FUNCTION my_size() + my_size = 10 + END FUNCTION + + SUBROUTINE my_sub + END SUBROUTINE + + SUBROUTINE test (field1, field2, field3, field4) + REAL :: field1 (config%my_size()) + REAL :: field2 (config%sz()) + REAL :: field3 (config%my_sub()) ! { dg-error "should be a FUNCTION" } + REAL :: field4 (config%sub()) ! { dg-error "should be a FUNCTION" } + END SUBROUTINE + +END MODULE Index: Fortran/gfortran/regression/typebound_call_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_26.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 64244: [4.8/4.9/5 Regression] ICE at class.c:236 when using non_overridable +! +! Contributed by Ondřej Čertík + +module m + implicit none + + type :: A + contains + generic :: f => g + procedure, non_overridable :: g + end type + +contains + + subroutine g(this) + class(A), intent(in) :: this + end subroutine + +end module + + +program test_non_overridable + use m, only: A + implicit none + class(A), allocatable :: h + call h%f() +end Index: Fortran/gfortran/regression/typebound_call_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_27.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR fortran/66257 +! Check that typebound function calls are accepted as actual argument. +! +MODULE test_class + IMPLICIT NONE + PRIVATE + PUBLIC:: test + + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15) + + TYPE test + PRIVATE + CONTAINS + PRIVATE + PROCEDURE, PUBLIC:: E + PROCEDURE, PUBLIC:: Om + END TYPE test + +CONTAINS + + ELEMENTAL FUNCTION E (self, a) + IMPLICIT NONE + CLASS(test), INTENT(IN):: self + REAL(kind=dp), INTENT(IN):: a + REAL(kind=dp):: E + + E = a + END FUNCTION E + + ELEMENTAL FUNCTION Om (self, z) + IMPLICIT NONE + CLASS(test), INTENT(IN):: self + REAL(kind=dp), INTENT(IN):: z + REAL(kind=dp):: Om + + Om = self%E(self%E(z)) + Om = log10(self%E(z)) + END FUNCTION Om +END MODULE test_class Index: Fortran/gfortran/regression/typebound_call_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_28.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 80766: [7/8 Regression] [OOP] ICE with type-bound procedure returning an array +! +! Contributed by Vladimir Fuka + +module m1 + + type :: base + contains + procedure :: fun + end type + + type, extends(base) :: child + end type + +contains + + function fun(o) result(res) + real :: res(3) + class(base) :: o + res = 0 + end function +end module + + +module m2 +contains + + subroutine sub(o) + use m1 + class(child) :: o + real :: res(3) + + res = o%fun() + end subroutine +end module Index: Fortran/gfortran/regression/typebound_call_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_29.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR 82932: [OOP] ICE in update_compcall_arglist, at fortran/resolve.c:5837 +! +! Contributed by Janus Weil + +module m + + implicit none + + type, abstract :: AT + contains + procedure(init_ifc), deferred :: sinit + procedure(missing_ifc), deferred :: missing + generic :: init => sinit + end type + + abstract interface + subroutine init_ifc(data) + import AT + class(AT) :: data + end subroutine + subroutine missing_ifc(data) + import AT + class(AT) :: data + end subroutine + end interface + +end module + + +program p + + use m + + implicit none + + type, extends(AT) :: ET ! { dg-error "must be ABSTRACT" } + contains + procedure :: sinit + end type + + type(ET) :: c + call c%init() + +end Index: Fortran/gfortran/regression/typebound_call_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_3.f03 @@ -0,0 +1,46 @@ +! { dg-do run } + +! Type-bound procedures +! Check that calls work across module-boundaries. + +MODULE m + IMPLICIT NONE + + TYPE trueOrFalse + LOGICAL :: val + CONTAINS + PROCEDURE, PASS :: swap + END TYPE trueOrFalse + +CONTAINS + + SUBROUTINE swap (me1, me2) + IMPLICIT NONE + CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2 + + IF (.NOT. me1%val .OR. me2%val) THEN + STOP 1 + END IF + + me1%val = .FALSE. + me2%val = .TRUE. + END SUBROUTINE swap + +END MODULE m + +PROGRAM main + USE m, ONLY: trueOrFalse + IMPLICIT NONE + + TYPE(trueOrFalse) :: t, f + + t%val = .TRUE. + f%val = .FALSE. + + CALL t%swap (f) + CALL f%swap (t) + + IF (.NOT. t%val .OR. f%val) THEN + STOP 2 + END IF +END PROGRAM main Index: Fortran/gfortran/regression/typebound_call_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_30.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 86830: [8/9 Regression] Contiguous array pointer function result not recognized as contiguous +! +! Contributed by + +module m + implicit none + + type :: t1 + contains + procedure :: get_ptr + end type + + type :: t2 + class(t1), allocatable :: c + end type + +contains + + function get_ptr(this) + class(t1) :: this + real, dimension(:), contiguous, pointer :: get_ptr + end function + + subroutine test() + real, dimension(:), contiguous, pointer:: ptr + type(t2) :: x + ptr => x%c%get_ptr() + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_call_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_31.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR 88008 - this use to ICE. Original test case by +! Gerhard Steinmetz. + +module m + type t + integer, pointer :: z + contains + procedure :: g + end type +contains + subroutine g(x) + class(t) :: x + call x%z%g() ! { dg-error "Error in typebound call" } + end +end Index: Fortran/gfortran/regression/typebound_call_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_32.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR98897 in which typebound subroutines of associate names +! were not recognised in a call. Functions were OK but this is tested below. +! +! Contributed by Damian Rouson +! +module output_data_m + implicit none + + type output_data_t + integer, private :: i = 0 + contains + procedure output, return_value + end type + + +contains + subroutine output(self) + implicit none + class(output_data_t) self + self%i = 1234 + end subroutine + + integer function return_value(self) + implicit none + class(output_data_t) self + return_value = self%i + end function +end module + + use output_data_m + implicit none + associate(output_data => output_data_t()) + call output_data%output + if (output_data%return_value() .ne. 1234) stop 1 + end associate +end + Index: Fortran/gfortran/regression/typebound_call_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_4.f03 @@ -0,0 +1,49 @@ +! { dg-do compile } + +! Type-bound procedures +! Check for recognition/errors with more complicated references and some +! error-handling in general. + +MODULE m + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, PASS :: proc + PROCEDURE, NOPASS :: func + END TYPE t + + TYPE compt + TYPE(t) :: myobj + END TYPE compt + +CONTAINS + + SUBROUTINE proc (me) + IMPLICIT NONE + CLASS(t), INTENT(INOUT) :: me + END SUBROUTINE proc + + INTEGER FUNCTION func () + IMPLICIT NONE + func = 1812 + END FUNCTION func + + SUBROUTINE test () + IMPLICIT NONE + TYPE(compt) :: arr(2) + + ! These two are OK. + CALL arr(1)%myobj%proc () + WRITE (*,*) arr(2)%myobj%func () + + ! Can't CALL a function or take the result of a SUBROUTINE. + CALL arr(1)%myobj%func () ! { dg-error "SUBROUTINE" } + WRITE (*,*) arr(2)%myobj%proc () ! { dg-error "FUNCTION" } + + ! Error. + CALL arr(2)%myobj%proc () x ! { dg-error "Junk after" } + WRITE (*,*) arr(1)%myobj%func ! { dg-error "Expected argument list" } + END SUBROUTINE test + +END MODULE m Index: Fortran/gfortran/regression/typebound_call_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_5.f03 @@ -0,0 +1,39 @@ +! { dg-do compile } + +! Type-bound procedures +! Check for correct access-checking on type-bound procedures. + +MODULE m + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, NOPASS, PRIVATE :: priv => proc + PROCEDURE, NOPASS, PUBLIC :: publ => proc + END TYPE t + +CONTAINS + + SUBROUTINE proc () + END SUBROUTINE proc + + ! This is inside the module. + SUBROUTINE test1 () + IMPLICIT NONE + TYPE(t) :: obj + + CALL obj%priv () ! { dg-bogus "PRIVATE" } + CALL obj%publ () + END SUBROUTINE test1 + +END MODULE m + +! This is outside the module. +SUBROUTINE test2 () + USE m + IMPLICIT NONE + TYPE(t) :: obj + + CALL obj%priv () ! { dg-error "PRIVATE" } + CALL obj%publ () +END SUBROUTINE test2 Index: Fortran/gfortran/regression/typebound_call_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_6.f03 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-output "Super(\n|\r\n|\r).*Sub" } + +! Type-bound procedures +! Check for calling right overloaded procedure. + +MODULE m + IMPLICIT NONE + + TYPE supert + CONTAINS + PROCEDURE, NOPASS :: proc => proc_super + END TYPE supert + + TYPE, EXTENDS(supert) :: subt + CONTAINS + PROCEDURE, NOPASS :: proc => proc_sub + END TYPE subt + +CONTAINS + + SUBROUTINE proc_super () + IMPLICIT NONE + WRITE (*,*) "Super" + END SUBROUTINE proc_super + + SUBROUTINE proc_sub () + IMPLICIT NONE + WRITE (*,*) "Sub" + END SUBROUTINE proc_sub + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(supert) :: super + TYPE(subt) :: sub + + CALL super%proc + CALL sub%proc +END PROGRAM main Index: Fortran/gfortran/regression/typebound_call_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_7.f03 @@ -0,0 +1,48 @@ +! { dg-do compile } + +! PR fortran/37429 +! Checks for assignments from type-bound functions. + +MODULE touching + IMPLICIT NONE + + TYPE :: EqnSys33 + CONTAINS + PROCEDURE, NOPASS :: solve1 + PROCEDURE, NOPASS :: solve2 + PROCEDURE, NOPASS :: solve3 + END TYPE EqnSys33 + +CONTAINS + + FUNCTION solve1 () + IMPLICIT NONE + REAL :: solve1(3) + solve1 = 0.0 + END FUNCTION solve1 + + CHARACTER(len=5) FUNCTION solve2 () + IMPLICIT NONE + solve2 = "hello" + END FUNCTION solve2 + + REAL FUNCTION solve3 () + IMPLICIT NONE + solve3 = 4.2 + END FUNCTION solve3 + + SUBROUTINE fill_gap () + IMPLICIT NONE + TYPE(EqnSys33) :: sys + REAL :: res + REAL :: resArr(3), resSmall(2) + + res = sys%solve1 () ! { dg-error "Incompatible rank" } + res = sys%solve2 () ! { dg-error "Cannot convert" } + resSmall = sys%solve1 () ! { dg-error "Different shape" } + + res = sys%solve3 () + resArr = sys%solve1 () + END SUBROUTINE fill_gap + +END MODULE touching Index: Fortran/gfortran/regression/typebound_call_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_8.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } + +! PR fortran/37429 +! This used to ICE, check that is fixed. + +MODULE touching + IMPLICIT NONE + + TYPE :: EqnSys33 + CONTAINS + PROCEDURE, NOPASS :: solve1 + END TYPE EqnSys33 + +CONTAINS + + FUNCTION solve1 () + IMPLICIT NONE + REAL :: solve1(3) + solve1 = 0.0 + END FUNCTION solve1 + + SUBROUTINE fill_gap () + IMPLICIT NONE + TYPE(EqnSys33) :: sys + REAL :: res + + res = sys%solve1 () ! { dg-error "Incompatible rank" } + END SUBROUTINE fill_gap + +END MODULE touching Index: Fortran/gfortran/regression/typebound_call_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_call_9.f03 @@ -0,0 +1,58 @@ +! { dg-do compile } + +! PR fortran/37638 +! If a PASS(arg) is invalid, a call to this routine later would ICE in +! resolving. Check that this also works for GENERIC, in addition to the +! PR's original test. + +! Contributed by Salvatore Filippone + +module foo_mod + implicit none + + type base_foo_type + integer :: nr,nc + integer, allocatable :: iv1(:), iv2(:) + + contains + + procedure, pass(a) :: makenull ! { dg-error "has no argument 'a'" } + generic :: null2 => makenull ! { dg-error "Undefined specific binding" } + + end type base_foo_type + +contains + + subroutine makenull(m) + implicit none + type(base_foo_type), intent(inout) :: m + + m%nr=0 + m%nc=0 + + end subroutine makenull + + subroutine foo_free(a,info) + implicit none + Type(base_foo_type), intent(inout) :: A + Integer, intent(out) :: info + integer :: iret + info = 0 + + + if (allocated(a%iv1)) then + deallocate(a%iv1,stat=iret) + if (iret /= 0) info = max(info,2) + endif + if (allocated(a%iv2)) then + deallocate(a%iv2,stat=iret) + if (iret /= 0) info = max(info,3) + endif + + call a%makenull() + call a%null2 () ! { dg-error "should be a SUBROUTINE" } + + Return + End Subroutine foo_free + +end module foo_mod Index: Fortran/gfortran/regression/typebound_deferred_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_deferred_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 46952: [OOP] Spurious "recursive call" error with type bound procedure +! +! Contributed by Ian Harvey + +module m + + type, abstract :: t + contains + procedure(inter), pass, deferred :: foo + end type + +contains + + subroutine inter(this) + class(t) :: this + call this%foo() + end subroutine inter + +end module m Index: Fortran/gfortran/regression/typebound_generic_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_1.f03 @@ -0,0 +1,94 @@ +! { dg-do compile } + +! Type-bound procedures +! Compiling and errors with GENERIC binding declarations. +! Bindings with NOPASS. + +MODULE m + IMPLICIT NONE + + TYPE somet + CONTAINS + PROCEDURE, NOPASS :: p1 => intf1 + PROCEDURE, NOPASS :: p1a => intf1a + PROCEDURE, NOPASS :: p2 => intf2 + PROCEDURE, NOPASS :: p3 => intf3 + PROCEDURE, NOPASS :: subr + + GENERIC :: gen1 => p1a ! { dg-error "are ambiguous" } + + GENERIC, PUBLIC :: gen1 => p1, p2 + GENERIC :: gen1 => p3 ! Implicitly PUBLIC. + GENERIC, PRIVATE :: gen2 => p1 + + GENERIC :: gen2 => p2 ! { dg-error "same access" } + GENERIC :: gen1 => p1 ! { dg-error "already defined as specific binding" } + GENERIC, PASS :: gen3 => p1 ! { dg-error "Expected access-specifier" } + GENERIC :: p1 => p1 ! { dg-error "already a non-generic procedure" } + PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "already a procedure" } + GENERIC :: gen3 => ! { dg-error "specific binding" } + GENERIC :: gen4 => p1 x ! { dg-error "Junk after" } + GENERIC :: gen5 => p_notthere ! { dg-error "Undefined specific binding" } + GENERIC :: gen6 => p1 + GENERIC :: gen7 => gen6 ! { dg-error "must target a specific binding" } + + GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" } + GENERIC :: gensubr => subr + + END TYPE somet + + TYPE supert + CONTAINS + PROCEDURE, NOPASS :: p1 => intf1 + PROCEDURE, NOPASS :: p1a => intf1a + PROCEDURE, NOPASS :: p2 => intf2 + PROCEDURE, NOPASS :: p3 => intf3 + PROCEDURE, NOPASS :: sub1 => subr + + GENERIC :: gen1 => p1, p2 + GENERIC :: gen1 => p3 + GENERIC :: gen2 => p1 + GENERIC :: gensub => sub1 + END TYPE supert + + TYPE, EXTENDS(supert) :: t + CONTAINS + GENERIC :: gen2 => p1a ! { dg-error "are ambiguous" } + GENERIC :: gen2 => p3 + GENERIC :: p1 => p2 ! { dg-error "cannot overwrite specific" } + GENERIC :: gensub => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" } + + PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "Cannot overwrite GENERIC" } + END TYPE t + +CONTAINS + + INTEGER FUNCTION intf1 (a, b) + IMPLICIT NONE + INTEGER :: a, b + intf1 = 42 + END FUNCTION intf1 + + INTEGER FUNCTION intf1a (a, b) + IMPLICIT NONE + INTEGER :: a, b + intf1a = 42 + END FUNCTION intf1a + + INTEGER FUNCTION intf2 (a, b) + IMPLICIT NONE + REAL :: a, b + intf2 = 42.0 + END FUNCTION intf2 + + LOGICAL FUNCTION intf3 () + IMPLICIT NONE + intf3 = .TRUE. + END FUNCTION intf3 + + SUBROUTINE subr (x) + IMPLICIT NONE + INTEGER :: x + END SUBROUTINE subr + +END MODULE m Index: Fortran/gfortran/regression/typebound_generic_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_10.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 49196: [OOP] gfortran compiles invalid generic TBP: dummy arguments are type compatible +! +! Contributed by Hans-Werner Boschmann + +module generic + + type :: a_type + contains + procedure :: a_subroutine + end type a_type + + type,extends(a_type) :: b_type + contains + procedure :: b_subroutine + generic :: g_sub => a_subroutine,b_subroutine ! { dg-error "are ambiguous" } + end type b_type + +contains + + subroutine a_subroutine(this) + class(a_type)::this + end subroutine a_subroutine + + subroutine b_subroutine(this) + class(b_type)::this + end subroutine b_subroutine + +end module generic Index: Fortran/gfortran/regression/typebound_generic_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_11.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! +! PR fortran/52024 +! +! Contributed by Fran Martinez Fadrique +! +module m_test + type t_test + integer :: i = 0 + contains + generic :: operator(==) => t_equal_i, i_equal_t ! OK + procedure, private :: t_equal_i + procedure, private, pass(t) :: i_equal_t + end type t_test +contains + function t_equal_i (t, i) result(res) + class(t_test), intent(in) :: t + integer, intent(in) :: i + logical :: res + + print *, 't_equal_i', t%i, i + res = ( t%i == i ) + end function t_equal_i + + function i_equal_t (i, t) result(res) + integer, intent(in) :: i + class(t_test), intent(in) :: t + logical :: res + + print *, 'i_equal_t', i, t%i + res = ( t%i == i ) + end function i_equal_t +end module m_test + +module m_test2 + type t2_test + integer :: i = 0 + contains + generic :: gen => t2_equal_i, i_equal_t2 ! { dg-error "'t2_equal_i' and 'i_equal_t2' for GENERIC 'gen' at .1. are ambiguous" } + procedure, private :: t2_equal_i + procedure, private, pass(t) :: i_equal_t2 + end type t2_test +contains + function t2_equal_i (t, i) result(res) + class(t2_test), intent(in) :: t + integer, intent(in) :: i + logical :: res + + print *, 't2_equal_i', t%i, i + res = ( t%i == i ) + end function t2_equal_i + + function i_equal_t2 (i, t) result(res) + integer, intent(in) :: i + class(t2_test), intent(in) :: t + logical :: res + + print *, 'i_equal_t2', i, t%i + res = ( t%i == i ) + end function i_equal_t2 +end module m_test2 Index: Fortran/gfortran/regression/typebound_generic_12.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_12.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 53328: [OOP] Ambiguous check for type-bound GENERIC shall ignore PASSed arguments +! +! Contributed by Salvatore Filippone + +module m + type t + contains + procedure, pass(this) :: sub1 + procedure, pass(this) :: sub2 + generic :: gen => sub1, sub2 ! { dg-error "are ambiguous" } + end type t +contains + subroutine sub1 (x, this) + integer :: i + class(t) :: this + end subroutine sub1 + + subroutine sub2 (this, y) + integer :: i + class(t) :: this + end subroutine sub2 +end module m Index: Fortran/gfortran/regression/typebound_generic_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_13.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 47710: [OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS +! +! Contributed by Janus Weil + +module m + + type base_t + contains + procedure, nopass :: baseproc_nopass => baseproc1 + procedure, pass :: baseproc_pass => baseproc2 + generic :: some_proc => baseproc_pass, baseproc_nopass ! { dg-error "are ambiguous" } + end type + +contains + + subroutine baseproc1 (this) + class(base_t) :: this + end subroutine + + subroutine baseproc2 (this, that) + class(base_t) :: this, that + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_generic_14.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_14.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 54594: [OOP] Type-bound ASSIGNMENTs (elemental + array version) rejected as ambiguous +! +! Contributed by James van Buskirk + +module a_mod + + type :: a + contains + procedure, NOPASS :: a_ass, a_ass_sv + generic :: ass => a_ass, a_ass_sv + end type + +contains + + impure elemental subroutine a_ass (out) + class(a), intent(out) :: out + end subroutine + + subroutine a_ass_sv (out) + class(a), intent(out) :: out(:) + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_generic_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_15.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 60231: [4.8/4.9 Regression] ICE on undefined generic +! +! Contributed by Antony Lewis + +module Objects + + Type TObjectList + contains + procedure :: Add1 ! { dg-error "must be a module procedure" } + procedure :: Add2 ! { dg-error "must be a module procedure" } + generic :: Add => Add1, Add2 ! { dg-error "are ambiguous" } + end Type + +end module Index: Fortran/gfortran/regression/typebound_generic_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_16.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 77501: [F03] ICE in gfc_match_generic, at fortran/decl.c:9429 +! +! Contributed by Gerhard Steinmetz + +module m1 + type t + contains + generic :: f => g ! { dg-error "must target a specific binding" } + generic :: g => h ! { dg-error "Undefined specific binding" } + end type +end + +module m2 + type t + contains + generic :: f => g ! { dg-error "must target a specific binding" } + generic :: g => f ! { dg-error "Undefined specific binding" } + end type +end Index: Fortran/gfortran/regression/typebound_generic_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_2.f03 @@ -0,0 +1,62 @@ +! { dg-do compile } + +! Type-bound procedures +! Check for errors with calls to GENERIC bindings and their module IO. +! Calls with NOPASS. + +MODULE m + IMPLICIT NONE + + TYPE supert + CONTAINS + PROCEDURE, NOPASS :: func_int + PROCEDURE, NOPASS :: sub_int + GENERIC :: func => func_int + GENERIC :: sub => sub_int + END TYPE supert + + TYPE, EXTENDS(supert) :: t + CONTAINS + PROCEDURE, NOPASS :: func_real + GENERIC :: func => func_real + END TYPE t + +CONTAINS + + INTEGER FUNCTION func_int (x) + IMPLICIT NONE + INTEGER :: x + func_int = x + END FUNCTION func_int + + INTEGER FUNCTION func_real (x) + IMPLICIT NONE + REAL :: x + func_real = INT(x * 4.2) + END FUNCTION func_real + + SUBROUTINE sub_int (x) + IMPLICIT NONE + INTEGER :: x + END SUBROUTINE sub_int + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(t) :: myobj + + ! These are ok. + CALL myobj%sub (1) + WRITE (*,*) myobj%func (1) + WRITE (*,*) myobj%func (2.5) + + ! These are not. + CALL myobj%sub (2.5) ! { dg-error "no matching specific binding" } + WRITE (*,*) myobj%func ("hello") ! { dg-error "no matching specific binding" } + CALL myobj%func (2.5) ! { dg-error "SUBROUTINE" } + WRITE (*,*) myobj%sub (1) ! { dg-error "FUNCTION" } + +END PROGRAM main Index: Fortran/gfortran/regression/typebound_generic_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_3.f03 @@ -0,0 +1,61 @@ +! { dg-do run } + +! Type-bound procedures +! Check calls with GENERIC bindings. + +MODULE m + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, NOPASS :: plain_int + PROCEDURE, NOPASS :: plain_real + PROCEDURE, PASS(me) :: passed_intint + PROCEDURE, PASS(me) :: passed_realreal + + GENERIC :: gensub => plain_int, plain_real, passed_intint, passed_realreal + END TYPE t + +CONTAINS + + SUBROUTINE plain_int (x) + IMPLICIT NONE + INTEGER :: x + WRITE (*,*) "Plain Integer" + END SUBROUTINE plain_int + + SUBROUTINE plain_real (x) + IMPLICIT NONE + REAL :: x + WRITE (*,*) "Plain Real" + END SUBROUTINE plain_real + + SUBROUTINE passed_intint (me, x, y) + IMPLICIT NONE + CLASS(t) :: me + INTEGER :: x, y + WRITE (*,*) "Passed Integer" + END SUBROUTINE passed_intint + + SUBROUTINE passed_realreal (x, me, y) + IMPLICIT NONE + REAL :: x, y + CLASS(t) :: me + WRITE (*,*) "Passed Real" + END SUBROUTINE passed_realreal + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(t) :: myobj + + CALL myobj%gensub (5) + CALL myobj%gensub (2.5) + CALL myobj%gensub (5, 5) + CALL myobj%gensub (2.5, 2.5) +END PROGRAM main + +! { dg-output "Plain Integer(\n|\r\n|\r).*Plain Real(\n|\r\n|\r).*Passed Integer(\n|\r\n|\r).*Passed Real" } Index: Fortran/gfortran/regression/typebound_generic_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_4.f03 @@ -0,0 +1,53 @@ +! { dg-do run } + +! PR fortran/37588 +! This test used to not resolve the GENERIC binding. + +! Contributed by Salvatore Filippone + +module bar_mod + + type foo + integer :: i + + contains + procedure, pass(a) :: foo_v => foo_v_inner + procedure, pass(a) :: foo_m => foo_m_inner + generic, public :: foo => foo_v, foo_m + end type foo + + private foo_v_inner, foo_m_inner + +contains + + subroutine foo_v_inner(x,a) + real :: x(:) + class(foo) :: a + + a%i = int(x(1)) + WRITE (*,*) "Vector" + end subroutine foo_v_inner + + subroutine foo_m_inner(x,a) + real :: x(:,:) + class(foo) :: a + + a%i = int(x(1,1)) + WRITE (*,*) "Matrix" + end subroutine foo_m_inner +end module bar_mod + +program foobar + use bar_mod + type(foo) :: dat + real :: x1(10), x2(10,10) + + x1=1 + x2=2 + + call dat%foo(x1) + call dat%foo(x2) + +end program foobar + +! { dg-output "Vector.*Matrix" } Index: Fortran/gfortran/regression/typebound_generic_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_5.f03 @@ -0,0 +1,53 @@ +! { dg-do run } + +! Check that generic bindings targetting ELEMENTAL procedures work. + +MODULE m + IMPLICIT NONE + + TYPE :: t + CONTAINS + PROCEDURE, NOPASS :: double + PROCEDURE, NOPASS :: double_here + GENERIC :: double_it => double + GENERIC :: double_inplace => double_here + END TYPE t + +CONTAINS + + ELEMENTAL INTEGER FUNCTION double (val) + IMPLICIT NONE + INTEGER, INTENT(IN) :: val + double = 2 * val + END FUNCTION double + + ELEMENTAL SUBROUTINE double_here (val) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: val + val = 2 * val + END SUBROUTINE double_here + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(t) :: obj + INTEGER :: arr(42), arr2(42), arr3(42), arr4(42) + INTEGER :: i + + arr = (/ (i, i = 1, 42) /) + + arr2 = obj%double (arr) + arr3 = obj%double_it (arr) + + arr4 = arr + CALL obj%double_inplace (arr4) + + IF (ANY (arr2 /= 2 * arr) .OR. & + ANY (arr3 /= 2 * arr) .OR. & + ANY (arr4 /= 2 * arr)) THEN + STOP 1 + END IF +END PROGRAM main Index: Fortran/gfortran/regression/typebound_generic_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_6.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! +! PR 43945: [OOP] Derived type with GENERIC: resolved to the wrong specific TBP +! +! Contributed by by Salvatore Filippone + +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + generic, public :: do => doit + generic, public :: get => getit + end type foo + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + a%i = 1 + write(*,*) 'FOO%DOIT base version' + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + res = a%i + end function getit +end module foo_mod + +module foo2_mod + use foo_mod + type, extends(foo) :: foo2 + integer :: j + contains + procedure, pass(a) :: doit => doit2 + procedure, pass(a) :: getit => getit2 + end type foo2 + private doit2, getit2 + +contains + + subroutine doit2(a) + class(foo2) :: a + a%i = 2 + a%j = 3 + end subroutine doit2 + function getit2(a) result(res) + class(foo2) :: a + integer :: res + res = a%j + end function getit2 +end module foo2_mod + +program testd15 + use foo2_mod + type(foo2) :: af2 + class(foo), allocatable :: afab + + allocate(foo2 :: afab) + call af2%do() + if (af2%i .ne. 2) STOP 1 + if (af2%get() .ne. 3) STOP 2 + call afab%do() + if (afab%i .ne. 2) STOP 3 + if (afab%get() .ne. 3) STOP 4 + +end program testd15 Index: Fortran/gfortran/regression/typebound_generic_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_7.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 44434: [OOP] ICE in in gfc_add_component_ref +! +! Contributed by Salvatore Filippone + +module foo_mod + type foo + contains + procedure :: doit + generic :: do => doit + end type +contains + subroutine doit(a) + class(foo) :: a + end subroutine +end module + +program testd15 +contains + subroutine dodo(x) + use foo_mod + class(foo) :: x + call x%do() + end subroutine +end Index: Fortran/gfortran/regression/typebound_generic_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_8.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 44565: [4.6 Regression] [OOP] ICE in gimplify_expr with array-valued generic TBP +! +! Contributed by Hans-Werner Boschmann + +module ice6 + + type :: t + contains + procedure :: get_array + generic :: get_something => get_array + end type + +contains + + function get_array(this) + class(t) :: this + real,dimension(2) :: get_array + end function get_array + + subroutine do_something(this) + class(t) :: this + print *,this%get_something() + end subroutine do_something + +end module ice6 Index: Fortran/gfortran/regression/typebound_generic_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_generic_9.f03 @@ -0,0 +1,61 @@ +! { dg-do run } +! +! PR 44936: [OOP] Generic TBP not resolved correctly at compile time +! +! Contributed by Salvatore Filippone + +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit => doit1 + procedure, pass(a) :: getit=> getit1 + generic, public :: do => doit + generic, public :: get => getit + end type foo + private doit1,getit1 +contains + subroutine doit1(a) + class(foo) :: a + a%i = 1 + write(*,*) 'FOO%DOIT base version' + end subroutine doit1 + function getit1(a) result(res) + class(foo) :: a + integer :: res + res = a%i + end function getit1 +end module foo_mod + +module foo2_mod + use foo_mod + type, extends(foo) :: foo2 + integer :: j + contains + procedure, pass(a) :: doit => doit2 + procedure, pass(a) :: getit => getit2 + end type foo2 + private doit2, getit2 +contains + subroutine doit2(a) + class(foo2) :: a + a%i = 2 + a%j = 3 + end subroutine doit2 + function getit2(a) result(res) + class(foo2) :: a + integer :: res + res = a%j + end function getit2 +end module foo2_mod + +program testd15 + use foo2_mod + type(foo2) :: af2 + + call af2%do() + if (af2%i .ne. 2) STOP 1 + if (af2%get() .ne. 3) STOP 2 + +end program testd15 + Index: Fortran/gfortran/regression/typebound_operator_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_1.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } + +! Type-bound procedures +! Check correct type-bound operator definitions. + +MODULE m + IMPLICIT NONE + + TYPE t + LOGICAL :: x + CONTAINS + PROCEDURE, PASS :: onearg + PROCEDURE, PASS :: twoarg1 + PROCEDURE, PASS :: twoarg2 + PROCEDURE, PASS(me) :: assign_proc + + GENERIC :: OPERATOR(.BINARY.) => twoarg1, twoarg2 + GENERIC :: OPERATOR(.UNARY.) => onearg + GENERIC :: ASSIGNMENT(=) => assign_proc + END TYPE t + +CONTAINS + + INTEGER FUNCTION onearg (me) + CLASS(t), INTENT(IN) :: me + onearg = 5 + END FUNCTION onearg + + INTEGER FUNCTION twoarg1 (me, a) + CLASS(t), INTENT(IN) :: me + INTEGER, INTENT(IN) :: a + twoarg1 = 42 + END FUNCTION twoarg1 + + INTEGER FUNCTION twoarg2 (me, a) + CLASS(t), INTENT(IN) :: me + REAL, INTENT(IN) :: a + twoarg2 = 123 + END FUNCTION twoarg2 + + SUBROUTINE assign_proc (me, b) + CLASS(t), INTENT(OUT) :: me + LOGICAL, INTENT(IN) :: b + me%x = .NOT. b + END SUBROUTINE assign_proc + +END MODULE m Index: Fortran/gfortran/regression/typebound_operator_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_10.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! PR51791 and original testcase for PR46328. +! +! Contributer by Thomas Koenig +! +module field_module + implicit none + type ,abstract :: field + contains + procedure(field_op_real) ,deferred :: multiply_real + generic :: operator(*) => multiply_real + end type + abstract interface + function field_op_real(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: field_op_real + end function + end interface +end module + +program main + use field_module + implicit none + class(field) ,pointer :: u + u = (u)*2. ! { dg-error "check that there is a matching specific" } +end program Index: Fortran/gfortran/regression/typebound_operator_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_11.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/46328 +! +! Contributed by Damian Rouson +! +module foo_module + type ,abstract :: foo + contains + procedure(t_interface) ,deferred :: t + procedure(assign_interface) ,deferred :: assign + procedure(multiply_interface) ,deferred :: multiply + generic :: operator(*) => multiply + generic :: assignment(=) => assign + end type + abstract interface + function t_interface(this) + import :: foo + class(foo) :: this + class(foo), allocatable ::t_interface + end function + function multiply_interface(lhs,rhs) + import :: foo + class(foo), allocatable :: multiply_interface + class(foo), intent(in) :: lhs + real, intent(in) :: rhs + end function + subroutine assign_interface(lhs,rhs) + import :: foo + class(foo), intent(in) :: rhs + class(foo), intent(inout) :: lhs + end subroutine + end interface +contains + subroutine bar(x,dt) + class(foo) :: x + real, intent(in) :: dt + x = x%t()*dt + end subroutine +end module Index: Fortran/gfortran/regression/typebound_operator_12.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_12.f03 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR51634 - Handle allocatable components correctly in expressions +! involving typebound operators. See comment 2 of PR. +! +! Reported by Tobias Burnus +! +module soop_stars_class + implicit none + type soop_stars + real, dimension(:), allocatable :: position,velocity + contains + procedure :: total + procedure :: product + generic :: operator(+) => total + generic :: operator(*) => product + end type +contains + type(soop_stars) function product(lhs,rhs) + class(soop_stars) ,intent(in) :: lhs + real ,intent(in) :: rhs + product%position = lhs%position*rhs + product%velocity = lhs%velocity*rhs + end function + + type(soop_stars) function total(lhs,rhs) + class(soop_stars) ,intent(in) :: lhs,rhs + total%position = lhs%position + rhs%position + total%velocity = lhs%velocity + rhs%velocity + end function +end module + +program main + use soop_stars_class ,only : soop_stars + implicit none + type(soop_stars) :: fireworks + real :: dt + fireworks%position = [1,2,3] + fireworks%velocity = [4,5,6] + dt = 5 + fireworks = fireworks + fireworks*dt + if (any (fireworks%position .ne. [6, 12, 18])) STOP 1 + if (any (fireworks%velocity .ne. [24, 30, 36])) STOP 2 +end program Index: Fortran/gfortran/regression/typebound_operator_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_13.f03 @@ -0,0 +1,57 @@ +! { dg-do run } +! PR51634 - Handle allocatable components correctly in expressions +! involving typebound operators. From comment 2 of PR but using +! classes throughout. +! +! Reported by Tobias Burnus +! +module soop_stars_class + implicit none + type soop_stars + real, dimension(:), allocatable :: position,velocity + contains + procedure :: total + procedure :: mult + procedure :: assign + generic :: operator(+) => total + generic :: operator(*) => mult + generic :: assignment(=) => assign + end type +contains + function mult(lhs,rhs) + class(soop_stars) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(soop_stars), allocatable :: mult + type(soop_stars) :: tmp + tmp = soop_stars (lhs%position*rhs, lhs%velocity*rhs) + allocate (mult, source = tmp) + end function + + function total(lhs,rhs) + class(soop_stars) ,intent(in) :: lhs,rhs + class(soop_stars), allocatable :: total + type(soop_stars) :: tmp + tmp = soop_stars (lhs%position + rhs%position, & + lhs%velocity + rhs%velocity) + allocate (total, source = tmp) + end function + + subroutine assign(lhs,rhs) + class(soop_stars), intent(in) :: rhs + class(soop_stars), intent(out) :: lhs + lhs%position = rhs%position + lhs%velocity = rhs%velocity + end subroutine +end module + +program main + use soop_stars_class ,only : soop_stars + implicit none + class(soop_stars), allocatable :: fireworks + real :: dt + allocate (fireworks, source = soop_stars ([1,2,3], [4,5,6])) + dt = 5 + fireworks = fireworks + fireworks*dt + if (any (fireworks%position .ne. [6, 12, 18])) STOP 1 + if (any (fireworks%velocity .ne. [24, 30, 36])) STOP 2 +end program Index: Fortran/gfortran/regression/typebound_operator_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_14.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR fortran/52024 +! +! The test case was segfaulting before +! + +module m_sort + implicit none + type, abstract :: sort_t + contains + generic :: operator(.gt.) => gt_cmp + procedure :: gt_cmp + end type sort_t +contains + logical function gt_cmp(a,b) + class(sort_t), intent(in) :: a, b + gt_cmp = .true. + end function gt_cmp +end module + +module test + use m_sort + implicit none + type, extends(sort_t) :: sort_int_t + integer :: i + contains + generic :: operator(.gt.) => gt_cmp_int ! { dg-error "are ambiguous" } + procedure :: gt_cmp_int + end type +contains + logical function gt_cmp_int(a,b) result(cmp) + class(sort_int_t), intent(in) :: a, b + if (a%i > b%i) then + cmp = .true. + else + cmp = .false. + end if + end function gt_cmp_int +end module + Index: Fortran/gfortran/regression/typebound_operator_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_15.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! PR fortran/53255 +! +! Contributed by Reinhold Bader. +! +! Before TYPE(ext)'s .tr. wrongly called the base type's trace +! instead of ext's trace_ext. +! +module mod_base + implicit none + private + integer, public :: base_cnt = 0 + type, public :: base + private + real :: r(2,2) = reshape( (/ 1.0, 2.0, 3.0, 4.0 /), (/ 2, 2 /)) + contains + procedure, private :: trace + generic :: operator(.tr.) => trace + end type base +contains + complex function trace(this) + class(base), intent(in) :: this + base_cnt = base_cnt + 1 +! write(*,*) 'executing base' + trace = this%r(1,1) + this%r(2,2) + end function trace +end module mod_base + +module mod_ext + use mod_base + implicit none + private + integer, public :: ext_cnt = 0 + public :: base, base_cnt + type, public, extends(base) :: ext + private + real :: i(2,2) = reshape( (/ 1.0, 1.0, 1.0, 1.5 /), (/ 2, 2 /)) + contains + procedure, private :: trace => trace_ext + end type ext +contains + complex function trace_ext(this) + class(ext), intent(in) :: this + +! the following should be executed through invoking .tr. p below +! write(*,*) 'executing override' + ext_cnt = ext_cnt + 1 + trace_ext = .tr. this%base + (0.0, 1.0) * ( this%i(1,1) + this%i(2,2) ) + end function trace_ext + +end module mod_ext +program test_override + use mod_ext + implicit none + type(base) :: o + type(ext) :: p + real :: r + + ! Note: ext's ".tr." (trace_ext) calls also base's "trace" + +! write(*,*) .tr. o +! write(*,*) .tr. p + if (base_cnt /= 0 .or. ext_cnt /= 0) STOP 1 + r = .tr. o + if (base_cnt /= 1 .or. ext_cnt /= 0) STOP 2 + r = .tr. p + if (base_cnt /= 2 .or. ext_cnt /= 1) STOP 3 + + if (abs(.tr. o - 5.0 ) < 1.0e-6 .and. abs( .tr. p - (5.0,2.5)) < 1.0e-6) & + then + if (base_cnt /= 4 .or. ext_cnt /= 2) STOP 4 +! write(*,*) 'OK' + else + STOP 5 +! write(*,*) 'FAIL' + end if +end program test_override Index: Fortran/gfortran/regression/typebound_operator_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_16.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR 49591: [OOP] Multiple identical specific procedures in type-bound operator not detected +! +! This is interpretation request F03/0018: +! http://www.j3-fortran.org/doc/meeting/195/11-214.txt +! +! Contributed by Tobias Burnus + +module M1 + type T + integer x + contains + procedure :: MyAdd_t => myadd + generic :: operator(+) => myAdd_t + end type T + type X + real q + contains + procedure, pass(b) :: MyAdd_x => myadd + generic :: operator(+) => myAdd_x ! { dg-error "is already present in the interface" } + end type X +contains + integer function MyAdd ( A, B ) + class(t), intent(in) :: A + class(x), intent(in) :: B + myadd = a%x + b%q + end function MyAdd +end module + +module M2 + interface operator(+) + procedure MyAdd + end interface + type T + integer x + contains + procedure :: MyAdd_t => myadd + generic :: operator(+) => myAdd_t ! { dg-error "is already present in the interface" } + end type T +contains + integer function MyAdd ( A, B ) + class(t), intent(in) :: A + real, intent(in) :: B + myadd = a%x + b + end function MyAdd +end module Index: Fortran/gfortran/regression/typebound_operator_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_17.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR 54832: [4.8 Regression] [OOP] Type-bound operator not picked up with RESULT variable +! +! Contributed by Damian Rouson + + type, abstract :: integrand + contains + procedure(t_interface), deferred :: t + procedure(assign_interface), deferred :: assign + procedure(times_interface), deferred :: times + generic :: operator(*) => times + generic :: assignment(=) => assign + end type + + abstract interface + function t_interface(this) result(dState_dt) + import :: integrand + class(integrand) ,intent(in) :: this + class(integrand) ,allocatable :: dState_dt + end function + function times_interface(lhs,rhs) + import :: integrand + class(integrand) ,intent(in) :: lhs + class(integrand) ,allocatable :: times_interface + real, intent(in) :: rhs + end function + subroutine assign_interface(lhs,rhs) + import :: integrand + class(integrand) ,intent(in) :: rhs + class(integrand) ,intent(inout) :: lhs + end subroutine + end interface + +contains + + subroutine integrate(model,dt) + class(integrand) :: model + real dt + model = model%t()*dt + end subroutine + +end Index: Fortran/gfortran/regression/typebound_operator_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_18.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 55297: [4.8 Regression] [OOP] type-bound operator clashes with abstract interface +! +! Contributed by Damian Rouson + +module athlete_module + type athlete + contains + procedure :: negative + generic :: operator(-) => negative + end type + abstract interface + integer function sum_interface(this) + import athlete + class(athlete) this + end function + end interface +contains + integer function negative(this) + class(athlete) ,intent(in) :: this + end function +end module Index: Fortran/gfortran/regression/typebound_operator_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_19.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/54195 +! The compiler used to diagnose a duplicate entity in the assignment interface +! because NC was resolved twice. +! +! Contributed by Damian Rouson + +module import_clashes_with_generic + + type ,abstract :: foo + contains + procedure :: unary + generic :: operator(-) => unary + end type + + abstract interface + integer function bar() + import :: foo + end function + end interface + +contains + + integer function unary(rhs) + class(foo) ,intent(in) :: rhs + end function + +end module Index: Fortran/gfortran/regression/typebound_operator_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_2.f03 @@ -0,0 +1,65 @@ +! { dg-do compile } + +! Type-bound procedures +! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage. + +MODULE m + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, PASS :: onearg + PROCEDURE, PASS :: onearg_alt => onearg + PROCEDURE, PASS :: onearg_alt2 => onearg + PROCEDURE, NOPASS :: nopassed => onearg + PROCEDURE, PASS :: threearg + PROCEDURE, PASS :: sub + PROCEDURE, PASS :: sub2 + PROCEDURE, PASS :: func + + ! These give errors at the targets' definitions. + GENERIC :: OPERATOR(.AND.) => sub2 + GENERIC :: OPERATOR(*) => onearg + GENERIC :: ASSIGNMENT(=) => func + + GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" } + GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" } + ! We can't check for the 'at least one argument' error, because in this case + ! the procedure must be NOPASS and that other error is issued. But of + ! course this should be alright. + + GENERIC :: OPERATOR(.UNARY.) => onearg_alt + GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" } + + GENERIC :: OPERATOR(.UNARYPRIME.) => nopassed ! { dg-error "cannot be NOPASS" } + GENERIC :: OPERATOR(-) => nopassed ! { dg-error "cannot be NOPASS" } + END TYPE t + +CONTAINS + + INTEGER FUNCTION onearg (me) ! { dg-error "wrong number of arguments" } + CLASS(t), INTENT(IN) :: me + onearg = 5 + END FUNCTION onearg + + INTEGER FUNCTION threearg (a, b, c) + CLASS(t), INTENT(IN) :: a, b, c + threearg = 42 + END FUNCTION threearg + + LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" } + CLASS(t), INTENT(OUT) :: me + CLASS(t), INTENT(IN) :: b + func = .TRUE. + END FUNCTION func + + SUBROUTINE sub (a) + CLASS(t), INTENT(IN) :: a + END SUBROUTINE sub + + SUBROUTINE sub2 (a, x) ! { dg-error "must be a FUNCTION" } + CLASS(t), INTENT(IN) :: a + INTEGER, INTENT(IN) :: x + END SUBROUTINE sub2 + +END MODULE m Index: Fortran/gfortran/regression/typebound_operator_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_20.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! PR 63733: [4.8/4.9/5 Regression] [OOP] wrong resolution for OPERATOR generics +! +! Original test case from Alberto F. Martín Huertas +! Slightly modified by Salvatore Filippone +! Further modified by Janus Weil + +module overwrite + type parent + contains + procedure :: sum => sum_parent + generic :: operator(+) => sum + end type + + type, extends(parent) :: child + contains + procedure :: sum => sum_child + end type + +contains + + integer function sum_parent(op1,op2) + implicit none + class(parent), intent(in) :: op1, op2 + sum_parent = 0 + end function + + integer function sum_child(op1,op2) + implicit none + class(child) , intent(in) :: op1 + class(parent), intent(in) :: op2 + sum_child = 1 + end function + +end module + +program drive + use overwrite + implicit none + + type(parent) :: m1, m2 + class(parent), pointer :: mres + type(child) :: h1, h2 + class(parent), pointer :: hres + + if (m1 + m2 /= 0) STOP 1 + if (h1 + m2 /= 1) STOP 2 + if (h1%sum(h2) /= 1) STOP 3 + +end Index: Fortran/gfortran/regression/typebound_operator_21.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_21.f03 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! Test that pr78395 is fixed. +! Contributed by Chris MacMackin and Janus Weil + +module types_mod + implicit none + + type, public :: t1 + integer :: a + contains + procedure :: get_t2 + end type + + type, public :: t2 + integer :: b + contains + procedure, pass(rhs) :: mul2 + procedure :: assign + generic :: operator(*) => mul2 + generic :: assignment(=) => assign + end type + +contains + + function get_t2(this) + class(t1), intent(in) :: this + class(t2), allocatable :: get_t2 + type(t2), allocatable :: local + allocate(local) + local%b = this%a + call move_alloc(local, get_t2) + end function + + function mul2(lhs, rhs) + class(t2), intent(in) :: rhs + integer, intent(in) :: lhs + class(t2), allocatable :: mul2 + type(t2), allocatable :: local + allocate(local) + local%b = rhs%b*lhs + call move_alloc(local, mul2) + end function + + subroutine assign(this, rhs) + class(t2), intent(out) :: this + class(t2), intent(in) :: rhs + select type(rhs) + type is(t2) + this%b = rhs%b + class default + error stop + end select + end subroutine + +end module + + +program minimal + use types_mod + implicit none + + class(t1), allocatable :: v4 + class(t2), allocatable :: v6 + + allocate(v4, source=t1(4)) + allocate(v6) + v6 = 3 * v4%get_t2() + + select type (v6) + type is (t2) + if (v6%b /= 12) error stop + class default + error stop + end select + deallocate(v4, v6) +end + Index: Fortran/gfortran/regression/typebound_operator_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_3.f03 @@ -0,0 +1,123 @@ +! { dg-do run } + +! Type-bound procedures +! Check they can actually be called and run correctly. +! This also checks for correct module save/restore. + +! FIXME: Check that calls to inherited bindings work once CLASS allows that. + +MODULE m + IMPLICIT NONE + + TYPE mynum + REAL :: num_real + INTEGER :: num_int + CONTAINS + PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE. + PROCEDURE, PASS :: add_int + PROCEDURE, PASS :: add_real + PROCEDURE, PASS :: assign_int + PROCEDURE, PASS :: assign_real + PROCEDURE, PASS(from) :: assign_to_int + PROCEDURE, PASS(from) :: assign_to_real + PROCEDURE, PASS :: get_all + + GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real + GENERIC :: OPERATOR(.GET.) => get_all + GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, & + assign_to_int, assign_to_real + END TYPE mynum + +CONTAINS + + TYPE(mynum) FUNCTION add_mynum (a, b) + CLASS(mynum), INTENT(IN) :: a, b + add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int) + END FUNCTION add_mynum + + TYPE(mynum) FUNCTION add_int (a, b) + CLASS(mynum), INTENT(IN) :: a + INTEGER, INTENT(IN) :: b + add_int = mynum (a%num_real, a%num_int + b) + END FUNCTION add_int + + TYPE(mynum) FUNCTION add_real (a, b) + CLASS(mynum), INTENT(IN) :: a + REAL, INTENT(IN) :: b + add_real = mynum (a%num_real + b, a%num_int) + END FUNCTION add_real + + REAL FUNCTION get_all (me) + CLASS(mynum), INTENT(IN) :: me + get_all = me%num_real + me%num_int + END FUNCTION get_all + + SUBROUTINE assign_real (dest, from) + CLASS(mynum), INTENT(INOUT) :: dest + REAL, INTENT(IN) :: from + dest%num_real = from + END SUBROUTINE assign_real + + SUBROUTINE assign_int (dest, from) + CLASS(mynum), INTENT(INOUT) :: dest + INTEGER, INTENT(IN) :: from + dest%num_int = from + END SUBROUTINE assign_int + + SUBROUTINE assign_to_real (dest, from) + REAL, INTENT(OUT) :: dest + CLASS(mynum), INTENT(IN) :: from + dest = from%num_real + END SUBROUTINE assign_to_real + + SUBROUTINE assign_to_int (dest, from) + INTEGER, INTENT(OUT) :: dest + CLASS(mynum), INTENT(IN) :: from + dest = from%num_int + END SUBROUTINE assign_to_int + + ! Test it works basically within the module. + SUBROUTINE check_in_module () + IMPLICIT NONE + TYPE(mynum) :: num + + num = mynum (1.0, 2) + num = num + 7 + IF (num%num_real /= 1.0 .OR. num%num_int /= 9) STOP 1 + END SUBROUTINE check_in_module + +END MODULE m + +! Here we see it also works for use-associated operators loaded from a module. +PROGRAM main + USE m, ONLY: mynum, check_in_module + IMPLICIT NONE + + TYPE(mynum) :: num1, num2, num3 + REAL :: real_var + INTEGER :: int_var + + CALL check_in_module () + + num1 = mynum (1.0, 2) + num2 = mynum (2.0, 3) + + num3 = num1 + num2 + IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) STOP 2 + + num3 = num1 + 5 + IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) STOP 3 + + num3 = num1 + (-100.5) + IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) STOP 4 + + num3 = 42 + num3 = -1.2 + IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) STOP 5 + + real_var = num3 + int_var = num3 + IF (real_var /= -1.2 .OR. int_var /= 42) STOP 6 + + IF (.GET. num1 /= 3.0) STOP 7 +END PROGRAM main Index: Fortran/gfortran/regression/typebound_operator_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_4.f03 @@ -0,0 +1,89 @@ +! { dg-do compile } + +! Type-bound procedures +! Check for errors with operator calls. + +MODULE m + IMPLICIT NONE + + TYPE myint + INTEGER :: value + CONTAINS + PROCEDURE, PASS :: add_int + PROCEDURE, PASS :: assign_int + GENERIC, PRIVATE :: OPERATOR(.PLUS.) => add_int + GENERIC, PRIVATE :: OPERATOR(+) => add_int + GENERIC, PRIVATE :: ASSIGNMENT(=) => assign_int + END TYPE myint + + TYPE myreal + REAL :: value + CONTAINS + PROCEDURE, PASS :: add_real + PROCEDURE, PASS :: assign_real + GENERIC :: OPERATOR(.PLUS.) => add_real + GENERIC :: OPERATOR(+) => add_real + GENERIC :: ASSIGNMENT(=) => assign_real + END TYPE myreal + +CONTAINS + + PURE TYPE(myint) FUNCTION add_int (a, b) + CLASS(myint), INTENT(IN) :: a + INTEGER, INTENT(IN) :: b + add_int = myint (a%value + b) + END FUNCTION add_int + + SUBROUTINE assign_int (dest, from) + CLASS(myint), INTENT(OUT) :: dest + INTEGER, INTENT(IN) :: from + dest%value = from + END SUBROUTINE assign_int + + TYPE(myreal) FUNCTION add_real (a, b) + CLASS(myreal), INTENT(IN) :: a + REAL, INTENT(IN) :: b + add_real = myreal (a%value + b) + END FUNCTION add_real + + SUBROUTINE assign_real (dest, from) + CLASS(myreal), INTENT(OUT) :: dest + REAL, INTENT(IN) :: from + dest%value = from + END SUBROUTINE assign_real + + SUBROUTINE in_module () + TYPE(myint) :: x + x = 0 ! { dg-bogus "Cannot convert" } + x = x + 42 ! { dg-bogus "Operands of" } + x = x .PLUS. 5 ! { dg-bogus "Unknown operator" } + END SUBROUTINE in_module + + PURE SUBROUTINE iampure () + TYPE(myint) :: x + + x = x + 42 ! { dg-bogus "to a impure procedure" } + x = x .PLUS. 5 ! { dg-bogus "to a impure procedure" } + END SUBROUTINE iampure + +END MODULE m + +PURE SUBROUTINE iampure2 () + USE m + IMPLICIT NONE + TYPE(myreal) :: x + + x = 0.0 ! { dg-error "is not PURE" } + x = x + 42.0 ! { dg-error "impure function" } + x = x .PLUS. 5.0 ! { dg-error "impure function" } +END SUBROUTINE iampure2 + +PROGRAM main + USE m + IMPLICIT NONE + TYPE(myint) :: x + + x = 0 ! { dg-error "Cannot convert" } + x = x + 42 ! { dg-error "binary intrinsic numeric operator" } + x = x .PLUS. 5 ! { dg-error "Unknown operator" } +END PROGRAM main Index: Fortran/gfortran/regression/typebound_operator_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_5.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 45933: [4.6 regression] [OOP] ICE in gfc_add_component_ref, at fortran/class.c:77 +! +! Contributed by Mark Rashid + +MODULE DEF1 + TYPE :: DAT + INTEGER :: NN + CONTAINS + PROCEDURE :: LESS_THAN + GENERIC :: OPERATOR (.LT.) => LESS_THAN + END TYPE +CONTAINS + LOGICAL FUNCTION LESS_THAN(A, B) + CLASS (DAT), INTENT (IN) :: A, B + LESS_THAN = (A%NN .LT. B%NN) + END FUNCTION +END MODULE + +PROGRAM P + USE DEF1 + TYPE NODE + TYPE (DAT), POINTER :: PT + END TYPE + CLASS (NODE),POINTER :: A, B + PRINT *, A%PT .LT. B%PT +END Index: Fortran/gfortran/regression/typebound_operator_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_6.f03 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! PR 45961: [4.6 Regression] [OOP] Problem with polymorphic type-bound operators +! +! Contributed by Mark Rashid + +MODULE DAT_MOD + + TYPE :: DAT + INTEGER :: NN + CONTAINS + PROCEDURE :: LESS_THAN + GENERIC :: OPERATOR (.LT.) => LESS_THAN + END TYPE DAT + +CONTAINS + + LOGICAL FUNCTION LESS_THAN(A, B) + CLASS (DAT), INTENT (IN) :: A, B + LESS_THAN = (A%NN .LT. B%NN) + END FUNCTION LESS_THAN + +END MODULE DAT_MOD + + +MODULE NODE_MOD + USE DAT_MOD + + TYPE NODE + INTEGER :: KEY + CLASS (DAT), POINTER :: PT + CONTAINS + PROCEDURE :: LST + GENERIC :: OPERATOR (.LT.) => LST + END TYPE NODE + +CONTAINS + + LOGICAL FUNCTION LST(A, B) + CLASS (NODE), INTENT (IN) :: A, B + IF (A%KEY .GT. 0 .AND. B%KEY .GT. 0) THEN + LST = (A%KEY .LT. B%KEY) + ELSE + LST = (A%PT .LT. B%PT) + END IF + END FUNCTION LST + +END MODULE NODE_MOD + + +PROGRAM TEST + USE NODE_MOD + IMPLICIT NONE + + CLASS (DAT), POINTER :: POINTA => NULL(), POINTB => NULL() + CLASS (NODE), POINTER :: NDA => NULL(), NDB => NULL() + + ALLOCATE (DAT :: POINTA) + ALLOCATE (DAT :: POINTB) + ALLOCATE (NODE :: NDA) + ALLOCATE (NODE :: NDB) + + POINTA%NN = 5 + NDA%PT => POINTA + NDA%KEY = 2 + POINTB%NN = 10 + NDB%PT => POINTB + NDB%KEY = 3 + + if (.NOT. NDA .LT. NDB) STOP 1 +END Index: Fortran/gfortran/regression/typebound_operator_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_7.f03 @@ -0,0 +1,101 @@ +! { dg-do run } +! PR46328 - complex expressions involving typebound operators of class objects. +! +module field_module + implicit none + type ,abstract :: field + contains + procedure(field_op_real) ,deferred :: multiply_real + procedure(field_plus_field) ,deferred :: plus + procedure(assign_field) ,deferred :: assn + generic :: operator(*) => multiply_real + generic :: operator(+) => plus + generic :: ASSIGNMENT(=) => assn + end type + abstract interface + function field_plus_field(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: field_plus_field + end function + end interface + abstract interface + function field_op_real(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: field_op_real + end function + end interface + abstract interface + subroutine assign_field(lhs,rhs) + import :: field + class(field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + end subroutine + end interface +end module + +module i_field_module + use field_module + implicit none + type, extends (field) :: i_field + integer :: i + contains + procedure :: multiply_real => i_multiply_real + procedure :: plus => i_plus_i + procedure :: assn => i_assn + end type +contains + function i_plus_i(lhs,rhs) + class(i_field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: i_plus_i + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i + end select + select type (rhs) + type is (i_field); m = rhs%i + m + end select + allocate (i_plus_i, source = i_field (m)) + end function + function i_multiply_real(lhs,rhs) + class(i_field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: i_multiply_real + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i * int (rhs) + end select + allocate (i_multiply_real, source = i_field (m)) + end function + subroutine i_assn(lhs,rhs) + class(i_field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + select type (lhs) + type is (i_field) + select type (rhs) + type is (i_field) + lhs%i = rhs%i + end select + end select + end subroutine +end module + +program main + use i_field_module + implicit none + class(i_field) ,allocatable :: u + allocate (u, source = i_field (99)) + + u = (u)*2. + u = (u*2.0*4.0) + u*4.0 + u = u%multiply_real (2.0)*4.0 + u = i_multiply_real (u, 2.0) * 4.0 + + select type (u) + type is (i_field); if (u%i .ne. 152064) STOP 1 + end select +end program Index: Fortran/gfortran/regression/typebound_operator_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_8.f03 @@ -0,0 +1,99 @@ +! { dg-do run } +! PR48946 - complex expressions involving typebound operators of derived types. +! +module field_module + implicit none + type ,abstract :: field + contains + procedure(field_op_real) ,deferred :: multiply_real + procedure(field_plus_field) ,deferred :: plus + procedure(assign_field) ,deferred :: assn + generic :: operator(*) => multiply_real + generic :: operator(+) => plus + generic :: ASSIGNMENT(=) => assn + end type + abstract interface + function field_plus_field(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: field_plus_field + end function + end interface + abstract interface + function field_op_real(lhs,rhs) + import :: field + class(field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: field_op_real + end function + end interface + abstract interface + subroutine assign_field(lhs,rhs) + import :: field + class(field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + end subroutine + end interface +end module + +module i_field_module + use field_module + implicit none + type, extends (field) :: i_field + integer :: i + contains + procedure :: multiply_real => i_multiply_real + procedure :: plus => i_plus_i + procedure :: assn => i_assn + end type +contains + function i_plus_i(lhs,rhs) + class(i_field) ,intent(in) :: lhs + class(field) ,intent(in) :: rhs + class(field) ,allocatable :: i_plus_i + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i + end select + select type (rhs) + type is (i_field); m = rhs%i + m + end select + allocate (i_plus_i, source = i_field (m)) + end function + function i_multiply_real(lhs,rhs) + class(i_field) ,intent(in) :: lhs + real ,intent(in) :: rhs + class(field) ,allocatable :: i_multiply_real + integer :: m = 0 + select type (lhs) + type is (i_field); m = lhs%i * int (rhs) + end select + allocate (i_multiply_real, source = i_field (m)) + end function + subroutine i_assn(lhs,rhs) + class(i_field) ,intent(OUT) :: lhs + class(field) ,intent(IN) :: rhs + select type (lhs) + type is (i_field) + select type (rhs) + type is (i_field) + lhs%i = rhs%i + end select + end select + end subroutine +end module + +program main + use i_field_module + implicit none + type(i_field) ,allocatable :: u + allocate (u, source = i_field (99)) + + u = u*2. + u = (u*2.0*4.0) + u*4.0 + u = u%multiply_real (2.0)*4.0 + u = i_multiply_real (u, 2.0) * 4.0 + + if (u%i .ne. 152064) STOP 1 +end program Index: Fortran/gfortran/regression/typebound_operator_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_operator_9.f03 @@ -0,0 +1,499 @@ +! { dg-do run } +! { dg-add-options ieee } +! +! Solve a diffusion problem using an object-oriented approach +! +! Author: Arjen Markus (comp.lang.fortran) +! This version: pault@gcc.gnu.org +! +! Note: +! (i) This could be turned into a more sophisticated program +! using the techniques described in the chapter on +! mathematical abstractions. +! (That would allow the selection of the time integration +! method in a transparent way) +! +! (ii) The target procedures for process_p and source_p are +! different to the typebound procedures for dynamic types +! because the passed argument is not type(base_pde_object). +! +! (iii) Two solutions are calculated, one with the procedure +! pointers and the other with typebound procedures. The sums +! of the solutions are compared. + +! (iv) The source is a delta function in the middle of the +! mesh, whilst the process is quartic in the local value, +! when it is positive. +! +! base_pde_objects -- +! Module to define the basic objects +! +module base_pde_objects + implicit none + type, abstract :: base_pde_object +! No data + procedure(process_p), pointer, pass :: process_p + procedure(source_p), pointer, pass :: source_p + contains + procedure(process), deferred :: process + procedure(source), deferred :: source + procedure :: initialise + procedure :: nabla2 + procedure :: print + procedure(real_times_obj), pass(obj), deferred :: real_times_obj + procedure(obj_plus_obj), deferred :: obj_plus_obj + procedure(obj_assign_obj), deferred :: obj_assign_obj + generic :: operator(*) => real_times_obj + generic :: operator(+) => obj_plus_obj + generic :: assignment(=) => obj_assign_obj + end type + abstract interface + function process_p (obj) + import base_pde_object + class(base_pde_object), intent(in) :: obj + class(base_pde_object), allocatable :: process_p + end function process_p + end interface + abstract interface + function source_p (obj, time) + import base_pde_object + class(base_pde_object), intent(in) :: obj + real, intent(in) :: time + class(base_pde_object), allocatable :: source_p + end function source_p + end interface + abstract interface + function process (obj) + import base_pde_object + class(base_pde_object), intent(in) :: obj + class(base_pde_object), allocatable :: process + end function process + end interface + abstract interface + function source (obj, time) + import base_pde_object + class(base_pde_object), intent(in) :: obj + real, intent(in) :: time + class(base_pde_object), allocatable :: source + end function source + end interface + abstract interface + function real_times_obj (factor, obj) result(newobj) + import base_pde_object + real, intent(in) :: factor + class(base_pde_object), intent(in) :: obj + class(base_pde_object), allocatable :: newobj + end function real_times_obj + end interface + abstract interface + function obj_plus_obj (obj1, obj2) result(newobj) + import base_pde_object + class(base_pde_object), intent(in) :: obj1 + class(base_pde_object), intent(in) :: obj2 + class(base_pde_object), allocatable :: newobj + end function obj_plus_obj + end interface + abstract interface + subroutine obj_assign_obj (obj1, obj2) + import base_pde_object + class(base_pde_object), intent(inout) :: obj1 + class(base_pde_object), intent(in) :: obj2 + end subroutine obj_assign_obj + end interface +contains +! print -- +! Print the concentration field + subroutine print (obj) + class(base_pde_object) :: obj + ! Dummy + end subroutine print +! initialise -- +! Initialise the concentration field using a specific function + subroutine initialise (obj, funcxy) + class(base_pde_object) :: obj + interface + real function funcxy (coords) + real, dimension(:), intent(in) :: coords + end function funcxy + end interface + ! Dummy + end subroutine initialise +! nabla2 -- +! Determine the divergence + function nabla2 (obj) + class(base_pde_object), intent(in) :: obj + class(base_pde_object), allocatable :: nabla2 + ! Dummy + end function nabla2 +end module base_pde_objects +! cartesian_2d_objects -- +! PDE object on a 2D cartesian grid +! +module cartesian_2d_objects + use base_pde_objects + implicit none + type, extends(base_pde_object) :: cartesian_2d_object + real, dimension(:,:), allocatable :: c + real :: dx + real :: dy + contains + procedure :: process => process_cart2d + procedure :: source => source_cart2d + procedure :: initialise => initialise_cart2d + procedure :: nabla2 => nabla2_cart2d + procedure :: print => print_cart2d + procedure, pass(obj) :: real_times_obj => real_times_cart2d + procedure :: obj_plus_obj => obj_plus_cart2d + procedure :: obj_assign_obj => obj_assign_cart2d + end type cartesian_2d_object + interface grid_definition + module procedure grid_definition_cart2d + end interface +contains + function process_cart2d (obj) + class(cartesian_2d_object), intent(in) :: obj + class(base_pde_object), allocatable :: process_cart2d + allocate (process_cart2d,source = obj) + select type (process_cart2d) + type is (cartesian_2d_object) + process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4 + class default + STOP 1 + end select + end function process_cart2d + function process_cart2d_p (obj) + class(base_pde_object), intent(in) :: obj + class(base_pde_object), allocatable :: process_cart2d_p + allocate (process_cart2d_p,source = obj) + select type (process_cart2d_p) + type is (cartesian_2d_object) + select type (obj) + type is (cartesian_2d_object) + process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4 + end select + class default + STOP 2 + end select + end function process_cart2d_p + function source_cart2d (obj, time) + class(cartesian_2d_object), intent(in) :: obj + real, intent(in) :: time + class(base_pde_object), allocatable :: source_cart2d + integer :: m, n + m = size (obj%c, 1) + n = size (obj%c, 2) + allocate (source_cart2d, source = obj) + select type (source_cart2d) + type is (cartesian_2d_object) + if (allocated (source_cart2d%c)) deallocate (source_cart2d%c) + allocate (source_cart2d%c(m, n)) + source_cart2d%c = 0.0 + if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1 + class default + STOP 3 + end select + end function source_cart2d + + function source_cart2d_p (obj, time) + class(base_pde_object), intent(in) :: obj + real, intent(in) :: time + class(base_pde_object), allocatable :: source_cart2d_p + integer :: m, n + select type (obj) + type is (cartesian_2d_object) + m = size (obj%c, 1) + n = size (obj%c, 2) + class default + STOP 4 + end select + allocate (source_cart2d_p,source = obj) + select type (source_cart2d_p) + type is (cartesian_2d_object) + if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c) + allocate (source_cart2d_p%c(m,n)) + source_cart2d_p%c = 0.0 + if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1 + class default + STOP 5 + end select + end function source_cart2d_p + +! grid_definition -- +! Initialises the grid +! + subroutine grid_definition_cart2d (obj, sizes, dims) + class(base_pde_object), allocatable :: obj + real, dimension(:) :: sizes + integer, dimension(:) :: dims + allocate( cartesian_2d_object :: obj ) + select type (obj) + type is (cartesian_2d_object) + allocate (obj%c(dims(1), dims(2))) + obj%c = 0.0 + obj%dx = sizes(1)/dims(1) + obj%dy = sizes(2)/dims(2) + class default + STOP 6 + end select + end subroutine grid_definition_cart2d +! print_cart2d -- +! Print the concentration field to the screen +! + subroutine print_cart2d (obj) + class(cartesian_2d_object) :: obj + character(len=20) :: format + write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)' + write( *, format ) obj%c + end subroutine print_cart2d +! initialise_cart2d -- +! Initialise the concentration field using a specific function +! + subroutine initialise_cart2d (obj, funcxy) + class(cartesian_2d_object) :: obj + interface + real function funcxy (coords) + real, dimension(:), intent(in) :: coords + end function funcxy + end interface + integer :: i, j + real, dimension(2) :: x + obj%c = 0.0 + do j = 2,size (obj%c, 2)-1 + x(2) = obj%dy * (j-1) + do i = 2,size (obj%c, 1)-1 + x(1) = obj%dx * (i-1) + obj%c(i,j) = funcxy (x) + enddo + enddo + end subroutine initialise_cart2d +! nabla2_cart2d +! Determine the divergence + function nabla2_cart2d (obj) + class(cartesian_2d_object), intent(in) :: obj + class(base_pde_object), allocatable :: nabla2_cart2d + integer :: m, n + real :: dx, dy + m = size (obj%c, 1) + n = size (obj%c, 2) + dx = obj%dx + dy = obj%dy + allocate (cartesian_2d_object :: nabla2_cart2d) + select type (nabla2_cart2d) + type is (cartesian_2d_object) + allocate (nabla2_cart2d%c(m,n)) + nabla2_cart2d%c = 0.0 + nabla2_cart2d%c(2:m-1,2:n-1) = & + -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) - obj%c(3:m,2:n-1)) / dx**2 & + -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) - obj%c(2:m-1,3:n)) / dy**2 + class default + STOP 7 + end select + end function nabla2_cart2d + function real_times_cart2d (factor, obj) result(newobj) + real, intent(in) :: factor + class(cartesian_2d_object), intent(in) :: obj + class(base_pde_object), allocatable :: newobj + integer :: m, n + m = size (obj%c, 1) + n = size (obj%c, 2) + allocate (cartesian_2d_object :: newobj) + select type (newobj) + type is (cartesian_2d_object) + allocate (newobj%c(m,n)) + newobj%c = factor * obj%c + class default + STOP 8 + end select + end function real_times_cart2d + function obj_plus_cart2d (obj1, obj2) result( newobj ) + class(cartesian_2d_object), intent(in) :: obj1 + class(base_pde_object), intent(in) :: obj2 + class(base_pde_object), allocatable :: newobj + integer :: m, n + m = size (obj1%c, 1) + n = size (obj1%c, 2) + allocate (cartesian_2d_object :: newobj) + select type (newobj) + type is (cartesian_2d_object) + allocate (newobj%c(m,n)) + select type (obj2) + type is (cartesian_2d_object) + newobj%c = obj1%c + obj2%c + class default + STOP 9 + end select + class default + STOP 10 + end select + end function obj_plus_cart2d + subroutine obj_assign_cart2d (obj1, obj2) + class(cartesian_2d_object), intent(inout) :: obj1 + class(base_pde_object), intent(in) :: obj2 + select type (obj2) + type is (cartesian_2d_object) + obj1%c = obj2%c + class default + STOP 11 + end select + end subroutine obj_assign_cart2d +end module cartesian_2d_objects +! define_pde_objects -- +! Module to bring all the PDE object types together +! +module define_pde_objects + use base_pde_objects + use cartesian_2d_objects + implicit none + interface grid_definition + module procedure grid_definition_general + end interface +contains + subroutine grid_definition_general (obj, type, sizes, dims) + class(base_pde_object), allocatable :: obj + character(len=*) :: type + real, dimension(:) :: sizes + integer, dimension(:) :: dims + select case (type) + case ("cartesian 2d") + call grid_definition (obj, sizes, dims) + case default + write(*,*) 'Unknown grid type: ', trim (type) + stop + end select + end subroutine grid_definition_general +end module define_pde_objects +! pde_specific -- +! Module holding the routines specific to the PDE that +! we are solving +! +module pde_specific + implicit none +contains + real function patch (coords) + real, dimension(:), intent(in) :: coords + if (sum ((coords-[50.0,50.0])**2) < 40.0) then + patch = 1.0 + else + patch = 0.0 + endif + end function patch +end module pde_specific +! test_pde_solver -- +! Small test program to demonstrate the usage +! +program test_pde_solver + use define_pde_objects + use pde_specific + implicit none + class(base_pde_object), allocatable :: solution, deriv + integer :: i + real :: time, dtime, diff, chksum(2) + + call simulation1 ! Use proc pointers for source and process define_pde_objects + select type (solution) + type is (cartesian_2d_object) + deallocate (solution%c) + end select + select type (deriv) + type is (cartesian_2d_object) + deallocate (deriv%c) + end select + deallocate (solution, deriv) + + call simulation2 ! Use typebound procedures for source and process + if (chksum(1) .ne. chksum(2)) STOP 12 + if ((chksum(1) - 0.881868720)**2 > 1e-4) STOP 13 +contains + subroutine simulation1 +! +! Create the grid +! + call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16]) + call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16]) +! +! Initialise the concentration field +! + call solution%initialise (patch) +! +! Set the procedure pointers +! + solution%source_p => source_cart2d_p + solution%process_p => process_cart2d_p +! +! Perform the integration - explicit method +! + time = 0.0 + dtime = 0.1 + diff = 5.0e-3 + +! Give the diffusion coefficient correct dimensions. + select type (solution) + type is (cartesian_2d_object) + diff = diff * solution%dx * solution%dy / dtime + end select + +! write(*,*) 'Time: ', time, diff +! call solution%print + do i = 1,100 + deriv = solution%nabla2 () + solution = solution + diff * dtime * deriv + solution%source_p (time) + solution%process_p () +! if ( mod(i, 25) == 0 ) then +! write(*,*)'Time: ', time +! call solution%print +! endif + time = time + dtime + enddo +! write(*,*) 'End result 1: ' +! call solution%print + select type (solution) + type is (cartesian_2d_object) + chksum(1) = sum (solution%c) + end select + end subroutine + subroutine simulation2 +! +! Create the grid +! + call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16]) + call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16]) +! +! Initialise the concentration field +! + call solution%initialise (patch) +! +! Set the procedure pointers +! + solution%source_p => source_cart2d_p + solution%process_p => process_cart2d_p +! +! Perform the integration - explicit method +! + time = 0.0 + dtime = 0.1 + diff = 5.0e-3 + +! Give the diffusion coefficient correct dimensions. + select type (solution) + type is (cartesian_2d_object) + diff = diff * solution%dx * solution%dy / dtime + end select + +! write(*,*) 'Time: ', time, diff +! call solution%print + do i = 1,100 + deriv = solution%nabla2 () + solution = solution + diff * dtime * deriv + solution%source (time) + solution%process () +! if ( mod(i, 25) == 0 ) then +! write(*,*)'Time: ', time +! call solution%print +! endif + time = time + dtime + enddo +! write(*,*) 'End result 2: ' +! call solution%print + select type (solution) + type is (cartesian_2d_object) + chksum(2) = sum (solution%c) + end select + end subroutine +end program test_pde_solver Index: Fortran/gfortran/regression/typebound_override_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_1.f90 @@ -0,0 +1,123 @@ +! { dg-do compile } +! +! PR 49638: [OOP] length parameter is ignored when overriding type bound character functions with constant length. +! +! Original test case contributed by Hans-Werner Boschmann + +module m + + implicit none + + type :: t1 + contains + procedure, nopass :: a => a1 + procedure, nopass :: b => b1 + procedure, nopass :: c => c1 + procedure, nopass :: d => d1 + procedure, nopass :: e => e1 + end type + + type, extends(t1) :: t2 + contains + procedure, nopass :: a => a2 ! { dg-error "Character length mismatch in function result" } + procedure, nopass :: b => b2 ! { dg-error "Rank mismatch in function result" } + procedure, nopass :: c => c2 ! FIXME: dg-warning "Possible character length mismatch" + procedure, nopass :: d => d2 ! valid, check for commutativity (+,*) + procedure, nopass :: e => e2 ! { dg-error "Character length mismatch in function result" } + end type + +contains + + function a1 () + character(len=6) :: a1 + end function + + function a2 () + character(len=7) :: a2 + end function + + function b1 () + integer :: b1 + end function + + function b2 () + integer, dimension(2) :: b2 + end function + + function c1 (x) + integer, intent(in) :: x + character(2*x) :: c1 + end function + + function c2 (x) + integer, intent(in) :: x + character(3*x) :: c2 + end function + + function d1 (y) + integer, intent(in) :: y + character(2*y+1) :: d1 + end function + + function d2 (y) + integer, intent(in) :: y + character(1+y*2) :: d2 + end function + + function e1 (z) + integer, intent(in) :: z + character(3) :: e1 + end function + + function e2 (z) + integer, intent(in) :: z + character(z) :: e2 + end function + +end module m + + + + +module w1 + + implicit none + + integer :: n = 1 + + type :: tt1 + contains + procedure, nopass :: aa => aa1 + end type + +contains + + function aa1 (m) + integer, intent(in) :: m + character(n+m) :: aa1 + end function + +end module w1 + + +module w2 + + use w1, only : tt1 + + implicit none + + integer :: n = 2 + + type, extends(tt1) :: tt2 + contains + procedure, nopass :: aa => aa2 ! FIXME: dg-warning "Possible character length mismatch" + end type + +contains + + function aa2 (m) + integer, intent(in) :: m + character(n+m) :: aa2 + end function + +end module w2 Index: Fortran/gfortran/regression/typebound_override_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 47978: [OOP] Invalid INTENT in overriding TBP not detected +! +! Contributed by Salvatore Filippone + +module foo_mod + type foo + contains + procedure, pass(f) :: bar => base_bar + end type foo +contains + subroutine base_bar(f,j) + class(foo), intent(inout) :: f + integer, intent(in) :: j + end subroutine base_bar +end module foo_mod + +module extfoo_mod + use foo_mod + type, extends(foo) :: extfoo + contains + procedure, pass(f) :: bar => ext_bar ! { dg-error "INTENT mismatch in argument" } + end type extfoo +contains + subroutine ext_bar(f,j) + class(extfoo), intent(inout) :: f + integer, intent(inout) :: j + end subroutine ext_bar +end module extfoo_mod Index: Fortran/gfortran/regression/typebound_override_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_3.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 54134: [OOP] ICE overriding derived type bound function with allocatable character as result +! +! Contributed by + +module dtAs + implicit none + type :: A + contains + procedure, nopass :: name => name_A + end type +contains + function name_A() result( name ) + character(:), allocatable :: name + name = "name_A" + end function +end module + +module dtBs + use dtAs + implicit none + type, extends( A ) :: B + contains + procedure, nopass :: name => name_B + end type +contains + function name_B() result( name ) + character(:), allocatable :: name + name = "name_B" + end function +end module Index: Fortran/gfortran/regression/typebound_override_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_4.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check +! +! Contributed by Salvatore Filippone + +module base_mod + implicit none + type base_type + contains + procedure, pass(map) :: clone => base_clone + end type +contains + subroutine base_clone(map,mapout) + class(base_type) :: map + class(base_type) :: mapout + end subroutine +end module + +module r_mod + use base_mod + implicit none + type, extends(base_type) :: r_type + contains + procedure, pass(map) :: clone => r_clone ! { dg-error "Type mismatch in argument" } + end type +contains + subroutine r_clone(map,mapout) + class(r_type) :: map + class(r_type) :: mapout + end subroutine +end module Index: Fortran/gfortran/regression/typebound_override_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_5.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure +! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check +! +! Contributed by Tobias Burnus + +module base_mod + implicit none + type base_type + integer :: kind + contains + procedure, pass(map) :: clone => base_clone + end type +contains + subroutine base_clone(map,mapout,info) + class(base_type), intent(inout) :: map + class(base_type), intent(inout) :: mapout + integer :: info + end subroutine +end module + +module r_mod + use base_mod + implicit none + type, extends(base_type) :: r_type + real :: dat + contains + procedure, pass(map) :: clone => r_clone ! { dg-error "Type mismatch in argument" } + end type +contains + subroutine r_clone(map,mapout,info) + class(r_type), intent(inout) :: map +!gcc$ attributes no_arg_check :: mapout + integer, intent(inout) :: mapout + integer :: info + end subroutine +end module Index: Fortran/gfortran/regression/typebound_override_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_6.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure +! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check +! +! Contributed by Tobias Burnus + +module base_mod + implicit none + type base_type + integer :: kind + contains + procedure, pass(map) :: clone => base_clone + end type +contains + subroutine base_clone(map,mapout,info) + class(base_type), intent(inout) :: map + class(base_type), intent(inout) :: mapout + integer :: info + end subroutine +end module + +module r_mod + use base_mod + implicit none + type, extends(base_type) :: r_type + real :: dat + contains + procedure, pass(map) :: clone => r_clone ! { dg-error "Rank mismatch in argument" } + end type +contains + subroutine r_clone(map,mapout,info) + class(r_type), intent(inout) :: map + class(base_type), intent(inout) :: mapout(..) + integer :: info + end subroutine +end module Index: Fortran/gfortran/regression/typebound_override_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_override_7.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure +! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check +! +! Contributed by Tobias Burnus + +module base_mod + implicit none + type base_type + integer :: kind + contains + procedure, pass(map) :: clone => base_clone + end type +contains + subroutine base_clone(map,mapout,info) + class(base_type), intent(inout) :: map + class(base_type), intent(inout) :: mapout + integer :: info + end subroutine +end module + +module r_mod + use base_mod + implicit none + type, extends(base_type) :: r_type + real :: dat + contains + procedure, pass(map) :: clone => r_clone ! { dg-error "Type mismatch in argument" } + end type +contains + subroutine r_clone(map,mapout,info) + class(r_type), intent(inout) :: map + type(*), intent(inout) :: mapout + integer :: info + end subroutine +end module Index: Fortran/gfortran/regression/typebound_proc_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_1.f08 @@ -0,0 +1,67 @@ +! { dg-do compile } + +! Type-bound procedures +! Test that the basic syntax for specific bindings is parsed and resolved. + +MODULE othermod + IMPLICIT NONE + +CONTAINS + + SUBROUTINE othersub () + IMPLICIT NONE + END SUBROUTINE othersub + +END MODULE othermod + +MODULE testmod + USE othermod + IMPLICIT NONE + + TYPE t1 + ! Might be empty + CONTAINS + PROCEDURE proc1 + PROCEDURE, PASS(me) :: p2 => proc2 + END TYPE t1 + + TYPE t2 + INTEGER :: x + CONTAINS + PRIVATE + PROCEDURE, NOPASS, PRIVATE :: othersub + PROCEDURE,NON_OVERRIDABLE,PUBLIC,PASS :: proc3 + END TYPE t2 + + TYPE t3 + CONTAINS + ! This might be empty for Fortran 2008 + END TYPE t3 + + TYPE t4 + CONTAINS + PRIVATE + ! Empty, too + END TYPE t4 + +CONTAINS + + SUBROUTINE proc1 (me) + IMPLICIT NONE + CLASS(t1) :: me + END SUBROUTINE proc1 + + REAL FUNCTION proc2 (x, me) + IMPLICIT NONE + REAL :: x + CLASS(t1) :: me + proc2 = x / 2 + END FUNCTION proc2 + + INTEGER FUNCTION proc3 (me) + IMPLICIT NONE + CLASS(t2) :: me + proc3 = 42 + END FUNCTION proc3 + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_10.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_10.f03 @@ -0,0 +1,41 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for resolution errors with DEFERRED, namely checks about invalid +! overriding and taking into account inherited DEFERRED bindings. +! Also check that DEFERRED attribute is saved to module correctly. + +MODULE m1 + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: def + PROCEDURE, NOPASS :: nodef => realproc + END TYPE abstract_type + +CONTAINS + + SUBROUTINE realproc () + END SUBROUTINE realproc + +END MODULE m1 + +MODULE m2 + USE m1 + IMPLICIT NONE + + TYPE, ABSTRACT, EXTENDS(abstract_type) :: sub_type1 + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: nodef ! { dg-error "must not be DEFERRED" } + END TYPE sub_type1 + + TYPE, EXTENDS(abstract_type) :: sub_type2 ! { dg-error "must be ABSTRACT" } + END TYPE sub_type2 + +END MODULE m2 Index: Fortran/gfortran/regression/typebound_proc_11.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_11.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } + +! Type-bound procedures +! Test that legal usage of DEFERRED is accepted. + +MODULE testmod + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: p1 + PROCEDURE(realproc), DEFERRED, NOPASS :: p2 + END TYPE abstract_type + + TYPE, EXTENDS(abstract_type) :: sub_type + CONTAINS + PROCEDURE, NOPASS :: p1 => realproc + PROCEDURE, NOPASS :: p2 => realproc + END TYPE sub_type + +CONTAINS + + SUBROUTINE realproc () + END SUBROUTINE realproc + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_12.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Test the fix for PR41258, where an ICE was caused by a search +! for a typebound procedure to resolve d%c%e +! +! Contributed by Joost VandeVondele +! + TYPE a + TYPE(b), DIMENSION(:), POINTER :: c ! { dg-error "has not been declared" } + END TYPE + TYPE(a), POINTER :: d + CALL X(d%c%e) ! { dg-error "before it is defined" } +end Index: Fortran/gfortran/regression/typebound_proc_13.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_13.f03 @@ -0,0 +1,46 @@ +! { dg-do compile } + +! PR fortran/41177 +! Test for additional errors with type-bound procedure bindings. +! Namely that non-scalar base objects are rejected for TBP calls which are +! NOPASS, and that passed-object dummy arguments must be scalar, non-POINTER +! and non-ALLOCATABLE. + +MODULE m + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, NOPASS :: myproc + END TYPE t + + TYPE t2 + CONTAINS + PROCEDURE, PASS :: nonscalar ! { dg-error "must be scalar" } + PROCEDURE, PASS :: is_pointer ! { dg-error "must not be POINTER" } + PROCEDURE, PASS :: is_allocatable ! { dg-error "must not be ALLOCATABLE" } + END TYPE t2 + +CONTAINS + + SUBROUTINE myproc () + END SUBROUTINE myproc + + SUBROUTINE nonscalar (me) + CLASS(t2), INTENT(IN) :: me(:) + END SUBROUTINE nonscalar + + SUBROUTINE is_pointer (me) + CLASS(t2), POINTER, INTENT(IN) :: me + END SUBROUTINE is_pointer + + SUBROUTINE is_allocatable (me) + CLASS(t2), ALLOCATABLE, INTENT(IN) :: me + END SUBROUTINE is_allocatable + + SUBROUTINE test () + TYPE(t) :: arr(2) + CALL arr%myproc () ! { dg-error "must be scalar" } + END SUBROUTINE test + +END MODULE m Index: Fortran/gfortran/regression/typebound_proc_14.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_14.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE +! +! Contributed by Janus Weil + +module m + +implicit none + +type :: t +contains + procedure :: foo, bar, baz +end type + +contains + + subroutine foo (this) + class(t) :: this + end subroutine + + real function bar (this) + class(t) :: this + end function + + subroutine baz (this, par) + class(t) :: this + integer :: par + end subroutine + +end Index: Fortran/gfortran/regression/typebound_proc_15.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_15.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE +! +! Contributed by Janus Weil + +module m + +implicit none + +type :: t +contains + procedure :: foo + procedure :: bar, baz ! { dg-error "PROCEDURE list" } +end type + +contains + + subroutine foo (this) + class(t) :: this + end subroutine + + subroutine bar (this) + class(t) :: this + end subroutine + + subroutine baz (this) + class(t) :: this + end subroutine + +end Index: Fortran/gfortran/regression/typebound_proc_16.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_16.f03 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR 44549: [OOP][F2008] Type-bound procedure: bogus error from list after PROCEDURE +! +! Contributed by Dominique d'Humieres + +MODULE rational_numbers + IMPLICIT NONE + PRIVATE + TYPE,PUBLIC :: rational + PRIVATE + INTEGER n,d + + CONTAINS + ! ordinary type-bound procedure + PROCEDURE :: real => rat_to_real + ! specific type-bound procedures for generic support + PROCEDURE,PRIVATE :: rat_asgn_i, rat_plus_rat, rat_plus_i + PROCEDURE,PRIVATE,PASS(b) :: i_plus_rat + ! generic type-bound procedures + GENERIC :: ASSIGNMENT(=) => rat_asgn_i + GENERIC :: OPERATOR(+) => rat_plus_rat, rat_plus_i, i_plus_rat + END TYPE + CONTAINS + ELEMENTAL REAL FUNCTION rat_to_real(this) RESULT(r) + CLASS(rational),INTENT(IN) :: this + r = REAL(this%n)/this%d + END FUNCTION + + impure ELEMENTAL SUBROUTINE rat_asgn_i(a,b) + CLASS(rational),INTENT(OUT) :: a + INTEGER,INTENT(IN) :: b + a%n = b + a%d = 1 + END SUBROUTINE + + ELEMENTAL TYPE(rational) FUNCTION rat_plus_i(a,b) RESULT(r) + CLASS(rational),INTENT(IN) :: a + INTEGER,INTENT(IN) :: b + r%n = a%n + b*a%d + r%d = a%d + END FUNCTION + + ELEMENTAL TYPE(rational) FUNCTION i_plus_rat(a,b) RESULT(r) + INTEGER,INTENT(IN) :: a + CLASS(rational),INTENT(IN) :: b + r%n = b%n + a*b%d + r%d = b%d + END FUNCTION + + ELEMENTAL TYPE(rational) FUNCTION rat_plus_rat(a,b) RESULT(r) + CLASS(rational),INTENT(IN) :: a,b + r%n = a%n*b%d + b%n*a%d + r%d = a%d*b%d + END FUNCTION +END Index: Fortran/gfortran/regression/typebound_proc_17.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_17.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 44962: [OOP] ICE with specification expression SIZE() +! +! Contributed by Satish.BD + + +module array + +type :: t_array + real, dimension(10) :: coeff +contains + procedure :: get_coeff +end type t_array + +contains + +function get_coeff(self) result(coeff) + class(t_array), intent(in) :: self + real, dimension(size(self%coeff)) :: coeff !! The SIZE here carashes !! +end function get_coeff + +end module array Index: Fortran/gfortran/regression/typebound_proc_18.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_18.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 45456: [4.6 Regression] [OOP] Bogus pointer initialization error on pointer-valued TBP +! +! Contributed by Andrew Benson + +module Merger_Trees + private + public :: mergerTree + + type mergerTree + contains + procedure :: getNode => Tree_Node_Get + end type mergerTree + +contains + + function Tree_Node_Get(thisTree,nodeIndex) result(foundNode) + implicit none + class(mergerTree), intent(inout) :: thisTree + integer, intent(in) :: nodeIndex + integer, pointer :: foundNode + + return + end function Tree_Node_Get + +end module Merger_Trees Index: Fortran/gfortran/regression/typebound_proc_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_19.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! +! PR fortran/47399 +! +! Contributed by Wolfgang Kilian. +! + +module mytypes + implicit none + private + public :: mytype, get_i + + integer, save :: i_priv = 13 + type :: mytype + integer :: dummy + contains + procedure, nopass :: i => get_i + end type mytype + contains + pure function get_i () result (i) + integer :: i + i = i_priv + end function get_i +end module mytypes + +subroutine test() + use mytypes + implicit none + + type(mytype) :: a + type(mytype), parameter :: a_const = mytype (0) + integer, dimension (get_i()) :: x ! #1 + integer, dimension (a%i()) :: y ! #2 + integer, dimension (a_const%i()) :: z ! #3 + + if (size (x) /= 13 .or. size(y) /= 13 .or. size(z) /= 13) STOP 1 +! print *, size (x), size(y), size(z) +end subroutine test + +call test() +end Index: Fortran/gfortran/regression/typebound_proc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_2.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Type-bound procedures +! Test that F95 does not allow type-bound procedures + +MODULE testmod + IMPLICIT NONE + + TYPE t + INTEGER :: x + CONTAINS ! { dg-error "Fortran 2003: CONTAINS block in derived type definition" } + PROCEDURE proc1 ! { dg-error "Fortran 2003: PROCEDURE statement" } + PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003: PROCEDURE statement" } + END TYPE t ! { dg-error "Fortran 2008: Derived type definition at .1. with empty CONTAINS section" } + +CONTAINS + + SUBROUTINE proc1 (me) ! { dg-error "no IMPLICIT type" } + IMPLICIT NONE + TYPE(t1) :: me ! { dg-error "being used before it is defined" } + END SUBROUTINE proc1 + + REAL FUNCTION proc2 (me, x) ! { dg-error "no IMPLICIT type" } + IMPLICIT NONE + TYPE(t1) :: me ! { dg-error "being used before it is defined" } + REAL :: x + proc2 = x / 2 + END FUNCTION proc2 + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_20.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR fortran/47455 +! +! Based on an example by Thomas Henlich +! + +module class_t + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type :: t + type(tx), pointer :: x + type(tx) :: y + contains + procedure :: calc + procedure :: find_x + procedure :: find_y + end type t +contains + subroutine calc(this) + class(t), target :: this + type(tx), target :: that + that%i = [1,2] + this%x => this%find_x(that, .true.) + if (associated (this%x)) STOP 1 + this%x => this%find_x(that, .false.) + if(any (this%x%i /= [5, 7])) STOP 2 + if (.not.associated (this%x,that)) STOP 3 + allocate(this%x) + if (associated (this%x,that)) STOP 4 + if (allocated(this%x%i)) STOP 5 + this%x = this%find_x(that, .false.) + that%i = [3,4] + if(any (this%x%i /= [5, 7])) STOP 6 ! FAILS + + if (allocated (this%y%i)) STOP 7 + this%y = this%find_y() ! FAILS + if (.not.allocated (this%y%i)) STOP 8 + if(any (this%y%i /= [6, 8])) STOP 9 + end subroutine calc + function find_x(this, that, l_null) + class(t), intent(in) :: this + type(tx), target :: that + type(tx), pointer :: find_x + logical :: l_null + if (l_null) then + find_x => null() + else + find_x => that + that%i = [5, 7] + end if + end function find_x + function find_y(this) result(res) + class(t), intent(in) :: this + type(tx), allocatable :: res + allocate(res) + res%i = [6, 8] + end function find_y +end module class_t + +use class_t +type(t) :: x +call x%calc() +end Index: Fortran/gfortran/regression/typebound_proc_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_21.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/47455 +! +module class_t + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type :: t + type(tx), pointer :: x + contains + procedure :: calc + procedure :: find_x + end type t +contains + subroutine calc(this) + class(t), target :: this + this%x = this%find_x() + end subroutine calc + function find_x(this) + class(t), intent(in) :: this + type(tx), pointer :: find_x + find_x => null() + end function find_x +end module class_t Index: Fortran/gfortran/regression/typebound_proc_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_22.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR fortran/48810 +! +! Contributed by Andrew Baldwin +! + module qtest + type foobar + integer :: x + contains + private + procedure :: gimmex + generic, public :: getx => gimmex + end type foobar + contains + function gimmex(foo) + class (foobar) :: foo + integer :: gimmex + gimmex = foo%x + end function gimmex + end module qtest + + module qtestPriv + type foobarPriv + integer :: x + contains + private + procedure :: gimmexPriv + generic, private :: getxPriv => gimmexPriv + end type foobarPriv + contains + function gimmexPriv(foo) + class (foobarPriv) :: foo + integer :: gimmex + gimmex = foo%x + end function gimmexPriv + end module qtestPriv + + program quicktest + use qtest + use qtestPriv + type (foobar) :: foo + type (foobarPriv) :: fooPriv + integer :: bar + bar = foo%getx() ! OK + bar = fooPriv%getxPriv() ! { dg-error " is PRIVATE " } + end program quicktest Index: Fortran/gfortran/regression/typebound_proc_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_23.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR 49562: [4.6/4.7 Regression] [OOP] assigning value to type-bound function +! +! Contributed by Hans-Werner Boschmann + +module ice + type::ice_type + contains + procedure::ice_func + end type + integer, target :: it = 0 +contains + function ice_func(this) + integer, pointer :: ice_func + class(ice_type)::this + ice_func => it + end function ice_func + subroutine ice_sub(a) + class(ice_type)::a + a%ice_func() = 1 + end subroutine ice_sub +end module + +use ice +type(ice_type) :: t +if (it/=0) STOP 1 +call ice_sub(t) +if (it/=1) STOP 2 +end Index: Fortran/gfortran/regression/typebound_proc_24.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_24.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 49112: [4.6/4.7 Regression] [OOP] Missing type-bound procedure, "duplicate save" warnings and internal compiler error +! +! Contributed by John + +module datetime_mod + + implicit none + + type :: DateTime + integer :: year, month, day + contains + procedure :: getFormattedString + end type + + type(DateTime) :: ISO_REFERENCE_DATE = DateTime(1875, 5, 20) + +contains + + character function getFormattedString(dt) + class(DateTime) :: dt + end function + + subroutine test + type(DateTime) :: dt + print *,dt%getFormattedString() + end subroutine + +end module Index: Fortran/gfortran/regression/typebound_proc_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_25.f90 @@ -0,0 +1,108 @@ +! { dg-do compile } +! +! PR fortran/51995 +! +! Contributed by jilfa12@yahoo.com +! + +MODULE factory_pattern + + TYPE CFactory + PRIVATE + CHARACTER(len=20) :: factory_type !! Descriptive name for database + CLASS(Connection), POINTER :: connection_type !! Which type of database ? + CONTAINS !! Note 'class' not 'type' ! + PROCEDURE :: init !! Constructor + PROCEDURE :: create_connection !! Connect to database + PROCEDURE :: finalize !! Destructor + END TYPE CFactory + + TYPE, ABSTRACT :: Connection + CONTAINS + PROCEDURE(generic_desc), DEFERRED, PASS(self) :: description + END TYPE Connection + + ABSTRACT INTERFACE + SUBROUTINE generic_desc(self) + IMPORT :: Connection + CLASS(Connection), INTENT(in) :: self + END SUBROUTINE generic_desc + END INTERFACE + + !! An Oracle connection + TYPE, EXTENDS(Connection) :: OracleConnection + CONTAINS + PROCEDURE, PASS(self) :: description => oracle_desc + END TYPE OracleConnection + + !! A MySQL connection + TYPE, EXTENDS(Connection) :: MySQLConnection + CONTAINS + PROCEDURE, PASS(self) :: description => mysql_desc + END TYPE MySQLConnection + +CONTAINS + + SUBROUTINE init(self, string) + CLASS(CFactory), INTENT(inout) :: self + CHARACTER(len=*), INTENT(in) :: string + self%factory_type = TRIM(string) + self%connection_type => NULL() !! pointer is nullified + END SUBROUTINE init + + SUBROUTINE finalize(self) + CLASS(CFactory), INTENT(inout) :: self + DEALLOCATE(self%connection_type) !! Free the memory + NULLIFY(self%connection_type) + END SUBROUTINE finalize + + FUNCTION create_connection(self) RESULT(ptr) + CLASS(CFactory) :: self + CLASS(Connection), POINTER :: ptr + + IF(self%factory_type == "Oracle") THEN + IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type) + ALLOCATE(OracleConnection :: self%connection_type) + ptr => self%connection_type + ELSEIF(self%factory_type == "MySQL") THEN + IF(ASSOCIATED(self%connection_type)) DEALLOCATE(self%connection_type) + ALLOCATE(MySQLConnection :: self%connection_type) + ptr => self%connection_type + END IF + + END FUNCTION create_connection + + SUBROUTINE oracle_desc(self) + CLASS(OracleConnection), INTENT(in) :: self + WRITE(*,'(A)') "You are now connected with Oracle" + END SUBROUTINE oracle_desc + + SUBROUTINE mysql_desc(self) + CLASS(MySQLConnection), INTENT(in) :: self + WRITE(*,'(A)') "You are now connected with MySQL" + END SUBROUTINE mysql_desc +end module + + + PROGRAM main + USE factory_pattern + + IMPLICIT NONE + + TYPE(CFactory) :: factory + CLASS(Connection), POINTER :: db_connect => NULL() + + CALL factory%init("Oracle") + db_connect => factory%create_connection() !! Create Oracle DB + CALL db_connect%description() + + !! The same factory can be used to create different connections + CALL factory%init("MySQL") !! Create MySQL DB + + !! 'connect' is a 'class' pointer. So can be used for either Oracle or MySQL + db_connect => factory%create_connection() + CALL db_connect%description() + + CALL factory%finalize() ! Destroy the object + + END PROGRAM main Index: Fortran/gfortran/regression/typebound_proc_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_26.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 54147: [F03] Interface checks for PPCs & deferred TBPs +! +! Contributed by Janus Weil + + interface gen + procedure gen + end interface + + type, abstract :: t1 + contains + procedure(gen),deferred,nopass :: p1 + procedure(gen2),deferred,nopass :: p2 ! { dg-error "may not be generic" } + end type + + type, abstract :: t2 + contains + procedure(sf),deferred,nopass :: p3 ! { dg-error "may not be a statement function" } + end type + + type, abstract :: t3 + contains + procedure(char),deferred,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/typebound_proc_27.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_27.f03 @@ -0,0 +1,91 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/47586 +! Missing deep copy for data pointer returning functions when the type +! has allocatable components +! +! Original testcase by Thomas Henlich +! Reduced by Tobias Burnus +! + +module m + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type proc_t + procedure(find_x), nopass, pointer :: ppc => null() + contains + procedure, nopass :: tbp => find_x + end type proc_t + +contains + + function find_x(that) + type(tx), target :: that + type(tx), pointer :: find_x + find_x => that + end function find_x + +end module m + +program prog + + use m + + block ! Start new scoping unit as PROGRAM implies SAVE + type(tx) :: this + type(tx), target :: that + type(tx), pointer :: p + + type(proc_t) :: tab + + allocate(that%i(2)) + that%i = [3, 7] + p => that + this = that ! (1) direct assignment: works (deep copy) + that%i = [2, -5] + !print *,this%i + if(any (this%i /= [3, 7])) STOP 1 + this = p ! (2) using a pointer works as well + that%i = [10, 1] + !print *,this%i + if(any (this%i /= [2, -5])) STOP 2 + this = find_x(that) ! (3) pointer function: used to fail (deep copy missing) + that%i = [4, 6] + !print *,this%i + if(any (this%i /= [10, 1])) STOP 3 + this = tab%tbp(that) ! other case: typebound procedure + that%i = [8, 9] + !print *,this%i + if(any (this%i /= [4, 6])) STOP 4 + tab%ppc => find_x + this = tab%ppc(that) ! other case: procedure pointer component + that%i = [-1, 2] + !print *,this%i + if(any (this%i /= [8, 9])) STOP 5 + + end block +end program prog + +! +! We add another check for deep copy by looking at the dump. +! We use realloc on assignment here: if we do a deep copy for the assignment +! to `this', we have a reallocation of `this%i'. +! Thus, the total number of malloc calls should be the number of assignment to +! `that%i' + the number of assignments to `this' + the number of allocate +! statements. +! It is assumed that if the number of allocate is right, the number of +! deep copies is right too. +! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } } + +! +! Realloc are only used for assignments to `that%i'. Don't know why. +! { dg-final { scan-tree-dump-times "__builtin_realloc" 6 "original" } } +! + +! No leak: Only assignments to `this' use malloc. Assignments to `that%i' +! take the realloc path after the first assignment, so don't count as a malloc. +! { dg-final { scan-tree-dump-times "__builtin_free" 10 "original" } } +! + Index: Fortran/gfortran/regression/typebound_proc_28.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_28.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 56266: [OOP] ICE on invalid in gfc_match_varspec +! +! Contributed by Andrew Benson + +module t + + implicit none + + type nc + contains + procedure :: encM => em + end type nc + +contains + + double precision function em(self) + class(nc) :: self + em=0. + end function + + double precision function cem(c) + type(nc) :: c + cem=c(i)%encM() ! { dg-error "Unclassifiable statement" } + end function + +end module Index: Fortran/gfortran/regression/typebound_proc_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_29.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 55959: [OOP] ICE in in gfc_simplify_expr, at fortran/expr.c:1920 +! +! Contributed by Tilo Schwarz + +module pdfs + type :: pdf + contains + procedure, nopass :: getx + end type + +contains + + real function getx() + end function + +end module + +program abstract + use pdfs + type(pdf) pp + print pp%getx() ! { dg-error "must be of type default-kind CHARACTER or of INTEGER" } +end program Index: Fortran/gfortran/regression/typebound_proc_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_3.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! Type-bound procedures +! Test that F2003 does not allow empty CONTAINS sections. + +MODULE testmod + IMPLICIT NONE + + TYPE t + INTEGER :: x + CONTAINS + END TYPE t ! { dg-error "Fortran 2008" } + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_30.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR 59143: [OOP] Bogus warning with array-valued type-bound procedure +! +! Contributed by Jürgen Reuter + +module phs_single + + type :: phs_single_t + contains + procedure, nopass :: d1, d2 + end type + +contains + + subroutine evaluate (phs) + class(phs_single_t) :: phs + call func1 (phs%d1 ()) + call func1 (phs%d2 (2)) + end subroutine + + subroutine func1 (p) + real :: p(2) + end subroutine + + function d1 () + real :: d1(2) + d1 = 1. + end function + + function d2 (n) + real :: d2(n) + d2 = 1. + end function + +end module Index: Fortran/gfortran/regression/typebound_proc_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_31.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 59450: [OOP] ICE for type-bound-procedure expression in module procedure interface +! +! Contributed by + +module classes + + implicit none + + type :: base_class + contains + procedure, nopass :: get_num + end type + +contains + + pure integer function get_num() + end function + + function get_array( this ) result(array) + class(base_class), intent(in) :: this + integer, dimension( this%get_num() ) :: array + end function + +end module Index: Fortran/gfortran/regression/typebound_proc_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_32.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 59547: [OOP] Problem with using tbp specification function in multiple class procedures +! +! Contributed by + +module classes + + implicit none + + type :: base_class + contains + procedure, nopass :: get_num + procedure :: get_array, get_array2 + end type + +contains + + pure integer function get_num() + get_num = 2 + end function + + function get_array( this ) result(array) + class(base_class), intent(in) :: this + integer, dimension( this%get_num() ) :: array + end function + + function get_array2( this ) result(array) + class(base_class), intent(in) :: this + integer, dimension( this%get_num(), this%get_num() ) :: array + end function + +end module Index: Fortran/gfortran/regression/typebound_proc_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_33.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 60232: [OOP] The rank of the element in the structure constructor does not match that of the component +! +! Contributed by Antony Lewis + +module ObjectLists + implicit none + + Type TObjectList + contains + procedure :: ArrayItem + end Type + +contains + + function ArrayItem(L) result(P) + Class(TObjectList) :: L + Class(TObjectList), pointer :: P(:) + end function + +end module + + + use ObjectLists + implicit none + + Type, extends(TObjectList):: TSampleList + end Type + +contains + + subroutine TSampleList_ConfidVal(L) + Class(TSampleList) :: L + end subroutine + +end Index: Fortran/gfortran/regression/typebound_proc_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_34.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 60952: [F03] Problem using "end" as a type bound procedure and contained procedures +! +! Contributed by tlcclt + +module A_mod + implicit none + + type A + contains + procedure, nopass :: end + end type + +contains + + subroutine swap + contains + subroutine subSwap + end subroutine + end subroutine + + integer function end() + end function + +end module Index: Fortran/gfortran/regression/typebound_proc_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_35.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! +! PR 78443: [OOP] Incorrect behavior with non_overridable keyword +! +! Contributed by federico + +module types + implicit none + + + ! Abstract parent class and its child type + type, abstract :: P1 + contains + procedure :: test => test1 + procedure (square_interface), deferred :: square + endtype + + ! Deferred procedure interface + abstract interface + function square_interface( this, x ) result( y ) + import P1 + class(P1) :: this + real :: x, y + end function square_interface + end interface + + type, extends(P1) :: C1 + contains + procedure, non_overridable :: square => C1_square + endtype + + ! Non-abstract parent class and its child type + type :: P2 + contains + procedure :: test => test2 + procedure :: square => P2_square + endtype + + type, extends(P2) :: C2 + contains + procedure, non_overridable :: square => C2_square + endtype + +contains + + real function test1( this, x ) + class(P1) :: this + real :: x + test1 = this % square( x ) + end function + + real function test2( this, x ) + class(P2) :: this + real :: x + test2 = this % square( x ) + end function + + function P2_square( this, x ) result( y ) + class(P2) :: this + real :: x, y + y = -100. ! dummy + end function + + function C1_square( this, x ) result( y ) + class(C1) :: this + real :: x, y + y = x**2 + end function + + function C2_square( this, x ) result( y ) + class(C2) :: this + real :: x, y + y = x**2 + end function + +end module + +program main + use types + implicit none + type(P2) :: t1 + type(C2) :: t2 + type(C1) :: t3 + + if ( t1 % test( 2. ) /= -100.) STOP 1 + if ( t2 % test( 2. ) /= 4.) STOP 2 + if ( t3 % test( 2. ) /= 4.) STOP 3 +end program Index: Fortran/gfortran/regression/typebound_proc_36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_36.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! Test the fix for PR82312.f90 +! +! Posted on Stack Overflow: +! https://stackoverflow.com/questions/46369744 +! /gfortran-associates-wrong-type-bound-procedure/46388339#46388339 +! +module minimalisticcase + implicit none + + type, public :: DataStructure + integer :: i + contains + procedure, pass :: init => init_data_structure + procedure, pass :: a => beginning_of_alphabet + end type + + type, public :: DataLogger + type(DataStructure), pointer :: data_structure + contains + procedure, pass :: init => init_data_logger + procedure, pass :: do_something => do_something + end type + + integer :: ctr = 0 + +contains + subroutine init_data_structure(self) + implicit none + class(DataStructure), intent(inout) :: self + write(*,*) 'init_data_structure' + ctr = ctr + 1 + end subroutine + + subroutine beginning_of_alphabet(self) + implicit none + class(DataStructure), intent(inout) :: self + + write(*,*) 'beginning_of_alphabet' + ctr = ctr + 10 + end subroutine + + subroutine init_data_logger(self, data_structure) + implicit none + class(DataLogger), intent(inout) :: self + class(DataStructure), target :: data_structure + write(*,*) 'init_data_logger' + ctr = ctr + 100 + + self%data_structure => data_structure ! Invalid change of 'self' vptr + call self%do_something() + end subroutine + + subroutine do_something(self) + implicit none + class(DataLogger), intent(inout) :: self + + write(*,*) 'do_something' + ctr = ctr + 1000 + + end subroutine +end module + +program main + use minimalisticcase + implicit none + + type(DataStructure) :: data_structure + type(DataLogger) :: data_logger + + call data_structure%init() + call data_structure%a() + call data_logger%init(data_structure) + + if (ctr .ne. 1111) STOP 1 +end program Index: Fortran/gfortran/regression/typebound_proc_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_4.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for errors in specific bindings, during parsing (not resolution). + +MODULE testmod + IMPLICIT NONE + + TYPE t + REAL :: a + CONTAINS + PROCEDURE p0 ! { dg-error "no IMPLICIT|module procedure" } + PRIVATE ! { dg-error "must precede" } + PROCEDURE p1 => proc1 ! { dg-error "::" } + PROCEDURE :: ! { dg-error "Expected binding name" } + PROCEDURE ! { dg-error "Expected binding name" } + PROCEDURE ? ! { dg-error "Expected binding name" } + PROCEDURE :: p2 => ! { dg-error "Expected binding target" } + PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" } + PROCEDURE p4, ! { dg-error "Expected binding name" } + PROCEDURE :: p5 => proc2, ! { dg-error "Expected binding name" } + PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" } + PROCEDURE, PASS p6 ! { dg-error "::" } + PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" } + PROCEDURE PASS :: ! { dg-error "Syntax error" } + PROCEDURE, PASS (x ! { dg-error "Expected" } + PROCEDURE, PASS () ! { dg-error "Expected" } + PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" } + PROCEDURE, PASS, NON_OVERRIDABLE, PASS(x) ! { dg-error "illegal PASS" } + PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" } + PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" } + PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" } + END TYPE t + +CONTAINS + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_5.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_5.f03 @@ -0,0 +1,117 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for errors in specific bindings, during resolution. + +MODULE othermod + IMPLICIT NONE +CONTAINS + + REAL FUNCTION proc_noarg () + IMPLICIT NONE + END FUNCTION proc_noarg + +END MODULE othermod + +MODULE testmod + USE othermod + IMPLICIT NONE + + INTEGER :: noproc + + PROCEDURE() :: proc_nointf + + INTERFACE + SUBROUTINE proc_intf () + END SUBROUTINE proc_intf + END INTERFACE + + ABSTRACT INTERFACE + SUBROUTINE proc_abstract_intf () + END SUBROUTINE proc_abstract_intf + END INTERFACE + + TYPE supert + CONTAINS + PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg + PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_sub_noarg + END TYPE supert + + TYPE, EXTENDS(supert) :: t + CONTAINS + + ! Bindings that should succeed + PROCEDURE, NOPASS :: p0 => proc_noarg + PROCEDURE, PASS :: p1 => proc_arg_first + PROCEDURE proc_arg_first + PROCEDURE, PASS(me) :: p2 => proc_arg_middle + PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last + PROCEDURE, NOPASS :: p4 => proc_nome + PROCEDURE, NOPASS :: p5 => proc_intf + PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg + + ! Bindings that should not succeed + PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|module procedure" } + PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" } + PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" } + PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" } + PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" } + PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" } + PROCEDURE :: e6 => noproc ! { dg-error "module procedure" } + PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" } + PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" } + PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" } + + END TYPE t + +CONTAINS + + SUBROUTINE proc_arg_first (me, x) + IMPLICIT NONE + CLASS(t) :: me + REAL :: x + END SUBROUTINE proc_arg_first + + INTEGER FUNCTION proc_arg_middle (x, me, y) + IMPLICIT NONE + REAL :: x, y + CLASS(t) :: me + END FUNCTION proc_arg_middle + + SUBROUTINE proc_arg_last (x, me) + IMPLICIT NONE + CLASS(t) :: me + REAL :: x + END SUBROUTINE proc_arg_last + + SUBROUTINE proc_nome (arg, x, y) + IMPLICIT NONE + TYPE(t) :: arg + REAL :: x, y + END SUBROUTINE proc_nome + + SUBROUTINE proc_mewrong (me, x) + IMPLICIT NONE + REAL :: x + INTEGER :: me + END SUBROUTINE proc_mewrong + + SUBROUTINE proc_sub_noarg () + END SUBROUTINE proc_sub_noarg + +END MODULE testmod + +PROGRAM main + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, NOPASS :: proc_no_module ! { dg-error "module procedure" } + END TYPE t + +CONTAINS + + SUBROUTINE proc_no_module () + END SUBROUTINE proc_no_module + +END PROGRAM main Index: Fortran/gfortran/regression/typebound_proc_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_6.f03 @@ -0,0 +1,178 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for the check if overriding methods "match" the overridden ones by their +! characteristics. + +MODULE testmod + IMPLICIT NONE + + TYPE supert + CONTAINS + + ! For checking the PURE/ELEMENTAL matching. + PROCEDURE, NOPASS :: pure1 => proc_pure + PROCEDURE, NOPASS :: pure2 => proc_pure + PROCEDURE, NOPASS :: nonpure => proc_sub + PROCEDURE, NOPASS :: elemental1 => proc_elemental + PROCEDURE, NOPASS :: elemental2 => proc_elemental + PROCEDURE, NOPASS :: nonelem1 => proc_nonelem + PROCEDURE, NOPASS :: nonelem2 => proc_nonelem + + ! Same number of arguments! + PROCEDURE, NOPASS :: three_args_1 => proc_threearg + PROCEDURE, NOPASS :: three_args_2 => proc_threearg + + ! For SUBROUTINE/FUNCTION/result checking. + PROCEDURE, NOPASS :: subroutine1 => proc_sub + PROCEDURE, NOPASS :: subroutine2 => proc_sub + PROCEDURE, NOPASS :: intfunction1 => proc_intfunc + PROCEDURE, NOPASS :: intfunction2 => proc_intfunc + PROCEDURE, NOPASS :: intfunction3 => proc_intfunc + + ! For access-based checks. + PROCEDURE, NOPASS, PRIVATE :: priv => proc_sub + PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub + PROCEDURE, NOPASS, PUBLIC :: publ2 => proc_sub + + ! For passed-object dummy argument checks. + PROCEDURE, NOPASS :: nopass1 => proc_stme1 + PROCEDURE, NOPASS :: nopass2 => proc_stme1 + PROCEDURE, PASS :: pass1 => proc_stme1 + PROCEDURE, PASS(me) :: pass2 => proc_stme1 + PROCEDURE, PASS(me1) :: pass3 => proc_stmeme + + ! For corresponding dummy arguments. + PROCEDURE, PASS :: corresp1 => proc_stmeint + PROCEDURE, PASS :: corresp2 => proc_stmeint + PROCEDURE, PASS :: corresp3 => proc_stmeint + + END TYPE supert + + ! Checking for NON_OVERRIDABLE is in typebound_proc_5.f03. + + TYPE, EXTENDS(supert) :: t + CONTAINS + + ! For checking the PURE/ELEMENTAL matching. + PROCEDURE, NOPASS :: pure1 => proc_pure ! Ok, both pure. + PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" } + PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure. + PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental. + PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be" } + PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental. + PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" } + + ! Same number of arguments! + PROCEDURE, NOPASS :: three_args_1 => proc_threearg ! Ok. + PROCEDURE, NOPASS :: three_args_2 => proc_twoarg ! { dg-error "same number of formal arguments" } + + ! For SUBROUTINE/FUNCTION/result checking. + PROCEDURE, NOPASS :: subroutine1 => proc_sub ! Ok, both subroutines. + PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" } + PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions. + PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" } + PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "Type mismatch in function result" } + + ! For access-based checks. + PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility. + PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub ! Ok, both PUBLIC. + PROCEDURE, NOPASS, PRIVATE :: publ2 => proc_sub ! { dg-error "must not be PRIVATE" } + + ! For passed-object dummy argument checks. + PROCEDURE, NOPASS :: nopass1 => proc_stme1 ! Ok, both NOPASS. + PROCEDURE, PASS :: nopass2 => proc_tme1 ! { dg-error "must also be NOPASS" } + PROCEDURE, PASS :: pass1 => proc_tme1 ! Ok. + PROCEDURE, NOPASS :: pass2 => proc_stme1 ! { dg-error "must also be PASS" } + PROCEDURE, PASS(me2) :: pass3 => proc_tmeme ! { dg-error "same position" } + + ! For corresponding dummy arguments. + PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok. + PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" } + PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Type mismatch in argument 'a'" } + + END TYPE t + +CONTAINS + + PURE SUBROUTINE proc_pure () + END SUBROUTINE proc_pure + + ELEMENTAL SUBROUTINE proc_elemental (arg) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: arg + END SUBROUTINE proc_elemental + + SUBROUTINE proc_nonelem (arg) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: arg + END SUBROUTINE proc_nonelem + + SUBROUTINE proc_threearg (a, b, c) + IMPLICIT NONE + INTEGER :: a, b, c + END SUBROUTINE proc_threearg + + SUBROUTINE proc_twoarg (a, b) + IMPLICIT NONE + INTEGER :: a, b + END SUBROUTINE proc_twoarg + + SUBROUTINE proc_sub () + END SUBROUTINE proc_sub + + INTEGER FUNCTION proc_intfunc () + proc_intfunc = 42 + END FUNCTION proc_intfunc + + REAL FUNCTION proc_realfunc () + proc_realfunc = 42.0 + END FUNCTION proc_realfunc + + SUBROUTINE proc_stme1 (me, a) + IMPLICIT NONE + CLASS(supert) :: me + INTEGER :: a + END SUBROUTINE proc_stme1 + + SUBROUTINE proc_tme1 (me, a) + IMPLICIT NONE + CLASS(t) :: me + INTEGER :: a + END SUBROUTINE proc_tme1 + + SUBROUTINE proc_stmeme (me1, me2) + IMPLICIT NONE + CLASS(supert) :: me1, me2 + END SUBROUTINE proc_stmeme + + SUBROUTINE proc_tmeme (me1, me2) + IMPLICIT NONE + CLASS(t) :: me1, me2 + END SUBROUTINE proc_tmeme + + SUBROUTINE proc_stmeint (me, a) + IMPLICIT NONE + CLASS(supert) :: me + INTEGER :: a + END SUBROUTINE proc_stmeint + + SUBROUTINE proc_tmeint (me, a) + IMPLICIT NONE + CLASS(t) :: me + INTEGER :: a + END SUBROUTINE proc_tmeint + + SUBROUTINE proc_tmeintx (me, x) + IMPLICIT NONE + CLASS(t) :: me + INTEGER :: x + END SUBROUTINE proc_tmeintx + + SUBROUTINE proc_tmereal (me, a) + IMPLICIT NONE + CLASS(t) :: me + REAL :: a + END SUBROUTINE proc_tmereal + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_7.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } + +! Type-bound procedures +! Tests that SEQUENCE and BIND(C) types do not allow a type-bound procedure +! section. + +MODULE testmod + USE ISO_C_BINDING + IMPLICIT NONE + + TYPE sequencet + SEQUENCE + INTEGER :: a, b + CONTAINS ! { dg-error "SEQUENCE" } + PROCEDURE, NOPASS :: proc_noarg + END TYPE sequencet + + TYPE, BIND(C) :: bindct + INTEGER(c_int) :: a + REAL(c_float) :: b + CONTAINS ! { dg-error "BIND" } + PROCEDURE, NOPASS :: proc_noarg + END TYPE bindct + +CONTAINS + + SUBROUTINE proc_noarg () + END SUBROUTINE proc_noarg + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_8.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_8.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for name collision between type-bound procedures and components. + +MODULE testmod + IMPLICIT NONE + + TYPE t + REAL :: comp + CONTAINS + PROCEDURE, NOPASS :: comp => proc ! { dg-error "same name as a component" } + END TYPE t + + TYPE supert + INTEGER :: comp1 + CONTAINS + PROCEDURE, NOPASS :: comp2 => proc + END TYPE supert + + TYPE, EXTENDS(supert) :: subt1 + INTEGER :: comp2 ! { dg-error "same name" } + END TYPE subt1 + + TYPE, EXTENDS(supert) :: subt2 + CONTAINS + PROCEDURE, NOPASS :: comp1 => proc ! { dg-error "same name as an inherited component" } + END TYPE subt2 + +CONTAINS + + SUBROUTINE proc () + END SUBROUTINE proc + +END MODULE testmod Index: Fortran/gfortran/regression/typebound_proc_9.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typebound_proc_9.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for basic parsing errors for invalid DEFERRED. + +MODULE testmod + IMPLICIT NONE + + ABSTRACT INTERFACE + SUBROUTINE intf () + END SUBROUTINE intf + END INTERFACE + + TYPE not_abstract + CONTAINS + PROCEDURE(intf), DEFERRED, NOPASS :: proc ! { dg-error "is not ABSTRACT" } + END TYPE not_abstract + + TYPE, ABSTRACT :: abstract_type + CONTAINS + PROCEDURE, DEFERRED :: p2 ! { dg-error "Interface must be specified" } + PROCEDURE(intf), NOPASS :: p3 ! { dg-error "should be declared DEFERRED" } + PROCEDURE(intf), DEFERRED, NON_OVERRIDABLE :: p4 ! { dg-error "cannot both" } + PROCEDURE(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|must be explicit" } + PROCEDURE(intf), DEFERRED, DEFERRED :: p6 ! { dg-error "Duplicate DEFERRED" } + PROCEDURE(intf), DEFERRED :: p6 => proc ! { dg-error "is invalid for DEFERRED" } + PROCEDURE(), DEFERRED :: p7 ! { dg-error "Interface-name expected" } + PROCEDURE(intf, DEFERRED) :: p8 ! { dg-error "'\\)' expected" } + END TYPE abstract_type + +END MODULE testmod Index: Fortran/gfortran/regression/typed_subroutine_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/typed_subroutine_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for 25088, in which the compiler failed to detect that +! a called object had a type. +! +! Contributed by Joost VandeVondele +! + INTEGER :: S ! { dg-error "has a type, which is not consistent with the CALL " } + CALL S() ! { dg-error "has a type, which is not consistent with the CALL " } + END + SUBROUTINE S + END SUBROUTINE Index: Fortran/gfortran/regression/ubound_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ubound_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/99027 +! + program test + integer, dimension (1:3,1:6) :: array + integer, dimension (2:5,3:7,4:9,-4:2) :: array2 + + if (any ([4] /= ubound (array (1, 1:4)))) stop 1 + if (4 /= ubound (array (1, 1:4), dim=1)) stop 2 + + if (any (ubound (array2 (3,3,4,:)) /= [4+1+2])) stop 3 + if ( ubound (array2 (3,3,4,:), dim=1) /= 4+1+2 ) stop 4 + + if (any (ubound (array2 (3,:,4,:)) /= [7-3+1, 4+1+2])) stop 5 + if ( ubound (array2 (3,:,4,:), dim=1) /= 7-3+1 ) stop 6 + if ( ubound (array2 (3,:,4,:), dim=2) /= 4+1+2) stop 7 + if (any (ubound (array2 (3,:,4:4,:)) /= [7-3+1, 1, 4+1+2])) stop 8 + if ( ubound (array2 (3,:,4:4,:), dim=1) /= 7-3+1 ) stop 9 + if ( ubound (array2 (3,:,4:4,:), dim=2) /= 1 ) stop 10 + if ( ubound (array2 (3,:,4:4,:), dim=3) /= 4+1+2) stop 11 + end program test Index: Fortran/gfortran/regression/unary_operator.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unary_operator.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/34536 -- unary operators following arithmetic ones + + real :: x + x = 2.0 ** -3 * 5 ! { dg-warning "Unary operator following arithmetic operator" } +end \ No newline at end of file Index: Fortran/gfortran/regression/uncommon_block_data_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/uncommon_block_data_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for 25083, in which the compiler failed to detect that +! data variables in BLOCK DATA were not in COMMON. +! +! Contributed by Joost VandeVondele +! + BLOCK DATA D + INTEGER I ! { dg-error "must be in COMMON" } + DATA I /1/ + END BLOCK DATA +END Index: Fortran/gfortran/regression/unconstrained_commons.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unconstrained_commons.f @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O3 -funconstrained-commons -fdump-tree-dom2-details" } + +! Test for PR69368: a single-element array in a common block, which will be +! overridden with a larger size at link time (contrary to language spec). +! Dominator opts considers accesses to differently-computed elements of X as +! equivalent, unless -funconstrained-commons is passed in. + SUBROUTINE FOO + IMPLICIT DOUBLE PRECISION (X) + INTEGER J + COMMON /MYCOMMON / X(1) + DO 10 J=1,1024 ! { dg-warning "out of bounds" } + X(J+1)=X(J+7) ! { dg-warning "out of bounds" } + 10 CONTINUE + RETURN + END +! { dg-final { scan-tree-dump-not "FIND" "dom2" } } +! We should retain both a read and write of mycommon.x. +! { dg-final { scan-tree-dump-times " _\[0-9\]+ = mycommon\\.x\\\[_\[0-9\]+\\\];" 1 "dom2" } } +! { dg-final { scan-tree-dump-times " mycommon\\.x\\\[j?_\[0-9\]+\\\] = _\[0-9\]+;" 1 "dom2" } } +! { dg-prune-output "overflows the destination" } Index: Fortran/gfortran/regression/underflow.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/underflow.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program a + real x + x = tiny(x) / huge(x) ! { dg-warning "Arithmetic underflow" } +end program a Index: Fortran/gfortran/regression/unexp_attribute.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexp_attribute.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/69498 +! This test used to result in an internal compiler error +function f() + interface + external f ! { dg-error "Unexpected attribute declaration statement in INTERFACE" } + end interface +end function Index: Fortran/gfortran/regression/unexpected_eof.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexpected_eof.f @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR66461 ICE on missing end program in fixed source + program p + integer x(2) + x = -1 + if ( x(1) < 0 .or. + & x(2) < 0 ) print *, x +! { dg-error "Unexpected end of file" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/unexpected_eof_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexpected_eof_2.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR71686 +program p + character(8) :: z + z = 'abc& ! { dg-error "Unterminated character constant" } +!end +! { dg-error "Unexpected end of file" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/unexpected_eof_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexpected_eof_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR71686 +program p + character(8) :: z = 'abc& ! { dg-error "Unterminated character constant" } +!end +! { dg-error "Unexpected end of file" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/unexpected_eof_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexpected_eof_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Wampersand" } +! PR77972 +program p + character(8) :: z + z = 'abc& +! { dg-error "Unterminated character constant" "" { target *-*-* } 0 } +! { dg-error "Unexpected end of file" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/unexpected_interface.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unexpected_interface.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/43592 +! Original code submitted by Joost VandeVondele +! Dejagnu-ification by Steven G. Kargl +! + interface assignment (=) + interface pseudo_scalar ! { dg-error "Unexpected INTERFACE statement" } + pure function double_tensor2odd (x, t2) result (xt2) +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/unf_io_convert_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_io_convert_1.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! { dg-options "-pedantic" } +! This test verifies the most basic sequential unformatted I/O +! with convert="swap". +! Adapted from seq_io.f. +! write 3 records of various sizes +! then read them back +program main + implicit none + integer size + parameter(size=100) + logical debug + data debug /.FALSE./ +! set debug to true for help in debugging failures. + integer m(2) + integer n + real r(size) + integer i + character(4) str + + m(1) = int(Z'11223344') + m(2) = int(Z'55667788') + n = int(Z'77AABBCC') + str = 'asdf' + do i = 1,size + r(i) = i + end do + open(9,form="unformatted",access="sequential",convert="swap") ! { dg-warning "Extension: CONVERT" } + write(9) m ! an array of 2 + write(9) n ! an integer + write(9) r ! an array of reals + write(9)str ! String +! zero all the results so we can compare after they are read back + do i = 1,size + r(i) = 0 + end do + m(1) = 0 + m(2) = 0 + n = 0 + str = ' ' + + rewind(9) + read(9) m + read(9) n + read(9) r + read(9) str + ! + ! check results + if (m(1).ne.int(Z'11223344')) then + if (debug) then + print '(A,Z8)','m(1) incorrect. m(1) = ',m(1) + else + STOP 1 + endif + endif + + if (m(2).ne.int(Z'55667788')) then + if (debug) then + print '(A,Z8)','m(2) incorrect. m(2) = ',m(2) + else + STOP 2 + endif + endif + + if (n.ne.int(Z'77AABBCC')) then + if (debug) then + print '(A,Z8)','n incorrect. n = ',n + else + STOP 3 + endif + endif + + do i = 1,size + if (int(r(i)).ne.i) then + if (debug) then + print*,'element ',i,' was ',r(i),' should be ',i + else + STOP 4 + endif + endif + end do + if (str .ne. 'asdf') then + if (debug) then + print *,'str incorrect, str = ', str + else + STOP 5 + endif + end if + ! use hexdump to look at the file "fort.9" + if (debug) then + close(9) + else + close(9,status='DELETE') + endif +end program main Index: Fortran/gfortran/regression/unf_io_convert_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_io_convert_2.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +program main + complex(kind=4) :: c + real(kind=4) :: a(2) + integer(kind=4) :: i(2) + integer(kind=1) :: b(8) + integer(kind=8) :: j + + c = (3.14, 2.71) + open (10, form="unformatted",convert="swap") ! { dg-warning "Extension: CONVERT" } + write (10) c + rewind (10) + read (10) a + if (a(1) /= 3.14 .or. a(2) /= 2.71) STOP 1 + close(10,status="delete") + + open (10, form="unformatted",convert="big_endian") ! { dg-warning "Extension: CONVERT" } + i = (/ int(Z'11223344'), int(Z'55667700') /) + write (10) i + rewind (10) + read (10) b + if (any(b /= (/ int(Z'11',1), int(Z'22',1), int(Z'33',1), int(Z'44',1), & + & int(Z'55',1), int(Z'66',1), int(Z'77',1), int(Z'00',1) /))) & + STOP 2 + backspace 10 + read (10) j + if (j /= int(Z'1122334455667700',8)) STOP 3 + close (10, status="delete") + + open (10, form="unformatted", convert="little_endian") ! { dg-warning "Extension: CONVERT" } + write (10) i + rewind (10) + read (10) b + if (any(b /= (/ int(Z'44',1), int(Z'33',1), int(Z'22',1), int(Z'11',1), & + & int(Z'00',1), int(Z'77',1), int(Z'66',1), int(Z'55',1) /))) & + STOP 4 + backspace 10 + read (10) j + if (j /= int(Z'5566770011223344',8)) STOP 5 + close (10, status="delete") + +end program main Index: Fortran/gfortran/regression/unf_io_convert_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_io_convert_3.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +program main + integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1) + real(kind=k) a,b,c + a = 1.1_k + open(10,convert="swap",form="unformatted") ! { dg-warning "Extension: CONVERT" } + write(10) a + backspace 10 + read (10) b + close(10,status="delete") + if (a /= b) STOP 1 + write (11) a + backspace 11 + open (11,form="unformatted") + read (11) c + if (a .ne. c) STOP 2 + close (11, status="delete") +end program main Index: Fortran/gfortran/regression/unf_io_convert_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_io_convert_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fconvert=big-endian" } +program main + character (len=30) ch + open (10,form="unformatted",convert="little_endian") + inquire (10, convert=ch) + if (ch .ne. "LITTLE_ENDIAN") STOP 1 + close (10, status="delete") + + open(11,form="unformatted") + inquire (11, convert=ch) + if (ch .ne. "BIG_ENDIAN") STOP 2 + close (11, status="delete") +end program main Index: Fortran/gfortran/regression/unf_read_corrupted_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_read_corrupted_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! Test the error message when an unformatted file has become +! corrupted. +program main + implicit none + integer(kind=4) :: i1, i2 + integer :: ios + character(len=50) :: msg + + ! Write out a truncated unformatted sequential file by + ! using unformatted stream. + + open (10, form="unformatted", access="stream", file="foo_unf_read_corrupted_1.dat", & + status="unknown") + write (10) 16_4, 1_4 + close (10, status="keep") + + ! Try to read + open (10, file="foo_unf_read_corrupted_1.dat", form="unformatted", access="sequential") + i1 = 0 + i2 = 0 + read (10, iostat=ios, iomsg=msg) i1, i2 + if (ios == 0) STOP 1 + if (i1 /= 1) STOP 2 + if (msg /= "Unformatted file structure has been corrupted") STOP 3 + close (10, status="delete") +end program main Index: Fortran/gfortran/regression/unf_read_corrupted_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_read_corrupted_2.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR31880 silent data corruption in gfortran read statement +! Test from PR. + program r3 + + integer(kind=4) :: a(1025),b(1025),c(1025),d(2048),e(1022) + + a = 5 + b = 6 + c = 7 + e = 8 + + do i=1,2048 + d(i)=i + end do + + open (3,form='unformatted', status="scratch") + write (3) a,b,c,d,e + rewind 3 + d = 0 + read (3) a,b,c,d + close (3) + + if (d(1).ne.1) STOP 1 + if (d(2048).ne.2048) STOP 2 + + end Index: Fortran/gfortran/regression/unf_short_record_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unf_short_record_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR 29627 - partial reads of unformatted records +program main + character a(3) + character(len=50) msg + open(10, form="unformatted", status="unknown") + write (10) 'a' + write (10) 'c' + a = 'b' + rewind 10 + read (10, err=20, iomsg=msg) a + STOP 1 +20 continue + if (msg .ne. "I/O past end of record on unformatted file") STOP 2 + if (a(1) .ne. 'a' .or. a(2) .ne. 'b' .or. a(3) .ne. 'b') STOP 3 + close (10, status="delete") +end program main Index: Fortran/gfortran/regression/unformatted_recl_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unformatted_recl_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run { target fd_truncate } } +! PR31099 Runtime error on legal code using RECL +program test + integer(kind=4) :: a, b + a=1 + b=2 + open(10, status="scratch", form="unformatted", recl=8) + write(10) a,b + write(10) a,b + write(10) a,b + write(10) b, a + rewind(10) + write(10) a,b + write(10) a,b + write(10) a,b + write(10) b, a + b=0 + a=0 + rewind(10) + read(10) a, b + read(10) a, b + read(10) a, b + read(10) a, b + if ((a.ne.2).and.( b.ne.1)) STOP 1 +end program test + Index: Fortran/gfortran/regression/unformatted_subrecord_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unformatted_subrecord_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run { target fd_truncate } } +! { dg-options "-fmax-subrecord-length=16" } +! Test Intel record markers with 16-byte subrecord sizes. +! PR 32770: Use explicit kinds for all integers and constants, +! to avoid problems with -fdefault-integer-8 and -fdefault-real-8 +program main + implicit none + integer(kind=4), dimension(20) :: n + integer(kind=4), dimension(30) :: m + integer(kind=4) :: i + real(kind=4) :: r + integer(kind=4) :: k + ! Maximum subrecord length is 16 here, or the test will fail. + open (10, file="f10.dat", & + form="unformatted", access="sequential") + n = (/ (i**2, i=1, 20) /) + write (10) n + close (10) + ! Read back the file, including record markers. + open (10, file="f10.dat", form="unformatted", access="stream") + read (10) m + if (any(m .ne. (/ -16, 1, 4, 9, 16, 16, -16, 25, 36, 49, 64, & + -16, -16, 81, 100, 121, 144, -16, -16, 169, 196, 225, & + 256, -16, 16, 289, 324, 361, 400, -16 /))) STOP 1 + close (10) + open (10, file="f10.dat", form="unformatted", & + access="sequential") + m = 42 + read (10) m(1:5) + if (any(m(1:5) .ne. (/ 1, 4, 9, 16, 25 /))) STOP 2 + if (any(m(6:30) .ne. 42)) STOP 3 + backspace 10 + n = 0 + read (10) n(1:5) + if (any(n(1:5) .ne. (/ 1, 4, 9, 16, 25 /))) STOP 4 + if (any(n(6:20) .ne. 0)) STOP 5 + ! Append to the end of the file + write (10) 3.14_4 + ! Test multiple backspace statements + backspace 10 + backspace 10 + read (10) k + if (k .ne. 1) STOP 6 + read (10) r + if (abs(r-3.14_4) .gt. 1e-7) STOP 7 + close (10, status="delete") +end program main Index: Fortran/gfortran/regression/unit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unit_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR40638 Run Time Error: Unit number in I/O statement too large + program main + integer(kind=2) :: lun, anum + integer(kind=1) :: looney, bin + lun = 12 + anum = 5 + looney = 42 + bin = 23 + open (lun, status='scratch') + write(lun,*) anum + anum = 0 + rewind(lun) + read (lun, *) anum + if (anum.ne.5) STOP 1 + open (looney, status='scratch') + write(looney,*)bin + bin = 0 + rewind (looney) + read (looney,*)bin + if (bin.ne.23) STOP 2 + close (lun) + close (looney) + end Index: Fortran/gfortran/regression/unlimited_fmt_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_fmt_1.f08 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR41075 Implement unlimited format item '*'. +! Contributed by Jerry DeLisle +program unlimited + implicit none + integer i + character(len=60) :: string + integer, parameter :: n = 10 + integer, dimension(n) :: iarray + iarray = (/ (i,i=1,n) /) + do i=1,10 + write( string, '( "iarray =", *(g0, :, ","))') & + & "abcdefg",iarray, i,"jklmnop" + end do + if (string.ne."iarray =abcdefg,1,2,3,4,5,6,7,8,9,10,10,jklmnop") & + & STOP 1 +end program unlimited Index: Fortran/gfortran/regression/unlimited_polymorphic_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_1.f03 @@ -0,0 +1,220 @@ +! { dg-do run } +! +! Basic tests of functionality of unlimited polymorphism +! +! Contributed by Paul Thomas +! +MODULE m + TYPE :: a + integer :: i + END TYPE + +contains + subroutine bar (arg, res) + class(*) :: arg + character(100) :: res + select type (w => arg) + type is (a) + write (res, '(a, I4)') "type(a)", w%i + type is (integer) + write (res, '(a, I4)') "integer", w + type is (real(4)) + write (res, '(a, F4.1)') "real4", w + type is (real(8)) + write (res, '(a, F4.1)') "real8", w + type is (character(*, kind = 4)) + STOP 1 + type is (character(*)) + write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w) + end select + end subroutine + + subroutine foo (arg, res) + class(*) :: arg (:) + character(100) :: res + select type (w => arg) + type is (a) + write (res,'(a, 10I4)') "type(a) array", w%i + type is (integer) + write (res,'(a, 10I4)') "integer array", w + type is (real) + write (res,'(a, 10F4.1)') "real array", w + type is (character(*)) + write (res, '(a5, I2, a, I2, a1, 2(a))') & + "char(",len(w),",", size(w,1),") array ", w + end select + end subroutine +END MODULE + + + USE m + TYPE(a), target :: obj1 = a(99) + TYPE(a), target :: obj2(3) = a(999) + integer, target :: obj3 = 999 + real(4), target :: obj4(4) = [(real(i), i = 1, 4)] + integer, target :: obj5(3) = [(i*99, i = 1, 3)] + class(*), pointer :: u1 + class(*), pointer :: u2(:) + class(*), allocatable :: u3 + class(*), allocatable :: u4(:) + type(a), pointer :: aptr(:) + character(8) :: sun = "sunshine" + character(100) :: res + + ! NULL without MOLD used to cause segfault + u2 => NULL() + u2 => NULL(aptr) + +! Test pointing to derived types. + u1 => obj1 + if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 + u2 => obj2 + call bar (u1, res) + if (trim (res) .ne. "type(a) 99") STOP 1 + + call foo (u2, res) + if (trim (res) .ne. "type(a) array 999 999 999") STOP 1 + + if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1 + +! Check allocate with an array SOURCE. + allocate (u2(5), source = [(a(i), i = 1,5)]) + if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) STOP 1 + call foo (u2, res) + if (trim (res) .ne. "type(a) array 1 2 3 4 5") STOP 1 + + deallocate (u2) + +! Point to intrinsic targets. + u1 => obj3 + call bar (u1, res) + if (trim (res) .ne. "integer 999") STOP 1 + + u2 => obj4 + call foo (u2, res) + if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 + + u2 => obj5 + call foo (u2, res) + if (trim (res) .ne. "integer array 99 198 297") STOP 1 + +! Test allocate with source. + allocate (u1, source = sun) + call bar (u1, res) + if (trim (res) .ne. "char( 8)sunshine") STOP 1 + deallocate (u1) + + allocate (u2(3), source = [7,8,9]) + call foo (u2, res) + if (trim (res) .ne. "integer array 7 8 9") STOP 1 + + deallocate (u2) + + if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 + + allocate (u2(3), source = [5.0,6.0,7.0]) + call foo (u2, res) + if (trim (res) .ne. "real array 5.0 6.0 7.0") STOP 1 + + if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) STOP 1 + if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1 + deallocate (u2) + +! Check allocate with a MOLD tag. + allocate (u2(3), mold = 8.0) + call foo (u2, res) + if (res(1:10) .ne. "real array") STOP 1 + deallocate (u2) + +! Test passing an intrinsic type to a CLASS(*) formal. + call bar(1, res) + if (trim (res) .ne. "integer 1") STOP 1 + + call bar(2.0, res) + if (trim (res) .ne. "real4 2.0") STOP 1 + + call bar(2d0, res) + if (trim (res) .ne. "real8 2.0") STOP 1 + + call bar(a(3), res) + if (trim (res) .ne. "type(a) 3") STOP 1 + + call bar(sun, res) + if (trim (res) .ne. "char( 8)sunshine") STOP 1 + + call bar (obj3, res) + if (trim (res) .ne. "integer 999") STOP 1 + + call foo([4,5], res) + if (trim (res) .ne. "integer array 4 5") STOP 1 + + call foo([6.0,7.0], res) + if (trim (res) .ne. "real array 6.0 7.0") STOP 1 + + call foo([a(8),a(9)], res) + if (trim (res) .ne. "type(a) array 8 9") STOP 1 + + call foo([sun, " & rain"], res) + if (trim (res) .ne. "char( 8, 2)sunshine & rain") STOP 1 + + call foo([sun//" never happens", " & rain always happens"], res) + if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") STOP 1 + + call foo (obj4, res) + if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1 + + call foo (obj5, res) + if (trim (res) .ne. "integer array 99 198 297") STOP 1 + +! Allocatable entities + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 + + allocate (u3, source = 2.4) + call bar (u3, res) + if (trim (res) .ne. "real4 2.4") STOP 1 + + allocate (u4(2), source = [a(88), a(99)]) + call foo (u4, res) + if (trim (res) .ne. "type(a) array 88 99") STOP 1 + + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) STOP 1 + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 + + deallocate (u3) + if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1 + + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) STOP 1 + deallocate (u4) + if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1 + if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1 + + +! Check assumed rank calls + call foobar (u3, 0, is_u3=.true.) + call foobar (u4, 1, is_u3=.false.) +contains + + subroutine foobar (arg, ranki, is_u3) + class(*) :: arg (..) + integer :: ranki + logical, value :: is_u3 + integer i + i = rank (arg) + if (i .ne. ranki) STOP 1 + if (is_u3) then + if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1 + else + ! arg == u4 + if (EXTENDS_TYPE_OF (arg, obj1) .neqv. .FALSE.) STOP 1 + end if + ! if (.NOT. SAME_TYPE_AS (arg, u3)) STOP 1 + ! if (.NOT. SAME_TYPE_AS (arg, u4)) STOP 1 + end subroutine + +END Index: Fortran/gfortran/regression/unlimited_polymorphic_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_10.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/58658 +! +! Contributed by Vladimír Fuka +! +subroutine sub(a) + class(*),allocatable :: a + a => null() ! { dg-error "Non-POINTER in pointer association context \\(pointer assignment\\)" } +end subroutine Index: Fortran/gfortran/regression/unlimited_polymorphic_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_11.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/58652 +! +! Contributed by Vladimir Fuka +! + class(*),allocatable :: a + class(*),allocatable :: c + call move_alloc(a,c) +end + +! { dg-final { scan-tree-dump "\\(struct __vtype__STAR \\*\\) c._vptr = \\(struct __vtype__STAR \\*\\) a._vptr;" "original" } } Index: Fortran/gfortran/regression/unlimited_polymorphic_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_12.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR fortran/58652 +! +! Contributed by Vladimir Fuka +! +! The passing of a CLASS(*) to a CLASS(*) was reject before +! +module gen_lists + type list_node + class(*),allocatable :: item + contains + procedure :: move_alloc => list_move_alloc + end type + + contains + + subroutine list_move_alloc(self,item) + class(list_node),intent(inout) :: self + class(*),intent(inout),allocatable :: item + + call move_alloc(item, self%item) + end subroutine +end module + +module lists + use gen_lists, only: node => list_node +end module lists + + +module sexp + use lists +contains + subroutine parse(ast) + class(*), allocatable, intent(out) :: ast + class(*), allocatable :: expr + integer :: ierr + allocate(node::ast) + select type (ast) + type is (node) + call ast%move_alloc(expr) + end select + end subroutine +end module Index: Fortran/gfortran/regression/unlimited_polymorphic_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_13.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! +! PR fortran/58793 +! +! Contributed by Vladimir Fuka +! +! Had the wrong value for the storage_size for complex +! +module m + use iso_fortran_env + implicit none + integer, parameter :: c1 = real_kinds(1) + integer, parameter :: c2 = real_kinds(2) + integer, parameter :: c3 = real_kinds(size(real_kinds)-1) + integer, parameter :: c4 = real_kinds(size(real_kinds)) + real(c1) :: r1 + real(c2) :: r2 + real(c3) :: r3 + real(c4) :: r4 +contains + subroutine s(o, k) + class(*) :: o + integer :: k + integer :: sz + + sz = 0 + select case (k) + case (4) + sz = storage_size(r1)*2 + end select + select case (k) + case (8) + sz = storage_size(r2)*2 + end select + select case (k) + case (real_kinds(size(real_kinds)-1)) + sz = storage_size(r3)*2 + end select + select case (k) + case (real_kinds(size(real_kinds))) + sz = storage_size(r4)*2 + end select + if (sz .eq. 0) STOP 1 + + if (storage_size(o) /= sz) STOP 2 + +! Break up the SELECT TYPE to pre-empt collisions in the value of 'cn' + select type (o) + type is (complex(c1)) + if (storage_size(o) /= sz) STOP 3 + end select + select type (o) + type is (complex(c2)) + if (storage_size(o) /= sz) STOP 4 + end select + select type (o) + type is (complex(c3)) + if (storage_size(o) /= sz) STOP 5 + end select + select type (o) + type is (complex(c4)) + if (storage_size(o) /= sz) STOP 6 + end select + end subroutine s +end module m + +program p + use m + call s((1._c1, 2._c1), c1) + call s((1._c2, 2._c2), c2) + call s((1._c3, 2._c3), c3) + call s((1._c4, 2._c4), c4) +end program p Index: Fortran/gfortran/regression/unlimited_polymorphic_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_14.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Uncovered in fixing PR fortran/58793 +! +! Contributed by Tobias Burnus +! +! Barfed on the hollerith argument +! +program test + logical l + call up("abc", l) + if (l) STOP 1 + call up(3habc, l) ! { dg-warning "Legacy Extension" } + if (.not. l) STOP 2 +contains + subroutine up(x, l) + class(*) :: x + logical l + select type(x) + type is (character(*)) + l = .false. + class default + l = .true. + end select + end subroutine +end program test Index: Fortran/gfortran/regression/unlimited_polymorphic_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_15.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 59493: [OOP] ICE: Segfault on Class(*) pointer association +! +! Contributed by Hossein Talebi + + implicit none + + type ty_mytype1 + end type + + class(ty_mytype1), allocatable, target:: cla1 + class(*), pointer :: ptr + + ptr => cla1 + +end Index: Fortran/gfortran/regression/unlimited_polymorphic_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_16.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 60359: [OOP] symbol `__io_MOD___copy_character_1' is already defined +! +! Contributed by Antony Lewis + +module IO +implicit none + +contains + + subroutine FWRite(S) + class(*) :: S + end subroutine + + subroutine IO_OutputMargeStats() + character(len=128) tag + call FWrite(tag) + call FWrite(' '//tag) + end subroutine + +end module Index: Fortran/gfortran/regression/unlimited_polymorphic_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_17.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Tests fix for PR60717 in which offsets in recursive calls below +! were not being set correctly. +! +! Reported on comp.lang.fortran by Thomas Schnurrenberger +! +module m + implicit none + real :: chksum0 = 0, chksum1 = 0, chksum2 = 0 +contains + recursive subroutine show_real(a) + real, intent(in) :: a(:) + if (size (a) > 0) then + chksum0 = a(1) + chksum0 + call show_real (a(2:)) + end if + return + end subroutine show_real + recursive subroutine show_generic1(a) + class(*), intent(in) :: a(:) + if (size (a) > 0) then + select type (a) + type is (real) + chksum1 = a(1) + chksum1 + end select + call show_generic1 (a(2:)) ! recursive call outside SELECT TYPE + end if + return + end subroutine show_generic1 + recursive subroutine show_generic2(a) + class(*), intent(in) :: a(:) + if (size (a) > 0) then + select type (a) + type is (real) + chksum2 = a(1) + chksum2 + call show_generic2 (a(2:)) ! recursive call inside SELECT TYPE + end select + end if + return + end subroutine show_generic2 +end module m +program test + use :: m + implicit none + real :: array(1:6) = (/ 0, 1, 2, 3, 4, 5 /) + call show_real (array) + call show_generic1 (array) + call show_generic2 (array) + if (chksum0 .ne. chksum1) STOP 1 + if (chksum0 .ne. chksum2) STOP 2 +end program test Index: Fortran/gfortran/regression/unlimited_polymorphic_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_18.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! Testing fix for +! PR fortran/60414 +! +module m + implicit none + Type T + real, public :: expectedScalar; + contains + procedure :: FCheck + procedure :: FCheckArr + generic :: Check => FCheck, FCheckArr + end Type + +contains + + subroutine FCheck(this,X) + class(T) this + class(*) X + real :: r + select type (X) + type is (real) + if ( abs (X - this%expectedScalar) > 0.0001 ) then + STOP 1 + end if + class default + STOP 2 + end select + end subroutine FCheck + + subroutine FCheckArr(this,X) + class(T) this + class(*) X(:) + integer i + do i = 1,6 + this%expectedScalar = i - 1.0 + call this%FCheck(X(i)) + end do + end subroutine FCheckArr + + subroutine CheckTextVector(vec, n, scal) + integer, intent(in) :: n + class(*), intent(in) :: vec(n) + class(*), intent(in) :: scal + integer j + Type(T) :: Tester + + ! Check full vector + call Tester%Check(vec) + ! Check a scalar of the same class like the vector + Tester%expectedScalar = 5.0 + call Tester%Check(scal) + ! Check an element of the vector, which is a scalar + j=3 + Tester%expectedScalar = 2.0 + call Tester%Check(vec(j)) + + end subroutine CheckTextVector + +end module + +program test + use :: m + implicit none + + real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /) + call checktextvector(vec, 6, 5.0) +end program test + Index: Fortran/gfortran/regression/unlimited_polymorphic_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_19.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument +! +! Contributed by Miha Polajnar + +MODULE m + IMPLICIT NONE + TYPE :: t + CLASS(*), ALLOCATABLE :: x(:) + CONTAINS + PROCEDURE :: copy + END TYPE t + INTERFACE + SUBROUTINE copy_proc_intr(a,b) + CLASS(*), INTENT(IN) :: a + CLASS(*), INTENT(OUT) :: b + END SUBROUTINE copy_proc_intr + END INTERFACE +CONTAINS + SUBROUTINE copy(self,cp,a) + CLASS(t), INTENT(IN) :: self + PROCEDURE(copy_proc_intr) :: cp + CLASS(*), INTENT(OUT) :: a(:) + INTEGER :: i + IF( .not.same_type_as(self%x(1),a(1)) ) STOP -1 + DO i = 1, size(self%x) + CALL cp(self%x(i),a(i)) + END DO + END SUBROUTINE copy +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + INTEGER, PARAMETER :: n = 3, x(n) = [ 1, 2, 3 ] + INTEGER :: copy_x(n) + TYPE(t) :: test + ALLOCATE(test%x(n),SOURCE=x) + CALL test%copy(copy_int,copy_x) +! PRINT '(*(I0,:2X))', copy_x +CONTAINS + SUBROUTINE copy_int(a,b) + CLASS(*), INTENT(IN) :: a + CLASS(*), INTENT(OUT) :: b + SELECT TYPE(a); TYPE IS(integer) + SELECT TYPE(b); TYPE IS(integer) + b = a + END SELECT; END SELECT + END SUBROUTINE copy_int +END PROGRAM main Index: Fortran/gfortran/regression/unlimited_polymorphic_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_2.f03 @@ -0,0 +1,80 @@ +! { dg-do compile } +! +! Test the most important constraints unlimited polymorphic entities +! +! Contributed by Paul Thomas +! and Tobias Burnus +! + CHARACTER(:), allocatable, target :: chr +! F2008: C5100 + integer :: i(2) + logical :: flag + class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" } + common u1 + u1 => chr +! F2003: C625 + allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" } + allocate (real :: u1) + Allocate (u1, source = 1.0) + +! F2008: C4106 + u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" } + + i = u2 ! { dg-error "Cannot convert CLASS\\(\\*\\)" } + +! Repeats same_type_as_1.f03 for unlimited polymorphic u2 + flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" } + flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" } + +contains + +! C717 (R735) If data-target is unlimited polymorphic, +! data-pointer-object shall be unlimited polymorphic, of a sequence +! derived type, or of a type with the BIND attribute. +! + subroutine bar + + type sq + sequence + integer :: i + end type sq + + type(sq), target :: x + class(*), pointer :: y + integer, pointer :: tgt + + x%i = 42 + y => x + call foo (y) + + y => tgt ! This is OK, of course. + tgt => y ! { dg-error "Data-pointer-object at .1. must be unlimited polymorphic" } + + select type (y) ! This is the correct way to accomplish the previous + type is (integer) + tgt => y + end select + + end subroutine bar + + + subroutine foo(tgt) + class(*), pointer, intent(in) :: tgt + type t + sequence + integer :: k + end type t + + type(t), pointer :: ptr + + ptr => tgt ! C717 allows this. + + select type (tgt) +! F03:C815 or F08:C839 + type is (t) ! { dg-error "shall not specify a sequence derived type" } + ptr => tgt ! { dg-error "Expected TYPE IS" } + end select + + print *, ptr%k + end subroutine foo +END Index: Fortran/gfortran/regression/unlimited_polymorphic_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_20.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! +! Testing fix for PR fortran/60255 +! +! Author: Andre Vehreschild +! +MODULE m + +contains + subroutine bar (arg, res) + class(*) :: arg + character(100) :: res + select type (w => arg) + type is (character(*)) + write (res, '(I2)') len(w) + end select + end subroutine + +END MODULE + +program test + use m; + implicit none + character(LEN=:), allocatable, target :: S + character(LEN=100) :: res + class(*), pointer :: ucp, ucp2 + call sub1 ("long test string", 16) + call sub2 () + S = "test" + ucp => S + call sub3 (ucp) + allocate (ucp2, source=ucp) + call sub3 (ucp2) + call sub4 (S, 4) + call sub4 ("This is a longer string.", 24) + call bar (S, res) + if (trim (res) .NE. " 4") STOP 1 + call bar(ucp, res) + if (trim (res) .NE. " 4") STOP 2 + +contains + + subroutine sub1(dcl, ilen) + character(len=*), target :: dcl + integer(4) :: ilen + character(len=:), allocatable :: hlp + class(*), pointer :: ucp + + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(dcl) .NE. ilen) STOP 3 + if (len(ucp) .NE. ilen) STOP 4 + hlp = ucp + if (len(hlp) .NE. ilen) STOP 5 + class default + STOP 6 + end select + end subroutine + + subroutine sub2 + character(len=:), allocatable, target :: dcl + class(*), pointer :: ucp + + dcl = "ttt" + ucp => dcl + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .ne. 3) STOP 7 + class default + STOP 8 + end select + end subroutine + + subroutine sub3(ucp) + character(len=:), allocatable :: hlp + class(*), pointer :: ucp + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .ne. 4) STOP 9 + hlp = ucp + if (len(hlp) .ne. 4) STOP 10 + class default + STOP 11 + end select + end subroutine + + subroutine sub4(ucp, ilen) + character(len=:), allocatable :: hlp + integer(4) :: ilen + class(*) :: ucp + + select type (ucp) + type is (character(len=*)) + if (len(ucp) .ne. ilen) STOP 12 + hlp = ucp + if (len(hlp) .ne. ilen) STOP 13 + class default + STOP 14 + end select + end subroutine +end program + Index: Fortran/gfortran/regression/unlimited_polymorphic_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_21.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Tests the fix for PR64578. +! +! Contributed by Damian Rouson +! + type foo + real, allocatable :: component(:) + end type + type (foo), target :: f + class(*), pointer :: ptr(:) + allocate(f%component(1),source=[0.99]) + call associate_pointer(f,ptr) + select type (ptr) + type is (real) + if (abs (ptr(1) - 0.99) > 1e-5) STOP 1 + end select + ptr => return_pointer(f) ! runtime segmentation fault + if (associated(return_pointer(f)) .neqv. .true.) STOP 2 + select type (ptr) + type is (real) + if (abs (ptr(1) - 0.99) > 1e-5) STOP 3 + end select +contains + subroutine associate_pointer(this, item) + class(foo), target :: this + class(*), pointer :: item(:) + item => this%component + end subroutine + function return_pointer(this) + class(foo), target :: this + class(*), pointer :: return_pointer(:) + return_pointer => this%component + end function +end + Index: Fortran/gfortran/regression/unlimited_polymorphic_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_22.f90 @@ -0,0 +1,215 @@ +! { dg-do run } +! Testing fix for PR fortran/60289 +! Contributed by: Andre Vehreschild +! +program test + implicit none + + class(*), pointer :: P1, P2, P3 + class(*), pointer, dimension(:) :: PA1 + class(*), allocatable :: A1, A2 + integer :: string_len = 10 *2 + character(len=:), allocatable, target :: str + character(len=:,kind=4), allocatable :: str4 + type T + class(*), pointer :: content + end type + type(T) :: o1, o2 + + str = "string for test" + str4 = 4_"string for test" + + allocate(character(string_len)::P1) + + select type(P1) + type is (character(*)) + P1 ="some test string" + if (P1 .ne. "some test string") STOP 1 + if (len(P1) .ne. 20) STOP 2 + if (len(P1) .eq. len("some test string")) STOP 3 + class default + STOP 4 + end select + + allocate(A1, source = P1) + + select type(A1) + type is (character(*)) + if (A1 .ne. "some test string") STOP 5 + if (len(A1) .ne. 20) STOP 6 + if (len(A1) .eq. len("some test string")) STOP 7 + class default + STOP 8 + end select + + allocate(A2, source = convertType(P1)) + + select type(A2) + type is (character(*)) + if (A2 .ne. "some test string") STOP 9 + if (len(A2) .ne. 20) STOP 10 + if (len(A2) .eq. len("some test string")) STOP 11 + class default + STOP 12 + end select + + allocate(P2, source = str) + + select type(P2) + type is (character(*)) + if (P2 .ne. "string for test") STOP 13 + if (len(P2) .eq. 20) STOP 14 + if (len(P2) .ne. len("string for test")) STOP 15 + class default + STOP 16 + end select + + allocate(P3, source = "string for test") + + select type(P3) + type is (character(*)) + if (P3 .ne. "string for test") STOP 17 + if (len(P3) .eq. 20) STOP 18 + if (len(P3) .ne. len("string for test")) STOP 19 + class default + STOP 20 + end select + + allocate(character(len=10)::PA1(3)) + + select type(PA1) + type is (character(*)) + PA1(1) = "string 10 " + if (PA1(1) .ne. "string 10 ") STOP 21 + if (any(len(PA1(:)) .ne. [10,10,10])) STOP 22 + class default + STOP 23 + end select + + deallocate(PA1) + deallocate(P3) +! if (len(P3) .ne. 0) STOP 24 ! Can't check, because select +! type would be needed, which needs the vptr, which is 0 now. + deallocate(P2) + deallocate(A2) + deallocate(A1) + deallocate(P1) + + ! Now for kind=4 chars. + + allocate(character(len=20,kind=4)::P1) + + select type(P1) + type is (character(len=*,kind=4)) + P1 ="some test string" + if (P1 .ne. 4_"some test string") STOP 25 + if (len(P1) .ne. 20) STOP 26 + if (len(P1) .eq. len("some test string")) STOP 27 + type is (character(len=*,kind=1)) + STOP 28 + class default + STOP 29 + end select + + allocate(A1, source=P1) + + select type(A1) + type is (character(len=*,kind=4)) + if (A1 .ne. 4_"some test string") STOP 30 + if (len(A1) .ne. 20) STOP 31 + if (len(A1) .eq. len("some test string")) STOP 32 + type is (character(len=*,kind=1)) + STOP 33 + class default + STOP 34 + end select + + allocate(A2, source = convertType(P1)) + + select type(A2) + type is (character(len=*, kind=4)) + if (A2 .ne. 4_"some test string") STOP 35 + if (len(A2) .ne. 20) STOP 36 + if (len(A2) .eq. len("some test string")) STOP 37 + class default + STOP 38 + end select + + allocate(P2, source = str4) + + select type(P2) + type is (character(len=*,kind=4)) + if (P2 .ne. 4_"string for test") STOP 39 + if (len(P2) .eq. 20) STOP 40 + if (len(P2) .ne. len("string for test")) STOP 41 + class default + STOP 42 + end select + + allocate(P3, source = convertType(P2)) + + select type(P3) + type is (character(len=*, kind=4)) + if (P3 .ne. 4_"string for test") STOP 43 + if (len(P3) .eq. 20) STOP 44 + if (len(P3) .ne. len("string for test")) STOP 45 + class default + STOP 46 + end select + + allocate(character(kind=4, len=10)::PA1(3)) + + select type(PA1) + type is (character(len=*, kind=4)) + PA1(1) = 4_"string 10 " + if (PA1(1) .ne. 4_"string 10 ") STOP 47 + if (any(len(PA1(:)) .ne. [10,10,10])) STOP 48 + class default + STOP 49 + end select + + deallocate(PA1) + deallocate(P3) + deallocate(P2) + deallocate(A2) + deallocate(P1) + deallocate(A1) + + allocate(o1%content, source='test string') + allocate(o2%content, source=o1%content) + select type (c => o1%content) + type is (character(*)) + if (c /= 'test string') STOP 50 + class default + STOP 51 + end select + select type (d => o2%content) + type is (character(*)) + if (d /= 'test string') STOP 52 + class default + end select + + call AddCopy ('test string') + +contains + + function convertType(in) + class(*), pointer, intent(in) :: in + class(*), pointer :: convertType + + convertType => in + end function + + subroutine AddCopy(C) + class(*), intent(in) :: C + class(*), pointer :: P + allocate(P, source=C) + select type (P) + type is (character(*)) + if (P /= 'test string') STOP 53 + class default + STOP 54 + end select + end subroutine + +end program test Index: Fortran/gfortran/regression/unlimited_polymorphic_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_23.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Test the fix for PR65024, in which the structure for the 'info' +! component of type 'T' was not being converted into TREE_SSA and +! so caused an ICE in trans-expr.c:gfc_conv_component_ref. +! +! Reported by +! +MODULE X + TYPE T + CLASS(*), pointer :: info + END TYPE +END MODULE + +PROGRAM P + call bug +CONTAINS + SUBROUTINE BUG + USE X + CLASS(T), pointer :: e + integer, target :: i = 42 + allocate(e) + e%info => NULL () ! used to ICE + if (.not.associated(e%info)) e%info => i ! used to ICE + select type (z => e%info) + type is (integer) + if (z .ne.i) STOP 1 + end select + END SUBROUTINE + + SUBROUTINE NEXT + USE X + CLASS (T), pointer :: e + END SUBROUTINE +END Index: Fortran/gfortran/regression/unlimited_polymorphic_24.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_24.f03 @@ -0,0 +1,216 @@ +! { dg-do run } +! +! Copyright 2015 NVIDIA Corporation +! +! Test case for unlimited polymorphism that is derived from the article +! by Mark Leair, in the 'PGInsider': +! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm +! Note that 'addValue' has been removed from the generic 'add' because +! gfortran asserts that this is ambiguous. See +! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion. +! +module link_mod + private + public :: link, output, index + character(6) :: output (14) + integer :: index = 0 + type link + private + class(*), pointer :: value => null() ! value stored in link + type(link), pointer :: next => null()! next link in list + contains + procedure :: getValue ! return value pointer + procedure :: printLinks ! print linked list starting with this link + procedure :: nextLink ! return next pointer + procedure :: setNextLink ! set next pointer + end type link + + interface link + procedure constructor ! construct/initialize a link + end interface + +contains + + function nextLink(this) + class(link) :: this + class(link), pointer :: nextLink + nextLink => this%next + end function nextLink + + subroutine setNextLink(this,next) + class(link) :: this + class(link), pointer :: next + this%next => next + end subroutine setNextLink + + function getValue(this) + class(link) :: this + class(*), pointer :: getValue + getValue => this%value + end function getValue + + subroutine printLink(this) + class(link) :: this + + index = index + 1 + + select type(v => this%value) + type is (integer) + write (output(index), '(i6)') v + type is (character(*)) + write (output(index), '(a6)') v + type is (real) + write (output(index), '(f6.2)') v + class default + stop 'printLink: unexepected type for link' + end select + + end subroutine printLink + + subroutine printLinks(this) + class(link) :: this + class(link), pointer :: curr + + call printLink(this) + curr => this%next + do while(associated(curr)) + call printLink(curr) + curr => curr%next + end do + + end subroutine + + function constructor(value, next) + class(link),pointer :: constructor + class(*) :: value + class(link), pointer :: next + allocate(constructor) + constructor%next => next + allocate(constructor%value, source=value) + end function constructor + +end module link_mod + +module list_mod + use link_mod + private + public :: list + type list + private + class(link),pointer :: firstLink => null() ! first link in list + class(link),pointer :: lastLink => null() ! last link in list + contains + procedure :: printValues ! print linked list + procedure :: addInteger ! add integer to linked list + procedure :: addChar ! add character to linked list + procedure :: addReal ! add real to linked list + procedure :: addValue ! add class(*) to linked list + procedure :: firstValue ! return value associated with firstLink + procedure :: isEmpty ! return true if list is empty + generic :: add => addInteger, addChar, addReal + end type list + +contains + + subroutine printValues(this) + class(list) :: this + + if (.not.this%isEmpty()) then + call this%firstLink%printLinks() + endif + end subroutine printValues + + subroutine addValue(this, value) + class(list) :: this + class(*) :: value + class(link), pointer :: newLink + + if (.not. associated(this%firstLink)) then + this%firstLink => link(value, this%firstLink) + this%lastLink => this%firstLink + else + newLink => link(value, this%lastLink%nextLink()) + call this%lastLink%setNextLink(newLink) + this%lastLink => newLink + end if + + end subroutine addValue + + subroutine addInteger(this, value) + class(list) :: this + integer value + class(*), allocatable :: v + allocate(v,source=value) + call this%addValue(v) + end subroutine addInteger + + subroutine addChar(this, value) + class(list) :: this + character(*) :: value + class(*), allocatable :: v + + allocate(v,source=value) + call this%addValue(v) + end subroutine addChar + + subroutine addReal(this, value) + class(list) :: this + real value + class(*), allocatable :: v + + allocate(v,source=value) + call this%addValue(v) + end subroutine addReal + + function firstValue(this) + class(list) :: this + class(*), pointer :: firstValue + + firstValue => this%firstLink%getValue() + + end function firstValue + + function isEmpty(this) + class(list) :: this + logical isEmpty + + if (associated(this%firstLink)) then + isEmpty = .false. + else + isEmpty = .true. + endif + end function isEmpty + +end module list_mod + +program main + use link_mod, only : output + use list_mod + implicit none + integer i, j + type(list) :: my_list + + do i=1, 10 + call my_list%add(i) + enddo + call my_list%add(1.23) + call my_list%add('A') + call my_list%add('BC') + call my_list%add('DEF') + call my_list%printvalues() + do i = 1, 14 + select case (i) + case (1:10) + read (output(i), '(i6)') j + if (j .ne. i) STOP 1 + case (11) + if (output(i) .ne. " 1.23") STOP 2 + case (12) + if (output(i) .ne. " A") STOP 3 + case (13) + if (output(i) .ne. " BC") STOP 4 + case (14) + if (output(i) .ne. " DEF") STOP 5 + end select + end do +end program main Index: Fortran/gfortran/regression/unlimited_polymorphic_25.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_25.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Tests the fix for PR69566, in which a boolean expression testing a +! the component of a pointer did not check the pointer, resulting in +! the ICE. +! +! Contributed by Janus Weil +! + print *, associated(return_pointer()) ! ICE +contains + function return_pointer() + class(*), pointer :: return_pointer(:) + end function +end Index: Fortran/gfortran/regression/unlimited_polymorphic_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_25.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Test contributed by Valery Weber + +module mod + + TYPE, PUBLIC :: base_type + END TYPE base_type + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(base_type), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + type(base_type) :: a, b + call dict_put(t, a, b) + + if (.NOT. allocated(t%key)) STOP 1 + select type (x => t%key) + type is (base_type) + class default + STOP 2 + end select + deallocate(t%key) +end + Index: Fortran/gfortran/regression/unlimited_polymorphic_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_26.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Test contributed by Valery Weber + +module mod + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + ALLOCATE( this%val, SOURCE=val, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + call dict_put(t, "foo", 42) + + if (.NOT. allocated(t%key)) STOP 1 + select type (x => t%key) + type is (CHARACTER(*)) + if (x /= "foo") STOP 2 + class default + STOP 3 + end select + deallocate(t%key) + + if (.NOT. allocated(t%val)) STOP 4 + select type (x => t%val) + type is (INTEGER) + if (x /= 42) STOP 5 + class default + STOP 6 + end select + deallocate(t%val) +end + Index: Fortran/gfortran/regression/unlimited_polymorphic_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_27.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 78800: [OOP] ICE in compare_parameter, at fortran/interface.c:2246 +! +! Contributed by Gerhard Steinmetz + +program p + type t + end type + class(*) :: z ! { dg-error "must be dummy, allocatable or pointer" } + call s(z) +contains + subroutine s(x) + type(t) :: x + end +end Index: Fortran/gfortran/regression/unlimited_polymorphic_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_28.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! +! PR 82257: ICE in gfc_typename(), compare_rank(), resolve_structure_cons() + +module m1 + +implicit none + + type,abstract :: c_base + contains + procedure(i1),private,deferred :: f_base + end type c_base + + abstract interface + function i1(this) result(res) + import + class(c_base),intent(IN) :: this + class(c_base), pointer :: res + end function i1 + end interface + + type,abstract,extends(c_base) :: c_derived + contains + procedure :: f_base => f_derived ! { dg-error "Type mismatch in function result" } + end type c_derived + +contains + + function f_derived(this) result(res) ! { dg-error "must be dummy, allocatable or pointer" } + class(c_derived), intent(IN) :: this + class(*) :: res + end function f_derived + +end module m1 + +module m2 + +implicit none + + type :: t + contains + procedure :: p + end type t + +contains + + class(*) function p(this) ! { dg-error "must be dummy, allocatable or pointer" } + class(t), intent(IN) :: this + end function p + +end module m2 Index: Fortran/gfortran/regression/unlimited_polymorphic_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_29.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! Test the fix for PR84546 in which the failing cases would +! have x%vec = ['foo','b ']. +! +! Contributed by Neil Carlson +! +module any_vector_type + + type :: any_vector + class(*), allocatable :: vec(:) + end type + + interface any_vector + procedure any_vector1 + end interface + +contains + + function any_vector1(vec) result(this) + class(*), intent(in) :: vec(:) + type(any_vector) :: this + allocate(this%vec, source=vec) + end function + +end module + +program main + + use any_vector_type + implicit none + + class(*), allocatable :: x + character(*), parameter :: vec(2) = ['foo','bar'] + integer :: vec1(3) = [7,8,9] + + call foo1 + call foo2 + call foo3 + call foo4 + +contains + + subroutine foo1 ! This always worked + allocate (any_vector :: x) + select type (x) + type is (any_vector) + x = any_vector(vec) + end select + call bar(1) + deallocate (x) + end + + subroutine foo2 ! Failure found during diagnosis + x = any_vector (vec) + call bar(2) + deallocate (x) + end + + subroutine foo3 ! Original failure + allocate (x, source = any_vector (vec)) + call bar(3) + deallocate (x) + end + + subroutine foo4 ! This always worked + allocate (x, source = any_vector (vec1)) + call bar(4) + deallocate (x) + end + + subroutine bar (stop_flag) + integer :: stop_flag + select type (x) + type is (any_vector) + select type (xvec => x%vec) + type is (character(*)) + if (any(xvec /= vec)) stop stop_flag + type is (integer) + if (any(xvec /= (vec1))) stop stop_flag + end select + end select + end +end program Index: Fortran/gfortran/regression/unlimited_polymorphic_3.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_3.f03 @@ -0,0 +1,75 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-dse-details" } +! +! Check that pointer assignments allowed by F2003:C717 +! work and check null initialization of CLASS(*) pointers. +! +! Contributed by Tobias Burnus +! +program main + interface + subroutine foo_bc(z) + class(*), pointer, intent(in) :: z + end subroutine foo_bc + subroutine foo_sq(z) + class(*), pointer, intent(in) :: z + end subroutine foo_sq + end interface + type, bind(c) :: bc + integer :: i + end type bc + type sq + sequence + integer :: k + end type sq + type(bc), target :: w + type(sq), target :: x + class(*), pointer :: y, z + w%i = 23 + y => w + z => y ! unlimited => unlimited allowed + call foo_bc(z) + x%k = 42 + y => x + z => y ! unlimited => unlimited allowed + call foo_sq(z) + call bar +contains + subroutine bar + type t + end type t + type(t), pointer :: x + class(*), pointer :: ptr1 => null() ! pointer initialization + if (same_type_as (ptr1, x) .neqv. .FALSE.) STOP 1 + end subroutine bar + +end program main + +subroutine foo_bc(tgt) + use iso_c_binding + class(*), pointer, intent(in) :: tgt + type, bind(c) :: bc + integer (c_int) :: i + end type bc + type(bc), pointer :: ptr1 + ptr1 => tgt ! bind(c) => unlimited allowed + if (ptr1%i .ne. 23) STOP 2 +end subroutine foo_bc + +subroutine foo_sq(tgt) + class(*), pointer, intent(in) :: tgt + type sq + sequence + integer :: k + end type sq + type(sq), pointer :: ptr2 + ptr2 => tgt ! sequence type => unlimited allowed + if (ptr2%k .ne. 42) STOP 3 +end subroutine foo_sq + +! PR fortran/103662 +! We used to produce multiple independant types for the unlimited polymorphic +! descriptors (types for class(*)) which caused stores to them to be seen as +! useless. +! { dg-final { scan-tree-dump-not "Deleted dead store: z._data = &w" "dse1" { target __OPTIMIZE__ } } } +! { dg-final { scan-tree-dump-not "Deleted dead store: z._data = &x" "dse1" { target __OPTIMIZE__ } } } Index: Fortran/gfortran/regression/unlimited_polymorphic_30.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_30.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR83318. +! +! Contributed by Neil Carlson +! +type :: any_vector + class(*), allocatable :: v(:) +end type +type(any_vector) :: x, y + +! This did not work correctly + x%v = ['foo','bar'] + call foo (x, 1) + +! This was reported as not working correctly but was OK before the above was fixed + y = x + call foo (y, 2) + + x%v = [1_4,2_4] + call foo (x, 3) + + y = x + call foo (y, 4) + +contains + + subroutine foo (arg, n) + type (any_vector) :: arg + integer :: n + select type (v => arg%v) + type is (character(*)) + if (any (v .ne. ["foo","bar"])) stop n + type is (integer(4)) + if (any (v .ne. [1_4,2_4])) stop n + end select + end subroutine +end Index: Fortran/gfortran/regression/unlimited_polymorphic_31.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_31.f03 @@ -0,0 +1,58 @@ +! { dg-do run } +! 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" } { "" } } */ +! +! Test the fix for PR92785, where the array passed to 'write scalar' was not +! normalised to LBOUND = 1. +! +! Contributed by +! + program tst + use iso_fortran_env, only : compiler_version, compiler_options + implicit none + integer :: i + integer :: ibad=0 + integer :: iarr(10) = [(i*10, i = 1,size (iarr))] + character(len=:), allocatable :: line + character(len=*), parameter :: expected = '10 20 30 40 50 60 70 80 90 100' + character(len=*), parameter :: expected_minus = '-10 -20 -30 -40 -50 -60 -70 -80 -90 -100' + print '(4a)', & + 'This file was compiled by ', compiler_version(), & + ' using the options ', compiler_options() + call write_row ('iarr ', iarr) ! pass in the array, OK + call write_row ('iarr+0 ', iarr+0) ! pass in an expression, NOT OK + call write_row ('-iarr ', -iarr) ! pass in an expression, NOT OK + call write_row ('iarr(::1) ', iarr(::1)) ! pass in the array, OK + call write_row ('[iarr(::1)] ', [iarr(::1)]) ! pass in compound constructor, NOT OK + call write_row ('[(i*10,i=1,size(iarr))]', [(i*10,i=1,size(iarr))]) ! pass in constructor, OK + call write_row ('10*[(i,i=1,size(iarr))]', 10*[(i,i=1,size(iarr))]) ! pass in constructor, OK + if (ibad .gt. 0) stop 1 + contains + subroutine write_scalar (g1) + class(*) :: g1 + character(len = 20) :: word + select type(g1) + type is (integer) + write (word, '(i0)') g1 + line = line // trim( word) // ' ' + end select + end subroutine write_scalar + subroutine write_row (string,array) + character(len = *) :: string + class(*) :: array(:) + integer :: i + line = '' + do i = 1, size (array) + call write_scalar (array(i)) + enddo + if (expected .eq. line) then + write (*, *) string, ':GOOD' + else if (expected_minus .eq. line) then + write (*, *) string, ':GOOD' + else + write (*, *) string, ':BAD. EXPECTED [', expected, '] got [', trim (line),']' + ibad = ibad + 1 + endif + end subroutine write_row + end program tst Index: Fortran/gfortran/regression/unlimited_polymorphic_32.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_32.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! Test the fix of the test case referenced in comment 17 of PR83118. +! +! Contributed by Damian Rouson +! + implicit none + type Wrapper + class(*), allocatable :: elements(:) + end type + type Mytype + real(4) :: r = 42.0 + end type + + call driver +contains + subroutine driver + class(*), allocatable :: obj + type(Wrapper) w + integer(4) :: expected4(2) = [42_4, 43_4] + integer(8) :: expected8(3) = [42_8, 43_8, 44_8] + + w = new_wrapper (expected4) + obj = w + call test (obj, 0) + obj = new_wrapper (expected8) ! Used to generate a linker error + call test (obj, 10) + obj = new_wrapper ([mytype (99.0)]) + call test (obj, 100) + obj = Mytype (42.0) ! Used to generate a linker error + call test (obj, 1000) + end subroutine + function new_wrapper(array) result (res) + class(*) :: array(:) + type(Wrapper) :: res + res%elements = array ! Used to runtime segfault + end function + subroutine test (arg, idx) + class(*) :: arg + integer :: idx + select type (arg) + type is (wrapper) + select type (z => arg%elements) + type is (integer(4)) + if (any (z .ne. [42_4, 43_4])) stop 1 + idx + type is (integer(8)) + if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx + type is (Mytype) + if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx + class default + stop 2 + idx + end select + type is (Mytype) + if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx + class default + stop 3 + idx + end select + end subroutine +end Index: Fortran/gfortran/regression/unlimited_polymorphic_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_32.f90 @@ -0,0 +1,254 @@ +implicit none +type t2 + integer :: x +end type t2 + +type, extends(t2) :: t2e + integer :: y +end type t2e + +type t + class(*), allocatable :: au, au2(:,:) + class(t2), allocatable :: at, at2(:,:) +end type t + +type(t), target :: var, var0, var2(4), var2a(4) +class(*), allocatable :: au, au2(:,:) +class(t2), allocatable :: at, at2(:,:) + + +if (same_type_as (var%au, var%at)) error stop 1 +if (same_type_as (var%au2, var%at)) error stop 2 +if (same_type_as (var%au, var%at)) error stop 3 +! Note: class(*) has no declared type, hence .false. +if (same_type_as (var%au, var0%au)) error stop 4 +if (same_type_as (var%au2, var0%au2)) error stop 5 +if (same_type_as (var%au, var0%au2)) error stop 6 +call c1(var%au, var%au, var%au2) + +if (.not.same_type_as (var%at, var%at)) error stop 7 +if (.not.same_type_as (var%at2, var%at)) error stop 8 +if (.not.same_type_as (var%at, var%at2)) error stop 9 +if (.not.extends_type_of (var%at, var%at)) error stop 10 +if (.not.extends_type_of (var%at2, var%at)) error stop 11 +if (.not.extends_type_of (var%at, var%at2)) error stop 12 +if (same_type_as (var%at, var0%au)) error stop 13 +if (same_type_as (var%at2, var0%au2)) error stop 14 +if (same_type_as (var%at, var0%au2)) error stop 15 +call c2(var%at, var%at, var%at2) + +if (same_type_as (au, var%at)) error stop 16 +if (same_type_as (au2, var%at)) error stop 17 +if (same_type_as (au, var%at)) error stop 18 +! Note: class(*) has no declared type, hence .false. +if (same_type_as (au, var0%au)) error stop 19 +if (same_type_as (au2, var0%au2)) error stop 20 +if (same_type_as (au, var0%au2)) error stop 21 +call c1(au, var%au, var%au2) + +if (.not.same_type_as (at, var%at)) error stop 22 +if (.not.same_type_as (at2, var%at)) error stop 23 +if (.not.same_type_as (at, var%at2)) error stop 24 +if (.not.extends_type_of (at, var%at)) error stop 25 +if (.not.extends_type_of (at2, var%at)) error stop 26 +if (.not.extends_type_of (at, var%at2)) error stop 27 +if (same_type_as (at, var0%au)) error stop 28 +if (same_type_as (at2, var0%au2)) error stop 29 +if (same_type_as (at, var0%au2)) error stop 30 +call c2(var%at, var%at, var%at2) + +if (same_type_as (var%au, at)) error stop 31 +if (same_type_as (var%au2, at)) error stop 32 +if (same_type_as (var%au, at)) error stop 33 +! Note: class(*) has no declared type, hence .false. +if (same_type_as (var%au, au)) error stop 34 +if (same_type_as (var%au2, au2)) error stop 35 +if (same_type_as (var%au, au2)) error stop 36 +call c1(var%au, var%au, au2) + +if (.not.same_type_as (var%at, at)) error stop 37 +if (.not.same_type_as (var%at2, at)) error stop 38 +if (.not.same_type_as (var%at, at2)) error stop 39 +if (.not.extends_type_of (var%at, at)) error stop 40 +if (.not.extends_type_of (var%at2, at)) error stop 41 +if (.not.extends_type_of (var%at, at2)) error stop 42 +if (same_type_as (var%at, au)) error stop 43 +if (same_type_as (var%at2, au2)) error stop 44 +if (same_type_as (var%at, au2)) error stop 45 +call c2(var%at, var%at, at2) + +allocate(t2e :: var0%at, var0%at2(4,4)) +allocate(t2 :: var0%au, var0%au2(4,4)) + +if (.not.same_type_as (var0%au, var%at)) error stop 46 +if (.not.same_type_as (var0%au2, var%at)) error stop 47 +if (.not.same_type_as (var0%au, var%at)) error stop 48 +if (.not.same_type_as (var0%au, var0%au2)) error stop 49 +if (.not.same_type_as (var0%au2, var0%au2)) error stop 50 +if (.not.same_type_as (var0%au, var0%au2)) error stop 51 +if (.not.extends_type_of (var0%au, var%at)) error stop 52 +if (.not.extends_type_of (var0%au2, var%at)) error stop 53 +if (.not.extends_type_of (var0%au, var%at)) error stop 54 +if (.not.extends_type_of (var0%au, var0%au2)) error stop 55 +if (.not.extends_type_of (var0%au2, var0%au2)) error stop 56 +if (.not.extends_type_of (var0%au, var0%au2)) error stop 57 + +if (.not.same_type_as (var0%au, at)) error stop 58 +if (.not.same_type_as (var0%au2, at)) error stop 59 +if (.not.same_type_as (var0%au, at2)) error stop 60 +if (.not.extends_type_of (var0%au, at)) error stop 61 +if (.not.extends_type_of (var0%au2, at)) error stop 62 +if (.not.extends_type_of (var0%au, at2)) error stop 63 + +if (same_type_as (var0%at, var%at)) error stop 64 +if (same_type_as (var0%at2, var%at)) error stop 65 +if (same_type_as (var0%at, var%at)) error stop 66 +if (same_type_as (var0%at, var0%au2)) error stop 67 +if (same_type_as (var0%at2, var0%au2)) error stop 68 +if (same_type_as (var0%at, var0%au2)) error stop 69 +if (.not.extends_type_of (var0%at, var%at)) error stop 70 +if (.not.extends_type_of (var0%at2, var%at)) error stop 71 +if (.not.extends_type_of (var0%at, var%at)) error stop 72 +if (.not.extends_type_of (var0%at, var0%au2)) error stop 73 +if (.not.extends_type_of (var0%at2, var0%au2)) error stop 74 +if (.not.extends_type_of (var0%at, var0%au2)) error stop 75 + +if (same_type_as (var0%at, at)) error stop 76 +if (same_type_as (var0%at2, at)) error stop 77 +if (same_type_as (var0%at, at2)) error stop 78 +if (.not.extends_type_of (var0%at, at)) error stop 79 +if (.not.extends_type_of (var0%at2, at)) error stop 80 +if (.not.extends_type_of (var0%at, at2)) error stop 81 + +call c3(var0%au, var0%au2, var0%at, var0%at2) +call c4(var0%au, var0%au2, var0%at, var0%at2) + +contains + subroutine c1(x, y, z) + class(*) :: x, y(..), z(..) + if (same_type_as (x, var0%at)) error stop 82 + if (same_type_as (y, var0%at)) error stop 83 + if (same_type_as (z, var0%at)) error stop 84 + if (same_type_as (x, var%au)) error stop 85 + if (same_type_as (y, var%au2)) error stop 86 + if (same_type_as (z, var%au2)) error stop 87 + + if (same_type_as (x, at)) error stop 88 + if (same_type_as (y, at)) error stop 89 + if (same_type_as (z, at)) error stop 90 + if (same_type_as (x, au)) error stop 91 + if (same_type_as (y, au2)) error stop 92 + if (same_type_as (z, au2)) error stop 93 + end + + subroutine c2(x, y, z) + class(*) :: x, y(..), z(..) + if (.not.same_type_as (x, var0%at)) error stop 94 + if (.not.same_type_as (y, var0%at)) error stop 95 + if (.not.same_type_as (z, var0%at)) error stop 96 + if (.not.extends_type_of (x, var0%at)) error stop 97 + if (.not.extends_type_of (y, var0%at)) error stop 98 + if (.not.extends_type_of (z, var0%at)) error stop 99 + if (same_type_as (x, var%au)) error stop 100 + if (same_type_as (y, var%au2)) error stop 101 + if (same_type_as (z, var%au2)) error stop 102 + + if (.not.same_type_as (x, at)) error stop 103 + if (.not.same_type_as (y, at)) error stop 104 + if (.not.same_type_as (z, at)) error stop 105 + if (.not.extends_type_of (x, at)) error stop 106 + if (.not.extends_type_of (y, at)) error stop 107 + if (.not.extends_type_of (z, at)) error stop 108 + if (same_type_as (x, au)) error stop 109 + if (same_type_as (y, au2)) error stop 110 + if (same_type_as (z, au2)) error stop 111 + end + + subroutine c3(mau, mau2, mat, mat2) + class(*) :: mau, mau2(:,:), mat, mat2(:,:) + + if (.not.same_type_as (mau, var%at)) error stop 112 + if (.not.same_type_as (mau2, var%at)) error stop 113 + if (.not.same_type_as (mau, var%at)) error stop 114 + if (.not.same_type_as (mau, var0%au2)) error stop 115 + if (.not.same_type_as (mau2, var0%au2)) error stop 116 + if (.not.same_type_as (mau, var0%au2)) error stop 117 + if (.not.extends_type_of (mau, var%at)) error stop 118 + if (.not.extends_type_of (mau2, var%at)) error stop 119 + if (.not.extends_type_of (mau, var%at)) error stop 120 + if (.not.extends_type_of (mau, var0%au2)) error stop 121 + if (.not.extends_type_of (mau2, var0%au2)) error stop 122 + if (.not.extends_type_of (mau, var0%au2)) error stop 123 + + if (.not.same_type_as (mau, at)) error stop 124 + if (.not.same_type_as (mau2, at)) error stop 125 + if (.not.same_type_as (mau, at2)) error stop 126 + if (.not.extends_type_of (mau, at)) error stop 127 + if (.not.extends_type_of (mau2, at)) error stop 128 + if (.not.extends_type_of (mau, at2)) error stop 129 + + if (same_type_as (mat, var%at)) error stop 130 + if (same_type_as (mat2, var%at)) error stop 131 + if (same_type_as (mat, var%at)) error stop 132 + if (same_type_as (mat, var0%au2)) error stop 133 + if (same_type_as (mat2, var0%au2)) error stop 134 + if (same_type_as (mat, var0%au2)) error stop 135 + if (.not.extends_type_of (mat, var%at)) error stop 136 + if (.not.extends_type_of (mat2, var%at)) error stop 137 + if (.not.extends_type_of (mat, var%at)) error stop 138 + if (.not.extends_type_of (mat, var0%au2)) error stop 139 + if (.not.extends_type_of (mat2, var0%au2)) error stop 140 + if (.not.extends_type_of (mat, var0%au2)) error stop 141 + + if (same_type_as (mat, at)) error stop 142 + if (same_type_as (mat2, at)) error stop 143 + if (same_type_as (mat, at2)) error stop 144 + if (.not.extends_type_of (mat, at)) error stop 145 + if (.not.extends_type_of (mat2, at)) error stop 147 + if (.not.extends_type_of (mat, at2)) error stop 148 + end + + subroutine c4(mau, mau2, mat, mat2) + class(*) :: mau(..), mau2(..), mat(..), mat2(..) + + if (.not.same_type_as (mau, var%at)) error stop 149 + if (.not.same_type_as (mau2, var%at)) error stop 150 + if (.not.same_type_as (mau, var%at)) error stop 151 + if (.not.same_type_as (mau, var0%au2)) error stop 152 + if (.not.same_type_as (mau2, var0%au2)) error stop 153 + if (.not.same_type_as (mau, var0%au2)) error stop 154 + if (.not.extends_type_of (mau, var%at)) error stop 155 + if (.not.extends_type_of (mau2, var%at)) error stop 156 + if (.not.extends_type_of (mau, var%at)) error stop 157 + if (.not.extends_type_of (mau, var0%au2)) error stop 158 + if (.not.extends_type_of (mau2, var0%au2)) error stop 159 + if (.not.extends_type_of (mau, var0%au2)) error stop 160 + + if (.not.same_type_as (mau, at)) error stop 161 + if (.not.same_type_as (mau2, at)) error stop 162 + if (.not.same_type_as (mau, at2)) error stop 163 + if (.not.extends_type_of (mau, at)) error stop 164 + if (.not.extends_type_of (mau2, at)) error stop 165 + if (.not.extends_type_of (mau, at2)) error stop 166 + + if (same_type_as (mat, var%at)) error stop 167 + if (same_type_as (mat2, var%at)) error stop 168 + if (same_type_as (mat, var%at)) error stop 169 + if (same_type_as (mat, var0%au2)) error stop 170 + if (same_type_as (mat2, var0%au2)) error stop 171 + if (same_type_as (mat, var0%au2)) error stop 172 + if (.not.extends_type_of (mat, var%at)) error stop 173 + if (.not.extends_type_of (mat2, var%at)) error stop 174 + if (.not.extends_type_of (mat, var%at)) error stop 175 + if (.not.extends_type_of (mat, var0%au2)) error stop 176 + if (.not.extends_type_of (mat2, var0%au2)) error stop 178 + if (.not.extends_type_of (mat, var0%au2)) error stop 179 + + if (same_type_as (mat, at)) error stop 180 + if (same_type_as (mat2, at)) error stop 181 + if (same_type_as (mat, at2)) error stop 182 + if (.not.extends_type_of (mat, at)) error stop 183 + if (.not.extends_type_of (mat2, at)) error stop 184 + if (.not.extends_type_of (mat, at2)) error stop 185 + end +end Index: Fortran/gfortran/regression/unlimited_polymorphic_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_33.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/101349 - ICE in gfc_get_descriptor_field +! Check constraint F2008:C628 / F2018:C932 + +subroutine s(x) + class(*) :: x(:) + allocate (x, source=['abc']) ! { dg-error "must be ALLOCATABLE or a POINTER" } +end + +subroutine t(x) + class(*), allocatable :: x(:) + allocate (x, source=['abc']) +end + +subroutine u(x) + class(*), pointer :: x(:) + allocate (x, source=['abc']) +end Index: Fortran/gfortran/regression/unlimited_polymorphic_4.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_4.f03 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! Fix PR55763 +! Contributed by Tobias Burnus +! +module mpi_f08_f + implicit none + abstract interface + subroutine user_function( inoutvec ) + class(*), dimension(:), intent(inout) :: inoutvec + end subroutine user_function + end interface +end module + +module mod_test1 + use mpi_f08_f + implicit none +contains + subroutine my_function( invec ) ! { dg-error "no IMPLICIT type" } + class(*), dimension(:), intent(inout) :: inoutvec ! { dg-error "not a DUMMY" } + + select type (inoutvec) + type is (integer) + inoutvec = 2*inoutvec + end select + end subroutine my_function +end module + +module mod_test2 + use mpi_f08_f + implicit none +contains + subroutine my_function( inoutvec ) ! Used to produce a BOGUS ERROR + class(*), dimension(:), intent(inout) :: inoutvec + + select type (inoutvec) + type is (integer) + inoutvec = 2*inoutvec + end select + end subroutine my_function +end module Index: Fortran/gfortran/regression/unlimited_polymorphic_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_5.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/55763 +! +! Based on Reinhold Bader's test case +! + +program mvall_03 + implicit none + integer, parameter :: n1 = 100, n2 = 200 + class(*), allocatable :: i1(:), i3(:) + integer, allocatable :: i2(:) + + allocate(real :: i1(n1)) + allocate(i2(n2)) + i2 = 2 + call move_alloc(i2, i1) + if (size(i1) /= n2 .or. allocated(i2)) then + STOP 1 +! write(*,*) 'FAIL' + else +! write(*,*) 'OK' + end if + + select type (i1) + type is (integer) + if (any (i1 /= 2)) STOP 2 + class default + STOP 1 + end select + call move_alloc (i1, i3) + if (size(i3) /= n2 .or. allocated(i1)) then + STOP 2 + end if + select type (i3) + type is (integer) + if (any (i3 /= 2)) STOP 3 + class default + STOP 3 + end select +end program Index: Fortran/gfortran/regression/unlimited_polymorphic_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_6.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR fortran/55763 +! +! Contributed by Reinhold Bader +! +module mod_alloc_scalar_01 +contains + subroutine construct(this) + class(*), allocatable, intent(out) :: this + integer :: this_i + this_i = 4 + allocate(this, source=this_i) + end subroutine +end module + +program alloc_scalar_01 + use mod_alloc_scalar_01 + implicit none + class(*), allocatable :: mystuff + + call construct(mystuff) + call construct(mystuff) + + select type(mystuff) + type is (integer) + if (mystuff == 4) then +! write(*,*) 'OK' + else + STOP 1 +! write(*,*) 'FAIL 1' + end if + class default + STOP 2 +! write(*,*) 'FAIL 2' + end select +end program Index: Fortran/gfortran/regression/unlimited_polymorphic_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/55763 +! +! Contributed by Harald Anlauf +! + +module gfcbug121 + implicit none + type myobj + class(*), allocatable :: x + contains + procedure :: print + end type myobj +contains + subroutine print(this) + class(myobj) :: this + end subroutine print +end module gfcbug121 Index: Fortran/gfortran/regression/unlimited_polymorphic_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_8.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/55854 +! +! Contributed by Damian Rouson +! + + type foo + class(*), allocatable :: x + end type +contains + subroutine bar(this) + type(foo), intent(out) :: this + end +end + +! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__STAR;" 1 "original" } } Index: Fortran/gfortran/regression/unlimited_polymorphic_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unlimited_polymorphic_9.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 57639: [OOP] ICE with polymorphism (and illegal code) +! +! Contributed by Walter Spector + + implicit none + + class(*) :: t1, t2 ! { dg-error "must be dummy, allocatable or pointer" } + + print *, 'main: compare = ', compare (t1, t2) + print *, SAME_TYPE_AS (t1, t2) + +contains + + logical function compare (a, b) + class(*), intent(in), allocatable :: a, b + end function + +end Index: Fortran/gfortran/regression/unpack_bounds_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_bounds_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(2)) + allocate (mask(2,2)) + allocate (res(2,1)) + + vector = 1 + mask = reshape((/ .TRUE., .FALSE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, 0) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" } Index: Fortran/gfortran/regression/unpack_bounds_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_bounds_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(2)) + allocate (mask(2,2)) + allocate (res(2,2)) + + vector = 1 + mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, 0) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } Index: Fortran/gfortran/regression/unpack_bounds_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_bounds_3.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size of return value in UNPACK intrinsic: should be at least 3, is 2" } +program main + integer, allocatable, dimension(:) :: vector + integer, allocatable, dimension(:,:) :: res + integer, allocatable, dimension(:,:) :: field + logical, allocatable, dimension(:,:) :: mask + + allocate (vector(3)) + allocate (mask(2,2)) + allocate (res(2,2)) + allocate (field(3,2)) + + vector = 1 + field = 0 + mask = reshape((/ .TRUE., .TRUE., .FALSE., .TRUE. /),(/2,2/)) + res = unpack(vector, mask, field) + print *,res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in FIELD of UNPACK intrinsic in dimension 1: is 3, should be 2" } Index: Fortran/gfortran/regression/unpack_field_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_field_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/107922 - ICE in gfc_simplify_unpack +! Test error recovery when shapes of FIELD and MASK do not match +! Contributed by G.Steinmetz + +program p + integer, parameter :: a(2) = 1 + integer, parameter :: d(3) = 1 + logical, parameter :: mask(3) = [.false.,.true.,.false.] + integer, parameter :: b(2) = unpack(a,mask,a) ! { dg-error "must have identical shape" } + integer :: c(3) = unpack(a,[.false.,.true.,.false.],a) ! { dg-error "must have identical shape" } + print *, unpack(a,mask,a) ! { dg-error "must have identical shape" } + print *, unpack(a,mask,d) ! OK + print *, unpack(a,mask,3) ! OK +end Index: Fortran/gfortran/regression/unpack_init_expr.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_init_expr.f03 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! Example from F2003, sec 13.7.125 +! + INTEGER, PARAMETER :: m(3,3) = RESHAPE ([1,0,0,0,1,0,0,0,1], [3,3]) + INTEGER, PARAMETER :: v(3) = [1,2,3] + LOGICAL, PARAMETER :: F = .FALSE., T = .TRUE. + LOGICAL, PARAMETER :: q(3,3) = RESHAPE ([F,T,F,T,F,F,F,F,T], [3,3]) + + INTEGER, PARAMETER :: r1(3,3) = UNPACK (V, MASK=Q, FIELD=M) + INTEGER, PARAMETER :: r2(3,3) = UNPACK (V, MASK=Q, FIELD=0) + + IF (ANY (r1 /= RESHAPE ([1,1,0,2,1,0,0,0,3], [3,3]))) STOP 1 + IF (ANY (r2 /= RESHAPE ([0,1,0,2,0,0,0,0,3], [3,3]))) STOP 2 +END Index: Fortran/gfortran/regression/unpack_mask_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_mask_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 32731 - upack lacked conversion for kind=1 and kind=2 mask +program main + implicit none + character(len=80) line + logical(kind=1),dimension(2,2) :: mask1 + logical(kind=1),dimension(2,2) :: mask2 + mask1 = .true. + mask2 = .true. + write(unit=line,fmt='(4I4)') unpack((/1,2,3,4/),mask1,0) + write(unit=line,fmt='(4I4)') unpack((/1,2,3,4/),mask2,0) +end program main Index: Fortran/gfortran/regression/unpack_vector_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_vector_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/105813 +! Fix checking of VECTOR argument to UNPACK when MASK is a variable. +! Contributed by G.Steinmetz + +program p + logical, parameter :: mask(2,2) = reshape ([.true., .true., & + .false., .true.], & + shape (mask)) + print *, unpack ([1,2,3], mask, 0) ! OK + print *, unpack ([1,2], mask, 0) ! { dg-error "must provide at least" } +end Index: Fortran/gfortran/regression/unpack_zerosize_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unpack_zerosize_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 32217 - unpack used to crash at runtime with a zero-sized +! array. Test case submitted by Jaroslav Hajek. +program bug_report + implicit none + integer,parameter:: rp = kind(1.d0),na = 6 + real(rp),allocatable:: hhe(:,:,:),hhc(:,:,:),dv(:) + integer:: nhh,ndv + nhh = 0 + allocate(hhe(nhh,2,2)) + ndv = 2*na + count(hhe /= 0) + allocate(hhc(nhh,2,2),dv(ndv)) + hhc = unpack(dv(2*na+1:),hhe /= 0._rp,0._rp) +end program bug_report Index: Fortran/gfortran/regression/unreferenced_use_assoc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unreferenced_use_assoc_1.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the fix for PR31424. +! +module InternalCompilerError + + type Byte + private + character(len=1) :: singleByte + end type + + type (Byte) :: BytesPrototype(1) + + type UserType + real :: r + end type + +contains + + function UserTypeToBytes(user) result (bytes) + type(UserType) :: user + type(Byte) :: bytes(size(transfer(user, BytesPrototype))) + bytes = transfer(user, BytesPrototype) + end function + + subroutine DoSomethingWithBytes(bytes) + type(Byte), intent(in) :: bytes(:) + end subroutine + +end module + + +program main + use InternalCompilerError + type (UserType) :: user + + ! The following line caused the ICE + call DoSomethingWithBytes( UserTypeToBytes(user) ) + +end program Index: Fortran/gfortran/regression/unresolved_fixup_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unresolved_fixup_1.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR fortran/58007 +! Unresolved fixup while loading a module. +! +! This tests that the specification expression A%MAX_DEGREE in module BSR is +! correctly loaded and resolved in program MAIN. +! +! Original testcase from Daniel Shapiro +! Reduced by Tobias Burnus and Janus Weil + +module matrix + type :: sparse_matrix + integer :: max_degree + end type +contains + subroutine init_interface (A) + class(sparse_matrix), intent(in) :: A + end subroutine + real function get_value_interface() + end function +end module + +module ellpack + use matrix +end module + +module bsr + use matrix + type, extends(sparse_matrix) :: bsr_matrix + contains + procedure :: get_neighbors + end type +contains + function get_neighbors (A) + class(bsr_matrix), intent(in) :: A + integer :: get_neighbors(A%max_degree) + end function +end module + +program main + use ellpack + use bsr +end Index: Fortran/gfortran/regression/unresolved_fixup_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unresolved_fixup_2.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/58007 +! Unresolved fiixup while loading a module. +! +! This tests that the specification expression A%MAX_DEGREE in module BSR is +! correctly loaded and resolved in program MAIN. +! +! Original testcase from Daniel Shapiro + +module matrix + type :: sparse_matrix + integer :: max_degree + end type +end module + +module bsr + use matrix + + type, extends(sparse_matrix) :: bsr_matrix + end type + + integer :: i1 + integer :: i2 + integer :: i3 +contains + function get_neighbors (A) + type(bsr_matrix), intent(in) :: A + integer :: get_neighbors(A%max_degree) + end function +end module + +program main + use matrix + use bsr +end Index: Fortran/gfortran/regression/unused_artificial_dummies_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/unused_artificial_dummies_1.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-Wunused-variable -Wunused-parameter" } +! This tests the fix for PR18111 in which some artificial declarations +! were being listed as unused parameters: +! (i) Array dummies, where a copy is made; +! (ii) The dummies of "entry thunks" (ie. the articial procedures that +! represent ENTRYs and call the "entry_master" function; and +! (iii) The __entry parameter of the entry_master function, which +! indentifies the calling entry thunk. +! All of these have DECL_ARTIFICIAL (tree) set. +! +! Contributed by Paul Thomas +! +module foo + implicit none +contains + +!This is the original problem + + subroutine bar(arg1, arg2, arg3, arg4, arg5) + character(len=80), intent(in) :: arg1 + character(len=80), dimension(:), intent(in) :: arg2 + integer, dimension(arg4), intent(in) :: arg3 + integer, intent(in) :: arg4 + character(len=arg4), intent(in) :: arg5 + print *, arg1, arg2, arg3, arg4, arg5 + end subroutine bar + +! This ICED with the first version of the fix because gfc_build_dummy_array_decl +! sometimes NULLS sym->backend_decl; taken from aliasing_dummy_1.f90 + + subroutine foo1 (slist, i) + character(*), dimension(*) :: slist + integer i + write (slist(i), '(2hi=,i3)') i + end subroutine foo1 + +! This tests the additions to the fix that prevent the dummies of entry thunks +! and entry_master __entry parameters from being listed as unused. + + function f1 (a) + integer, dimension (2, 2) :: a, b, f1, e1 + f1 (:, :) = 15 + a + return + entry e1 (b) + e1 (:, :) = 42 + b + end function + +end module foo Index: Fortran/gfortran/regression/use_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_1.f90 @@ -0,0 +1,8 @@ + ! { dg-do compile } + ! { dg-options "-ffixed-form" } + module foo + end module foo + + subroutine bar1 + usefoo + end Index: Fortran/gfortran/regression/use_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_10.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +module a + implicit none +interface operator(.op.) + module procedure sub +end interface +interface operator(.ops.) + module procedure sub2 +end interface + +contains + function sub(i) + integer :: sub + integer,intent(in) :: i + sub = -i + end function sub + function sub2(i) + integer :: sub2 + integer,intent(in) :: i + sub2 = i + end function sub2 +end module a + +program test +use a, only: operator(.op.), operator(.op.), & +operator(.my.)=>operator(.op.),operator(.ops.)=>operator(.op.) +implicit none +if (.my.2 /= -2 .or. .op.3 /= -3 .or. .ops.7 /= -7) STOP 1 +end Index: Fortran/gfortran/regression/use_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_11.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Test the fix for a regression caused by the fix for PR33541, +! in which the second local version of a would not be associated. +! +! Contributed by Dominique d'Humieres +! and Tobias Burnus +! +module m + integer :: a +end module m + +use m, local1 => a +use m, local2 => a +local1 = 5 +local2 = 3 +if (local1 .ne. local2) STOP 1 +end Index: Fortran/gfortran/regression/use_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_12.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Wreturn-type" } +! Tests the fix of PR34545, in which the 'numclusters' that determines the size +! of fnres was not properly associated. +! +! Reported by Jon D. Richards +! +module m1 + integer :: numclusters = 2 +end module m1 + +module m2 + contains + function get_nfirst( ) result(fnres) ! { dg-warning "not set" } + use m1, only: numclusters + real :: fnres(numclusters) ! change to REAL and it works!! + end function get_nfirst +end module m2 + +program kmeans_driver + use m1 + use m2 + integer :: nfirst(3) + nfirst(1:numclusters) = get_nfirst( ) +end program kmeans_driver Index: Fortran/gfortran/regression/use_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_13.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR fortran/44360 +! +! Test-case based on a contribution of Vittorio Zecca. +! +! The used subroutine was not the use-associated but the host associated one! +! The use-associated function/variable were already working properly. +! +module m + integer :: var = 43 +contains + integer function fun() + fun = 42 + end function fun + subroutine fun2() + var = 44 + end subroutine fun2 +end module m + +module m2 + integer :: var = -2 +contains + subroutine test() + ! All procedures/variables below refer to the ones in module "m" + ! and not to the siblings in this module "m2". + use m + if (fun() /= 42) STOP 1 + if (var /= 43) STOP 2 + call fun2() + if (var /= 44) STOP 3 + end subroutine test + integer function fun() + STOP 4 + fun = -3 + end function fun + subroutine fun2() + STOP 5 + end subroutine fun2 +end module m2 + +use m2 +call test() +end Index: Fortran/gfortran/regression/use_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_14.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/34657 +! +module test_mod +interface + subroutine my_sub (a) + real a + end subroutine +end interface +end module + +subroutine my_sub (a) + use test_mod, gugu => my_sub + real a + print *, a +end subroutine + +END Index: Fortran/gfortran/regression/use_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_15.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR fortran/34657 +! +module test_mod +interface + subroutine my_sub (a) + real a + end subroutine +end interface +end module + +subroutine my_sub (a) + use test_mod ! { dg-error "is also the name of the current program unit" } + real a + print *, a +end subroutine + + +module test_mod2 + integer :: my_sub2 +end module + +subroutine my_sub2 (a) + use test_mod2 ! { dg-error "is also the name of the current program unit" } + real a + print *, a +end subroutine + + +subroutine my_sub3 (a) ! { dg-error "\(1\)" } + use test_mod2, my_sub3 => my_sub2 ! { dg-error "conflicts with the rename" } + real a + print *, a +end subroutine + +END ! { dg-error "is an ambiguous reference" } Index: Fortran/gfortran/regression/use_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_16.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/31600 +! +module a +implicit none +contains + integer function bar() + bar = 42 + end function +end module a + +use a ! { dg-error "Symbol 'bar' at \\(1\\) conflicts with symbol from module 'a'" } +implicit none +integer :: bar ! { dg-error "Symbol 'bar' at \\(1\\) conflicts with symbol from module 'a'" } +end Index: Fortran/gfortran/regression/use_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_17.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR fortran/51578 +! +! Contributed by Billy Backer +! +! Check that indict importing of the symbol "axx" works +! even if renaming prevent the direct import. +! +module mod1 +integer :: axx=2 +end module mod1 + +module mod2 +use mod1 +end module mod2 + +subroutine sub1 +use mod1, oxx=>axx +use mod2 +implicit none +print*,axx ! Valid - was working before +end subroutine sub1 + +subroutine sub2 +use mod2 +use mod1, oxx=>axx +implicit none +print*,axx ! Valid - was failing before +end subroutine sub2 + +subroutine test1 + use :: iso_c_binding + use, intrinsic :: iso_c_binding, only: c_double_orig => c_double + integer :: c_double + integer, parameter :: p1 = c_int, p2 = c_double_orig +end subroutine test1 Index: Fortran/gfortran/regression/use_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_18.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/51816 +! +! Contributed by Harald Anlauf +! +module foo + implicit none + type t + integer :: i + end type t + interface operator (*) + module procedure mult + end interface +contains + function mult (i, j) + type(t), intent(in) :: i, j + integer :: mult + mult = i%i * j%i + end function mult +end module foo + +module bar + implicit none + type t2 + integer :: i + end type t2 + interface operator (>) + module procedure gt + end interface +contains + function gt (i, j) + type(t2), intent(in) :: i, j + logical :: gt + gt = i%i > j%i + end function gt +end module bar + +use bar, only : t2, operator(>) , operator(>) +use foo, only : t +use foo, only : operator (*) +use foo, only : t +use foo, only : operator (*) +implicit none +type(t) :: i = t(1), j = t(2) +type(t2) :: k = t2(1), l = t2(2) +print *, i*j +print *, k > l +end Index: Fortran/gfortran/regression/use_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_19.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR fortran/51816 +! +module m +end module m + +use m, only: operator(/) ! { dg-error "Intrinsic operator '/' referenced at .1. not found in module 'm'" } +end Index: Fortran/gfortran/regression/use_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_2.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +subroutine bar1 + usefoo ! { dg-error "Unclassifiable statement" } +end Index: Fortran/gfortran/regression/use_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_20.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR fortran/51809 +! +! Contributed by Kacper Kowalik +! +module foo + implicit none + + type foo_t + contains + procedure :: func_foo + end type foo_t + +contains + + subroutine func_foo(this) + implicit none + class(foo_t), intent(in) :: this + end subroutine func_foo + +end module foo + +module bar + use foo, only: foo_t + + implicit none + + type, extends(foo_t) :: bar_t + contains + procedure :: func_bar + end type bar_t + +contains + + subroutine func_bar(this) + use foo, only: foo_t ! <--- removing this line also fixes ICE + implicit none + class(bar_t), intent(in) :: this + end subroutine func_bar + +end module bar + +module merry_ICE + use foo, only: foo_t ! <------ change order to prevent ICE + use bar, only: bar_t ! <------ change order to prevent ICE +end module merry_ICE Index: Fortran/gfortran/regression/use_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_21.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/51056 +! +! Contributed by Kacper Kowalik +! +module domain + implicit none + private + public :: domain_container, dom + + type :: domain_container + integer :: D_x !< set to 1 when x-direction exists, 0 otherwise + contains + procedure :: init => init_domain_container + end type domain_container + + type(domain_container) :: dom + + contains + subroutine init_domain_container(this) + implicit none + class(domain_container), intent(inout) :: this + this%D_x = 0 + end subroutine init_domain_container +end module domain + +program ala + use domain, only: dom + implicit none + call dom%init +end program ala Index: Fortran/gfortran/regression/use_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_22.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/55827 +! gfortran used to ICE with the call to `tostring' depending on how the +! `tostring' symbol was USE-associated. +! +! Contributed by Lorenz Hüdepohl + +module stringutils + interface + pure function strlen(handle) result(len) + integer, intent(in) :: handle + integer :: len + end function + end interface +end module +module intermediate ! does not die if this module is merged with stringutils + contains + function tostring(handle) result(string) + use stringutils + integer, intent(in) :: handle + character(len=strlen(handle)) :: string + end function +end module +module usage + contains + subroutine dies_here(handle) + use stringutils ! does not die if this unnecessary line is omitted or placed after "use intermediate" + use intermediate + integer :: handle + write(*,*) tostring(handle) ! ICE + end subroutine +end module + + Index: Fortran/gfortran/regression/use_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_23.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! PR fortran/42769 +! This test used to ICE in resolve_typebound_procedure because T1's GET +! procedure was wrongly associated to MOD2's MY_GET (instead of the original +! MOD1's MY_GET) in MOD3's SUB. +! +! Original testcase by Salvator Filippone +! Reduced by Janus Weil + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + logical function my_get() + end function +end module + +module mod2 +contains + logical function my_get() + end function +end module + +module mod3 +contains + subroutine sub(a) + use mod2, only: my_get + use mod1, only: t1 + type(t1) :: a + end subroutine +end module + + +use mod2, only: my_get +use mod3, only: sub +end + + + Index: Fortran/gfortran/regression/use_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_24.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/42769 +! The static resolution of A%GET used to be incorrectly simplified to MOD2's +! MY_GET instead of the original MOD1's MY_GET, depending on the order in which +! MOD1 and MOD2 were use-associated. +! +! Original testcase by Salvator Filippone +! Reduced by Janus Weil + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + subroutine my_get(i) + i = 2 + end subroutine +end module + +module mod2 +contains + subroutine my_get(i) ! must have the same name as the function in mod1 + i = 5 + end subroutine +end module + + + call test1() + call test2() + +contains + + subroutine test1() + use mod2 + use mod1 + type(t1) :: a + call a%get(j) + if (j /= 2) STOP 1 + end subroutine test1 + + subroutine test2() + use mod1 + use mod2 + type(t1) :: a + call a%get(j) + if (j /= 2) STOP 2 + end subroutine test2 +end + + + Index: Fortran/gfortran/regression/use_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_25.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! PR fortran/42769 +! This test used to be rejected because the typebound call A%GET was +! simplified to MY_GET which is an ambiguous name in the main program +! namespace. +! +! Original testcase by Salvator Filippone +! Reduced by Janus Weil + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + subroutine my_get() + print *,"my_get (mod1)" + end subroutine +end module + +module mod2 +contains + subroutine my_get() ! must have the same name as the function in mod1 + print *,"my_get (mod2)" + end subroutine +end module + + use mod2 + use mod1 + type(t1) :: a + call call_get + contains + subroutine call_get + call a%get() + end subroutine call_get +end + + Index: Fortran/gfortran/regression/use_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_26.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! PR fortran/45836 +! The B_TYPE_INSTANCE%SIZERETURN() typebound function used to be rejected on a +! type mismatch because the function was resolved to A's SIZERETURN instead of +! B's because of the ambiguity of the SIZERETURN name in the MAIN namespace. +! +! Original testcase by someone + +module A +implicit none + type :: a_type + private + integer :: size = 1 + contains + procedure :: sizeReturn + end type a_type + contains + function sizeReturn( a_type_ ) + implicit none + integer :: sizeReturn + class(a_type) :: a_type_ + + sizeReturn = a_type_%size + end function sizeReturn +end module A + +module B +implicit none + type :: b_type + private + integer :: size = 2 + contains + procedure :: sizeReturn + end type b_type + contains + function sizeReturn( b_type_ ) + implicit none + integer :: sizeReturn + class(b_type) :: b_type_ + + sizeReturn = b_type_%size + end function sizeReturn +end module B + +program main + + call test1 + call test2 + +contains + + subroutine test1 + use A + use B + implicit none + type(a_type) :: a_type_instance + type(b_type) :: b_type_instance + + print *, a_type_instance%sizeReturn() + print *, b_type_instance%sizeReturn() + end subroutine test1 + + subroutine test2 + use B + use A + implicit none + type(a_type) :: a_type_instance + type(b_type) :: b_type_instance + + print *, a_type_instance%sizeReturn() + print *, b_type_instance%sizeReturn() + end subroutine test2 +end program main + + Index: Fortran/gfortran/regression/use_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_27.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! +! PR fortran/45900 +! The BTYPEINSTANCE%CALLBACK() typebound call was resolved incorrectly to +! A's CALLBACK procedure instead of B's because the CALLBACK name is ambiguous +! in the MAIN namespace. +! +! Original testcase by someone + +module A +implicit none + type :: aType + contains + procedure :: callback + end type aType + contains + subroutine callback( callback_, i ) + implicit none + class(aType) :: callback_ + integer :: i + + i = 3 + end subroutine callback + + subroutine solver( callback_, i ) + implicit none + class(aType) :: callback_ + integer :: i + + call callback_%callback(i) + end subroutine solver +end module A + +module B +use A, only: aType +implicit none + type, extends(aType) :: bType + integer :: i + contains + procedure :: callback + end type bType + contains + subroutine callback( callback_, i ) + implicit none + class(bType) :: callback_ + integer :: i + + i = 7 + end subroutine callback +end module B + +program main + call test1() + call test2() + +contains + + subroutine test1 + use A + use B + implicit none + type(aType) :: aTypeInstance + type(bType) :: bTypeInstance + integer :: iflag + + bTypeInstance%i = 4 + + iflag = 0 + call bTypeInstance%callback(iflag) + if (iflag /= 7) STOP 1 + iflag = 1 + call solver( bTypeInstance, iflag ) + if (iflag /= 7) STOP 2 + + iflag = 2 + call aTypeInstance%callback(iflag) + if (iflag /= 3) STOP 3 + end subroutine test1 + + subroutine test2 + use B + use A + implicit none + type(aType) :: aTypeInstance + type(bType) :: bTypeInstance + integer :: iflag + + bTypeInstance%i = 4 + + iflag = 0 + call bTypeInstance%callback(iflag) + if (iflag /= 7) STOP 4 + iflag = 1 + call solver( bTypeInstance, iflag ) + if (iflag /= 7) STOP 5 + + iflag = 2 + call aTypeInstance%callback(iflag) + if (iflag /= 3) STOP 6 + end subroutine test2 +end program main + + Index: Fortran/gfortran/regression/use_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_28.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/47203 +! The USE statement of a module was not rejected in a procedure with the same +! name if the procedure was contained. +! +! Contributed by Tobias Burnus + +module m +end module m + +call m +contains + subroutine m() + use m ! { dg-error "is also the name of the current program unit" } + end subroutine m +end + Index: Fortran/gfortran/regression/use_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_29.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/57435 +! +! Contributed by Lorenz Hüdepohl +! +module precision +end module precision + contains + use precision ! { dg-error "Unexpected USE statement in CONTAINS section" } +module stressten_rt ! { dg-error "Unexpected MODULE statement in CONTAINS section" } + use precision ! { dg-error "Unexpected USE statement in CONTAINS section" } + implicit none ! { dg-error "Unexpected IMPLICIT NONE statement in CONTAINS section" } + +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/use_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +module foo +end module foo + + use foo + use :: foo + use, intrinsic iso_fortran_env ! { dg-error "\"::\" was expected after module nature" } + use, non_intrinsic iso_fortran_env ! { dg-error "\"::\" was expected after module nature" } + use, nonintrinsic :: iso_fortran_env ! { dg-error "shall be either INTRINSIC or NON_INTRINSIC" } + use, intrinsic :: iso_fortran_env +end Index: Fortran/gfortran/regression/use_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_30.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR53542 USE-associated variables shows original instead of renamed symbol name +! Contributed by Tobias Burnus +! +module select_precision + integer :: dp = kind(1.0) +end module select_precision + +module ode_types + use select_precision, only: wp => dp +contains + subroutine ode_derivative(x) + real(wp) :: x ! { dg-error "Parameter .wp. at .1. has not been declared" } + end subroutine ode_derivative +end module ode_types +end Index: Fortran/gfortran/regression/use_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/30973 +! Using symbols with the name of the module + +module foo + integer :: i +end module foo + +module bar + integer :: j +end module bar + +module test + use foo, only: + integer :: foo ! { dg-error "cannot have a type" } +end module test + +module test2 + use bar, only: foo => j + use foo ! ok, unless foo is accessed +end module test2 + +module test3 + use bar, only: foo => j + use foo ! ok, unless foo is accessed + foo = 5 ! { dg-error "is an ambiguous reference to 'j'" } +end module test3 + +program test_foo + use foo, only: foo ! { dg-error "been used as an external module name" } + use foo, only: i => foo! { dg-error "been used as an external module name" } + use foo, only: foo => i! { dg-error "been used as an external module name" } +end program Index: Fortran/gfortran/regression/use_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_5.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Renaming of operators +module z + interface operator(.addfive.) + module procedure sub2 + end interface +contains +function sub2(x) + integer :: sub + integer,intent(in) :: x + sub2 = x + 5 +end function sub2 +end module z + +module y + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 15 +end function sub +end module y + +module x + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 25 +end function sub +end module x + +use x, only : operator(.bar.) => operator(.addfive.) +use y, operator(.my.) => operator(.addfive.) +use z + integer :: i + i = 2 + if ((.bar. i) /= 2+25) STOP 1 + if ((.my. i) /= 2+15) STOP 2 + if ((.addfive. i) /= 2+5) STOP 3 +end Index: Fortran/gfortran/regression/use_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_6.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Renaming of operators +module z + interface operator(.addfive.) + module procedure sub2 + end interface +contains +function sub2(x) + integer :: sub + integer,intent(in) :: x + sub2 = x + 5 +end function sub2 +end module z + +module y + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 15 +end function sub +end module y + +module x + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 25 +end function sub +end module x + +use x, only : operator(.bar.) => operator(.addfive.) ! { dg-error "Fortran 2003: Renaming operators in USE statements" } +use y, operator(.my.) => operator(.addfive.) ! { dg-error "Fortran 2003: Renaming operators in USE statements" } +use z +end Index: Fortran/gfortran/regression/use_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_7.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Renaming of operators +module z + type myT + integer :: t + end type myT + interface operator(+) + module procedure sub2 + end interface +contains +function sub2(x) + type(myT) :: sub2 + type(myT),intent(in) :: x + sub2%t = x%t + 5 +end function sub2 +end module z + +module y + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 15 +end function sub +end module y + +module x + interface operator(.addfive.) + module procedure sub + end interface +contains +function sub(x) + integer :: sub + integer,intent(in) :: x + sub = x + 25 +end function sub +end module x + +use z, operator(-) => operator(+) ! { dg-error "Syntax error in USE statement" } +use z, operator(.op.) => operator(+) ! { dg-error "Syntax error in USE statement" } +use x, only : bar => operator(.addfive.) ! { dg-error "Syntax error in USE statement" } +use y, operator(.my.) => sub ! { dg-error "Syntax error in USE statement" } +use y, operator(+) => operator(.addfive.) ! { dg-error "Syntax error in USE statement" } +end Index: Fortran/gfortran/regression/use_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_8.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +module a + + type, private, bind(C) b ! { dg-error "Expected :: in TYPE definition" } + integer i + end type b ! { dg-error "Expecting END MODULE statement" } + + type, public c ! { dg-error "Expected :: in TYPE definition" } + integer j + end type c ! { dg-error "Expecting END MODULE statement" } + + type, private d ! { dg-error "Expected :: in TYPE definition" } + integer k + end type b ! { dg-error "Expecting END MODULE statement" } + + type, bind(C), public e ! { dg-error "Expected :: in TYPE definition" } + integer l + end type e ! { dg-error "Expecting END MODULE statement" } + + type, bind(C) f ! { dg-error "Expected :: in TYPE definition" } + integer m + end type f ! { dg-error "Expecting END MODULE statement" } + +end module a Index: Fortran/gfortran/regression/use_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_9.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +module test + interface operator(.bar.) + module procedure func + end interface +contains +function func(a) + integer,intent(in) :: a + integer :: funct + func = a+1 +end function +end module test + +use test, only: operator(.func.) ! { dg-error "not found in module 'test'" } +end Index: Fortran/gfortran/regression/use_allocated_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_allocated_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR17678 +! We were incorrectly setting use-associated variables to unallocated +! on procedure entry. +module foo + integer, dimension(:), allocatable :: bar +end module + +program main + use foo + allocate (bar(10)) + call init +end program main + +subroutine init + use foo + if (.not.allocated(bar)) STOP 1 +end subroutine init Index: Fortran/gfortran/regression/use_iso_c_binding.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_iso_c_binding.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! this is to simply test that the various ways the use statement can +! appear are handled by the compiler, since i did a special treatment +! of the intrinsic iso_c_binding module. note: if the user doesn't +! provide the 'intrinsic' keyword, the compiler will check for a user +! provided module by the name of iso_c_binding before using the +! intrinsic one. --Rickett, 09.26.06 +module use_stmt_0 + ! this is an error because c_ptr_2 does not exist + use, intrinsic :: iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) not found" } +end module use_stmt_0 + +module use_stmt_1 + ! this is an error because c_ptr_2 does not exist + use iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) not found" } +end module use_stmt_1 + +module use_stmt_2 + ! works fine + use, intrinsic :: iso_c_binding, only: c_ptr +end module use_stmt_2 + +module use_stmt_3 + ! works fine + use iso_c_binding, only: c_ptr +end module use_stmt_3 + +module use_stmt_4 + ! works fine + use, intrinsic :: iso_c_binding +end module use_stmt_4 + +module use_stmt_5 + ! works fine + use iso_c_binding +end module use_stmt_5 + +module use_stmt_6 + ! hmm, is this an error? if so, it's not being caught... + ! --Rickett, 09.13.06 + use, intrinsic :: iso_c_binding, only: c_int, c_int +end module use_stmt_6 + +module use_stmt_7 + ! hmm, is this an error? if so, it's not being caught... + ! --Rickett, 09.13.06 + use iso_c_binding, only: c_int, c_int +end module use_stmt_7 Index: Fortran/gfortran/regression/use_only_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_1.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! { dg-options "-O1" } +! Checks the fix for PR33541, in which a requirement of +! F95 11.3.2 was not being met: The local names 'x' and +! 'y' coming from the USE statements without an ONLY clause +! should not survive in the presence of the locally renamed +! versions. In fixing the PR, the same correction has been +! made to generic interfaces. +! +! Reported by Reported by John Harper in +! http://gcc.gnu.org/ml/fortran/2007-09/msg00397.html +! +MODULE xmod + integer(4) :: x = -666 + private foo, bar + interface xfoobar + module procedure foo, bar + end interface +contains + integer function foo () + foo = 42 + end function + integer function bar (a) + integer a + bar = a + end function +END MODULE xmod + +MODULE ymod + integer(4) :: y = -666 + private foo, bar + interface yfoobar + module procedure foo, bar + end interface +contains + integer function foo () + foo = 42 + end function + integer function bar (a) + integer a + bar = a + end function +END MODULE ymod + + integer function xfoobar () ! These function as defaults should... + xfoobar = 99 + end function + + integer function yfoobar () ! ...the rename works correctly. + yfoobar = 99 + end function + +PROGRAM test2uses + implicit integer(2) (a-z) + x = 666 ! These assignments generate implicitly typed + y = 666 ! local variables 'x' and 'y'. + call test1 + call test2 + call test3 +contains + subroutine test1 ! Test the fix of the original PR + USE xmod + USE xmod, ONLY: xrenamed => x + USE ymod, ONLY: yrenamed => y + USE ymod + implicit integer(2) (a-z) + if (kind(xrenamed) == kind(x)) STOP 1 + if (kind(yrenamed) == kind(y)) STOP 2 + end subroutine + + subroutine test2 ! Test the fix applies to generic interfaces + USE xmod + USE xmod, ONLY: xfoobar_renamed => xfoobar + USE ymod, ONLY: yfoobar_renamed => yfoobar + USE ymod + implicit integer(4) (a-z) + if (xfoobar_renamed (42) == xfoobar ()) STOP 3 + if (yfoobar_renamed (42) == yfoobar ()) STOP 4 + end subroutine + + subroutine test3 ! Check that USE_NAME == LOCAL_NAME is OK + USE xmod + USE xmod, ONLY: x => x, xfoobar => xfoobar + USE ymod, ONLY: y => y, yfoobar => yfoobar + USE ymod + if (kind (x) /= 4) STOP 5 + if (kind (y) /= 4) STOP 6 + if (xfoobar (77) /= 77_4) STOP 7 + if (yfoobar (77) /= 77_4) STOP 8 + end subroutine +END PROGRAM test2uses Index: Fortran/gfortran/regression/use_only_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_2.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! Checks the fix for PR34672, in which generic interfaces were not +! being written correctly, when renamed. +! +! Contributed by Jos de Kloe +! +MODULE MyMod1 + integer, parameter :: i2_ = Selected_Int_Kind(4) +END Module MyMod1 + +module MyMod2 + INTERFACE write_int + module procedure write_int_local + END INTERFACE +contains + subroutine write_int_local(value) + integer, intent(in) :: value + print *,value + end subroutine write_int_local +end module MyMod2 + +module MyMod3 + USE MyMod2, only: write_MyInt => write_int + USE MyMod1, only: i2_ +end module MyMod3 + +module MyMod4 + USE MyMod3, only: write_MyInt +end module MYMOD4 Index: Fortran/gfortran/regression/use_only_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_3.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! This tests the patch for PR34975, in which 'n', 'ipol', and 'i' would be +! determined to have 'no IMPLICIT type'. It turned out to be fiendishly +! difficult to write a testcase for this PR because even the smallest changes +! would make the bug disappear. This is the testcase provided in the PR, except +! that all the modules are put in 'use_only_3.inc' in the same order as the +! makefile. Even this has an effect; only 'n' is now determined to be +! improperly typed. All this is due to the richness of the symtree and the +! way in which the renaming inserted new symtree entries. Unless somenody can +! come up with a reduced version, this relatively large file will have to be added +! to the testsuite. Fortunately, it only has to be comiled once:) +! +! Reported by Tobias Burnus +! +include 'use_only_3.inc' +subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df) + use gvecs + use gvecw, only: ngw + use parameters + use electrons_base, only: nx => nbspx, n => nbsp, nspin, f + use constants + use cvan + use ions_base + use ions_base, only : nas => nax + implicit none + + integer ipol, i, ctabin + complex c0(n), betae, df,& + & gqq,gqqm,& + & qmat + real bec0,& + & dq2, gmes + + end subroutine dforceb Index: Fortran/gfortran/regression/use_only_3.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_3.inc @@ -0,0 +1,998 @@ + MODULE kinds + INTEGER, PARAMETER :: DP = selected_real_kind(14,200) + PRIVATE + PUBLIC :: DP + END MODULE kinds + +MODULE constants + USE kinds, ONLY : DP + IMPLICIT NONE + SAVE + REAL(DP), PARAMETER :: pi = 3.14159265358979323846_DP + REAL(DP), PARAMETER :: tpi= 2.0_DP * pi + REAL(DP), PARAMETER :: fpi= 4.0_DP * pi + REAL(DP), PARAMETER :: sqrtpi = 1.77245385090551602729_DP + REAL(DP), PARAMETER :: sqrtpm1= 1.0_DP / sqrtpi + REAL(DP), PARAMETER :: sqrt2 = 1.41421356237309504880_DP + REAL(DP), PARAMETER :: H_PLANCK_SI = 6.6260693D-34 ! J s + REAL(DP), PARAMETER :: K_BOLTZMANN_SI = 1.3806505D-23 ! J K^-1 + REAL(DP), PARAMETER :: ELECTRON_SI = 1.60217653D-19 ! C + REAL(DP), PARAMETER :: ELECTRONVOLT_SI = 1.60217653D-19 ! J + REAL(DP), PARAMETER :: ELECTRONMASS_SI = 9.1093826D-31 ! Kg + REAL(DP), PARAMETER :: HARTREE_SI = 4.35974417D-18 ! J + REAL(DP), PARAMETER :: RYDBERG_SI = HARTREE_SI/2.0_DP! J + REAL(DP), PARAMETER :: BOHR_RADIUS_SI = 0.5291772108D-10 ! m + REAL(DP), PARAMETER :: AMU_SI = 1.66053886D-27 ! Kg + REAL(DP), PARAMETER :: K_BOLTZMANN_AU = K_BOLTZMANN_SI / HARTREE_SI + REAL(DP), PARAMETER :: K_BOLTZMANN_RY = K_BOLTZMANN_SI / RYDBERG_SI + REAL(DP), PARAMETER :: AUTOEV = HARTREE_SI / ELECTRONVOLT_SI + REAL(DP), PARAMETER :: RYTOEV = AUTOEV / 2.0_DP + REAL(DP), PARAMETER :: AMU_AU = AMU_SI / ELECTRONMASS_SI + REAL(DP), PARAMETER :: AMU_RY = AMU_AU / 2.0_DP + REAL(DP), PARAMETER :: AU_SEC = H_PLANCK_SI/tpi/HARTREE_SI + REAL(DP), PARAMETER :: AU_PS = AU_SEC * 1.0D+12 + REAL(DP), PARAMETER :: AU_GPA = HARTREE_SI / BOHR_RADIUS_SI ** 3 & + / 1.0D+9 + REAL(DP), PARAMETER :: RY_KBAR = 10.0_dp * AU_GPA / 2.0_dp + ! + REAL(DP), PARAMETER :: DEBYE_SI = 3.3356409519 * 1.0D-30 ! C*m + REAL(DP), PARAMETER :: AU_DEBYE = ELECTRON_SI * BOHR_RADIUS_SI / & + DEBYE_SI + REAL(DP), PARAMETER :: eV_to_kelvin = ELECTRONVOLT_SI / K_BOLTZMANN_SI + REAL(DP), PARAMETER :: ry_to_kelvin = RYDBERG_SI / K_BOLTZMANN_SI + REAL(DP), PARAMETER :: eps4 = 1.0D-4 + REAL(DP), PARAMETER :: eps6 = 1.0D-6 + REAL(DP), PARAMETER :: eps8 = 1.0D-8 + REAL(DP), PARAMETER :: eps14 = 1.0D-14 + REAL(DP), PARAMETER :: eps16 = 1.0D-16 + REAL(DP), PARAMETER :: eps32 = 1.0D-32 + REAL(DP), PARAMETER :: gsmall = 1.0d-12 + REAL(DP), PARAMETER :: e2 = 2.D0 ! the square of the electron charge + REAL(DP), PARAMETER :: degspin = 2.D0 ! the number of spins per level + REAL(DP), PARAMETER :: amconv = AMU_RY + REAL(DP), PARAMETER :: uakbar = RY_KBAR + REAL(DP), PARAMETER :: bohr_radius_cm = bohr_radius_si * 100.0 + REAL(DP), PARAMETER :: BOHR_RADIUS_ANGS = bohr_radius_cm * 1.0D8 + REAL(DP), PARAMETER :: ANGSTROM_AU = 1.0/BOHR_RADIUS_ANGS + REAL(DP), PARAMETER :: DIP_DEBYE = AU_DEBYE + REAL(DP), PARAMETER :: AU_TERAHERTZ = AU_PS + REAL(DP), PARAMETER :: AU_TO_OHMCMM1 = 46000.0D0 ! (ohm cm)^-1 + ! + +END MODULE constants + +! +! Copyright (C) 2001-2005 Quantum-ESPRESSO group +! This file is distributed under the terms of the +! GNU General Public License. See the file `License' +! in the root directory of the present distribution, +! or http://www.gnu.org/copyleft/gpl.txt . +! +! +!--------------------------------------------------------------------------- +MODULE parameters + !--------------------------------------------------------------------------- + ! + IMPLICIT NONE + SAVE + ! + INTEGER, PARAMETER :: & + ntypx = 10, &! max number of different types of atom + npsx = ntypx, &! max number of different PPs (obsolete) + npk = 40000, &! max number of k-points + lmaxx = 3, &! max non local angular momentum (l=0 to lmaxx) + nchix = 6, &! max number of atomic wavefunctions per atom + ndmx = 2000 ! max number of points in the atomic radial mesh + ! + INTEGER, PARAMETER :: & + nbrx = 14, &! max number of beta functions + lqmax= 2*lmaxx+1, &! max number of angular momenta of Q + nqfx = 8 ! max number of coefficients in Q smoothing + ! + INTEGER, PARAMETER :: nacx = 10 ! max number of averaged + ! quantities saved to the restart + INTEGER, PARAMETER :: nsx = ntypx ! max number of species + INTEGER, PARAMETER :: natx = 5000 ! max number of atoms + INTEGER, PARAMETER :: npkx = npk ! max number of K points + INTEGER, PARAMETER :: ncnsx = 101 ! max number of constraints + INTEGER, PARAMETER :: nspinx = 2 ! max number of spinors + ! + INTEGER, PARAMETER :: nhclm = 4 ! max number NH chain length, nhclm can be + ! easily increased since the restart file + ! should be able to handle it, perhaps + ! better to align nhclm by 4 + ! + INTEGER, PARAMETER :: max_nconstr = 100 + ! + INTEGER, PARAMETER :: maxcpu = 2**17 ! Maximum number of CPU + INTEGER, PARAMETER :: maxgrp = 128 ! Maximum number of task-groups + ! +END MODULE parameters + +MODULE control_flags + USE kinds + USE parameters + IMPLICIT NONE + SAVE + TYPE convergence_criteria + ! + LOGICAL :: active + INTEGER :: nstep + REAL(DP) :: ekin + REAL(DP) :: derho + REAL(DP) :: force + ! + END TYPE convergence_criteria + ! + TYPE ionic_conjugate_gradient + ! + LOGICAL :: active + INTEGER :: nstepix + INTEGER :: nstepex + REAL(DP) :: ionthr + REAL(DP) :: elethr + ! + END TYPE ionic_conjugate_gradient + ! + CHARACTER(LEN=4) :: program_name = ' ' ! used to control execution flow inside module + ! + LOGICAL :: tvlocw = .FALSE. ! write potential to unit 46 (only cp, seldom used) + LOGICAL :: trhor = .FALSE. ! read rho from unit 47 (only cp, seldom used) + LOGICAL :: trhow = .FALSE. ! CP code, write rho to restart dir + ! + LOGICAL :: tsde = .FALSE. ! electronic steepest descent + LOGICAL :: tzeroe = .FALSE. ! set to zero the electronic velocities + LOGICAL :: tfor = .FALSE. ! move the ions ( calculate forces ) + LOGICAL :: tsdp = .FALSE. ! ionic steepest descent + LOGICAL :: tzerop = .FALSE. ! set to zero the ionic velocities + LOGICAL :: tprnfor = .FALSE. ! print forces to standard output + LOGICAL :: taurdr = .FALSE. ! read ionic position from standard input + LOGICAL :: tv0rd = .FALSE. ! read ionic velocities from standard input + LOGICAL :: tpre = .FALSE. ! calculate stress, and (in fpmd) variable cell dynamic + LOGICAL :: thdyn = .FALSE. ! variable-cell dynamics (only cp) + LOGICAL :: tsdc = .FALSE. ! cell geometry steepest descent + LOGICAL :: tzeroc = .FALSE. ! set to zero the cell geometry velocities + LOGICAL :: tstress = .FALSE. ! print stress to standard output + LOGICAL :: tortho = .FALSE. ! use iterative orthogonalization + LOGICAL :: tconjgrad = .FALSE. ! use conjugate gradient electronic minimization + LOGICAL :: timing = .FALSE. ! print out timing information + LOGICAL :: memchk = .FALSE. ! check for memory leakage + LOGICAL :: tprnsfac = .FALSE. ! print out structure factor + LOGICAL :: toptical = .FALSE. ! print out optical properties + LOGICAL :: tcarpar = .FALSE. ! tcarpar is set TRUE for a "pure" Car Parrinello simulation + LOGICAL :: tdamp = .FALSE. ! Use damped dinamics for electrons + LOGICAL :: tdampions = .FALSE. ! Use damped dinamics for electrons + LOGICAL :: tatomicwfc = .FALSE. ! Use atomic wavefunctions as starting guess for ch. density + LOGICAL :: tscreen = .FALSE. ! Use screened coulomb potentials for cluster calculations + LOGICAL :: twfcollect = .FALSE. ! Collect wave function in the restart file at the end of run. + LOGICAL :: tuspp = .FALSE. ! Ultra-soft pseudopotential are being used + INTEGER :: printwfc = -1 ! Print wave functions, temporarely used only by ensemble-dft + LOGICAL :: force_pairing = .FALSE. ! ... Force pairing + LOGICAL :: tchi2 = .FALSE. ! Compute Chi^2 + ! + TYPE (convergence_criteria) :: tconvthrs + ! thresholds used to check GS convergence + ! + ! ... Ionic vs Electronic step frequency + ! ... When "ion_nstep > 1" and "electron_dynamics = 'md' | 'sd' ", ions are + ! ... propagated every "ion_nstep" electronic step only if the electronic + ! ... "ekin" is lower than "ekin_conv_thr" + ! + LOGICAL :: tionstep = .FALSE. + INTEGER :: nstepe = 1 + ! parameters to control how many electronic steps + ! between ions move + + LOGICAL :: tsteepdesc = .FALSE. + ! parameters for electronic steepest desceent + + TYPE (ionic_conjugate_gradient) :: tconjgrad_ion + ! conjugate gradient for ionic minimization + + INTEGER :: nbeg = 0 ! internal code for initialization ( -1, 0, 1, 2, .. ) + INTEGER :: ndw = 0 ! + INTEGER :: ndr = 0 ! + INTEGER :: nomore = 0 ! + INTEGER :: iprint = 0 ! print output every iprint step + INTEGER :: isave = 0 ! write restart to ndr unit every isave step + INTEGER :: nv0rd = 0 ! + INTEGER :: iprsta = 0 ! output verbosity (increasing from 0 to infinity) + ! + ! ... .TRUE. if only gamma point is used + ! + LOGICAL :: gamma_only = .TRUE. + ! + LOGICAL :: tnewnfi = .FALSE. + INTEGER :: newnfi = 0 + ! + ! This variable is used whenever a timestep change is requested + ! + REAL(DP) :: dt_old = -1.0D0 + ! + ! ... Wave function randomization + ! + LOGICAL :: trane = .FALSE. + REAL(DP) :: ampre = 0.D0 + ! + ! ... Ionic position randomization + ! + LOGICAL :: tranp(nsx) = .FALSE. + REAL(DP) :: amprp(nsx) = 0.D0 + ! + ! ... Read the cell from standard input + ! + LOGICAL :: tbeg = .FALSE. + ! + ! ... This flags control the calculation of the Dipole Moments + ! + LOGICAL :: tdipole = .FALSE. + ! + ! ... Flags that controls DIIS electronic minimization + ! + LOGICAL :: t_diis = .FALSE. + LOGICAL :: t_diis_simple = .FALSE. + LOGICAL :: t_diis_rot = .FALSE. + ! + ! ... Flag controlling the Nose thermostat for electrons + ! + LOGICAL :: tnosee = .FALSE. + ! + ! ... Flag controlling the Nose thermostat for the cell + ! + LOGICAL :: tnoseh = .FALSE. + ! + ! ... Flag controlling the Nose thermostat for ions + ! + LOGICAL :: tnosep = .FALSE. + LOGICAL :: tcap = .FALSE. + LOGICAL :: tcp = .FALSE. + REAL(DP) :: tolp = 0.D0 ! tolerance for temperature variation + ! + REAL(DP), PUBLIC :: & + ekin_conv_thr = 0.D0, &! conv. threshold for fictitious e. kinetic energy + etot_conv_thr = 0.D0, &! conv. threshold for DFT energy + forc_conv_thr = 0.D0 ! conv. threshold for atomic forces + INTEGER, PUBLIC :: & + ekin_maxiter = 100, &! max number of iter. for ekin convergence + etot_maxiter = 100, &! max number of iter. for etot convergence + forc_maxiter = 100 ! max number of iter. for atomic forces conv. + ! + ! ... Several variables controlling the run ( used mainly in PW calculations ) + ! + ! ... logical flags controlling the execution + ! + LOGICAL, PUBLIC :: & + lfixatom, &! if .TRUE. some atom is kept fixed + lscf, &! if .TRUE. the calc. is selfconsistent + lbfgs, &! if .TRUE. the calc. is a relaxation based on new BFGS scheme + lmd, &! if .TRUE. the calc. is a dynamics + lmetadyn, &! if .TRUE. the calc. is a meta-dynamics + lpath, &! if .TRUE. the calc. is a path optimizations + lneb, &! if .TRUE. the calc. is NEB dynamics + lsmd, &! if .TRUE. the calc. is string dynamics + lwf, &! if .TRUE. the calc. is with wannier functions + lphonon, &! if .TRUE. the calc. is phonon + lbands, &! if .TRUE. the calc. is band structure + lconstrain, &! if .TRUE. the calc. is constraint + ldamped, &! if .TRUE. the calc. is a damped dynamics + lrescale_t, &! if .TRUE. the ionic temperature is rescaled + langevin_rescaling, &! if .TRUE. the ionic dynamics is overdamped Langevin + lcoarsegrained, &! if .TRUE. a coarse-grained phase-space is used + restart ! if .TRUE. restart from results of a preceding run + ! + LOGICAL, PUBLIC :: & + remove_rigid_rot ! if .TRUE. the total torque acting on the atoms is + ! removed + ! + ! ... pw self-consistency + ! + INTEGER, PUBLIC :: & + ngm0, &! used in mix_rho + niter, &! the maximum number of iteration + nmix, &! the number of iteration kept in the history + imix ! the type of mixing (0=plain,1=TF,2=local-TF) + REAL(DP), PUBLIC :: & + mixing_beta, &! the mixing parameter + tr2 ! the convergence threshold for potential + LOGICAL, PUBLIC :: & + conv_elec ! if .TRUE. electron convergence has been reached + ! + ! ... pw diagonalization + ! + REAL(DP), PUBLIC :: & + ethr ! the convergence threshold for eigenvalues + INTEGER, PUBLIC :: & + david, &! used on Davidson diagonalization + isolve, &! Davidson or CG or DIIS diagonalization + max_cg_iter, &! maximum number of iterations in a CG di + diis_buff, &! dimension of the buffer in diis + diis_ndim ! dimension of reduced basis in DIIS + LOGICAL, PUBLIC :: & + diago_full_acc ! if true all the empty eigenvalues have the same + ! accuracy of the occupied ones + ! + ! ... wfc and rho extrapolation + ! + REAL(DP), PUBLIC :: & + alpha0, &! the mixing parameters for the extrapolation + beta0 ! of the starting potential + INTEGER, PUBLIC :: & + history, &! number of old steps available for potential updating + pot_order, &! type of potential updating ( see update_pot ) + wfc_order ! type of wavefunctions updating ( see update_pot ) + ! + ! ... ionic dynamics + ! + INTEGER, PUBLIC :: & + nstep, &! number of ionic steps + istep = 0 ! current ionic step + LOGICAL, PUBLIC :: & + conv_ions ! if .TRUE. ionic convergence has been reached + REAL(DP), PUBLIC :: & + upscale ! maximum reduction of convergence threshold + ! + ! ... system's symmetries + ! + LOGICAL, PUBLIC :: & + nosym, &! if .TRUE. no symmetry is used + noinv = .FALSE. ! if .TRUE. eliminates inversion symmetry + ! + ! ... phonon calculation + ! + INTEGER, PUBLIC :: & + modenum ! for single mode phonon calculation + ! + ! ... printout control + ! + LOGICAL, PUBLIC :: & + reduce_io ! if .TRUE. reduce the I/O to the strict minimum + INTEGER, PUBLIC :: & + iverbosity ! type of printing ( 0 few, 1 all ) + LOGICAL, PUBLIC :: & + use_para_diago = .FALSE. ! if .TRUE. a parallel Householder algorithm + INTEGER, PUBLIC :: & + para_diago_dim = 0 ! minimum matrix dimension above which a parallel + INTEGER :: ortho_max = 0 ! maximum number of iterations in routine ortho + REAL(DP) :: ortho_eps = 0.D0 ! threshold for convergence in routine ortho + LOGICAL, PUBLIC :: & + use_task_groups = .FALSE. ! if TRUE task groups parallelization is used + INTEGER, PUBLIC :: iesr = 1 + LOGICAL, PUBLIC :: tvhmean = .FALSE. + REAL(DP), PUBLIC :: vhrmin = 0.0d0 + REAL(DP), PUBLIC :: vhrmax = 1.0d0 + CHARACTER(LEN=1), PUBLIC :: vhasse = 'Z' + LOGICAL, PUBLIC :: tprojwfc = .FALSE. + CONTAINS + SUBROUTINE fix_dependencies() + END SUBROUTINE fix_dependencies + SUBROUTINE check_flags() + END SUBROUTINE check_flags +END MODULE control_flags + +! +! Copyright (C) 2002 FPMD group +! This file is distributed under the terms of the +! GNU General Public License. See the file `License' +! in the root directory of the present distribution, +! or http://www.gnu.org/copyleft/gpl.txt . +! + +!=----------------------------------------------------------------------------=! + MODULE gvecw +!=----------------------------------------------------------------------------=! + USE kinds, ONLY: DP + + IMPLICIT NONE + SAVE + + ! ... G vectors less than the wave function cut-off ( ecutwfc ) + INTEGER :: ngw = 0 ! local number of G vectors + INTEGER :: ngwt = 0 ! in parallel execution global number of G vectors, + ! in serial execution this is equal to ngw + INTEGER :: ngwl = 0 ! number of G-vector shells up to ngw + INTEGER :: ngwx = 0 ! maximum local number of G vectors + INTEGER :: ng0 = 0 ! first G-vector with nonzero modulus + ! needed in the parallel case (G=0 is on one node only!) + + REAL(DP) :: ecutw = 0.0d0 + REAL(DP) :: gcutw = 0.0d0 + + ! values for costant cut-off computations + + REAL(DP) :: ecfix = 0.0d0 ! value of the constant cut-off + REAL(DP) :: ecutz = 0.0d0 ! height of the penalty function (above ecfix) + REAL(DP) :: ecsig = 0.0d0 ! spread of the penalty function around ecfix + LOGICAL :: tecfix = .FALSE. ! .TRUE. if constant cut-off is in use + + ! augmented cut-off for k-point calculation + + REAL(DP) :: ekcut = 0.0d0 + REAL(DP) :: gkcut = 0.0d0 + + ! array of G vectors module plus penalty function for constant cut-off + ! simulation. + ! + ! ggp = g + ( agg / tpiba**2 ) * ( 1 + erf( ( tpiba2 * g - e0gg ) / sgg ) ) + + REAL(DP), ALLOCATABLE, TARGET :: ggp(:) + + CONTAINS + + SUBROUTINE deallocate_gvecw + IF( ALLOCATED( ggp ) ) DEALLOCATE( ggp ) + END SUBROUTINE deallocate_gvecw + +!=----------------------------------------------------------------------------=! + END MODULE gvecw +!=----------------------------------------------------------------------------=! + +!=----------------------------------------------------------------------------=! + MODULE gvecs +!=----------------------------------------------------------------------------=! + USE kinds, ONLY: DP + + IMPLICIT NONE + SAVE + + ! ... G vectors less than the smooth grid cut-off ( ? ) + INTEGER :: ngs = 0 ! local number of G vectors + INTEGER :: ngst = 0 ! in parallel execution global number of G vectors, + ! in serial execution this is equal to ngw + INTEGER :: ngsl = 0 ! number of G-vector shells up to ngw + INTEGER :: ngsx = 0 ! maximum local number of G vectors + + INTEGER, ALLOCATABLE :: nps(:), nms(:) + + REAL(DP) :: ecuts = 0.0d0 + REAL(DP) :: gcuts = 0.0d0 + + REAL(DP) :: dual = 0.0d0 + LOGICAL :: doublegrid = .FALSE. + + CONTAINS + + SUBROUTINE deallocate_gvecs() + IF( ALLOCATED( nps ) ) DEALLOCATE( nps ) + IF( ALLOCATED( nms ) ) DEALLOCATE( nms ) + END SUBROUTINE deallocate_gvecs + +!=----------------------------------------------------------------------------=! + END MODULE gvecs +!=----------------------------------------------------------------------------=! + + MODULE electrons_base + USE kinds, ONLY: DP + IMPLICIT NONE + SAVE + + INTEGER :: nbnd = 0 ! number electronic bands, each band contains + ! two spin states + INTEGER :: nbndx = 0 ! array dimension nbndx >= nbnd + INTEGER :: nspin = 0 ! nspin = number of spins (1=no spin, 2=LSDA) + INTEGER :: nel(2) = 0 ! number of electrons (up, down) + INTEGER :: nelt = 0 ! total number of electrons ( up + down ) + INTEGER :: nupdwn(2) = 0 ! number of states with spin up (1) and down (2) + INTEGER :: iupdwn(2) = 0 ! first state with spin (1) and down (2) + INTEGER :: nudx = 0 ! max (nupdw(1),nupdw(2)) + INTEGER :: nbsp = 0 ! total number of electronic states + ! (nupdwn(1)+nupdwn(2)) + INTEGER :: nbspx = 0 ! array dimension nbspx >= nbsp + + LOGICAL :: telectrons_base_initval = .FALSE. + LOGICAL :: keep_occ = .FALSE. ! if .true. when reading restart file keep + ! the occupations calculated in initval + + REAL(DP), ALLOCATABLE :: f(:) ! occupation numbers ( at gamma ) + REAL(DP) :: qbac = 0.0d0 ! background neutralizing charge + INTEGER, ALLOCATABLE :: ispin(:) ! spin of each state +! +!------------------------------------------------------------------------------! + CONTAINS +!------------------------------------------------------------------------------! + + + SUBROUTINE electrons_base_initval( zv_ , na_ , nsp_ , nelec_ , nelup_ , neldw_ , nbnd_ , & + nspin_ , occupations_ , f_inp, tot_charge_, multiplicity_, tot_magnetization_ ) + REAL(DP), INTENT(IN) :: zv_ (:), tot_charge_ + REAL(DP), INTENT(IN) :: nelec_ , nelup_ , neldw_ + REAL(DP), INTENT(IN) :: f_inp(:,:) + INTEGER, INTENT(IN) :: na_ (:) , nsp_, multiplicity_, tot_magnetization_ + INTEGER, INTENT(IN) :: nbnd_ , nspin_ + CHARACTER(LEN=*), INTENT(IN) :: occupations_ + END SUBROUTINE electrons_base_initval + + + subroutine set_nelup_neldw ( nelec_, nelup_, neldw_, tot_magnetization_, & + multiplicity_) + ! + REAL (KIND=DP), intent(IN) :: nelec_ + REAL (KIND=DP), intent(INOUT) :: nelup_, neldw_ + INTEGER, intent(IN) :: tot_magnetization_, multiplicity_ + end subroutine set_nelup_neldw + +!---------------------------------------------------------------------------- + + + SUBROUTINE deallocate_elct() + IF( ALLOCATED( f ) ) DEALLOCATE( f ) + IF( ALLOCATED( ispin ) ) DEALLOCATE( ispin ) + telectrons_base_initval = .FALSE. + RETURN + END SUBROUTINE deallocate_elct + + +!------------------------------------------------------------------------------! + END MODULE electrons_base +!------------------------------------------------------------------------------! + + + +!------------------------------------------------------------------------------! + MODULE electrons_nose +!------------------------------------------------------------------------------! + + USE kinds, ONLY: DP +! + IMPLICIT NONE + SAVE + + REAL(DP) :: fnosee = 0.0d0 ! frequency of the thermostat ( in THz ) + REAL(DP) :: qne = 0.0d0 ! mass of teh termostat + REAL(DP) :: ekincw = 0.0d0 ! kinetic energy to be kept constant + + REAL(DP) :: xnhe0 = 0.0d0 + REAL(DP) :: xnhep = 0.0d0 + REAL(DP) :: xnhem = 0.0d0 + REAL(DP) :: vnhe = 0.0d0 + CONTAINS + subroutine electrons_nose_init( ekincw_ , fnosee_ ) + REAL(DP), INTENT(IN) :: ekincw_, fnosee_ + end subroutine electrons_nose_init + + + function electrons_nose_nrg( xnhe0, vnhe, qne, ekincw ) + real(8) :: electrons_nose_nrg + real(8), intent(in) :: xnhe0, vnhe, qne, ekincw + electrons_nose_nrg = 0.0 + end function electrons_nose_nrg + + subroutine electrons_nose_shiftvar( xnhep, xnhe0, xnhem ) + implicit none + real(8), intent(out) :: xnhem + real(8), intent(inout) :: xnhe0 + real(8), intent(in) :: xnhep + end subroutine electrons_nose_shiftvar + + subroutine electrons_nosevel( vnhe, xnhe0, xnhem, delt ) + implicit none + real(8), intent(inout) :: vnhe + real(8), intent(in) :: xnhe0, xnhem, delt + end subroutine electrons_nosevel + + subroutine electrons_noseupd( xnhep, xnhe0, xnhem, delt, qne, ekinc, ekincw, vnhe ) + implicit none + real(8), intent(out) :: xnhep, vnhe + real(8), intent(in) :: xnhe0, xnhem, delt, qne, ekinc, ekincw + end subroutine electrons_noseupd + + + SUBROUTINE electrons_nose_info() + END SUBROUTINE electrons_nose_info + END MODULE electrons_nose + +module cvan + use parameters, only: nsx + implicit none + save + integer nvb, ish(nsx) + integer, allocatable:: indlm(:,:) +contains + subroutine allocate_cvan( nind, ns ) + integer, intent(in) :: nind, ns + end subroutine allocate_cvan + + subroutine deallocate_cvan( ) + end subroutine deallocate_cvan + +end module cvan + + MODULE cell_base + USE kinds, ONLY : DP + IMPLICIT NONE + SAVE + REAL(DP) :: alat = 0.0d0 + REAL(DP) :: celldm(6) = (/ 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: a1(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: a2(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: a3(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: b1(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: b2(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: b3(3) = (/ 0.0d0, 0.0d0, 0.0d0 /) + REAL(DP) :: ainv(3,3) = 0.0d0 + REAl(DP) :: omega = 0.0d0 ! volume of the simulation cell + REAL(DP) :: tpiba = 0.0d0 ! = 2 PI / alat + REAL(DP) :: tpiba2 = 0.0d0 ! = ( 2 PI / alat ) ** 2 + REAL(DP) :: at(3,3) = RESHAPE( (/ 0.0d0 /), (/ 3, 3 /), (/ 0.0d0 /) ) + REAL(DP) :: bg(3,3) = RESHAPE( (/ 0.0d0 /), (/ 3, 3 /), (/ 0.0d0 /) ) + INTEGER :: ibrav ! index of the bravais lattice + CHARACTER(len=9) :: symm_type ! 'cubic' or 'hexagonal' when ibrav=0 + REAL(DP) :: h(3,3) = 0.0d0 ! simulation cell at time t + REAL(DP) :: hold(3,3) = 0.0d0 ! simulation cell at time t-delt + REAL(DP) :: hnew(3,3) = 0.0d0 ! simulation cell at time t+delt + REAL(DP) :: velh(3,3) = 0.0d0 ! simulation cell velocity + REAL(DP) :: deth = 0.0d0 ! determinant of h ( cell volume ) + INTEGER :: iforceh(3,3) = 1 ! if iforceh( i, j ) = 0 then h( i, j ) + LOGICAL :: thdiag = .FALSE. ! True if only cell diagonal elements + REAL(DP) :: wmass = 0.0d0 ! cell fictitious mass + REAL(DP) :: press = 0.0d0 ! external pressure + REAL(DP) :: frich = 0.0d0 ! firction parameter for cell damped dynamics + REAL(DP) :: greash = 1.0d0 ! greas parameter for damped dynamics + LOGICAL :: tcell_base_init = .FALSE. + CONTAINS + SUBROUTINE updatecell(box_tm1, box_t0, box_tp1) + integer :: box_tm1, box_t0, box_tp1 + END SUBROUTINE updatecell + SUBROUTINE dgcell( gcdot, box_tm1, box_t0, delt ) + REAL(DP), INTENT(OUT) :: GCDOT(3,3) + REAL(DP), INTENT(IN) :: delt + integer, intent(in) :: box_tm1, box_t0 + END SUBROUTINE dgcell + + SUBROUTINE cell_init_ht( box, ht ) + integer :: box + REAL(DP) :: ht(3,3) + END SUBROUTINE cell_init_ht + + SUBROUTINE cell_init_a( box, a1, a2, a3 ) + integer :: box + REAL(DP) :: a1(3), a2(3), a3(3) + END SUBROUTINE cell_init_a + + SUBROUTINE r_to_s1 (r,s,box) + REAL(DP), intent(out) :: S(3) + REAL(DP), intent(in) :: R(3) + integer, intent(in) :: box + END SUBROUTINE r_to_s1 + + SUBROUTINE r_to_s3 ( r, s, na, nsp, hinv ) + REAL(DP), intent(out) :: S(:,:) + INTEGER, intent(in) :: na(:), nsp + REAL(DP), intent(in) :: R(:,:) + REAL(DP), intent(in) :: hinv(:,:) ! hinv = TRANSPOSE( box%m1 ) + integer :: i, j, ia, is, isa + isa = 0 + DO is = 1, nsp + DO ia = 1, na(is) + isa = isa + 1 + DO I=1,3 + S(I,isa) = 0.D0 + DO J=1,3 + S(I,isa) = S(I,isa) + R(J,isa)*hinv(i,j) + END DO + END DO + END DO + END DO + RETURN + END SUBROUTINE r_to_s3 + +!------------------------------------------------------------------------------! + + SUBROUTINE r_to_s1b ( r, s, hinv ) + REAL(DP), intent(out) :: S(:) + REAL(DP), intent(in) :: R(:) + REAL(DP), intent(in) :: hinv(:,:) ! hinv = TRANSPOSE( box%m1 ) + integer :: i, j + DO I=1,3 + S(I) = 0.D0 + DO J=1,3 + S(I) = S(I) + R(J)*hinv(i,j) + END DO + END DO + RETURN + END SUBROUTINE r_to_s1b + + + SUBROUTINE s_to_r1 (S,R,box) + REAL(DP), intent(in) :: S(3) + REAL(DP), intent(out) :: R(3) + integer, intent(in) :: box + END SUBROUTINE s_to_r1 + + SUBROUTINE s_to_r1b (S,R,h) + REAL(DP), intent(in) :: S(3) + REAL(DP), intent(out) :: R(3) + REAL(DP), intent(in) :: h(:,:) ! h = TRANSPOSE( box%a ) + END SUBROUTINE s_to_r1b + + SUBROUTINE s_to_r3 ( S, R, na, nsp, h ) + REAL(DP), intent(in) :: S(:,:) + INTEGER, intent(in) :: na(:), nsp + REAL(DP), intent(out) :: R(:,:) + REAL(DP), intent(in) :: h(:,:) ! h = TRANSPOSE( box%a ) + END SUBROUTINE s_to_r3 + + SUBROUTINE gethinv(box) + IMPLICIT NONE + integer, INTENT (INOUT) :: box + END SUBROUTINE gethinv + + + FUNCTION get_volume( hmat ) + IMPLICIT NONE + REAL(DP) :: get_volume + REAL(DP) :: hmat( 3, 3 ) + get_volume = 4.4 + END FUNCTION get_volume + + FUNCTION pbc(rin,box,nl) RESULT (rout) + IMPLICIT NONE + integer :: box + REAL (DP) :: rin(3) + REAL (DP) :: rout(3), s(3) + INTEGER, OPTIONAL :: nl(3) + rout = 4.4 + END FUNCTION pbc + + SUBROUTINE get_cell_param(box,cell,ang) + IMPLICIT NONE + integer, INTENT(in) :: box + REAL(DP), INTENT(out), DIMENSION(3) :: cell + REAL(DP), INTENT(out), DIMENSION(3), OPTIONAL :: ang + END SUBROUTINE get_cell_param + + SUBROUTINE pbcs_components(x1, y1, z1, x2, y2, z2, m) + USE kinds + INTEGER, INTENT(IN) :: M + REAL(DP), INTENT(IN) :: X1,Y1,Z1 + REAL(DP), INTENT(OUT) :: X2,Y2,Z2 + REAL(DP) MIC + END SUBROUTINE pbcs_components + + SUBROUTINE pbcs_vectors(v, w, m) + USE kinds + INTEGER, INTENT(IN) :: m + REAL(DP), INTENT(IN) :: v(3) + REAL(DP), INTENT(OUT) :: w(3) + REAL(DP) :: MIC + END SUBROUTINE pbcs_vectors + + SUBROUTINE cell_base_init( ibrav_ , celldm_ , trd_ht, cell_symmetry, rd_ht, cell_units, & + a_ , b_ , c_ , cosab, cosac, cosbc, wc_ , total_ions_mass , press_ , & + frich_ , greash_ , cell_dofree ) + + IMPLICIT NONE + INTEGER, INTENT(IN) :: ibrav_ + REAL(DP), INTENT(IN) :: celldm_ (6) + LOGICAL, INTENT(IN) :: trd_ht + CHARACTER(LEN=*), INTENT(IN) :: cell_symmetry + REAL(DP), INTENT(IN) :: rd_ht (3,3) + CHARACTER(LEN=*), INTENT(IN) :: cell_units + REAL(DP), INTENT(IN) :: a_ , b_ , c_ , cosab, cosac, cosbc + CHARACTER(LEN=*), INTENT(IN) :: cell_dofree + REAL(DP), INTENT(IN) :: wc_ , frich_ , greash_ , total_ions_mass + REAL(DP), INTENT(IN) :: press_ ! external pressure from imput ( GPa ) + END SUBROUTINE cell_base_init + + + SUBROUTINE cell_base_reinit( ht ) + REAL(DP), INTENT(IN) :: ht (3,3) + END SUBROUTINE cell_base_reinit + + SUBROUTINE cell_steepest( hnew, h, delt, iforceh, fcell ) + REAL(DP), INTENT(OUT) :: hnew(3,3) + REAL(DP), INTENT(IN) :: h(3,3), fcell(3,3) + INTEGER, INTENT(IN) :: iforceh(3,3) + REAL(DP), INTENT(IN) :: delt + END SUBROUTINE cell_steepest + + SUBROUTINE cell_verlet( hnew, h, hold, delt, iforceh, fcell, frich, tnoseh, hnos ) + REAL(DP), INTENT(OUT) :: hnew(3,3) + REAL(DP), INTENT(IN) :: h(3,3), hold(3,3), hnos(3,3), fcell(3,3) + INTEGER, INTENT(IN) :: iforceh(3,3) + REAL(DP), INTENT(IN) :: frich, delt + LOGICAL, INTENT(IN) :: tnoseh + END SUBROUTINE cell_verlet + + subroutine cell_hmove( h, hold, delt, iforceh, fcell ) + REAL(DP), intent(out) :: h(3,3) + REAL(DP), intent(in) :: hold(3,3), fcell(3,3) + REAL(DP), intent(in) :: delt + integer, intent(in) :: iforceh(3,3) + end subroutine cell_hmove + + subroutine cell_force( fcell, ainv, stress, omega, press, wmass ) + REAL(DP), intent(out) :: fcell(3,3) + REAL(DP), intent(in) :: stress(3,3), ainv(3,3) + REAL(DP), intent(in) :: omega, press, wmass + end subroutine cell_force + + subroutine cell_move( hnew, h, hold, delt, iforceh, fcell, frich, tnoseh, vnhh, velh, tsdc ) + REAL(DP), intent(out) :: hnew(3,3) + REAL(DP), intent(in) :: h(3,3), hold(3,3), fcell(3,3) + REAL(DP), intent(in) :: vnhh(3,3), velh(3,3) + integer, intent(in) :: iforceh(3,3) + REAL(DP), intent(in) :: frich, delt + logical, intent(in) :: tnoseh, tsdc + end subroutine cell_move + + subroutine cell_gamma( hgamma, ainv, h, velh ) + REAL(DP) :: hgamma(3,3) + REAL(DP), intent(in) :: ainv(3,3), h(3,3), velh(3,3) + end subroutine cell_gamma + + subroutine cell_kinene( ekinh, temphh, velh ) + REAL(DP), intent(out) :: ekinh, temphh(3,3) + REAL(DP), intent(in) :: velh(3,3) + end subroutine cell_kinene + + function cell_alat( ) + real(DP) :: cell_alat + cell_alat = 4.4 + end function cell_alat + END MODULE cell_base + + + MODULE ions_base + USE kinds, ONLY : DP + USE parameters, ONLY : ntypx + IMPLICIT NONE + SAVE + INTEGER :: nsp = 0 + INTEGER :: na(5) = 0 + INTEGER :: nax = 0 + INTEGER :: nat = 0 + REAL(DP) :: zv(5) = 0.0d0 + REAL(DP) :: pmass(5) = 0.0d0 + REAL(DP) :: amass(5) = 0.0d0 + REAL(DP) :: rcmax(5) = 0.0d0 + INTEGER, ALLOCATABLE :: ityp(:) + REAL(DP), ALLOCATABLE :: tau(:,:) ! initial positions read from stdin (in bohr) + REAL(DP), ALLOCATABLE :: vel(:,:) ! initial velocities read from stdin (in bohr) + REAL(DP), ALLOCATABLE :: tau_srt(:,:) ! tau sorted by specie in bohr + REAL(DP), ALLOCATABLE :: vel_srt(:,:) ! vel sorted by specie in bohr + INTEGER, ALLOCATABLE :: ind_srt(:) ! index of tau sorted by specie + INTEGER, ALLOCATABLE :: ind_bck(:) ! reverse of ind_srt + CHARACTER(LEN=3) :: atm( 5 ) + CHARACTER(LEN=80) :: tau_units + + + INTEGER, ALLOCATABLE :: if_pos(:,:) ! if if_pos( x, i ) = 0 then x coordinate of + ! the i-th atom will be kept fixed + INTEGER, ALLOCATABLE :: iforce(:,:) ! if_pos sorted by specie + INTEGER :: fixatom = -1 ! to be removed + INTEGER :: ndofp = -1 ! ionic degree of freedom + INTEGER :: ndfrz = 0 ! frozen degrees of freedom + + REAL(DP) :: fricp ! friction parameter for damped dynamics + REAL(DP) :: greasp ! friction parameter for damped dynamics + REAL(DP), ALLOCATABLE :: taui(:,:) + REAL(DP) :: cdmi(3), cdm(3) + REAL(DP) :: cdms(3) + LOGICAL :: tions_base_init = .FALSE. + CONTAINS + SUBROUTINE packtau( taup, tau, na, nsp ) + REAL(DP), INTENT(OUT) :: taup( :, : ) + REAL(DP), INTENT(IN) :: tau( :, :, : ) + INTEGER, INTENT(IN) :: na( : ), nsp + END SUBROUTINE packtau + + SUBROUTINE unpacktau( tau, taup, na, nsp ) + REAL(DP), INTENT(IN) :: taup( :, : ) + REAL(DP), INTENT(OUT) :: tau( :, :, : ) + INTEGER, INTENT(IN) :: na( : ), nsp + END SUBROUTINE unpacktau + + SUBROUTINE sort_tau( tausrt, isrt, tau, isp, nat, nsp ) + REAL(DP), INTENT(OUT) :: tausrt( :, : ) + INTEGER, INTENT(OUT) :: isrt( : ) + REAL(DP), INTENT(IN) :: tau( :, : ) + INTEGER, INTENT(IN) :: nat, nsp, isp( : ) + INTEGER :: ina( nsp ), na( nsp ) + END SUBROUTINE sort_tau + + SUBROUTINE unsort_tau( tau, tausrt, isrt, nat ) + REAL(DP), INTENT(IN) :: tausrt( :, : ) + INTEGER, INTENT(IN) :: isrt( : ) + REAL(DP), INTENT(OUT) :: tau( :, : ) + INTEGER, INTENT(IN) :: nat + END SUBROUTINE unsort_tau + + SUBROUTINE ions_base_init( nsp_, nat_, na_, ityp_, tau_, vel_, amass_, & + atm_, if_pos_, tau_units_, alat_, a1_, a2_, & + a3_, rcmax_ ) + INTEGER, INTENT(IN) :: nsp_, nat_, na_(:), ityp_(:) + REAL(DP), INTENT(IN) :: tau_(:,:) + REAL(DP), INTENT(IN) :: vel_(:,:) + REAL(DP), INTENT(IN) :: amass_(:) + CHARACTER(LEN=*), INTENT(IN) :: atm_(:) + CHARACTER(LEN=*), INTENT(IN) :: tau_units_ + INTEGER, INTENT(IN) :: if_pos_(:,:) + REAL(DP), INTENT(IN) :: alat_, a1_(3), a2_(3), a3_(3) + REAL(DP), INTENT(IN) :: rcmax_(:) + END SUBROUTINE ions_base_init + + SUBROUTINE deallocate_ions_base() + END SUBROUTINE deallocate_ions_base + + SUBROUTINE ions_vel3( vel, taup, taum, na, nsp, dt ) + REAL(DP) :: vel(:,:), taup(:,:), taum(:,:) + INTEGER :: na(:), nsp + REAL(DP) :: dt + END SUBROUTINE ions_vel3 + + SUBROUTINE ions_vel2( vel, taup, taum, nat, dt ) + REAL(DP) :: vel(:,:), taup(:,:), taum(:,:) + INTEGER :: nat + REAL(DP) :: dt + END SUBROUTINE ions_vel2 + + SUBROUTINE cofmass1( tau, pmass, na, nsp, cdm ) + REAL(DP), INTENT(IN) :: tau(:,:,:), pmass(:) + REAL(DP), INTENT(OUT) :: cdm(3) + INTEGER, INTENT(IN) :: na(:), nsp + END SUBROUTINE cofmass1 + + SUBROUTINE cofmass2( tau, pmass, na, nsp, cdm ) + REAL(DP), INTENT(IN) :: tau(:,:), pmass(:) + REAL(DP), INTENT(OUT) :: cdm(3) + INTEGER, INTENT(IN) :: na(:), nsp + END SUBROUTINE cofmass2 + + SUBROUTINE randpos(tau, na, nsp, tranp, amprp, hinv, ifor ) + REAL(DP) :: hinv(3,3) + REAL(DP) :: tau(:,:) + INTEGER, INTENT(IN) :: ifor(:,:), na(:), nsp + LOGICAL, INTENT(IN) :: tranp(:) + REAL(DP), INTENT(IN) :: amprp(:) + REAL(DP) :: oldp(3), rand_disp(3), rdisp(3) + + END SUBROUTINE randpos + + SUBROUTINE ions_kinene( ekinp, vels, na, nsp, h, pmass ) + REAL(DP), intent(out) :: ekinp ! ionic kinetic energy + REAL(DP), intent(in) :: vels(:,:) ! scaled ionic velocities + REAL(DP), intent(in) :: pmass(:) ! ionic masses + REAL(DP), intent(in) :: h(:,:) ! simulation cell + integer, intent(in) :: na(:), nsp + integer :: i, j, is, ia, ii, isa + END SUBROUTINE ions_kinene + + subroutine ions_temp( tempp, temps, ekinpr, vels, na, nsp, h, pmass, ndega, nhpdim, atm2nhp, ekin2nhp ) + REAL(DP), intent(out) :: ekinpr, tempp + REAL(DP), intent(out) :: temps(:) + REAL(DP), intent(out) :: ekin2nhp(:) + REAL(DP), intent(in) :: vels(:,:) + REAL(DP), intent(in) :: pmass(:) + REAL(DP), intent(in) :: h(:,:) + integer, intent(in) :: na(:), nsp, ndega, nhpdim, atm2nhp(:) + end subroutine ions_temp + + subroutine ions_thermal_stress( stress, pmass, omega, h, vels, nsp, na ) + REAL(DP), intent(inout) :: stress(3,3) + REAL(DP), intent(in) :: pmass(:), omega, h(3,3), vels(:,:) + integer, intent(in) :: nsp, na(:) + integer :: i, j, is, ia, isa + end subroutine ions_thermal_stress + + subroutine ions_vrescal( tcap, tempw, tempp, taup, tau0, taum, na, nsp, fion, iforce, & + pmass, delt ) + logical, intent(in) :: tcap + REAL(DP), intent(inout) :: taup(:,:) + REAL(DP), intent(in) :: tau0(:,:), taum(:,:), fion(:,:) + REAL(DP), intent(in) :: delt, pmass(:), tempw, tempp + integer, intent(in) :: na(:), nsp + integer, intent(in) :: iforce(:,:) + end subroutine ions_vrescal + subroutine ions_shiftvar( varp, var0, varm ) + REAL(DP), intent(in) :: varp + REAL(DP), intent(out) :: varm, var0 + end subroutine ions_shiftvar + SUBROUTINE cdm_displacement( dis, tau ) + REAL(DP) :: dis + REAL(DP) :: tau + END SUBROUTINE cdm_displacement + SUBROUTINE ions_displacement( dis, tau ) + REAL (DP), INTENT(OUT) :: dis + REAL (DP), INTENT(IN) :: tau + END SUBROUTINE ions_displacement + END MODULE ions_base Index: Fortran/gfortran/regression/use_only_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Test the fix for PR41062, in which an ICE would ensue because +! of confusion between the two 'one's in the creation of module +! debug info. +! +! Reported by Norman S. Clerman +! Reduced testcase by Tobias Burnus +! +module m1 + interface one ! GENERIC "one" + module procedure one1 + end interface +contains + subroutine one1() + STOP 1 + end subroutine one1 +end module m1 + +module m2 +use m1, only : one ! USE generic "one" +contains + subroutine two() + call one() ! Call internal "one" + contains + subroutine one() ! Internal "one" + print *, "m2" + end subroutine one + end subroutine two +end module m2 + + use m2 + call two +end Index: Fortran/gfortran/regression/use_only_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_5.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Test case was failing with the initial version of the +! constructor patch. +! +! Based on the Fortran XML library FoX + +module m_common_attrs + implicit none + private + + type dict_item + integer, allocatable :: i(:) + end type dict_item + + type dictionary_t + private + type(dict_item), pointer :: d => null() + end type dictionary_t + + public :: dictionary_t + public :: get_prefix_by_index + +contains + pure function get_prefix_by_index(dict) result(prefix) + type(dictionary_t), intent(in) :: dict + character(len=size(dict%d%i)) :: prefix + end function get_prefix_by_index +end module m_common_attrs + +module m_common_namespaces + use m_common_attrs, only: dictionary_t + use m_common_attrs, only: get_prefix_by_index +end module m_common_namespaces Index: Fortran/gfortran/regression/use_only_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_only_6.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 52668 - there used to be a bogus warning about not using b. +! Original test case by Arnaud Desitter. +module mm + integer :: a, b + common /mm1/ a, b +end module mm + +subroutine aa() + use mm, only: a + implicit none + a = 1 +end subroutine aa Index: Fortran/gfortran/regression/use_rename_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR34854, in which the second of the two subroutines would fail +! because the type declaration of nmoltype_phase would incorrectly conflict +! with the type given to the module variable of the same name. +! +! Contributed by Francois-Xavier Coudert +! +module common_init_conf + integer, dimension(2) :: Nmoltype_phase +end module common_init_conf + +subroutine read_initial_config_nml1() + use common_init_conf, nmoltype_phase_com => nmoltype_phase + use common_init_conf + implicit none + integer :: nmoltype_phase + namelist /confNmoltypePhase/ nmoltype_phase +end subroutine read_initial_config_nml1 + +subroutine read_initial_config_nml2() + use common_init_conf + use common_init_conf, nmoltype_phase_com => nmoltype_phase + implicit none + integer :: nmoltype_phase + namelist /confNmoltypePhase/ nmoltype_phase +end subroutine read_initial_config_nml2 Index: Fortran/gfortran/regression/use_rename_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_10.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/92736 +! +! Contributed by Chinoune Mehdi +! +module m1 + implicit none + integer, parameter :: i = 10 +end module m1 + +module m2 + use m1, only : i + implicit none + interface + module subroutine sb1() + end subroutine sb1 + end interface +end module m2 + +submodule(m2) s1 + use m1, only : i + implicit none +contains + module subroutine sb1 + print *,"hello", i + end subroutine sb1 +end submodule s1 Index: Fortran/gfortran/regression/use_rename_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_11.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! +! PR fortran/92736 +! +module m + integer :: i, j +end module m + +module m2 + integer :: i, k +end module m2 + +module mod + use m, only: i + interface + module subroutine sb1() + end subroutine sb1 + end interface +end + +! Error: use 'i' both for m's 'i' and 'j' +submodule(mod) sub ! { dg-error "Symbol 'i' at .1. conflicts with the rename symbol" } + use m1, only: i => j ! { dg-error "Symbol 'i' at .1. conflicts with the rename symbol" } +end + +module mod2 + use m, only: i + interface + module subroutine sb1() + end subroutine sb1 + end interface +end + +! Error: use 'i' both for m's 'i' and m2's 'k' +submodule(mod2) sub2 ! { dg-error "Symbol 'i' at .1. conflicts with the rename symbol" } + use m2, only: i => k ! { dg-error "Symbol 'i' at .1. conflicts with the rename symbol" } +end + + +module mod3 + use m, only: i + interface + module subroutine sb1() + end subroutine sb1 + end interface +end + +! Error: use 'i' both for m's 'i' and m2's 'i' +submodule(mod3) sub3 ! { dg-error "Symbol 'i' at .1. conflicts with the symbol" } + use m2, only: i ! { dg-error "Symbol 'i' at .1. conflicts with the symbol" } +end + + +module mod4 + use m, only: mm => i, i + interface + module subroutine sb1() + end subroutine sb1 + end interface +end + +! OK +submodule(mod4) sub4 + use m, only: i + use m, only: mm => i +end + +module mod5 + use m, only: mm => i + interface + module subroutine sb1() + end subroutine sb1 + end interface +end + +! mm from both m2 and m +submodule(mod5) sub5 ! { dg-error "Symbol 'mm' at .1. conflicts with the rename symbol" } + use m2, only: mm => i ! { dg-error "Symbol 'mm' at .1. conflicts with the rename symbol" } +end Index: Fortran/gfortran/regression/use_rename_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-O1" } +! Checks the fix for PR34896 which was a regression that prevented max +! and min from being interchanged by the USE statement below. It is further +! checked by libgomp/testsuite/libgomp.fortran/reduction5.f90 +! +! Reported by H.J. Lu +! +module reduction5 + intrinsic min, max +end module reduction5 + +program reduction_5_regression + call test2 +contains + subroutine test2 + use reduction5, min => max, max => min + integer a, b + a = max (1,5) + b = min (1,5) + if (a .ne. 1) STOP 1 + if (b .ne. 5) STOP 2 + end subroutine test2 +end Index: Fortran/gfortran/regression/use_rename_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_3.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! Tests the fix for PR35997, in which the use association of renamed +! valid2 and flag2 was treated as if the renaming were done on use +! association in the main program. Thus, the following, direct use +! association of valid and flag did not occur. +! +! Contributed by Drew McCormack +! +module funcinterfacemod + interface + logical function valid () + end function + end interface + logical :: flag = .true. +end module + +module secondmod + use funcinterfacemod, valid2 => valid, flag2 => flag +end module + +logical function valid () + valid = .true. +end function + +program main + use secondmod + use funcinterfacemod + if (valid ()) then + print *, 'Is Valid' + endif + if (flag) then + print *, 'Is flag' + endif +end program Index: Fortran/gfortran/regression/use_rename_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } + +! PR fortran/37193 +! Check fix for problem with re-using the same symbol both renamed and +! plain. + +MODULE m + IMPLICIT NONE + INTEGER :: i +END MODULE m + +PROGRAM main + USE m, ONLY: i, j => i + IMPLICIT NONE + + i = 4 + j = 5 + + IF (i /= j) THEN + STOP 1 + END IF +END PROGRAM main Index: Fortran/gfortran/regression/use_rename_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_5.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + +! PR fortran/37193 +! Check that renamed symbols are not accessiable uner their target name. + +MODULE m + IMPLICIT NONE + INTEGER :: i +END MODULE m + +PROGRAM main + USE m, ONLY: j => i + IMPLICIT NONE + + i = 4 ! { dg-error "no IMPLICIT type" } + j = 5 +END PROGRAM main Index: Fortran/gfortran/regression/use_rename_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_6.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/44702 +! +! Based on a test case by Joe Krahn. +! +! Multiple import of the same symbol was failing for +! intrinsic modules. +! +subroutine one() + use iso_c_binding, only: a => c_ptr, b => c_ptr, c_ptr + implicit none + type(a) :: x + type(b) :: y + type(c_ptr) :: z +end subroutine one + +subroutine two() + use iso_c_binding, a => c_ptr, b => c_ptr + implicit none + type(a) :: x + type(b) :: y +end subroutine two + +subroutine three() + use iso_fortran_env, only: a => error_unit, b => error_unit, error_unit + implicit none + if(a /= b) call shall_not_be_there() + if(a /= error_unit) call shall_not_be_there() +end subroutine three + +subroutine four() + use iso_fortran_env, a => error_unit, b => error_unit + implicit none + if(a /= b) call shall_not_be_there() +end subroutine four + +! { dg-final { scan-tree-dump-times "shall_not_be_there" 0 "original" } } Index: Fortran/gfortran/regression/use_rename_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_7.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/62044 +! ICE when loading module UnstructuredGridImages +! because the type UnstructuredGridImageSiloForm +! is not accessible there under its name. +! +! Contributed by Reuben Budiardja + +module UnstructuredGridImageSilo_Form + implicit none + private + type, public, abstract :: GridImageSiloTemplate + end type GridImageSiloTemplate + type, public, extends ( GridImageSiloTemplate ) :: & + UnstructuredGridImageSiloForm + end type UnstructuredGridImageSiloForm +end module UnstructuredGridImageSilo_Form + +module UnstructuredGridImages + use UnstructuredGridImageSilo_Form, & + UnstructuredGridImageForm => UnstructuredGridImageSiloForm +end module UnstructuredGridImages + +module FileSystem + use UnstructuredGridImages +end module FileSystem Index: Fortran/gfortran/regression/use_rename_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_8.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! PR fortran/63744 +! duplicate use rename used to be rejected when the target name +! was that of the current program unit +! +! Original testcase from Roger Ferrer Ibanez + +MODULE MOO + INTEGER :: A, B, C, D, E, F, G, H, I +END MODULE MOO + +SUBROUTINE S + USE MOO, ONLY: X => A, X => A +END SUBROUTINE S + +SUBROUTINE T + USE MOO, ONLY: X => B + USE MOO, ONLY: X => B +END SUBROUTINE T + +SUBROUTINE C ! { dg-error "\(1\)" } + USE MOO, ONLY: C ! { dg-error "conflicts with the" } +END SUBROUTINE C + +SUBROUTINE D + USE MOO, ONLY: X => D +END SUBROUTINE D + +SUBROUTINE E + USE MOO, ONLY: X => E, X => E +END SUBROUTINE E + +SUBROUTINE F + USE MOO, ONLY: X => F + USE MOO, ONLY: X => F +END SUBROUTINE F + +SUBROUTINE X ! { dg-error "\(1\)" } + USE MOO, ONLY: X => G ! { dg-error "conflicts with the rename" } +END SUBROUTINE X + +SUBROUTINE Y ! { dg-error "\(1\)" } + USE MOO, ONLY: Y => H ! { dg-error "conflicts with the rename" } +END SUBROUTINE Y + +SUBROUTINE Z ! { dg-error "\(1\)" } + USE MOO, ONLY: Z => I, Z => I ! { dg-error "conflicts with the rename" } +END SUBROUTINE Z + Index: Fortran/gfortran/regression/use_rename_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_rename_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Test the fix for PR86906, in which a spurious error was generated +! by 'config' in the subroutine having the same symbol name as the +! renamed 'foo_config'. +! +! Contributed by Damian Rouson +! +module foo + type config + end type +end module + use foo, only: foo_config => config +contains + subroutine cap + integer config + type(foo_config) extra + end subroutine +end Index: Fortran/gfortran/regression/use_without_only_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/use_without_only_1.f90 @@ -0,0 +1,21 @@ +! PR fortran/61234 Warn for use-stmt without explicit only-list. +! { dg-do compile } +! { dg-options "-Wuse-without-only" } +MODULE foo + INTEGER :: bar +END MODULE + +MODULE testmod + USE foo ! { dg-warning "7:has no ONLY qualifier" } + IMPLICIT NONE +CONTAINS + SUBROUTINE S1 + USE foo ! { dg-warning "10:has no ONLY qualifier" } + END SUBROUTINE S1 + SUBROUTINE S2 + USE foo, ONLY: bar + END SUBROUTINE + SUBROUTINE S3 + USE ISO_C_BINDING ! { dg-warning "10:has no ONLY qualifier" } + END SUBROUTINE S3 +END MODULE Index: Fortran/gfortran/regression/used_before_typed_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/32095 +! PR fortran/34228 +! Check that standards-conforming mode rejects uses of variables that +! are used before they are typed. + +SUBROUTINE test1 (n, arr, m, arr2, k, arr3, a) ! { dg-error "has no IMPLICIT" } + IMPLICIT NONE + + INTEGER :: arr(n) ! { dg-error "used before it is typed" } + INTEGER :: n + INTEGER :: m, arr2(m) ! { dg-bogus "used before it is typed" } + INTEGER, DIMENSION(k) :: arr3 ! { dg-error "used before it is typed" } + INTEGER :: k + CHARACTER(len=LEN(a)) :: a ! { dg-error "'a' is used before it is typed" } + + REAL(KIND=l) :: x ! { dg-error "has no IMPLICIT type" } + REAL(KIND=KIND(y)) :: y ! { dg-error "has no IMPLICIT type" } + + DATA str/'abc'/ ! { dg-error "used before it is typed" } + CHARACTER(len=3) :: str, str2 + DATA str2/'abc'/ ! { dg-bogus "used before it is typed" } +END SUBROUTINE test1 + +SUBROUTINE test2 (n, arr, m, arr2) + IMPLICIT INTEGER(a-z) + + INTEGER :: arr(n) + REAL :: n ! { dg-error "already has basic type" } + INTEGER :: m, arr2(m) ! { dg-bogus "already has an IMPLICIT type" } +END SUBROUTINE test2 + +SUBROUTINE test3 (n, arr, m, arr2) + IMPLICIT REAL(a-z) + + INTEGER :: arr(n) ! { dg-error "must be of INTEGER type" } + INTEGER :: m, arr2(m) ! { dg-bogus "must be of INTEGER type" } +END SUBROUTINE test3 Index: Fortran/gfortran/regression/used_before_typed_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + +! PR fortran/32095 +! PR fortran/34228 +! This program used to segfault, check this is fixed. +! Also check that -std=gnu behaves as expected. + +SUBROUTINE test1 (n, arr) + IMPLICIT NONE + + INTEGER :: arr(n) ! { dg-bogus "used before it is typed" } + INTEGER :: n + CHARACTER(len=LEN(a)) :: a ! { dg-error "used before it is typed" } +END SUBROUTINE test1 + +SUBROUTINE test2 () + IMPLICIT NONE + + DATA str/'abc'/ ! { dg-bogus "used before it is typed" } + CHARACTER(len=3) :: str +END SUBROUTINE test2 Index: Fortran/gfortran/regression/used_before_typed_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_3.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/32095 +! PR fortran/34228 +! Check for a special case when the return-type of a function is given outside +! its "body" and contains symbols defined inside. + +MODULE testmod + IMPLICIT REAL(a-z) + +CONTAINS + + CHARACTER(len=x) FUNCTION test1 (x) ! { dg-error "of INTEGER" } + IMPLICIT REAL(a-z) + INTEGER :: x ! { dg-error "already has basic type" } + test1 = "foobar" + END FUNCTION test1 + + CHARACTER(len=x) FUNCTION test2 (x) ! { dg-error "of INTEGER" } + IMPLICIT INTEGER(a-z) + test2 = "foobar" + END FUNCTION test2 + +END MODULE testmod + +CHARACTER(len=i) FUNCTION test3 (i) + ! i is IMPLICIT INTEGER by default + test3 = "foobar" +END FUNCTION test3 + +CHARACTER(len=g) FUNCTION test4 (g) ! { dg-error "of INTEGER" } + ! g is REAL, unless declared INTEGER. + test4 = "foobar" +END FUNCTION test4 + +! Test an empty function works, too. +INTEGER FUNCTION test5 () +END FUNCTION test5 Index: Fortran/gfortran/regression/used_before_typed_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_4.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Test for a special case of the used-before-typed errors, when the symbols +! not-yet-typed are indices. + +SUBROUTINE test (n, arr1, m, arr2) ! { dg-error "has no IMPLICIT type" } + IMPLICIT NONE + + INTEGER :: myarr(42) + + INTEGER :: arr1(SIZE (myarr(1:n))) ! { dg-error "'n' is used before" } + INTEGER :: n + + INTEGER :: arr2(LEN ("hello"(1:m))) ! { dg-error "'m' is used before" } + INTEGER :: m + + WRITE (*,*) SIZE (arr1) + WRITE (*,*) SIZE (arr2) +END SUBROUTINE test + +PROGRAM main + IMPLICIT NONE + INTEGER :: arr1(42), arr2(42) + CALL test (3, arr1, 2, arr2) ! { dg-error "Type mismatch in argument" } +END PROGRAM main Index: Fortran/gfortran/regression/used_before_typed_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_5.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-pedantic -std=f95" } + +! Check that DIMENSION/POINTER/ALLOCATABLE/INTENT statements *do* allow +! symbols to be typed later. + +SUBROUTINE test (a) + IMPLICIT REAL (a-z) + + ! Those should *not* IMPLICIT-type the symbols: + INTENT(IN) :: a + DIMENSION :: b(:) + POINTER :: c + ALLOCATABLE :: b + + ! So this is ok: + INTEGER :: a, b, c + +END SUBROUTINE test Index: Fortran/gfortran/regression/used_before_typed_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_before_typed_6.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + +! Allow legacy code to work even if not only a single symbol is used as +! expression but a basic arithmetic expression. + +SUBROUTINE test (n, m) + IMPLICIT NONE + + ! These should go fine. + INTEGER :: arr1(n + 1) ! { dg-bogus "used before it is typed" } + INTEGER :: arr2(n / (2 * m**5)) ! { dg-bogus "used before it is typed" } + + ! These should fail for obvious reasons. + INTEGER :: arr3(n * 1.1) ! { dg-error "must be of INTEGER type" } + INTEGER :: arr4(REAL (m)) ! { dg-error "used before it is typed" } + INTEGER :: arr5(SIN (m)) ! { dg-error "used before it is typed" } + + INTEGER :: n, m +END SUBROUTINE test Index: Fortran/gfortran/regression/used_dummy_types_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! This checks the fix for PR20244 in which USE association +! of derived types would cause an ICE, if the derived type +! was also available by host association. This occurred +! because the backend declarations were different. +! +! Contributed by Paul Thomas +!============== +module mtyp + type t1 + integer::a + end type t1 +end module mtyp +!============== +module atest + use mtyp + type(t1)::ze +contains + subroutine test(ze_in ) + use mtyp + implicit none + type(t1)::ze_in + ze_in = ze + end subroutine test + subroutine init( ) + implicit none + ze = t1 (42) + end subroutine init +end module atest +!============== + use atest + type(t1) :: res = t1 (0) + call init () + call test (res) + if (res%a.ne.42) STOP 1 +end Index: Fortran/gfortran/regression/used_dummy_types_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! This tests that the fix for PR25391 also fixes PR20244. If +! the USE mod1 in subroutine foo were deleted, the code would +! compile fine. With the USE statement, the compiler would +! make new TYPEs for T1 and T2 and bomb out in fold-convert. +! This is a slightly more elaborate test than +! used_dummy_types_1.f90 and came from the PR. +! +! Contributed by Jakub Jelinek +module mod1 + type t1 + real :: f1 + end type t1 + type t2 + type(t1), pointer :: f2(:) + real, pointer :: f3(:,:) + end type t2 +end module mod1 + +module mod2 + use mod1 + type(t1), pointer, save :: v(:) +contains + subroutine foo (x) + use mod1 + implicit none + type(t2) :: x + integer :: d + d = size (x%f3, 2) + v = x%f2(:) + end subroutine foo +end module mod2 Index: Fortran/gfortran/regression/used_dummy_types_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_3.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! This checks the fix for PR20864 in which same name, USE associated +! derived types from different modules, with private components were +! not recognised to be different. +! +! Contributed by Joost VandVondele +!============== + MODULE T1 + TYPE data_type + SEQUENCE + ! private causes the types in T1 and T2 to be different 4.4.2 + PRIVATE + INTEGER :: I + END TYPE + END MODULE + + MODULE T2 + TYPE data_type + SEQUENCE + PRIVATE + INTEGER :: I + END TYPE + + CONTAINS + + SUBROUTINE TEST(x) + TYPE(data_type) :: x + END SUBROUTINE TEST + END MODULE + + USE T1 + USE T2 , ONLY : TEST + TYPE(data_type) :: x + CALL TEST(x) ! { dg-error "Type mismatch in argument" } + END Index: Fortran/gfortran/regression/used_dummy_types_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_4.f90 @@ -0,0 +1,100 @@ +! { dg-do compile } +! This checks the fix for PR19362 in which types from different scopes +! that are the same, according to 4.4.2, would generate an ICE if one +! were assigned to the other. As well as the test itself, various +! other requirements of 4.4.2 are tested here. +! +! Contributed by Paul Thomas +!============== +module global + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + TYPE :: nonseq_type1 + integer :: i + end type nonseq_type1 + type (nonseq_type1) :: ns1 + +end module global + +! Host types with local name != true name + use global, only: seq_type2=>seq_type1, nonseq_type2=>nonseq_type1, ns1 + type (nonseq_type2) :: ns2 + +! Host non-sequence types + type :: different_type + integer :: i + end type different_type + type (different_type) :: dt1 + + type :: same_type + integer :: i + end type same_type + type (same_type) :: st1 + + real :: seq_type1 + +! Provide a reference to dt1. + dt1 = different_type (42) +! These share a type declaration. + ns2 = ns1 +! USE associated seq_type1 is renamed. + seq_type1 = 1.0 + +! These are different. + st1 = dt ! { dg-error "convert REAL" } + + call foo (st1) ! { dg-error "Type mismatch in argument" } + +contains + + subroutine foo (st2) + +! Contained type with local name != true name. +! This is the same as seq_type2 in the host. + use global, only: seq_type3=>seq_type1 + +! This local declaration is the same as seq_type3 and seq_type2. + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + +! Host association of renamed type. + type (seq_type2) :: x +! Locally declared version of the same thing. + type (seq_type1) :: y +! USE associated renamed type. + type (seq_type3) :: z + +! Contained type that is different to that in the host. + type :: different_type + complex :: z + end type different_type + + type :: same_type + integer :: i + end type same_type + + type (different_type) :: b + type (same_type) :: st2 + +! Error because these are not the same. + b = dt1 ! { dg-error "convert TYPE" } + +! Error in spite of the name - these are non-sequence types and are NOT +! the same. + st1 = st2 ! { dg-error "convert TYPE" } + + b%z = (2.0,-1.0) + +! Check that the references that are correct actually work. These test the +! fix for PR19362. + x = seq_type1 (1) + y = x + y = seq_type3 (99) + end subroutine foo +END Index: Fortran/gfortran/regression/used_dummy_types_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_5.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! This checks that the fix for PR19362 has not broken gfortran +! in respect of.references allowed by 4.4.2. +! +! Contributed by Paul Thomas +!============== +module global + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + TYPE :: nonseq_type1 + integer :: i = 44 + end type nonseq_type1 + type (nonseq_type1), save :: ns1 + +end module global + + use global, only: seq_type2=>seq_type1, nonseq_type1, ns1 + +! Host non-sequence types + type :: different_type + integer :: i + end type different_type + + type :: same_type + sequence + integer :: i + end type same_type + + type (seq_type2) :: t1 + type (different_type) :: dt1 + + type (nonseq_type1) :: ns2 + type (same_type) :: st1 + real seq_type1 + + t1 = seq_type2 (42) + dt1 = different_type (43) + ns2 = ns1 + seq_type1 =1.0e32 + st1%i = 45 + + call foo (t1) + +contains + + subroutine foo (x) + + use global, only: seq_type3=>seq_type1 + + TYPE :: seq_type1 + sequence + integer :: i + end type seq_type1 + + type :: different_type + complex :: z + end type different_type + + type :: same_type + sequence + integer :: i + end type same_type +! Host association of renamed type. + type (seq_type2) :: x +! Locally declared version of the same thing. + type (seq_type1) :: y +! USE associated renamed type. + type (seq_type3) :: z + + + type (different_type) :: dt2 + type (same_type) :: st2 + + dt2%z = (2.0,-1.0) + y = seq_type2 (46) + z = seq_type3 (47) + st2 = st1 + print *, x, y, z, dt2, st2, ns2, ns1 + end subroutine foo +END Index: Fortran/gfortran/regression/used_dummy_types_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_6.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! Tests the fix for PR30554, the USE statements in potential_energy +! would cause a segfault because the pointer_info for nfree coming +! from constraint would not find the existing symtree coming directly +! from atom. +! +! The last two modules came up subsequently to the original fix. The +! PRIVATE statement caused a revival of the original problem. This +! was tracked down to an interaction between the symbols being set +! referenced during module read and the application of the access +! attribute. +! +! Contributed by Tobias Burnus + +MODULE ATOMS +INTEGER :: NFREE = 0 +END MODULE ATOMS + +MODULE CONSTRAINT +USE ATOMS, ONLY: NFREE +CONTAINS + SUBROUTINE ENERGY_CONSTRAINT ( HESSIAN ) + REAL , DIMENSION(1:(3*NFREE*(3*NFREE+1))/2):: HESSIAN + END SUBROUTINE ENERGY_CONSTRAINT +END MODULE CONSTRAINT + +MODULE POTENTIAL_ENERGY +USE ATOMS +USE CONSTRAINT, ONLY : ENERGY_CONSTRAINT +END MODULE POTENTIAL_ENERGY + +MODULE P_CONSTRAINT +USE ATOMS, ONLY: NFREE +PRIVATE +PUBLIC :: ENERGY_CONSTRAINT +CONTAINS + SUBROUTINE ENERGY_CONSTRAINT ( HESSIAN ) + REAL , DIMENSION(1:(3*NFREE*(3*NFREE+1))/2):: HESSIAN + END SUBROUTINE ENERGY_CONSTRAINT +END MODULE P_CONSTRAINT + +MODULE P_POTENTIAL_ENERGY +USE ATOMS +USE CONSTRAINT, ONLY : ENERGY_CONSTRAINT +END MODULE P_POTENTIAL_ENERGY Index: Fortran/gfortran/regression/used_dummy_types_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_7.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! This tests a patch for a regression caused by the second part of +! the fix for PR30554. The linked derived types dummy_atom and +! dummy_atom_list caused a segment fault because they do not have +! a namespace. +! +! Contributed by Daniel Franke +! +MODULE types +TYPE :: dummy_atom_list + TYPE(dummy_atom), DIMENSION(:), POINTER :: table => null() +END TYPE + +TYPE :: dummy_atom + TYPE(dummy_atom_private), POINTER :: p => null() +END TYPE + +TYPE :: dummy_atom_private + INTEGER :: id +END TYPE +END MODULE + +MODULE atom +USE types, ONLY: dummy_atom +INTERFACE + SUBROUTINE dummy_atom_insert_symmetry_mate(this, other) + USE types, ONLY: dummy_atom + TYPE(dummy_atom), INTENT(inout) :: this + TYPE(dummy_atom), INTENT(in) :: other + END SUBROUTINE +END INTERFACE +END MODULE + +MODULE list +INTERFACE + SUBROUTINE dummy_atom_list_insert(this, atom2) + USE types, ONLY: dummy_atom_list + USE atom, ONLY: dummy_atom + + TYPE(dummy_atom_list), INTENT(inout) :: this + TYPE(dummy_atom), INTENT(in) :: atom2 + END SUBROUTINE +END INTERFACE +END MODULE Index: Fortran/gfortran/regression/used_dummy_types_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_dummy_types_8.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! Tests the fix for PR30880, in which the variable d1 +! in module m1 would cause an error in the main program +! because it has an initializer and is a dummy. This +! came about because the function with multiple entries +! assigns the initializer earlier than for other cases. +! +! Contributed by Joost VandeVondele +! +MODULE M1 + TYPE T1 + INTEGER :: i=7 + END TYPE T1 +CONTAINS + FUNCTION F1(d1) RESULT(res) + INTEGER :: res + TYPE(T1), INTENT(OUT) :: d1 + TYPE(T1), INTENT(INOUT) :: d2 + res=d1%i + d1%i=0 + RETURN + ENTRY E1(d2) RESULT(res) + res=d2%i + d2%i=0 + END FUNCTION F1 +END MODULE M1 + + USE M1 + TYPE(T1) :: D1 + D1=T1(3) + write(6,*) F1(D1) + D1=T1(3) + write(6,*) E1(D1) +END Index: Fortran/gfortran/regression/used_interface_ref.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_interface_ref.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Tests the fix for PR26393, in which an ICE would occur in trans-decl.c +! (gfc_get_symbol_decl) because anzKomponenten is not referenced in the +! interface for solveCConvert. The solution was to assert that the symbol +! is either referenced or in an interface body. +! +! Based on the testcase in the PR. +! + MODULE MODULE_CONC + INTEGER, SAVE :: anzKomponenten = 2 + END MODULE MODULE_CONC + + MODULE MODULE_THERMOCALC + INTERFACE + FUNCTION solveCConvert () + USE MODULE_CONC, ONLY: anzKomponenten + REAL :: solveCConvert(1:anzKomponenten) + END FUNCTION solveCConvert + END INTERFACE + END MODULE MODULE_THERMOCALC + + SUBROUTINE outDiffKoeff + USE MODULE_CONC + USE MODULE_THERMOCALC + REAL :: buffer_conc(1:anzKomponenten) + buffer_conc = solveCConvert () + if (any(buffer_conc .ne. (/(real(i), i = 1, anzKomponenten)/))) & + STOP 1 + END SUBROUTINE outDiffKoeff + + program missing_ref + USE MODULE_CONC + call outDiffKoeff +! Now set anzKomponenten to a value that would cause a segfault if +! buffer_conc and solveCConvert did not have the correct allocation +! of memory. + anzKomponenten = 5000 + call outDiffKoeff + end program missing_ref + + FUNCTION solveCConvert () + USE MODULE_CONC, ONLY: anzKomponenten + REAL :: solveCConvert(1:anzKomponenten) + solveCConvert = (/(real(i), i = 1, anzKomponenten)/) + END FUNCTION solveCConvert Index: Fortran/gfortran/regression/used_types_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! This checks that the fix for PR25730, which was a regression +! caused by the fix for PR19362. +! +! Contributed by Andrea Bedini +!============== +MODULE testcase + TYPE orbit_elem + CHARACTER(4) :: coo + END TYPE orbit_elem +END MODULE +MODULE tp_trace + USE testcase + TYPE(orbit_elem) :: tp_store +CONTAINS + SUBROUTINE str_clan() + USE testcase + TYPE(orbit_elem) :: mtpcar + mtpcar%coo='a' !ICE was here + END SUBROUTINE str_clan +END MODULE Index: Fortran/gfortran/regression/used_types_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_10.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! Tests the fix for PR28959 in which interface derived types were +! not always being associated. +! +! Contributed by Salvatore Filippone +! +module derived_type_mod + + type foo_dtype + integer, pointer :: v1(:)=>null() + end type foo_dtype + + +end module derived_type_mod + + +Module tools + + interface foo_d_sub + subroutine cdalv(m, v, i, desc_a, info, flag) + use derived_type_mod + Integer, intent(in) :: m,i, v(:) + integer, intent(in), optional :: flag + integer, intent(out) :: info + Type(foo_dtype), intent(out) :: desc_a + end subroutine cdalv + end interface + +end module tools + + + +subroutine foo_bar(a,p,info) + use derived_type_mod + implicit none + + type(foo_dtype), intent(in) :: a + type(foo_dtype), intent(inout) :: p + integer, intent(out) :: info + + info=0 + + call inner_sub(info) + + + return + + +contains + + subroutine inner_sub(info) + use tools + implicit none + + integer, intent(out) :: info + + integer :: i, nt,iv(10) + + i = 0 + nt = 1 + + call foo_d_sub(nt,iv,i,p,info,flag=1) + + return + + + end subroutine inner_sub + + + +end subroutine foo_bar Index: Fortran/gfortran/regression/used_types_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_11.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! Tests the patch for PR 29641, in which an ICE would occur with +! the ordering of USE statements below. +! +! Contributed by Jakub Jelinek +! +module A + type :: T + integer :: u + end type T +end module A + +module B +contains + function foo() + use A + type(T), pointer :: foo + nullify (foo) + end function foo +end module B + +subroutine bar() + use B ! The order here is important + use A ! If use A comes before use B, it works + type(T), pointer :: x + x => foo() +end subroutine bar + + use B + use A + type(T), pointer :: x + type(T), target :: y + x => y + print *, associated (x) + x => foo () + print *, associated (x) +end Index: Fortran/gfortran/regression/used_types_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_12.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Tests the fix PR29744, which is really a repeat of PR19362. +! The problem came about because the test for PR19362 shifted +! the fix to a subroutine, rather than the main program that +! it originally occurred in. Fixes for subsequent PRs introduced +! a difference between the main program and a contained procedure +! that resulted in the compiler going into an infinite loop. +! +! Contributed by Harald Anlauf +! and originally by Francois-Xavier Coudert +! +MODULE M + TYPE T0 + SEQUENCE + INTEGER I + END TYPE +END + +PROGRAM MAIN + USE M, T1 => T0 + TYPE T0 + SEQUENCE + INTEGER I + END TYPE + TYPE(T0) :: BAR + TYPE(T1) :: BAZ + BAZ = BAR +END Index: Fortran/gfortran/regression/used_types_13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_13.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR29820, which was another problem with derived type +! association. Not all siblings were being searched for identical types. +! +! Contributed by Harald Anlauf +! +module geo + type geodetic + real :: h + end type geodetic +end module geo +module gfcbug44 + implicit none +contains +subroutine point ( gp) + use geo + type(geodetic), intent(out) :: gp + type(geodetic) :: gpx(1) + gp = gpx(1) +end subroutine point +subroutine plane () + use geo + type(geodetic) :: gp + call point ( gp) +end subroutine plane +end module gfcbug44 Index: Fortran/gfortran/regression/used_types_14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_14.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Tests the fix for PR30531 in which the interface derived types +! was not being associated. +! +! Contributed by Salvatore Filippone +! +module foo_type_mod + type foo_type + integer, allocatable :: md(:) + end type foo_type +end module foo_type_mod + +module foo_mod + + interface + subroutine foo_initvg(foo_a) + use foo_type_mod + Type(foo_type), intent(out) :: foo_a + end subroutine foo_initvg + end interface + +contains + + subroutine foo_ext(foo_a) + use foo_type_mod + Type(foo_type) :: foo_a + + call foo_initvg(foo_a) + end subroutine foo_ext + +end module foo_mod Index: Fortran/gfortran/regression/used_types_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_15.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! Tests the fix for PR31086 in which the chained derived types +! was not being associated. +! +! Contributed by Daniel Franke +! +MODULE class_dummy_atom_types +TYPE :: dummy_atom_list + TYPE(dummy_atom), DIMENSION(:), POINTER :: table +END TYPE + +TYPE :: dummy_atom + TYPE(dummy_atom_list) :: neighbors +END TYPE + +TYPE :: dummy_atom_model + TYPE(dummy_atom_list) :: atoms +END TYPE +END MODULE + +MODULE test_class_intensity_private +CONTAINS + SUBROUTINE change_phase(atom) + USE class_dummy_atom_types + TYPE(dummy_atom), INTENT(inout) :: atom + END SUBROUTINE + + SUBROUTINE simulate_cube() + USE class_dummy_atom_types + TYPE(dummy_atom) :: atom + TYPE(dummy_atom_model) :: dam + atom = dam%atoms%table(1) + END SUBROUTINE +END MODULE Index: Fortran/gfortran/regression/used_types_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_16.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! Tests the fix for PR31550 in which pointers to derived type components +! were being TREE-SSA declared in the wrong order and so in the incorrect +! context. +! +! Contributed by Daniel Franke +! +MODULE class_dummy_atom_types +TYPE :: dummy_atom_list + TYPE(dummy_atom), DIMENSION(:), POINTER :: table + INTEGER :: nused +END TYPE + +TYPE :: dummy_atom + TYPE(dummy_atom_private), POINTER :: p +END TYPE + +TYPE :: dummy_atom_private + TYPE(dummy_atom_list) :: neighbors +END TYPE +END MODULE + +MODULE class_dummy_atom_list +USE class_dummy_atom_types, ONLY: dummy_atom_list + +INTERFACE + SUBROUTINE dummy_atom_list_init_copy(this, other) + USE class_dummy_atom_types, ONLY: dummy_atom_list + TYPE(dummy_atom_list), INTENT(out) :: this + TYPE(dummy_atom_list), INTENT(in) :: other + END SUBROUTINE +END INTERFACE + +INTERFACE + SUBROUTINE dummy_atom_list_merge(this, other) + USE class_dummy_atom_types, ONLY: dummy_atom_list + TYPE(dummy_atom_list), INTENT(inout) :: this + TYPE(dummy_atom_list), INTENT(in) :: other + END SUBROUTINE +END INTERFACE +END MODULE + +SUBROUTINE dummy_atom_list_init_copy(this, other) + USE class_dummy_atom_list, ONLY: dummy_atom_list, dummy_atom_list_merge + + TYPE(dummy_atom_list), INTENT(out) :: this + TYPE(dummy_atom_list), INTENT(in) :: other + + this%table(1:this%nused) = other%table(1:other%nused) +END SUBROUTINE Index: Fortran/gfortran/regression/used_types_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_17.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! Tests the fix for PR31630, in which the association of the argument +! of 'cmp' did not work. +! +! Contributed by Francois-Xavier Coudert +! +module box_module + type box + integer :: m = 0 + end type box +end module box_module + +module sort_box_module +contains + + subroutine heapsort_box(cmp) + interface + subroutine cmp(a) + use box_module + type(box) :: a + end subroutine cmp + end interface + optional :: cmp + end subroutine heapsort_box + +end module sort_box_module + + +module boxarray_module + use box_module + implicit none + + type boxarray + type(box), allocatable :: bxs(:) + end type boxarray +contains + + subroutine boxarray_build_l(ba) + type(boxarray) :: ba + allocate(ba%bxs(1)) + end subroutine boxarray_build_l + + subroutine boxarray_sort() + use sort_box_module + call heapsort_box + end subroutine boxarray_sort + +end module boxarray_module Index: Fortran/gfortran/regression/used_types_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_18.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Fortran 2003 allowes TYPE without components +! The error message for -std=f95 is tested in +! gfortran.dg/access_spec_2.f90 +! +! PR fortran/33188 +! +type t +end type + +type(t) :: a +print *, a +end Index: Fortran/gfortran/regression/used_types_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_19.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! Tests the fix for PR34335 a regression in which the PRIVATE attribute +! of type(a) in module b would be ignored and would prevent it being +! loaded in the main program. +! +! Contributed by Janus Weil +! +module A + type A_type + real comp + end type +end module A + +module B + use A + private + type(A_type) :: B_var + public:: B_var +end module B + +program C + use B + use A + type(A_type):: A_var +end program C Index: Fortran/gfortran/regression/used_types_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Tests the fix for PR28630, in which a contained, +! derived type function caused an ICE if its definition +! was both host and use associated. +! +! Contributed by Mark Hesselink +! +MODULE types + TYPE :: t + INTEGER :: i + END TYPE +END MODULE types + +MODULE foo + USE types +CONTAINS + FUNCTION bar (x) RESULT(r) + USE types + REAL, INTENT(IN) :: x + TYPE(t) :: r + r = t(0) + END FUNCTION bar +END MODULE + + +LOGICAL FUNCTION foobar (x) + USE foo + REAL, INTENT(IN) :: x + TYPE(t) :: c + foobar = .FALSE. + c = bar (x) +END FUNCTION foobar Index: Fortran/gfortran/regression/used_types_20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_20.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! Tests the fix for PR36366 a regression in which the order of USE statements +! in 'test2' would cause the result of 'test1' not to have a reference to +! the derived type 'inner'. +! +! Contributed by Jakub Jelinek +! +MODULE types + IMPLICIT NONE + TYPE :: inner + INTEGER, POINTER :: i(:) + END TYPE inner + + TYPE :: outer + TYPE(inner), POINTER :: inr(:) + END TYPE outer +END MODULE types + +MODULE mymod + IMPLICIT NONE +CONTAINS + FUNCTION test1() + USE types + IMPLICIT NONE + TYPE(outer), POINTER :: test1 + NULLIFY(test1) + END FUNCTION test1 +END MODULE mymod + +MODULE test + IMPLICIT NONE +CONTAINS + + SUBROUTINE test2(a) + USE mymod + USE types + IMPLICIT NONE + TYPE(outer), INTENT(INOUT) :: a + INTEGER :: i + i = a%inr(1)%i(1) + END SUBROUTINE test2 + + SUBROUTINE test3(a) + USE types + IMPLICIT NONE + TYPE(outer), INTENT(IN) :: a + END SUBROUTINE test3 +END MODULE test Index: Fortran/gfortran/regression/used_types_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_21.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Check that pointer components are allowed to empty types. + +TYPE :: empty_t +END TYPE empty_t + +TYPE :: comp_t + TYPE(empty_t), POINTER :: ptr +END TYPE comp_t + +END Index: Fortran/gfortran/regression/used_types_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_22.f90 @@ -0,0 +1,292 @@ +! { dg-do compile } +! Tests the fix for PR37274 a regression in which the derived type, +! 'vector' of the function results contained in 'class_motion' is +! private and is incorrectly detected to be ambiguous in 'smooth_mesh'. +! +! Contributed by Salvatore Filippone +! +module class_vector + + implicit none + + private ! Default + public :: vector + public :: vector_ + + type vector + private + real(kind(1.d0)) :: x + real(kind(1.d0)) :: y + real(kind(1.d0)) :: z + end type vector + +contains + ! ----- Constructors ----- + + ! Public default constructor + elemental function vector_(x,y,z) + type(vector) :: vector_ + real(kind(1.d0)), intent(in) :: x, y, z + + vector_ = vector(x,y,z) + + end function vector_ + +end module class_vector + +module class_dimensions + + implicit none + + private ! Default + public :: dimensions + + type dimensions + private + integer :: l + integer :: m + integer :: t + integer :: theta + end type dimensions + + +end module class_dimensions + +module tools_math + + implicit none + + + interface lin_interp + function lin_interp_s(f1,f2,fac) + real(kind(1.d0)) :: lin_interp_s + real(kind(1.d0)), intent(in) :: f1, f2 + real(kind(1.d0)), intent(in) :: fac + end function lin_interp_s + + function lin_interp_v(f1,f2,fac) + use class_vector + type(vector) :: lin_interp_v + type(vector), intent(in) :: f1, f2 + real(kind(1.d0)), intent(in) :: fac + end function lin_interp_v + end interface + + + interface pwl_deriv + subroutine pwl_deriv_x_s(dydx,x,y_data,x_data) + real(kind(1.d0)), intent(out) :: dydx + real(kind(1.d0)), intent(in) :: x + real(kind(1.d0)), intent(in) :: y_data(:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_s + + subroutine pwl_deriv_x_v(dydx,x,y_data,x_data) + real(kind(1.d0)), intent(out) :: dydx(:) + real(kind(1.d0)), intent(in) :: x + real(kind(1.d0)), intent(in) :: y_data(:,:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_v + + subroutine pwl_deriv_x_vec(dydx,x,y_data,x_data) + use class_vector + type(vector), intent(out) :: dydx + real(kind(1.d0)), intent(in) :: x + type(vector), intent(in) :: y_data(:) + real(kind(1.d0)), intent(in) :: x_data(:) + end subroutine pwl_deriv_x_vec + end interface + +end module tools_math + +module class_motion + + use class_vector + + implicit none + + private + public :: motion + public :: get_displacement, get_velocity + + type motion + private + integer :: surface_motion + integer :: vertex_motion + ! + integer :: iml + real(kind(1.d0)), allocatable :: law_x(:) + type(vector), allocatable :: law_y(:) + end type motion + +contains + + + function get_displacement(mot,x1,x2) + use tools_math + + type(vector) :: get_displacement + type(motion), intent(in) :: mot + real(kind(1.d0)), intent(in) :: x1, x2 + ! + integer :: i1, i2, i3, i4 + type(vector) :: p1, p2, v_A, v_B, v_C, v_D + type(vector) :: i_trap_1, i_trap_2, i_trap_3 + + get_displacement = vector_(0.d0,0.d0,0.d0) + + end function get_displacement + + + function get_velocity(mot,x) + use tools_math + + type(vector) :: get_velocity + type(motion), intent(in) :: mot + real(kind(1.d0)), intent(in) :: x + ! + type(vector) :: v + + get_velocity = vector_(0.d0,0.d0,0.d0) + + end function get_velocity + + + +end module class_motion + +module class_bc_math + + implicit none + + private + public :: bc_math + + type bc_math + private + integer :: id + integer :: nbf + real(kind(1.d0)), allocatable :: a(:) + real(kind(1.d0)), allocatable :: b(:) + real(kind(1.d0)), allocatable :: c(:) + end type bc_math + + +end module class_bc_math + +module class_bc + + use class_bc_math + use class_motion + + implicit none + + private + public :: bc_poly + public :: get_abc, & + & get_displacement, get_velocity + + type bc_poly + private + integer :: id + type(motion) :: mot + type(bc_math), pointer :: math => null() + end type bc_poly + + + interface get_displacement + module procedure get_displacement, get_bc_motion_displacement + end interface + + interface get_velocity + module procedure get_velocity, get_bc_motion_velocity + end interface + + interface get_abc + module procedure get_abc_s, get_abc_v + end interface + +contains + + + subroutine get_abc_s(bc,dim,id,a,b,c) + use class_dimensions + + type(bc_poly), intent(in) :: bc + type(dimensions), intent(in) :: dim + integer, intent(out) :: id + real(kind(1.d0)), intent(inout) :: a(:) + real(kind(1.d0)), intent(inout) :: b(:) + real(kind(1.d0)), intent(inout) :: c(:) + + + end subroutine get_abc_s + + + subroutine get_abc_v(bc,dim,id,a,b,c) + use class_dimensions + use class_vector + + type(bc_poly), intent(in) :: bc + type(dimensions), intent(in) :: dim + integer, intent(out) :: id + real(kind(1.d0)), intent(inout) :: a(:) + real(kind(1.d0)), intent(inout) :: b(:) + type(vector), intent(inout) :: c(:) + + + end subroutine get_abc_v + + + + function get_bc_motion_displacement(bc,x1,x2)result(res) + use class_vector + type(vector) :: res + type(bc_poly), intent(in) :: bc + real(kind(1.d0)), intent(in) :: x1, x2 + + res = get_displacement(bc%mot,x1,x2) + + end function get_bc_motion_displacement + + + function get_bc_motion_velocity(bc,x)result(res) + use class_vector + type(vector) :: res + type(bc_poly), intent(in) :: bc + real(kind(1.d0)), intent(in) :: x + + res = get_velocity(bc%mot,x) + + end function get_bc_motion_velocity + + +end module class_bc + +module tools_mesh_basics + + implicit none + + interface + function geom_tet_center(v1,v2,v3,v4) + use class_vector + type(vector) :: geom_tet_center + type(vector), intent(in) :: v1, v2, v3, v4 + end function geom_tet_center + end interface + + +end module tools_mesh_basics + + +subroutine smooth_mesh + + use class_bc + use class_vector + use tools_mesh_basics + + implicit none + + type(vector) :: new_pos ! the new vertex position, after smoothing + +end subroutine smooth_mesh Index: Fortran/gfortran/regression/used_types_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_23.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Tests the fix for PR37274 comment 4 in which the use associated 'vector' was +! passed up from the interface to the module 'tools_math'. +! +! Contributed by Mikael Morin +! +module class_vector + implicit none + type vector + end type vector +end module class_vector + +module tools_math + implicit none + interface lin_interp + function lin_interp_v() + use class_vector + type(vector) :: lin_interp_v + end function lin_interp_v + end interface +end module tools_math + +module smooth_mesh + use tools_math + implicit none + type(vector ) :: new_pos ! { dg-error "used before it is defined" } +end module smooth_mesh + Index: Fortran/gfortran/regression/used_types_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_24.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Tests the fix for PR37794 a regression where a bit of redundant code caused an ICE. +! +! Contributed by Jonathan Hogg +! +module m1 + implicit none + + type of01_data_private + real :: foo + end type of01_data_private + + type of01_data + type (of01_data_private) :: private + end type of01_data +end module m1 + +module m2 + implicit none + + type of01_data_private + integer :: youngest + end type of01_data_private +end module m2 + +module test_mod + use m1, of01_rdata => of01_data + use m2, of01_idata => of01_data ! { dg-error "not found in module" } + + implicit none +end module test_mod Index: Fortran/gfortran/regression/used_types_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_25.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Created to check this ambiguity when +! constructors were added. Cf. PR fortran/39427 + +module m + type t + end type t +end module m + +use m + type t ! { dg-error "Derived type definition of 't' at .1. has already been defined" } + end type t ! { dg-error "Expecting END PROGRAM statement" } +end Index: Fortran/gfortran/regression/used_types_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_26.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Check for ambiguity. +! +! Added as part of the constructor work (PR fortran/39427). +! + module m + type t + end type t + end module m + + module m2 + type t + end type t + end module m2 + + use m + use m2 + type(t) :: x ! { dg-error "Type name 't' at .1. is ambiguous" } + end Index: Fortran/gfortran/regression/used_types_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_27.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/56674 +! PR fortran/58813 +! PR fortran/59016 +! PR fortran/59024 +! The generic name 'atomic_kind_types' was keeping pointers to freed +! symbols, leading to random error-recovery ICEs. +! +! Original test case from Joost VandeVondele . + +MODULE atomic_kind_types + PUBLIC :: atomic_kind_type +CONTAINS + INTEGER FUNCTION is_hydrogen(atomic_kind) + TYPE(atomic_kind_type), pointer :: atomic_kind ! { dg-error "used before it is defined" } + END FUNCTION +END MODULE Index: Fortran/gfortran/regression/used_types_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_3.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! Test the fix for PR28601 in which line 55 would produce an ICE +! because the rhs and lhs derived times were not identically +! associated and so could not be cast. +! +! Contributed by Francois-Xavier Coudert +! +module modA +implicit none +save +private + +type, public :: typA +integer :: i +end type typA + +type, public :: atom +type(typA), pointer :: ofTypA(:,:) +end type atom +end module modA + +!!! re-name and re-export typA as typB: +module modB +use modA, only: typB => typA +implicit none +save +private + +public typB +end module modB + +!!! mixed used of typA and typeB: +module modC +use modB +implicit none +save +private +contains + +subroutine buggy(a) +use modA, only: atom +! use modB, only: typB +! use modA, only: typA +implicit none +type(atom),intent(inout) :: a +target :: a +! *** end of interface *** + +type(typB), pointer :: ofTypB(:,:) +! type(typA), pointer :: ofTypB(:,:) +integer :: i,j,k + +ofTypB => a%ofTypA + +a%ofTypA(i,j) = ofTypB(k,j) +end subroutine buggy +end module modC Index: Fortran/gfortran/regression/used_types_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_4.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the fix for PR28788, a regression in which an ICE was caused +! by the failure of derived type association for the arguments of +! InitRECFAST because the formal namespace derived types references +! were not being reassociated to the module. +! +! Contributed by Martin Reinecke +! +module Precision + integer, parameter :: dl = KIND(1.d0) +end module Precision + +module ModelParams + use precision + type CAMBparams + real(dl)::omegab,h0,tcmb,yhe + end type + type (CAMBparams) :: CP +contains + subroutine CAMBParams_Set(P) + type(CAMBparams), intent(in) :: P + end subroutine CAMBParams_Set +end module ModelParams + +module TimeSteps + use precision + use ModelParams +end module TimeSteps + +module ThermoData + use TimeSteps +contains + subroutine inithermo(taumin,taumax) + use precision + use ModelParams ! Would ICE here + real(dl) taumin,taumax + call InitRECFAST(CP%omegab,CP%h0,CP%tcmb,CP%yhe) + end subroutine inithermo +end module ThermoData Index: Fortran/gfortran/regression/used_types_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_5.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788, as noted in reply #9 in the Bugzilla +! entry by Martin Reinecke . +! The problem was caused by certain types of references +! that point to a deleted derived type symbol, after the +! type has been associated to another namespace. An +! example of this is the specification expression for x +! in subroutine foo below. At the same time, this tests +! the correct association of typeaa between a module +! procedure and a new definition of the type in MAIN. +! +module types + + type :: typea + sequence + integer :: i + end type typea + + type :: typeaa + sequence + integer :: i + end type typeaa + + type(typea) :: it = typea(2) + +end module types +!------------------------------ +module global + + use types, only: typea, it + +contains + + subroutine foo (x) + use types + type(typeaa) :: ca + real :: x(it%i) + common /c/ ca + x = 42.0 + ca%i = 99 + end subroutine foo + +end module global +!------------------------------ + use global, only: typea, foo + type :: typeaa + sequence + integer :: i + end type typeaa + type(typeaa) :: cam + real :: x(4) + common /c/ cam + x = -42.0 + call foo(x) + if (any (x .ne. (/42.0, 42.0, -42.0, -42.0/))) STOP 1 + if (cam%i .ne. 99) STOP 2 +end Index: Fortran/gfortran/regression/used_types_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_6.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788, as noted in reply #13 in the Bugzilla +! entry by Martin Tee . +! The problem was caused by contained, use associated +! derived types with pointer components of a derived type +! use associated in a sibling procedure, where both are +! associated by an ONLY clause. This is the reporter's +! test case. +! +MODULE type_mod + TYPE a + INTEGER :: n(10) + END TYPE a + + TYPE b + TYPE (a), POINTER :: m(:) => NULL () + END TYPE b +END MODULE type_mod + +MODULE seg_mod +CONTAINS + SUBROUTINE foo (x) + USE type_mod, ONLY : a ! failed + IMPLICIT NONE + TYPE (a) :: x + RETURN + END SUBROUTINE foo + + SUBROUTINE bar (x) + USE type_mod, ONLY : b ! failed + IMPLICIT NONE + TYPE (b) :: x + RETURN + END SUBROUTINE bar +END MODULE seg_mod Index: Fortran/gfortran/regression/used_types_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_7.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788 and posted as PR28908. The problem was +! caused by the patch preventing interface derived types +! from associating with identical derived types in the +! containing namespaces. +! +! Contributed by HJ Lu +! +module bar + implicit none + public + type ESMF_Time + integer :: DD + end type +end module bar + +module foo + use bar + implicit none + private + type ESMF_Clock + type(ESMF_Time) :: CurrTime + end type + interface operator (+) + function add (x, y) + use bar + type(ESMF_Time) :: add + type(ESMF_Time), intent(in) :: x + type(ESMF_Time), intent(in) :: y + end function add + end interface +contains + subroutine ESMF_ClockAdvance(clock) + type(ESMF_Clock), intent(inout) :: clock + clock%CurrTime = clock%CurrTime + clock%CurrTime + end subroutine ESMF_ClockAdvance +end module foo Index: Fortran/gfortran/regression/used_types_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_8.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788 and posted as PR28908. The problem was +! caused by the patch preventing interface derived types +! from associating with identical derived types in the +! containing namespaces. +! +! Contributed by HJ Lu +! +module bar + implicit none + public + type ESMF_Time + sequence + integer :: MM + end type + public operator (+) + private add + interface operator (+) + module procedure add + end interface +contains + function add (x, y) + type(ESMF_Time) :: add + type(ESMF_Time), intent(in) :: x + type(ESMF_Time), intent(in) :: y + add = x + end function add +end module bar + +module foo + use bar + implicit none + private + type ESMF_Clock + sequence + type(ESMF_Time) :: CurrTime + end type +contains + subroutine ESMF_ClockAdvance(clock) + use bar + type(ESMF_Clock), intent(inout) :: clock + clock%CurrTime = clock%CurrTime + clock%CurrTime + end subroutine ESMF_ClockAdvance +end module foo Index: Fortran/gfortran/regression/used_types_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/used_types_9.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! Tests the fix for a further regression caused by the +! fix for PR28788 and posted as PR28908. The problem was +! caused by the patch preventing interface derived types +! from associating with identical derived types in the +! containing namespaces. +! +! Contributed by HJ Lu +! +module bar + implicit none + public + type domain_ptr + type(domain), POINTER :: ptr + end type domain_ptr + type domain + TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: parents + TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: nests + end type domain +end module bar + +module foo +contains + recursive subroutine integrate (grid) + use bar + implicit none + type(domain), POINTER :: grid + interface + subroutine solve_interface (grid) + use bar + TYPE (domain) grid + end subroutine solve_interface + end interface + end subroutine integrate +end module foo Index: Fortran/gfortran/regression/userdef_operator_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/userdef_operator_1.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! Testcase from PR 25396: User defined operators returning arrays. +module geometry + + implicit none + + interface operator(.cross.) + module procedure cross + end interface + +contains + + ! Cross product between two 3d vectors. + pure function cross(a, b) + real, dimension(3), intent(in) :: a,b + real, dimension(3) :: cross + + cross = (/ a(2) * b(3) - a(3) * b(2), & + a(3) * b(1) - a(1) * b(3), & + a(1) * b(2) - a(2) * b(1) /) + end function cross + +end module geometry + +program opshape + use geometry + + implicit none + + real :: t(3,3), a + + a = dot_product (t(:,1), t(:,2) .cross. t(:,3)) + +end program opshape Index: Fortran/gfortran/regression/userdef_operator_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/userdef_operator_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 45338 - no ICE when cmp is not used explicitly. +! Test case by Simon Smart +module test_mod + implicit none +contains + subroutine test_fn (cmp) + interface operator(.myop.) + pure function cmp (a, b) result(ret) + integer, intent(in) :: a, b + logical ret + end function cmp + end interface + integer :: a, b + print*, a .myop. b + end subroutine test_fn +end module test_mod Index: Fortran/gfortran/regression/utf8_1.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/utf8_1.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! Contributed by Jerry DeLisle +program test1 + implicit none + integer, parameter :: k4 = 4 + character(kind=4, len=30) :: string1, string2 + character(kind=1, len=30) :: string3 + string1 = k4_"This is Greek: \u039f\u03cd\u03c7\u03af" + string2 = k4_"Jerry in Japanese is: \u30b8\u30a8\u30ea\u30fc" + open(10, encoding="utf-8", status="scratch") + write(10,'(a)') trim(string1) + write(10,*) string2 + rewind(10) + string1 = k4_"" + string2 = k4_"" + string3 = "abcdefghijklmnopqrstuvwxyz" + read(10,'(a)') string1 + read(10,'(a)') string2 + if (string1 /= k4_"This is Greek: \u039f\u03cd\u03c7\u03af") STOP 1 + if (len(trim(string1)) /= 20) STOP 2 + if (string2 /= k4_" Jerry in Japanese is: \u30b8\u30a8\u30ea\u30fc")& + & STOP 3 + if (len(string2) /= 30) STOP 4 + rewind(10) + read(10,'(a)') string3 + if (string3 /= "This is Greek: ????") STOP 5 +end program test1 +! The following examples require UTF-8 enabled editor to see correctly. +! ジエリー Sample of Japanese characters. +! Οὐχὶ Sample of Greek characters. Index: Fortran/gfortran/regression/utf8_2.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/utf8_2.f03 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! Contributed by Tobias Burnus +program test2 + integer,parameter :: ucs4 = selected_char_kind("iso_10646") + character(1,ucs4),parameter :: nen=char(int(z'5e74'),ucs4), & !year + gatsu=char(int(z'6708'),kind=ucs4), & !month + nichi=char(int(z'65e5'),kind=ucs4) !day + character(25,ucs4) :: string + open(10, encoding="utf-8", status="scratch") + write(10,1) 2008,nen,8,gatsu,10,nichi +1 format(i0,a,i0,a,i0,a) + rewind(10) + read(10,'(a)') string + if (string /= ucs4_"2008\u5e748\u670810\u65e5") STOP 1 +end program test2 Index: Fortran/gfortran/regression/value_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_1.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } +! Tests the functionality of the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +module global + type :: mytype + real(4) :: x + character(4) :: c + end type mytype +contains + subroutine typhoo (dt) + type(mytype), value :: dt + if (dtne (dt, mytype (42.0, "lmno"))) STOP 1 + dt = mytype (21.0, "wxyz") + if (dtne (dt, mytype (21.0, "wxyz"))) STOP 2 + end subroutine typhoo + + logical function dtne (a, b) + type(mytype) :: a, b + dtne = .FALSE. + if ((a%x /= b%x) .or. (a%c /= b%c)) dtne = .TRUE. + end function dtne +end module global + +program test_value + use global + integer(8) :: i = 42 + real(8) :: r = 42.0 + character(2) :: c = "ab" + complex(8) :: z = (-99.0, 199.0) + type(mytype) :: dt = mytype (42.0, "lmno") + + call foo (c) + if (c /= "ab") STOP 3 + + call bar (i) + if (i /= 42) STOP 4 + + call foobar (r) + if (r /= 42.0) STOP 5 + + call complex_foo (z) + if (z /= (-99.0, 199.0)) STOP 6 + + call typhoo (dt) + if (dtne (dt, mytype (42.0, "lmno"))) STOP 7 + + r = 20.0 + call foobar (r*2.0 + 2.0) + +contains + subroutine foo (c) + character(2), value :: c + if (c /= "ab") STOP 8 + c = "cd" + if (c /= "cd") STOP 9 + end subroutine foo + + subroutine bar (i) + integer(8), value :: i + if (i /= 42) STOP 10 + i = 99 + if (i /= 99) STOP 11 + end subroutine bar + + subroutine foobar (r) + real(8), value :: r + if (r /= 42.0) STOP 12 + r = 99.0 + if (r /= 99.0) STOP 13 + end subroutine foobar + + subroutine complex_foo (z) + COMPLEX(8), value :: z + if (z /= (-99.0, 199.0)) STOP 14 + z = (77.0, -42.0) + if (z /= (77.0, -42.0)) STOP 15 + end subroutine complex_foo + +end program test_value Index: Fortran/gfortran/regression/value_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Tests the standard check in the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +program test_value + integer(8) :: i = 42 + + call bar (i) + if (i /= 42) STOP 1 +contains + subroutine bar (i) + integer(8) :: i + value :: i ! { dg-error "Fortran 2003: VALUE" } + if (i /= 42) STOP 2 + i = 99 + if (i /= 99) STOP 3 + end subroutine bar +end program test_value Index: Fortran/gfortran/regression/value_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_3.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! Tests the constraints in the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +program test_value + integer(8) :: i = 42, j ! { dg-error "not a dummy" } + integer(8), value :: k ! { dg-error "not a dummy" } + value :: j + +contains + subroutine bar_1 (i) + integer(8) :: i + dimension i(8) + value :: i ! { dg-error "conflicts with DIMENSION" } + i = 0 + end subroutine bar_1 + + subroutine bar_2 (i) + integer(8) :: i + pointer :: i + value :: i ! { dg-error "conflicts with POINTER" } + i = 0 + end subroutine bar_2 + + integer function bar_3 (i) + integer(8) :: i + dimension i(8) + value :: bar_3 ! { dg-error "conflicts with FUNCTION" } + i = 0 + bar_3 = 0 + end function bar_3 + + subroutine bar_4 (i, j) + integer(8), intent(inout) :: i + integer(8), intent(out) :: j + value :: i ! { dg-error "conflicts with INTENT" } + value :: j ! { dg-error "conflicts with INTENT" } + i = 0 + j = 0 + end subroutine bar_4 + + integer function bar_5 () + integer(8) :: i + external :: i + integer, parameter :: j = 99 + value :: i ! { dg-error "conflicts with EXTERNAL" } + value :: j ! { dg-error "PARAMETER attribute conflicts with" } + bar_5 = 0 + end function bar_5 + +end program test_value Index: Fortran/gfortran/regression/value_4.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_4.c @@ -0,0 +1,49 @@ +/* Passing from fortran to C by value, using VALUE. This is identical + to c_by_val_1.c, which performs the same function for %VAL. + + Contributed by Paul Thomas */ + +/* We used to #include , but this fails for some platforms + (like cygwin) who don't have it yet. */ +#define complex __complex__ +#define _Complex_I (1.0iF) + +extern float *f_to_f__ (float, float*); +extern int *i_to_i__ (int, int*); +extern void c_to_c__ (complex float*, complex float, complex float*); +extern void abort (void); + +/* In f_to_f and i_to_i we return the second argument, so that we do + not have to worry about keeping track of memory allocation between + fortran and C. All three functions check that the argument passed + by value is the same as that passed by reference. Then the passed + by value argument is modified so that the caller can check that + its version has not changed.*/ + +float * +f_to_f__(float a1, float *a2) +{ + if ( a1 != *a2 ) abort(); + *a2 = a1 * 2.0; + a1 = 0.0; + return a2; +} + +int * +i_to_i__(int i1, int *i2) +{ + if ( i1 != *i2 ) abort(); + *i2 = i1 * 3; + i1 = 0; + return i2; +} + +void +c_to_c__(complex float *retval, complex float c1, complex float *c2) +{ + if ( c1 != *c2 ) abort(); + c1 = 0.0 + 0.0 * _Complex_I; + *retval = *c2 * 4.0; + return; +} + Index: Fortran/gfortran/regression/value_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_4.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! { dg-additional-sources value_4.c } +! { dg-options "-ff2c -w -O0" } +! +! Tests the functionality of the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran, by calling +! external C functions by value and by reference. This is effectively +! identical to c_by_val_1.f, which does the same for %VAL. +! +! Contributed by Paul Thomas +! +module global + interface delta + module procedure deltai, deltar, deltac + end interface delta + real(4) :: epsi = epsilon (1.0_4) +contains + function deltai (a, b) result (c) + integer(4) :: a, b + logical :: c + c = (a /= b) + end function deltai + + function deltar (a, b) result (c) + real(4) :: a, b + logical :: c + c = (abs (a-b) > epsi) + end function deltar + + function deltac (a, b) result (c) + complex(4) :: a, b + logical :: c + c = ((abs (real (a-b)) > epsi).or.(abs (aimag (a-b)) > epsi)) + end function deltac +end module global + +program value_4 + use global + interface + function f_to_f (x, y) + real(4), pointer :: f_to_f + real(4) :: x, y + value :: x + end function f_to_f + end interface + + interface + function i_to_i (x, y) + integer(4), pointer :: i_to_i + integer(4) :: x, y + value :: x + end function i_to_i + end interface + + interface + complex(4) function c_to_c (x, y) + complex(4) :: x, y + value :: x + end function c_to_c + end interface + + real(4) a, b, c + integer(4) i, j, k + complex(4) u, v, w + + a = 42.0 + b = 0.0 + c = a + b = f_to_f (a, c) + if (delta ((2.0 * a), b)) STOP 1 + + i = 99 + j = 0 + k = i + j = i_to_i (i, k) + if (delta ((3_4 * i), j)) STOP 2 + + u = (-1.0, 2.0) + v = (1.0, -2.0) + w = u + v = c_to_c (u, w) + if (delta ((4.0 * u), v)) STOP 3 +end program value_4 Index: Fortran/gfortran/regression/value_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_5.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! Length of character dummy variable with VALUE attribute: +! - must be initialization expression or omitted +! - C interoperable: must be initialization expression of length one +! or omitted +! +! Contributed by Tobias Burnus +program x + implicit none + character(10) :: c1,c10 + c1 = 'H' + c10 = 'Main' + call foo1(c1) + call foo2(c1) + call foo3(c10) + call foo4(c10) + call bar1(c1) + call bar2(c1) + call bar3(c10) + call bar4(c10) + +contains + + subroutine foo1(a) + character :: a + value :: a + end subroutine foo1 + + subroutine foo2(a) + character(1) :: a + value :: a + end subroutine foo2 + + subroutine foo3(a) + character(10) :: a + value :: a + end subroutine foo3 + + subroutine foo4(a) ! { dg-error "VALUE attribute must have constant length" } + character(*) :: a + value :: a + end subroutine foo4 + + subroutine bar1(a) + use iso_c_binding, only: c_char + character(kind=c_char) :: a + value :: a + end subroutine bar1 + + subroutine bar2(a) + use iso_c_binding, only: c_char + !character(kind=c_char,len=1) :: a + character(1,kind=c_char) :: a + value :: a + end subroutine bar2 + + subroutine bar3(a) ! { dg-error "VALUE attribute must have length one" } + use iso_c_binding, only: c_char + character(kind=c_char,len=10) :: a + value :: a + end subroutine bar3 + + subroutine bar4(a) ! { dg-error "VALUE attribute must have constant length" } + use iso_c_binding, only: c_char + character(kind=c_char,len=*) :: a + value :: a + end subroutine bar4 +end program x Index: Fortran/gfortran/regression/value_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_6.f03 @@ -0,0 +1,24 @@ +! { dg-do run } +! Verify by-value passing of character arguments w/in Fortran to a bind(c) +! procedure. +! PR fortran/32732 +module pr32732 + use, intrinsic :: iso_c_binding, only: c_char + implicit none +contains + subroutine test(a) bind(c) + character(kind=c_char), value :: a + call test2(a) + end subroutine test + subroutine test2(a) bind(c) + character(kind=c_char), value :: a + if(a /= c_char_'a') STOP 1 + print *, 'a=',a + end subroutine test2 +end module pr32732 + +program main + use pr32732 + implicit none + call test('a') +end program main Index: Fortran/gfortran/regression/value_7.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_7.f03 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test passing character strings by-value. +! PR fortran/32732 +program test + implicit none + character(len=13) :: chr + chr = 'Fortran ' + call sub1(chr) + if(chr /= 'Fortran ') STOP 1 +contains + subroutine sub1(a) + character(len=13), VALUE :: a + a = trim(a)//" rules" + call sub2(a) + end subroutine sub1 + subroutine sub2(a) + character(len=13), VALUE :: a + print *, a + if(a /= 'Fortran rules') STOP 2 + end subroutine sub2 +end program test + Index: Fortran/gfortran/regression/value_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR97491 - Wrong restriction for VALUE arguments of pure procedures + +pure function foo (x) result (ret) + integer :: ret + integer, value :: x + x = x / 2 + ret = x +end function foo + +elemental function foo1 (x) + integer :: foo1 + integer, value :: x + x = x / 2 + foo1 = x +end function foo1 Index: Fortran/gfortran/regression/value_test.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_test.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +program valueTests + integer :: myInt + interface + subroutine mySub(myInt) + integer, value :: myInt + end subroutine mySub + end interface + + myInt = 10 + + call mySub(myInt) + ! myInt should be unchanged since pass-by-value + if(myInt .ne. 10) then + STOP 1 + endif +end program valueTests + +subroutine mySub(myInt) + integer, value :: myInt + myInt = 11 +end subroutine mySub + Index: Fortran/gfortran/regression/value_tests_f03.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/value_tests_f03.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +program value_tests_f03 + use, intrinsic :: iso_c_binding + real(c_double) :: myDouble + interface + subroutine value_test(myDouble) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + end subroutine value_test + end interface + + myDouble = 9.0d0 + call value_test(myDouble) +end program value_tests_f03 + +subroutine value_test(myDouble) bind(c) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + interface + subroutine mySub(myDouble) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + end subroutine mySub + end interface + + myDouble = 10.0d0 + + call mySub(myDouble) +end subroutine value_test + +subroutine mySub(myDouble) + use, intrinsic :: iso_c_binding + real(c_double), value :: myDouble + + myDouble = 11.0d0 +end subroutine mySub + Index: Fortran/gfortran/regression/variable_parameter.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/variable_parameter.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR 87644 - this used to cause an ICE. +! Test case by Matt Thompson. +module test + + implicit none + private + public :: get + +contains + + subroutine initialize() + integer :: parameters + parameters = get() + end subroutine initialize + + function get() result(parameters) + integer :: parameters + parameters = 1 + end function get + +end module test Index: Fortran/gfortran/regression/vax_structure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vax_structure_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! Tests the VAX STRUCTURE and RECORD statements. +! These are syntactic sugar for TYPE statements. + + program vax_structure_1 + structure /stocklevel/ + integer*2 A + integer*4 B + integer*4 CS(0:15) + byte D(0:15) + end structure + + record /stocklevel/ rec1, recs(100) + integer x + integer*2 y + + rec1.A = 100 + recs(100).CS(10)=1 + x = 150 + y = 150 + + print *, rec1.B.eq.100 + print *, rec1.A.eq.x ! {dg-error "are INTEGER(2)/INTEGER(4)"} + print *, rec1.A.eq.y + print *, recs(100).CS(10) + end program Index: Fortran/gfortran/regression/vector_subscript_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_1.f90 @@ -0,0 +1,174 @@ +! PR 19239. Check for various kinds of vector subscript. In this test, +! all vector subscripts are indexing single-dimensional arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 10 + integer :: i, j, calls + integer, dimension (n) :: a, b, idx, id + + idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /) + id = (/ (i, i = 1, n) /) + b = (/ (i * 100, i = 1, n) /) + + !------------------------------------------------------------------ + ! Tests for a simple variable subscript + !------------------------------------------------------------------ + + a (idx) = b + call test (idx, id) + + a = b (idx) + call test (id, idx) + + a (idx) = b (idx) + call test (idx, idx) + + !------------------------------------------------------------------ + ! Tests for constant ranges with non-default stride + !------------------------------------------------------------------ + + a (idx (1:7:3)) = b (10:6:-2) + call test (idx (1:7:3), id (10:6:-2)) + + a (10:6:-2) = b (idx (1:7:3)) + call test (id (10:6:-2), idx (1:7:3)) + + a (idx (1:7:3)) = b (idx (1:7:3)) + call test (idx (1:7:3), idx (1:7:3)) + + a (idx (1:7:3)) = b (idx (10:6:-2)) + call test (idx (1:7:3), idx (10:6:-2)) + + a (idx (10:6:-2)) = b (idx (10:6:-2)) + call test (idx (10:6:-2), idx (10:6:-2)) + + a (idx (10:6:-2)) = b (idx (1:7:3)) + call test (idx (10:6:-2), idx (1:7:3)) + + !------------------------------------------------------------------ + ! Tests for subscripts of the form CONSTRANGE + CONST + !------------------------------------------------------------------ + + a (idx (1:5) + 1) = b (1:5) + call test (idx (1:5) + 1, id (1:5)) + + a (1:5) = b (idx (1:5) + 1) + call test (id (1:5), idx (1:5) + 1) + + a (idx (6:10) - 1) = b (idx (1:5) + 1) + call test (idx (6:10) - 1, idx (1:5) + 1) + + !------------------------------------------------------------------ + ! Tests for variable subranges + !------------------------------------------------------------------ + + do j = 5, 10 + a (idx (2:j:2)) = b (3:2+j/2) + call test (idx (2:j:2), id (3:2+j/2)) + + a (3:2+j/2) = b (idx (2:j:2)) + call test (id (3:2+j/2), idx (2:j:2)) + + a (idx (2:j:2)) = b (idx (2:j:2)) + call test (idx (2:j:2), idx (2:j:2)) + end do + + !------------------------------------------------------------------ + ! Tests for function vectors + !------------------------------------------------------------------ + + calls = 0 + + a (foo (5, calls)) = b (2:10:2) + call test (foo (5, calls), id (2:10:2)) + + a (2:10:2) = b (foo (5, calls)) + call test (id (2:10:2), foo (5, calls)) + + a (foo (5, calls)) = b (foo (5, calls)) + call test (foo (5, calls), foo (5, calls)) + + if (calls .ne. 8) STOP 1 + + !------------------------------------------------------------------ + ! Tests for constant vector constructors + !------------------------------------------------------------------ + + a ((/ 1, 5, 3, 9 /)) = b (1:4) + call test ((/ 1, 5, 3, 9 /), id (1:4)) + + a (1:4) = b ((/ 1, 5, 3, 9 /)) + call test (id (1:4), (/ 1, 5, 3, 9 /)) + + a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /)) + call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /)) + + !------------------------------------------------------------------ + ! Tests for variable vector constructors + !------------------------------------------------------------------ + + do j = 1, 5 + a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j) + call test ((/ 1, (i + 3, i = 2, j) /), id (1:j)) + + a (1:j) = b ((/ 1, (i + 3, i = 2, j) /)) + call test (id (1:j), (/ 1, (i + 3, i = 2, j) /)) + + a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /)) + call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /)) + end do + + !------------------------------------------------------------------ + ! Tests in which the vector dimension is partnered by a temporary + !------------------------------------------------------------------ + + calls = 0 + a (idx (1:6)) = foo (6, calls) + if (calls .ne. 1) STOP 2 + do i = 1, 6 + if (a (idx (i)) .ne. i + 3) STOP 3 + end do + a = 0 + + calls = 0 + a (idx (1:6)) = foo (6, calls) * 100 + if (calls .ne. 1) STOP 4 + do i = 1, 6 + if (a (idx (i)) .ne. (i + 3) * 100) STOP 5 + end do + a = 0 + + a (idx) = id + 100 + do i = 1, n + if (a (idx (i)) .ne. i + 100) STOP 6 + end do + a = 0 + + a (idx (1:10:3)) = (/ 20, 10, 9, 11 /) + if (a (idx (1)) .ne. 20) STOP 7 + if (a (idx (4)) .ne. 10) STOP 8 + if (a (idx (7)) .ne. 9) STOP 9 + if (a (idx (10)) .ne. 11) STOP 10 + a = 0 + +contains + subroutine test (lhs, rhs) + integer, dimension (:) :: lhs, rhs + integer :: i + + if (size (lhs, 1) .ne. size (rhs, 1)) STOP 11 + do i = 1, size (lhs, 1) + if (a (lhs (i)) .ne. b (rhs (i))) STOP 12 + end do + a = 0 + end subroutine test + + function foo (n, calls) + integer :: i, n, calls + integer, dimension (n) :: foo + + calls = calls + 1 + foo = (/ (i + 3, i = 1, n) /) + end function foo +end program main Index: Fortran/gfortran/regression/vector_subscript_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_2.f90 @@ -0,0 +1,39 @@ +! Like vector_subscript_1.f90, but check subscripts in multi-dimensional +! arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 5 + integer :: i1, i2, i3 + integer, dimension (n, n, n) :: a, b + integer, dimension (n) :: idx, id + + idx = (/ 3, 1, 5, 2, 4 /) + id = (/ (i1, i1 = 1, n) /) + forall (i1 = 1:n, i2 = 1:n, i3 = 1:n) + b (i1, i2, i3) = i1 + i2 * 10 + i3 * 100 + end forall + + i1 = 5 + a (foo (i1), 1, :) = b (2, :, foo (i1)) + do i1 = 1, 5 + do i2 = 1, 5 + if (a (idx (i1), 1, i2) .ne. b (2, i1, idx (i2))) STOP 1 + end do + end do + a = 0 + + a (1, idx (1:4), 2:4) = b (2:5, idx (3:5), 2) + do i1 = 1, 4 + do i2 = 1, 3 + if (a (1, idx (i1), 1 + i2) .ne. b (1 + i1, idx (i2 + 2), 2)) STOP 2 + end do + end do + a = 0 +contains + function foo (n) + integer :: n + integer, dimension (n) :: foo + foo = idx (1:n) + end function foo +end program main Index: Fortran/gfortran/regression/vector_subscript_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_3.f90 @@ -0,0 +1,45 @@ +! { dg-do run { target fd_truncate } } +! +! Test the fix for PR34875, in which the read with a vector index +! used to do nothing. +! +! Contributed by Dick Hendrickson +! +Program QH0008 + + REAL(4) QDA(10) + REAL(4) QDA1(10) +! Scramble the vector up a bit to make the test more interesting + integer, dimension(10) :: nfv1 = (/9,2,1,3,5,4,6,8,7,10/) +! Set qda1 in ordinal order + qda1(nfv1) = nfv1 + qda = -100 + OPEN (UNIT = 47, & + STATUS = 'SCRATCH', & + FORM = 'UNFORMATTED', & + ACTION = 'READWRITE') + ISTAT = -314 + REWIND (47, IOSTAT = ISTAT) + IF (ISTAT .NE. 0) STOP 1 + ISTAT = -314 +! write qda1 + WRITE (47,IOSTAT = ISTAT) QDA1 + IF (ISTAT .NE. 0) STOP 2 + ISTAT = -314 + REWIND (47, IOSTAT = ISTAT) + IF (ISTAT .NE. 0) STOP 3 +! Do the vector index read that used to fail + READ (47,IOSTAT = ISTAT) QDA(NFV1) + IF (ISTAT .NE. 0) STOP 4 +! Unscramble qda using the vector index + IF (ANY (QDA(nfv1) .ne. QDA1) ) print *, qda, qda1 + ISTAT = -314 + REWIND (47, IOSTAT = ISTAT) + IF (ISTAT .NE. 0) STOP 5 + qda = -200 +! Do the subscript read that was OK + READ (47,IOSTAT = ISTAT) QDA(1:10) + IF (ISTAT .NE. 0) STOP 6 + IF (ANY (QDA .ne. QDA1) ) STOP 7 +END + Index: Fortran/gfortran/regression/vector_subscript_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR37903, in which the temporary for the vector index +! got the wrong size. +! +! Contributed by Mikael Morin +! + integer :: i(-1:1) = 1, j(3) = 1, k(3) + k = j((/1,1,1/)+i) + end +! { dg-final { scan-tree-dump-times "A\.2\\\[3\\\]" 1 "original" } } Index: Fortran/gfortran/regression/vector_subscript_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_5.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Test the fix for PR37749 in which the expression in line 13 would cause an ICE +! because the upper value of the loop range was not set. +! +! Contributed by Jakub Jelinek +! +subroutine subr (m, n, a, b, c, d, p) + implicit none + integer m, n + real a(m,n), b(m,n), c(n,n), d(m,n) + integer p(n) + d = a(:,p) - matmul(b, c) +end subroutine + + implicit none + integer i + real a(3,2), b(3,2), c(2,2), d(3,2) + integer p(2) + a = reshape ((/(i, i = 1, 6)/), (/3, 2/)) + b = 1 + c = 2 + p = 2 + call subr (3, 2, a, b, c, d, p) + if (any (d .ne. reshape ((/(mod (i + 2, 3), i = 1, 6)/), (/3, 2/)))) STOP 1 +end Index: Fortran/gfortran/regression/vector_subscript_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_6.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } + +subroutine test0(esss,Ix, e_x) + real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(:), intent(in) :: Ix + integer(kind=kind(1)), dimension(:), intent(in) :: e_x + esss = Ix(e_x) +end subroutine + +subroutine test1(esss,Ix, e_x) + real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(:), intent(in) :: Ix + integer(kind=4), dimension(:), intent(in) :: e_x + esss = Ix(e_x) +end subroutine + +subroutine test2(esss,Ix, e_x) + real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(:), intent(in) :: Ix + integer(kind=8), dimension(:), intent(in) :: e_x + esss = Ix(e_x) +end subroutine + +subroutine test3(esss,Ix,Iyz, e_x, ii_ivec) + real(kind=kind(1.0d0)), dimension(:), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(:), intent(in) :: Ix,Iyz + integer(kind=kind(1)), dimension(:), intent(in) :: e_x,ii_ivec + esss = esss + Ix(e_x) * Iyz(ii_ivec) +end subroutine + +! { dg-final { scan-tree-dump-not "malloc" "original" } } Index: Fortran/gfortran/regression/vector_subscript_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_7.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR 58009 - If a vector subscript has two or more elements with the +! same value, an array section with that vector subscript +! shall not appear in a variable definition context. + +program main + real, dimension(4) :: a,b + real, dimension(1,4) :: c + read (*,*) a([1,2,3,2]),i ! { dg-error "Elements with the same value" } + read (*,*) c(1,[1,2,3,2]),i ! { dg-error "Elements with the same value" } + b([1+i,1,i+1,2]) = a ! { dg-error "Elements with the same value" } + c(1,[1+i,1,i+1,2]) = a ! { dg-error "Elements with the same value" } + call foo (a([4,2,1,1])) ! { dg-error "Elements with the same value" } + call foo (c(1,[4,2,1,1])) ! { dg-error "Elements with the same value" } + print *,a,b +contains + subroutine foo(arg) + real, intent(inout) :: arg(:) + arg = arg + 1 + end subroutine foo +end program main Index: Fortran/gfortran/regression/vector_subscript_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_8.f90 @@ -0,0 +1,16 @@ +! { 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 + integer, dimension (4) :: idx, a, b + a = (/ 11, 13, 17, 19 /) + idx = (/ 1, 2, 3, 4 /) + a(idx(4:1:-1)) = idx + if (a(1).ne.4) STOP 1 +end program main Index: Fortran/gfortran/regression/vector_subscript_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_9.f90 @@ -0,0 +1,21 @@ +! { 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 + integer, dimension (2) :: idx, a, b + a = (/ 3, 4 /) + idx = (/ 1, 2 /) + call check_values(a(idx(2:1:-1)), (/ 4, 3 /)) +contains + subroutine check_values(values, expected) + integer, dimension(:) :: values, expected + if (size(values) /= size(expected)) stop 1 + if (any(values /= expected)) stop 2 + end subroutine check_values +end program main Index: Fortran/gfortran/regression/vector_subscript_bound_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vector_subscript_bound_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/45745 +! ICE with {L,U}BOUND intrinsic function as vector subscript on derived +! type component. +! +! Original test by Joost Van de Vondele + +MODULE pw_types + TYPE pw_type + REAL, DIMENSION ( : ), POINTER :: cr + END TYPE pw_type +CONTAINS + SUBROUTINE pw_write(pw) + TYPE(pw_type), INTENT(in) :: pw + PRINT *, pw%cr(LBOUND(pw%cr)) + PRINT *, pw%cr(UBOUND(pw%cr)) + END SUBROUTINE pw_write +END MODULE Index: Fortran/gfortran/regression/verify_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/verify_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +program verify_2 + character(len=3) s1, s2 + s1 = 'abc' + s2 = '' + if (verify('ab', '') /= 1) STOP 1 + if (verify(s1, s2) /= 1) STOP 2 + if (verify('abc', '', .true.) /= 3) STOP 3 + if (verify(s1, s2, .true.) /= 3) STOP 4 +end program verify_2 + Index: Fortran/gfortran/regression/verify_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/verify_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/103789 +! Check the absence of ICE when generating calls to VERIFY with a KIND argument. + +program p + character(len=10) :: y(2) + integer :: z(2), x(2), w(2), v(2) + y = ['abc', 'def'] + z = verify(y, 'e', kind=4) + 1 + x = verify(y, 'e', back=.false., kind=4) + 1 + w = verify(y, 'e', .false., kind=4) + 1 + x = verify(y, 'e', .false., 4) + 1 +end program p Index: Fortran/gfortran/regression/volatile.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Test whether volatile statements and attributes are accepted +! PR fortran/29601 +program volatile_test + implicit none + real :: l,m + real, volatile :: r = 3. + volatile :: l + l = 4.0 + m = 3.0 +end program volatile_test Index: Fortran/gfortran/regression/volatile10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile10.f90 @@ -0,0 +1,147 @@ +! { dg-do run } +! { dg-options "-fdump-tree-optimized -O3" } +! Test setting host-/use-associated variables as VOLATILE +! PR fortran/30522 + +module impl + implicit REAL (A-Z) + volatile :: x +end module impl + +module one + implicit none + logical :: l, lv + volatile :: lv +contains + subroutine test1(cmp) + logical :: cmp + volatile :: l, lv + if (l .neqv. cmp) STOP 1 + if (lv .neqv. cmp) STOP 2 + l = .false. + lv = .false. + if(l .or. lv) print *, 'one_test1' ! not optimized away + end subroutine test1 + subroutine test2(cmp) + logical :: cmp + if (l .neqv. cmp) STOP 3 + if (lv .neqv. cmp) STOP 4 + l = .false. + if(l) print *, 'one_test2_1' ! optimized away + lv = .false. + if(lv) print *, 'one_test2_2' ! not optimized away + end subroutine test2 +end module one + +module two + use :: one + implicit none + volatile :: lv,l +contains + subroutine test1t(cmp) + logical :: cmp + volatile :: l, lv + if (l .neqv. cmp) STOP 5 + if (lv .neqv. cmp) STOP 6 + l = .false. + if(l) print *, 'two_test1_1' ! not optimized away + lv = .false. + if(lv) print *, 'two_test1_2' ! not optimized away + end subroutine test1t + subroutine test2t(cmp) + logical :: cmp + if (l .neqv. cmp) STOP 7 + if (lv .neqv. cmp) STOP 8 + l = .false. + if(l) print *, 'two_test2_1' ! not optimized away + lv = .false. + if(lv) print *, 'two_test2_2' ! not optimized away + end subroutine test2t +end module two + +program main + use :: two, only: test1t, test2t + implicit none + logical :: lm, lmv + volatile :: lmv + lm = .true. + lmv = .true. + call test1m(.true.) + lm = .true. + lmv = .true. + call test2m(.true.) + lm = .false. + lmv = .false. + call test1m(.false.) + lm = .false. + lmv = .false. + call test2m(.false.) +contains + subroutine test1m(cmp) + use :: one + logical :: cmp + volatile :: lm,lmv + if(lm .neqv. cmp) STOP 9 + if(lmv .neqv. cmp) STOP 10 + l = .false. + lv = .false. + call test1(.false.) + l = .true. + lv = .true. + call test1(.true.) + lm = .false. + lmv = .false. + if(lm .or. lmv) print *, 'main_test1_1' ! not optimized away + l = .false. + if(l) print *, 'main_test1_2' ! optimized away + lv = .false. + if(lv) print *, 'main_test1_3' ! not optimized away + l = .false. + lv = .false. + call test2(.false.) + l = .true. + lv = .true. + call test2(.true.) + end subroutine test1m + subroutine test2m(cmp) + use :: one + logical :: cmp + volatile :: lv + if(lm .neqv. cmp) STOP 1 + if(lmv .neqv. cmp) STOP 11 + l = .false. + lv = .false. + call test1(.false.) + l = .true. + lv = .true. + call test1(.true.) + lm = .false. + if(lm) print *, 'main_test2_1' ! not optimized away + lmv = .false. + if(lmv)print *, 'main_test2_2' ! not optimized away + l = .false. + if(l) print *, 'main_test2_3' ! optimized away + lv = .false. + if(lv) print *, 'main_test2_4' ! not optimized away + l = .false. + lv = .false. + call test2(.false.) + l = .true. + lv = .true. + call test2(.true.) + end subroutine test2m +end program main + +! { dg-final { scan-tree-dump "one_test1" "optimized" } } +! TODO: dg-final { scan-tree-dump-not "one_test2_1" "optimized" } +! { dg-final { scan-tree-dump "one_test2_2" "optimized" } } +! { dg-final { scan-tree-dump "one_test2_2" "optimized" } } +! { dg-final { scan-tree-dump "two_test2_1" "optimized" } } +! { dg-final { scan-tree-dump "two_test2_2" "optimized" } } +! { dg-final { scan-tree-dump "main_test1_1" "optimized" } } +! TODO: dg-final { scan-tree-dump-not "main_test1_2" "optimized" } +! { dg-final { scan-tree-dump "main_test1_3" "optimized" } } +! { dg-final { scan-tree-dump "main_test2_1" "optimized" } } +! { dg-final { scan-tree-dump "main_test2_2" "optimized" } } +! TODO: dg-final { scan-tree-dump-not "main_test2_3" "optimized" } +! { dg-final { scan-tree-dump "main_test2_4" "optimized" } } Index: Fortran/gfortran/regression/volatile11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile11.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! Tests that volatile can be applied to members of common blocks or +! equivalence groups (PR fortran/35037) +! +subroutine wait1 + logical event + volatile event + common /dd/ event + event = .false. + do + if (event) print *, 'NotOptimizedAway1' + end do +end subroutine + +subroutine wait2 + logical event, foo + volatile event + equivalence (event, foo) + event = .false. + do + if (event) print *, 'NotOptimizedAway2' + end do +end subroutine + +subroutine wait3 + logical event + integer foo + volatile foo + equivalence (event, foo) + event = .false. + do + if (event) print *, 'IsOptimizedAway' + end do +end subroutine + +! { dg-final { scan-tree-dump "NotOptimizedAway1" "optimized" } } */ +! { dg-final { scan-tree-dump "NotOptimizedAway2" "optimized" } } */ +! { dg-final { scan-tree-dump-not "IsOptimizedAway" "optimized" } } */ Index: Fortran/gfortran/regression/volatile12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile12.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-optimized -O3" } +! +! PR fortran/45742 +! + +subroutine sub(arg) + integer, volatile :: arg + if (arg /= arg) call I_dont_exist() +end + +! { dg-final { scan-tree-dump "integer.kind=.. . volatile arg" "optimized" } } +! { dg-final { scan-tree-dump-times " =.v. arg;" 2 "optimized" } } +! { dg-final { scan-tree-dump "i_dont_exist" "optimized" } } + Index: Fortran/gfortran/regression/volatile13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile13.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/51302 +! +! Volatile DO variable - was ICEing before +! +integer, volatile :: i +integer :: n = 1 +do i = 1, n +end do +end Index: Fortran/gfortran/regression/volatile14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile14.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 46459: ICE (segfault): Invalid read in compare_actual_formal [error recovery] +! +! Contributed by Harald Anlauf + + call sub (1) +contains + subroutine sub (j) + integer, volatile :: j + end subroutine +end + +subroutine sub1 () + call sub2 (1) ! { dg-error "Explicit interface required" } +end subroutine + +subroutine sub2 (j) + integer, volatile :: j +end subroutine + +subroutine sub3 () + interface + subroutine sub2 (j) + integer, volatile :: j + end subroutine + end interface + call sub2 (1) +end subroutine Index: Fortran/gfortran/regression/volatile2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-shouldfail "VOLATILE not part of F95" } +! { dg-options "-std=f95" } +! Test whether volatile statements and attributes are rejected +! with -std=f95. +! PR fortran/29601 +program volatile_test + implicit none + real, volatile :: foo ! { dg-error "VOLATILE attribute" } + real :: l + volatile :: l ! { dg-error "VOLATILE statement" } + l = 4.0 + foo = 3.0 ! { dg-error "no IMPLICIT type" } +end program volatile_test Index: Fortran/gfortran/regression/volatile3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-shouldfail "Invalid use of VOLATILE" } +! Test whether volatile statements and attributes are +! properly error checked. +! PR fortran/29601 +program volatile_test + implicit none + real, external, volatile :: foo ! { dg-error "VOLATILE attribute conflicts with EXTERNAL attribute" } + real, intrinsic, volatile :: sin ! { dg-error "VOLATILE attribute conflicts with INTRINSIC attribute" } + real, parameter, volatile :: r = 5.5 ! { dg-error "PARAMETER attribute conflicts with VOLATILE attribute" } + real :: l,m + real,volatile :: n + real, volatile,volatile :: r = 3. ! { dg-error "Duplicate VOLATILE attribute" } + volatile :: l,n ! { dg-warning "Duplicate VOLATILE attribute" } + volatile ! { dg-error "Syntax error in VOLATILE statement" } + volatile :: volatile_test ! { dg-error "PROGRAM attribute conflicts with VOLATILE attribute" } + l = 4.0 + m = 3.0 +contains + subroutine foo(a) ! { dg-error "has no IMPLICIT type" } ! due to error below + integer, intent(in), volatile :: a ! { dg-error "VOLATILE attribute conflicts with INTENT\\(IN\\)" } + end subroutine +end program volatile_test Index: Fortran/gfortran/regression/volatile4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! Tests whether volatile really works +! PR fortran/29601 +logical, volatile :: t1 +logical :: t2 +integer :: i + +t2 = .false. +t1 = .false. +do i = 1, 2 + if(t1) print *, 'VolatileNotOptimizedAway' + if(t2) print *, 'NonVolatileNotOptimizedAway' +end do +end +! { dg-final { scan-tree-dump "VolatileNotOptimizedAway" "optimized" } } */ +! { dg-final { scan-tree-dump-not "NonVolatileNotOptimizedAway" "optimized" } } */ Index: Fortran/gfortran/regression/volatile5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile5.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } +! Tests whether volatile really works with modules +! PR fortran/29601 +module volmod + implicit none + integer, volatile :: a + logical :: b,c + volatile :: b +contains + subroutine sample + a = 33. + if(a /= 432) print *,'aPresent' + + b = .false. + if(b) print *,'bPresent' + + c = .false. + if(c) print *,'cPresent' + end subroutine sample +end module volmod + +program main + use volmod + implicit none + + a = 432 + if(a /= 432) print *,'aStillPresent' + + b = .false. + if(b) print *,'bStillPresent' + + c = .false. + if(c) print *,'cStillPresent' +end program main +! { dg-final { scan-tree-dump "aPresent" "optimized" } } +! { dg-final { scan-tree-dump "bPresent" "optimized" } } +! { dg-final { scan-tree-dump "aStillPresent" "optimized" } } +! { dg-final { scan-tree-dump "bStillPresent" "optimized" } } +! { dg-final { scan-tree-dump-not "cPresent" "optimized" } } +! { dg-final { scan-tree-dump-not "cStillPresent" "optimized" } } Index: Fortran/gfortran/regression/volatile6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile6.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! Tests whether volatile really works for arrays +! PR fortran/29601 +logical, allocatable, volatile :: t1(:) +logical, allocatable :: t2(:) +integer :: i + +allocate(t1(1),t2(1)) +t1 = .false. +t2 = .false. +do i = 1, 2 + if(ubound(t1,1) /= 1) print *, 'VolatileNotOptimizedAway1' + if(ubound(t2,1) /= 1) print *, 'NonVolatileNotOptimizedAway1' +end do + +t1 = .false. +if(t1(1)) print *, 'VolatileNotOptimizedAway2' +t2 = .false. +if(t2(1)) print *, 'NonVolatileNotOptimizedAway2' +end +! { dg-final { scan-tree-dump "VolatileNotOptimizedAway1" "optimized" } } +! { dg-final { scan-tree-dump "VolatileNotOptimizedAway2" "optimized" } } +! { dg-final { scan-tree-dump-not "NonVolatileNotOptimizedAway1" "optimized" } } +! { dg-final { scan-tree-dump-not "NonVolatileNotOptimizedAway2" "optimized" } } Index: Fortran/gfortran/regression/volatile7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-optimized" } +! Tests whether volatile really works for pointers +! PR fortran/29601 +logical, pointer, volatile :: t1 +logical, pointer :: t2 +integer :: i + +t1 => NULL(t1) +if(associated(t1)) print *, 'VolatileNotOptimizedAway' +t2 => NULL(t2) +if(associated(t2)) print *, 'NonVolatileNotOptimizedAway' +end +! { dg-final { scan-tree-dump "VolatileNotOptimizedAway" "optimized" } } +! { dg-final { scan-tree-dump-not "NonVolatileNotOptimizedAway" "optimized" } } Index: Fortran/gfortran/regression/volatile8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile8.f90 @@ -0,0 +1,58 @@ +! Check for compatibily of actual arguments +! with dummy arguments marked as volatile +! +! Contributed by Steven Correll. +! +! PR fortran/30520 + +! { dg-do compile } + + subroutine s8() + implicit none + interface + subroutine sub8(dummy8) + integer, volatile, dimension(3) :: dummy8 + end subroutine sub8 + subroutine sub8a(dummy8a) + integer, volatile, dimension(:) :: dummy8a + end subroutine sub8a + end interface + integer, dimension(8) :: a + call sub8 (a(1:5:2)) ! { dg-error "Array-section actual argument" } + call sub8a(a(1:5:2)) + end subroutine s8 + + subroutine s9(s9dummy) + implicit none + integer, dimension(:) :: s9dummy + interface + subroutine sub9(dummy9) + integer, volatile, dimension(3) :: dummy9 + end subroutine sub9 + subroutine sub9a(dummy9a) + integer, volatile, dimension(:) :: dummy9a + end subroutine sub9a + end interface + integer, dimension(9) :: a + call sub9 (s9dummy) ! { dg-error "Assumed-shape actual argument" } + call sub9a(s9dummy) + end subroutine s9 + + subroutine s10() + implicit none + interface + subroutine sub10(dummy10) + integer, volatile, dimension(3) :: dummy10 + end subroutine sub10 + subroutine sub10a(dummy10a) + integer, volatile, dimension(:) :: dummy10a + end subroutine sub10a + subroutine sub10b(dummy10b) + integer, volatile, dimension(:), pointer :: dummy10b + end subroutine sub10b + end interface + integer, dimension(:), pointer :: a + call sub10 (a) ! { dg-error "Pointer-array actual argument" } + call sub10a(a) + call sub10b(a) + end subroutine s10 Index: Fortran/gfortran/regression/volatile9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/volatile9.f90 @@ -0,0 +1,42 @@ +! Check for valid VOLATILE uses +! +! Contributed by Steven Correll. +! +! PR fortran/30520 + +! { dg-do compile } + + function f() result(fr) + integer, volatile :: fr + fr = 5 + end function f + + module mod13 + implicit none + integer :: v13 + end module mod13 + + module mod13a + use mod13 + implicit none + volatile :: v13 + real :: v14 + contains + subroutine s13() + volatile :: v13 + volatile :: v14 + end subroutine s13 + end module mod13a + + module mod13b + use mod13a + implicit none + volatile :: v13 + end module mod13b + + + subroutine s14() + use mod13a + implicit none + volatile :: v13 + end subroutine s14 Index: Fortran/gfortran/regression/warn_alias.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_alias.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-Waliasing" } +! +! PR fortran/57991 +! +! Added check for OUT/OUT. IN/OUT and OUT/IN where already check +! since GCC 4.0, but not being tested for. + + Program q + integer :: x + x = 5 + Call test1(x, x) ! { dg-warning "Same actual argument associated with INTENT.OUT. argument 'a' and INTENT.OUT. argument 'b'" } + Call test2(x, x) ! { dg-warning "Same actual argument associated with INTENT.IN. argument 'a' and INTENT.OUT. argument 'b'" } + Call test3(x, x) ! { dg-warning "Same actual argument associated with INTENT.OUT. argument 'a' and INTENT.IN. argument 'b'" } + Contains + Subroutine test1(a,b) + Integer, intent(out) :: a + Integer, intent(out) :: b + b = 5 + a = 5 + End Subroutine + Subroutine test2(a,b) + Integer, intent(in) :: a + Integer, intent(out) :: b + b = 5 + a + End Subroutine + Subroutine test3(a,b) + Integer, intent(out) :: a + Integer, intent(in) :: b + a = 5 + b + End Subroutine + End Program + Index: Fortran/gfortran/regression/warn_align_commons.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_align_commons.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Wno-align-commons" } + +! PR fortran/37486 +! +! Test for -Wno-align-commons. +! +! Contributed by Janus Weil . + +implicit none +integer(kind=4) :: n +real(kind=8) :: p +common /foo/ n,p ! { dg-bogus "padding" } +end Index: Fortran/gfortran/regression/warn_concat.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_concat.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-additional-options "-Wall -O3" } +! PR 79929 - this used to give a warning. +! Test case by Harald Anlauf. +subroutine gfcbug138 (yerrmsg) + character(*) :: yerrmsg + yerrmsg = "" + yerrmsg = "bug: " // yerrmsg +end subroutine gfcbug138 Index: Fortran/gfortran/regression/warn_conversion.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-options "-Wconversion" } + +! +! PR fortran/27866 -improve -Wconversion +! +SUBROUTINE pr27866 + double precision :: d + real :: r + d = 4d99 + r = d ! { dg-warning "conversion" } +END SUBROUTINE + +SUBROUTINE pr27866c4 + real(kind=4) :: a + real(kind=8) :: b + integer(kind=1) :: i1 + integer(kind=4) :: i4 + i4 = 2.3 ! { dg-warning "conversion" } + i1 = 500 ! { dg-error "overflow" } + a = 2**26-1 ! { dg-warning "Change of value in conversion" } + b = 1d999 ! { dg-error "overflow" } + + a = i4 ! assignment INTEGER(4) to REAL(4) - no warning + b = i4 ! assignment INTEGER(4) to REAL(8) - no warning + i1 = i4 ! { dg-warning "conversion" } + a = b ! { dg-warning "conversion" } +END SUBROUTINE + + +! +! PR fortran/35003 - spurious warning with -Wconversion +! Contributed by Brian Barnes +! +SUBROUTINE pr35003 + IMPLICIT NONE + integer(8) :: i, n + n = 1_8 + + do i = 1_8,n + enddo +END SUBROUTINE + + +! +! PR fortran/42809 - Too much noise with -Wconversion +! Contributed by Harald Anlauf +! +SUBROUTINE pr42809 + implicit none + integer, parameter :: sp = kind (1.0) + integer, parameter :: dp = kind (1.d0) + real(sp) :: s + real(dp) :: d + complex(dp) :: z + + s = 0 ! assignment INTEGER(4) to REAL(4) - no warning + d = s ! assignment REAL((8)) to REAL(4) - no warning + z = (0, 1) ! conversion INTEGER(4) to REAL(4), + ! assignment COMPLEX(4) to COMPLEX(8) - no warning +END SUBROUTINE Index: Fortran/gfortran/regression/warn_conversion_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_10.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fno-range-check -Wconversion" } +! PR 88298 - this used to warn unnecessarily. Original test case by +! Harald Anlauf. +subroutine bug (j, js) + integer :: j, js(3,2) + js(:,:) = cshift (js(:,:), shift=j, dim=1) +end subroutine bug Index: Fortran/gfortran/regression/warn_conversion_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_11.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wconversion" } +! PR 86119 - this used to warn. +program proglen + +implicit none + + class(*), allocatable :: s + integer :: l2 + + allocate(s, source = '123 ') + + select type(s) + type is (character(len=*)) + l2 = len(s) + end select + +end program proglen Index: Fortran/gfortran/regression/warn_conversion_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Wconversion-extra" } + + real(8) :: sqrt2 + real x + + x = 2.0 + sqrt2 = sqrt(x) ! { dg-warning "Conversion" } + + sqrt2 = sqrt(2.0) ! { dg-warning "Conversion" } +end Index: Fortran/gfortran/regression/warn_conversion_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Wconversion -Wconversion-extra" } +! PR 47659 - warning about conversions on assignment +! Based on a test case by Thomas Henlich +program main + double precision d1, d2 + complex(8), parameter :: z = cmplx (0.5, 0.5) ! { dg-warning "Conversion" } + real :: r1, r2 + r1 = 2.3d0 ! { dg-warning "Change of value in conversion" } + r2 = 2.5d0 ! { dg-warning "Conversion" } + d1 = .13 ! { dg-warning "Conversion" } + d2 = .13d0 + d1 = z ! { dg-warning "Non-zero imaginary part" } +end program main Index: Fortran/gfortran/regression/warn_conversion_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wconversion" } +! +! PR fortran/54234 +! +! +module fft_mod + implicit none + integer, parameter :: dp=kind(0.0d0) +contains + subroutine test + integer :: x + x = int (abs (cmplx(2.3,0.1))) + x = int (abs (cmplx(2.3_dp,0.1))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" } + x = int (abs (cmplx(2.3,0.1_dp))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" } + x = int (abs (cmplx(2.3_dp,0.1_dp))) ! { dg-warning "Conversion from REAL.8. to default-kind COMPLEX.4. at .1. might lose precision, consider using the KIND argument" } + end subroutine test +end module fft_mod Index: Fortran/gfortran/regression/warn_conversion_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_5.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-Wconversion" } +! PR 47359 - additional warnings for conversions. +program main + implicit none + complex(kind=4) :: c4 + complex(kind=8) :: c8 + real(kind=4) :: r4 + real(kind=8) :: r8 + complex(kind=4), parameter :: c4p = (1.0, -4.) + complex, parameter :: c8w = (1.0_8, -4.2_8) ! { dg-warning "Change of value in conversion" } + complex (kind=8), parameter :: c8p = (1.0_8, -4.2_8) + integer :: i + + c4 = c8p ! { dg-warning "Change of value in conversion" } + c4 = 2**26 + 1 ! { dg-warning "Change of value in conversion" } + c4 = 1.3d0 ! { dg-warning "Change of value in conversion" } + c4 = c8p ! { dg-warning "Change of value in conversion" } + c4 = (1.2, 1000000001) ! { dg-warning "Change of value in conversion" } + r4 = (2**26 + 1) * 2.3 ! { dg-warning "Change of value in conversion" } + r4 = 2.4d0 ! { dg-warning "Change of value" } + r4 = c4p ! { dg-warning "Non-zero imaginary part" } + r4 = r4 + 2.3d0 ! { dg-warning "Possible change of value in conversion" } + r8 = 2_8**62 - 1_8 ! { dg-warning "Change of value in conversion" } + i = c4p ! { dg-warning "Non-zero imaginary part" } + i = 42 + 1.3 ! { dg-warning "Change of value in conversion" } + i = (1.2, 0.) ! { dg-warning "Change of value in conversion" } + c4 = 1.2 ! no warning + c4 = -3.25d0 ! no warning + c4 = -42 ! no warning + c8 = 2**26 + 1 ! no warning + i = 22. ! no warning + i = (35., 0.) ! no warning + r4 = 2.5d0 ! no warning + r4 = 235 ! no warning + r8 = 2.3 ! no warning +end program main Index: Fortran/gfortran/regression/warn_conversion_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_6.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-Wconversion -Wconversion-extra" } +! PR 47359 - additional warnings for conversions. +program main + implicit none + real(kind=8) :: a,b + complex(kind=8) :: c + integer :: i + real(kind=4) :: r + a = 0.13 ! { dg-warning "Conversion" } + print *,0.1_8 ** 0.2 ! { dg-warning "Conversion" } + b = a/0.13 ! { dg-warning "Conversion" } + i = 12345. ! { dg-warning "Conversion" } + i = (1., 23.) ! { dg-warning "Non-zero imaginary part" } + r = (1., 23.) ! { dg-warning "Non-zero imaginary part" } + b = 0.& ! { dg-warning "Possible change of value" } + &5_8*c ! { dg-warning "Conversion" } + c = 0.3 ! { dg-warning "Conversion" } + a = 0.5 ! { dg-warning "Conversion" } +end program main + Index: Fortran/gfortran/regression/warn_conversion_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_7.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wconversion-extra -Wconversion" } +program main + implicit none + double precision, parameter :: pi = & ! { dg-warning "Conversion" } + & 3.1415829535897932 ! { dg-warning "Non-significant digits" } +end program main Index: Fortran/gfortran/regression/warn_conversion_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_8.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-Winteger-division" } +program main + integer, parameter :: n = 23 + integer, parameter :: m = n*(n+1)/2 ! No warning + integer, parameter :: i = n*(n+1)/17 ! { dg-warning "Integer division truncated to constant" } + print *, 3/5 ! { dg-warning "Integer division truncated to constant" } +end program main Index: Fortran/gfortran/regression/warn_conversion_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_conversion_9.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wconversion" } +! PR 78221 - used to give a spurious warning +complex, parameter :: i = (0.,1.) +complex :: t +t = (i) +end Index: Fortran/gfortran/regression/warn_function_without_result.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_function_without_result.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-Wreturn-type" } +! +! PR fortran/31463 - inconsistent warnings if function return value is not set +! PR fortran/33950 - Warning missing for function result not set +! PR fortran/34296 - Intent(out) and character functions with RESULT: Value-not-set warning +! +FUNCTION f1() ! { dg-warning "not set" } +REAL :: f1 +END FUNCTION + +FUNCTION f2() ! { dg-warning "not set" } +REAL, DIMENSION(1) :: f2 +END FUNCTION + +FUNCTION f3() ! { dg-warning "not set" } +REAL, POINTER :: f3 +END FUNCTION + +FUNCTION f4() ! { dg-warning "not set" } +REAL, DIMENSION(:), POINTER :: f4 +END FUNCTION + +FUNCTION f5() ! { dg-warning "not set" } +REAL, DIMENSION(:), ALLOCATABLE :: f5 +END FUNCTION + +FUNCTION f6() ! { dg-warning "not set" } +CHARACTER(2) :: f6 +END FUNCTION + + + +FUNCTION g1() RESULT(h) ! { dg-warning "not set" } +REAL :: h +END FUNCTION + +FUNCTION g2() RESULT(h) ! { dg-warning "not set" } +REAL, DIMENSION(1) :: h +END FUNCTION + +FUNCTION g3() RESULT(h) ! { dg-warning "not set" } +REAL, POINTER :: h +END FUNCTION + +FUNCTION g4() RESULT(h) ! { dg-warning "not set" } +REAL, DIMENSION(:), POINTER :: h +END FUNCTION + +FUNCTION g5() RESULT(h) ! { dg-warning "not set" } +REAL, DIMENSION(:), ALLOCATABLE :: h +END FUNCTION + +FUNCTION g6() RESULT(h) ! { dg-warning "not set" } +CHARACTER(2) :: h +END FUNCTION + Index: Fortran/gfortran/regression/warn_function_without_result_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_function_without_result_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/50923 +! +module m +contains + integer pure function f() ! { dg-warning "Return value of function 'f' at .1. not set" } + end function f + integer pure function g() result(h) ! { dg-warning "Return value 'h' of function 'g' declared at .1. not set" } + end function g + integer pure function i() + i = 7 + end function i + integer pure function j() result(k) + k = 8 + end function j +end module m Index: Fortran/gfortran/regression/warn_implicit_procedure_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_implicit_procedure_1.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-Wimplicit-procedure" } + +! PR fortran/22552 +! Check for correct -Wimplicit-procedure warnings. + +MODULE m + +CONTAINS + + SUBROUTINE my_sub () + END SUBROUTINE my_sub + + INTEGER FUNCTION my_func () + my_func = 42 + END FUNCTION my_func + +END MODULE m + +SUBROUTINE test (proc) + IMPLICIT NONE + CALL proc () ! { dg-bogus "is not explicitly declared" } +END SUBROUTINE test + +PROGRAM main + USE m + EXTERNAL :: ext_sub + EXTERNAL :: test + INTEGER :: ext_func + + CALL ext_sub () ! { dg-bogus "is not explicitly declared" } + PRINT *, ext_func () ! { dg-bogus "is not explicitly declared" } + PRINT *, implicit_func () ! { dg-bogus "is not explicitly declared" } + CALL my_sub () ! { dg-bogus "is not explicitly declared" } + PRINT *, my_func () ! { dg-bogus "is not explicitly declared" } + PRINT *, SIN (3.14159) ! { dg-bogus "is not explicitly declared" } + + CALL undef_sub (1, 2, 3) ! { dg-warning "is not explicitly declared" } + ! Can't check undefined function, because it needs to be declared a type + ! in any case (and the implicit type is enough to not trigger this warning). +END PROGRAM Index: Fortran/gfortran/regression/warn_intent_out_not_set.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_intent_out_not_set.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-c -Wall" } +! +! PR fortran/42360 +! +MODULE m + TYPE :: t1 + INTEGER :: a = 42, b + END TYPE + + TYPE :: t2 + INTEGER :: a, b + END TYPE + +CONTAINS + SUBROUTINE sub1(x) ! no warning, default initializer + type(t1), intent(out) :: x + END SUBROUTINE + + SUBROUTINE sub2(x) ! no warning, initialized + type(t2), intent(out) :: x + x%a = 42 + END SUBROUTINE + + SUBROUTINE sub3(x) ! { dg-warning "not set" } + type(t2), intent(out) :: x + END SUBROUTINE +END MODULE Index: Fortran/gfortran/regression/warn_std_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_std_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! PR fortran/32778 - pedantic warning: intrinsics that +! are GNU extensions not part of -std=gnu +! +! (1/3) Check for excess errors if -std=gnu. +! + +CHARACTER(len=255) :: tmp +REAL(8) :: x + +! GNU extension, check overload of F77 standard intrinsic +x = ZABS(CMPLX(0.0, 1.0, 8)) + +! GNU extension +CALL flush() + +! F95 +tmp = ADJUSTL(" gfortran ") + +! F2003 +CALL GET_COMMAND (tmp) + +END Index: Fortran/gfortran/regression/warn_std_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_std_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f95 -Wintrinsics-std" } +! +! PR fortran/32778 - pedantic warning: intrinsics that +! are GNU extensions not part of -std=gnu +! +! (2/3) Check for GNU extensions and intrinsics from F2003 if -std=f95. +! + +CHARACTER(len=255) :: tmp +REAL(8) :: x + +! GNU extension, check overload of F77 standard intrinsic +x = ZABS(CMPLX(0.0, 1.0, 8)) ! { dg-warning "extension" } + +! GNU extension +CALL flush() ! { dg-warning "extension" } + +! F95 +tmp = ADJUSTL(" gfortran ") + +! F2003 +CALL GET_COMMAND (tmp) ! { dg-warning "Fortran 2003" } + +END Index: Fortran/gfortran/regression/warn_std_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_std_3.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wintrinsics-std" } +! +! PR fortran/32778 - pedantic warning: intrinsics that +! are GNU extensions not part of -std=gnu +! +! (3/3) Check for GNU extensions if -std=f2003. +! + +CHARACTER(len=255) :: tmp +REAL(8) :: x + +! GNU extension, check overload of F77 standard intrinsic +x = ZABS(CMPLX(0.0, 1.0, 8)) ! { dg-warning "extension" } + +! GNU extension +CALL flush() ! { dg-warning "extension" } + +! F95 +tmp = ADJUSTL(" gfortran ") + +! F2003 +CALL GET_COMMAND (tmp) + +END Index: Fortran/gfortran/regression/warn_target_lifetime_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_target_lifetime_1.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-Wtarget-lifetime" } +! +! PR fortran/54301 +! +function f () result (ptr) + integer, pointer :: ptr(:) + integer, allocatable, target :: a(:) + allocate(a(5)) + + ptr => a ! { dg-warning "Pointer at .1. in pointer assignment might outlive the pointer target" } + a = [1,2,3,4,5] +end function + + +subroutine foo() + integer, pointer :: ptr(:) + call bar () +contains + subroutine bar () + integer, target :: tgt(5) + ptr => tgt ! { dg-warning "Pointer at .1. in pointer assignment might outlive the pointer target" } + end subroutine bar +end subroutine foo + +function foo3(tgt) + integer, target :: tgt + integer, pointer :: foo3 + foo3 => tgt +end function + +subroutine sub() + implicit none + integer, pointer :: ptr + integer, target :: tgt + ptr => tgt + + block + integer, pointer :: p2 + integer, target :: tgt2 + p2 => tgt2 + p2 => tgt + ptr => p2 + ptr => tgt + ptr => tgt2 ! { dg-warning "Pointer at .1. in pointer assignment might outlive the pointer target" } + end block +end subroutine sub Index: Fortran/gfortran/regression/warn_target_lifetime_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_target_lifetime_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wtarget-lifetime" } +! +! PR fortran/54301 +! +function f() + integer, pointer :: f + integer, target :: t + f => t ! { dg-warning "Pointer at .1. in pointer assignment might outlive the pointer target" } +end Index: Fortran/gfortran/regression/warn_target_lifetime_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_target_lifetime_3.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/55476 +! +! Contributed by Janus Weil +! +subroutine test + integer, pointer :: p + integer, target :: t + p => t +contains + subroutine sub() ! { dg-warning "defined but not used" } + if (p /= 0) return + end subroutine +end subroutine + +module m + integer, pointer :: p2 +contains + subroutine test + integer, target :: t2 + p2 => t2 ! { dg-warning "Pointer at .1. in pointer assignment might outlive the pointer target" } + contains + subroutine sub() ! { dg-warning "defined but not used" } + if (p2 /= 0) return + end subroutine + end subroutine +end module m Index: Fortran/gfortran/regression/warn_target_lifetime_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_target_lifetime_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-Wtarget-lifetime" } +! +! PR fortran/81770: [5/6/7 Regression] Bogus warning: Pointer in pointer assignment might outlive the pointer target +! +! Contributed by Janus Weil + +module m + + type t + integer, allocatable :: l + end type + +contains + + subroutine sub(c_in, list) + type(t), target, intent(in) :: c_in + integer, pointer, intent(out) :: list + + type(t), pointer :: container + + container => c_in + + list => container%l + + end subroutine + +end Index: Fortran/gfortran/regression/warn_undefined_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_undefined_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-O2 -Wuninitialized" } +! PR 67679 - this used to cause an undefined warning for +! variables generated by the compiler. + +subroutine s(h, Gmin, r) + + implicit none + real, intent(in) :: Gmin(3), h(3) + integer, intent(inout) :: r + + integer :: x_min(3), x_max(3), k, iStat + logical, dimension(:), allocatable :: check + + do k = 1,1 + x_min(k) = int(Gmin(k)*h(k)) + x_max(k) = int(Gmin(k)*h(k)) + end do + + allocate(check(x_min(1):x_max(1)),stat=iStat) + + check(:) = .false. + + do k = x_min(1),x_max(1) + r = r + 1 + end do + +end Index: Fortran/gfortran/regression/warn_unused_dummy_argument_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/38407 +! + +SUBROUTINE s(dummy) ! { dg-warning "Unused dummy" } + INTEGER, INTENT(in) :: dummy + INTEGER :: variable ! { dg-warning "Unused variable" } +END SUBROUTINE Index: Fortran/gfortran/regression/warn_unused_dummy_argument_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wall -Wno-unused-dummy-argument" } +! +! PR fortran/38407 +! + +SUBROUTINE s(dummy) + INTEGER, INTENT(in) :: dummy + INTEGER :: variable ! { dg-warning "Unused variable" } +END SUBROUTINE Index: Fortran/gfortran/regression/warn_unused_dummy_argument_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-Wunused-dummy-argument -Wunused-parameter" } +! PR 48847 - we used to generate a warning for g(), and none for h() +program main +contains + function f(g,h) + interface + real function g() + end function g + end interface + interface + real function h() ! { dg-warning "Unused dummy argument" } + end function h + end interface + real :: f + f = g() + end function f +end program main Index: Fortran/gfortran/regression/warn_unused_dummy_argument_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR fortran/57469 +! +! Contributed by Vladimir Fuka +! +! Don't warn for unused dummy arguments when they are used in namelists +! + subroutine read_command_line(line,a,b) + character(*),intent(in) :: line + intent(inout) :: a,b + namelist /cmd/ a,b + + read(line,nml = cmd) + end Index: Fortran/gfortran/regression/warn_unused_dummy_argument_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-Wunused-dummy-argument" } +! PR 91557 - this used to generate a bogus warning +! Test case by Gerhard Steinmetz +program p + integer :: a, b + a = 1 + call g +contains + subroutine g + integer :: x, y + call h (x, y) + if ( a > 0 ) y = y - 1 + b = y - x + 1 + end +end Index: Fortran/gfortran/regression/warn_unused_dummy_argument_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_dummy_argument_6.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR 94270 - this used to give a bogus warning. +! Test case by Ignacio Fernández Galván. +subroutine foo() +external bar +call meh(bar) +call foo_internal() +contains + subroutine foo_internal() + call meh(bar) + end subroutine foo_internal +end subroutine foo Index: Fortran/gfortran/regression/warn_unused_function.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_function.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Wunused-function" } +! +! PR 54224: [4.8 Regression] Bogus -Wunused-function warning with static function +! +! Contributed by Tobias Burnus + +module mod_say_hello + private :: hello_integer +contains + subroutine say_hello() + call hello_integer(123) + end subroutine + + subroutine hello_integer( a ) + integer, intent(in) :: a + print *, "Hello ", a, "!" + end subroutine +end module Index: Fortran/gfortran/regression/warn_unused_function_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_function_2.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! [4.8 Regression] PR 54997: -Wunused-function gives false warnings +! PR 54224: missing warnings with -Wunused-function +! +! Contributed by Janus Weil + +module m + + implicit none + private :: s1,s2,s3 + +contains + + subroutine s1 ! { dg-warning "defined but not used" } + call s2(s3) + contains + subroutine s4 ! { dg-warning "defined but not used" } + end subroutine + end subroutine + + subroutine s2(dummy) ! { dg-warning "Unused dummy argument" } + procedure() :: dummy + end subroutine + + subroutine s3() + end subroutine + +end module + + +subroutine sub +entry en +end subroutine + +program test +contains + subroutine s5 ! { dg-warning "defined but not used" } + end subroutine +end Index: Fortran/gfortran/regression/warn_unused_function_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_function_3.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-Wunused-function" } +! +! PR 67982: Bogus -Wunused-function warning with contained function +! +! Contributed by Joost VandeVondele + +MODULE base + INTERFACE + SUBROUTINE bar_int() + END SUBROUTINE + END INTERFACE + PUBLIC hook + PRIVATE + PROCEDURE(bar_int), POINTER :: hook=>NULL() +END MODULE base + +MODULE foo + USE base, ONLY: hook + PUBLIC init + PRIVATE +CONTAINS + SUBROUTINE init() + hook=>bar + END SUBROUTINE init + SUBROUTINE bar() + WRITE(6,*) "In bar" + END SUBROUTINE +END MODULE + +USE foo, ONLY: init +USE base, ONLY: hook +CALL init() +CALL hook() +END Index: Fortran/gfortran/regression/warn_unused_var.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_var.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wunused-variable" } +! +! PR fortran/37420 +! +integer :: i ! { dg-warning "Unused variable" } +end Index: Fortran/gfortran/regression/warn_unused_var_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_var_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-Wunused" } +! +! PR fortran/31461 +! +! Contributed by Vivek Rao. +! + +module util_mod + integer :: i,j +end module util_mod + +program main + use util_mod, only: i,j ! { dg-warning "Unused module variable .i. which has been explicitly imported" } + j = 1 + print*,"j=",j +end program main Index: Fortran/gfortran/regression/warn_unused_var_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warn_unused_var_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-Wunused-parameter" } +! +! PR fortran/31461 +! +module util_mod + integer, parameter :: i = 4 +end module util_mod + +program main + use util_mod, only: i ! { dg-warning "Unused parameter .i. which has been explicitly imported" } + integer, parameter :: j = 4 ! { dg-warning "Unused parameter .j. declared at" } +end program main Index: Fortran/gfortran/regression/warning-directive-1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warning-directive-1.F90 @@ -0,0 +1,5 @@ +! { dg-do preprocess } +! { dg-options "-std=f95 -fdiagnostics-show-option" } + +#warning "Printed" +! { dg-warning "\"Printed\" .-Wcpp." "" { target *-*-* } .-1 } Index: Fortran/gfortran/regression/warning-directive-2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warning-directive-2.F90 @@ -0,0 +1,5 @@ +! { dg-do preprocess } +! { dg-options "-std=f95 -fdiagnostics-show-option -Werror=cpp" } +! { dg-message "some warnings being treated as errors" "" { target *-*-* } 0 } +#warning "Printed" +! { dg-error "\"Printed\" .-Werror=cpp." "" { target *-*-* } .-1 } Index: Fortran/gfortran/regression/warning-directive-3.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warning-directive-3.F90 @@ -0,0 +1,5 @@ +! { dg-do preprocess } +! { dg-options "-std=f95 -fdiagnostics-show-option -Werror -Wno-error=cpp" } + +#warning "Printed" +! { dg-warning "\"Printed\" .-Wcpp." "" { target *-*-* } .-1 } Index: Fortran/gfortran/regression/warning-directive-4.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warning-directive-4.F90 @@ -0,0 +1,5 @@ +! { dg-do preprocess } +! { dg-options "-std=f95 -fdiagnostics-show-option -Wno-cpp" } + +#warning "Not printed" +! { dg-bogus "." "" { target *-*-* } .-1 } Index: Fortran/gfortran/regression/warnings_are_errors_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warnings_are_errors_1.f @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options " -Werror" } +! { dg-message "warnings being treated as errors" "" { target *-*-* } 0 } +! PR fortran/21061 +! gfortran ignores -Werror +! fixed-form tests + program warnings_are_errors_1 + implicit none + integer(kind=1) :: i + real :: r1, r2(3) +! gfc_warning_now: +0 r1 = 0 ! { dg-error "Zero is not a valid statement label" } +! +34 5 i=0 +! gfc_notify_std(GFC_STD_F95_DEL): + do r1 = 1, 2 ! { dg-error "Deleted feature: Loop variable" } + i = i+1 + end do + call foo j bar +! gfc_warning: + r2(4) = 0 ! { dg-error "is out of bounds" } + + goto 3 45 + end +! { dg-final { output-exists-not } } Index: Fortran/gfortran/regression/warnings_are_errors_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/warnings_are_errors_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Werror -Wunused -std=f95" } +! PR fortran/21061 +! gfortran ignores -Werror +! free-form tests + +! gfc_notify_std: + function char_ (ch) ! { dg-error "Obsolescent feature" } + character(*) :: char_, ch + char_ = ch + end function char_ + +! warning(0,...): +! function wrong_warn (i) ! { -warning "Function does not return a value" } +! integer i +! end function wrong_warn + + implicit none +! gfc_warning: +1234 complex :: cplx ! { dg-error "defined but cannot be used" } + cplx = 20. + + end +! { dg-final { output-exists-not } } +! { dg-prune-output "warnings being treated as errors" } Index: Fortran/gfortran/regression/wdate-time.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wdate-time.F90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-Wdate-time" } +print *, __TIMESTAMP__ ! { dg-warning "might prevent reproducible builds" } +print *, __TIME__ ! { dg-warning "might prevent reproducible builds" } +print *, __DATE__ ! { dg-warning "might prevent reproducible builds" } +end Index: Fortran/gfortran/regression/weak-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/weak-1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-require-weak "" } +! { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?impl" { target { ! nvptx-*-* } } } } +! { dg-final { scan-assembler-times "\\.weak \\.func impl" 2 { target nvptx-*-* } } } +subroutine impl +!GCC$ ATTRIBUTES weak :: impl +end subroutine Index: Fortran/gfortran/regression/weak-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/weak-2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-require-weak "" } +! { dg-skip-if "" { x86_64-*-mingw* } } +! { dg-skip-if "" { nvptx-*-* } } + +! 1. +! { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?__foo_MOD_abc" } } +module foo +implicit none +!GCC$ ATTRIBUTES weak :: abc +real :: abc(7) +end module + +! 2. +! { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?impl1" } } +integer function impl1() +implicit none +!GCC$ ATTRIBUTES weak :: impl1 +end function + +! 3. +! { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?bar__" } } +integer function impl2() bind(c,name='bar__') +implicit none +!GCC$ ATTRIBUTES weak :: impl2 +end function Index: Fortran/gfortran/regression/weak-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/weak-3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-require-weak "" } + +! 1. +program foo1 ! { dg-error "weak declaration of 'foo1' must be public" "" } +implicit none +!GCC$ ATTRIBUTES weak :: foo1 +end program + +! 2. +subroutine foo2 +implicit none +contains + function dar() ! { dg-error "weak declaration of 'dar' must be public" "" } + integer :: dar +!GCC$ ATTRIBUTES weak :: dar + end function + subroutine bar ! { dg-error "weak declaration of 'bar' must be public" "" } +!GCC$ ATTRIBUTES weak :: bar + end subroutine +end subroutine + +! 3. +subroutine foo3(n) ! { dg-error "has the WEAK attribute but is a dummy argument" "" } +implicit none +integer :: n +!GCC$ ATTRIBUTES weak :: n +real :: abc ! { dg-error "has the WEAK attribute but is a local variable" "" } +!GCC$ ATTRIBUTES weak :: abc +end subroutine Index: Fortran/gfortran/regression/wextra_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wextra_1.f @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wall -Wextra" } + program main + integer, parameter :: x=3 ! { dg-warning "Unused parameter" } + real :: a + read (*,*) a + if (a .eq. 3.14) a=2. ! { dg-warning "Equality comparison" } + print *,a + end Index: Fortran/gfortran/regression/where_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_1.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! Tests the fix for PR35759 and PR35756 in which the dependencies +! led to an incorrect use of the "simple where", gfc_trans_where_3. +! +! Contributed by Dick Hendrickson +! + logical :: la(6) = (/(2*(i/2) /= i, i = 1, 6)/), lb(6) + CALL PR35759 + CALL PR35756 +! +! The first version of the fix caused this to regress as pointed +! out by Dominique d'Humieres +! + lb = la + where(la) + la = .false. + elsewhere + la = .true. + end where + if (any(la .eqv. lb)) STOP 1 +CONTAINS + subroutine PR35759 + integer UDA1L(6) + integer :: UDA1R(6), expected(6) = (/2,0,5,0,3,0/) + LOGICAL LDA(5) + UDA1L(1:6) = 0 + uda1r = (/1,2,3,4,5,6/) + lda = (/ (i/2*2 .ne. I, i=1,5) /) + WHERE (LDA) + UDA1L(1:5) = UDA1R(2:6) + ELSEWHERE + UDA1L(2:6) = UDA1R(6:2:-1) + ENDWHERE + if (any (expected /= uda1l)) STOP 1 + END subroutine + + SUBROUTINE PR35756 + INTEGER ILA(10), CLA(10) + LOGICAL LDA(10) + ILA = (/ (I, i=1,10) /) + LDA = (/ (i/2*2 .ne. I, i=1,10) /) + WHERE(LDA) + CLA = 10 + ELSEWHERE + CLA = 2 + ENDWHERE + WHERE(LDA) + ILA = R_MY_MAX_I(ILA) + ELSEWHERE + ILA = R_MY_MIN_I(ILA) + ENDWHERE + IF (any (CLA /= ILA)) STOP 2 + end subroutine + + INTEGER FUNCTION R_MY_MAX_I(A) + INTEGER :: A(:) + R_MY_MAX_I = MAXVAL(A) + END FUNCTION R_MY_MAX_I + + INTEGER FUNCTION R_MY_MIN_I(A) + INTEGER :: A(:) + R_MY_MIN_I = MINVAL(A) + END FUNCTION R_MY_MIN_I +END Index: Fortran/gfortran/regression/where_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fix for PR35743 and PR35745. +! +! Contributed by Dick Hendrickson +! +program try_rg0025 + logical lda(5) + lda = (/(i/2*2 .ne. I, i=1,5)/) + call PR35743 (lda, 1, 2, 3, 5, 6, -1, -2) + CALL PR34745 +end program + +! Previously, the negative mask size would not be detected. +SUBROUTINE PR35743 (LDA,nf1,nf2,nf3,nf5,nf6,mf1,mf2) + type unseq + real r + end type unseq + TYPE(UNSEQ) TDA1L(6) + LOGICAL LDA(NF5) + TDA1L(1:6)%r = 1.0 + WHERE (LDA(NF6:NF3)) + TDA1L(MF1:NF5:MF1) = TDA1L(NF6:NF2) + ENDWHERE +END SUBROUTINE + +! Previously, the expression in the WHERE block would be evaluated +! ouside the loop generated by the where. +SUBROUTINE PR34745 + INTEGER IDA(10) + REAL RDA(10) + RDA = 1.0 + nf0 = 0 + WHERE (RDA < -15.0) + IDA = 1/NF0 + 2 + ENDWHERE +END SUBROUTINE Index: Fortran/gfortran/regression/where_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/50129 +! ICE after reporting an error on a masked ELSEWHERE statement following an +! unmasked one. +! +! Contributed by Joost Van de Vondele + +INTEGER :: I(3) +WHERE (I>2) +ELSEWHERE +ELSEWHERE (I<1) ! { dg-error "follows previous unmasked ELSEWHERE" } +END WHERE +END + Index: Fortran/gfortran/regression/where_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 60522 - this used to ICE. +! Original test case Roger Ferrer Ibanez +subroutine foo(a, b) + implicit none + integer, dimension(:), intent(inout) :: a + integer, dimension(:), intent(in) :: b + + where (b(:) > 0) + where (b(:) > 100) + a(lbound(a, 1):ubound(a, 1)) = b(lbound(b, 1):ubound(b, 1)) * b(lbound(b, 1):ubound(b, 1)) - 100 + elsewhere + a(lbound(a, 1):ubound(a, 1)) = b(lbound(b, 1):ubound(b, 1)) * b(lbound(b, 1):ubound(b, 1)) + end where + elsewhere + a(lbound(a, 1):ubound(a, 1)) = - b(lbound(b, 1):ubound(b, 1)) * b(lbound(b, 1):ubound(b, 1)) + end where +end subroutine foo Index: Fortran/gfortran/regression/where_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-Wcharacter-truncation" } +subroutine where_ice (i,j) + + implicit none + + character(8) :: y(10,10,2) + + integer :: i + integer :: j + + character(12) :: txt(5) + where (txt(1:3) /= '' ) y(1:3,i,j) = txt(1:3) ! { dg-warning "CHARACTER expression will be truncated" } + +end subroutine where_ice Index: Fortran/gfortran/regression/where_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-Wcharacter-truncation" } +subroutine where_ice (i,j) + + implicit none + + character(8) :: y(10,10,2) + + integer :: i + integer :: j + + character(12) :: txt(5) + if (.true.) where (txt(1:3) /= '' ) y(1:3,i,j) = txt(1:3) ! { dg-warning "CHARACTER expression will be truncated" } + +end subroutine where_ice Index: Fortran/gfortran/regression/where_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_7.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! PR fortran/88073 - this used to ICE with front-end optimization +! Original test case by 'mecej4' +Subroutine tfu (n, x, f) + Implicit None + Integer, Parameter :: double = Kind (0.d0) + Integer, Intent (In) :: n + Real (double), Intent (Out) :: f + Real (double), Intent (In) :: x (n) + Integer :: j + Logical, Dimension(n) :: l1v, l2v, l3v +! + l3v = .False. + l2v = .False. + l1v = (/ (j, j=1, n) /) == 1 + Where ( .Not. (l1v)) + l2v = (/ (j, j=1, n) /) == n + End Where + Where ( .Not. l1v) + l3v = .Not. l2v + End Where + f = sum (x(1:n), mask=l3v) + Return +end subroutine tfu Index: Fortran/gfortran/regression/where_nested_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_nested_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR 25423: Nested WHERE constructs. +program nested_where + + implicit none + integer :: a(4) + logical :: mask1(4) = (/.TRUE., .TRUE., .FALSE., .FALSE./), & + mask2(4) = (/.TRUE., .FALSE., .TRUE., .FALSE./) + + where (mask1) + where (mask2) + a = 1 + elsewhere + a = 2 + end where + elsewhere + where (mask2) + a = 3 + elsewhere + a = 4 + end where + end where + + print *, a + +end program nested_where Index: Fortran/gfortran/regression/where_operator_assign_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_operator_assign_1.f90 @@ -0,0 +1,106 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. This is the test provided +! by the reporter. +! +! Contributed by Dominique d'Humieres +!============================================================================== + +MODULE kind_mod + + IMPLICIT NONE + + PRIVATE + + INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9) + INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4) + +END MODULE kind_mod + +!============================================================================== + +MODULE pointer_mod + + USE kind_mod, ONLY : I4 + + IMPLICIT NONE + + PRIVATE + + TYPE, PUBLIC :: pvt + INTEGER(I4), POINTER, DIMENSION(:) :: vect + END TYPE pvt + + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE p_to_p + END INTERFACE + + PUBLIC :: ASSIGNMENT(=) + +CONTAINS + + !--------------------------------------------------------------------------- + + PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2) + IMPLICIT NONE + TYPE(pvt), INTENT(OUT) :: a1 + TYPE(pvt), INTENT(IN) :: a2 + a1%vect = a2%vect + END SUBROUTINE p_to_p + + !--------------------------------------------------------------------------- + +END MODULE pointer_mod + +!============================================================================== + +PROGRAM test_prog + + USE pointer_mod, ONLY : pvt, ASSIGNMENT(=) + + USE kind_mod, ONLY : I4, TF + + IMPLICIT NONE + + INTEGER(I4), DIMENSION(12_I4), TARGET :: ia + LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la + TYPE(pvt), DIMENSION(6_I4) :: pv + INTEGER(I4) :: i + + ! Initialisation... + la(:,1_I4:3_I4:2_I4)=.TRUE._TF + la(:,2_I4)=.FALSE._TF + + DO i=1_I4,6_I4 + pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i)) + END DO + + ia=0_I4 + + DO i=1_I4,3_I4 + WHERE(la((/1_I4,2_I4/),i)) + pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/)) + ELSEWHERE + pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/)) + END WHERE + END DO + + if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) STOP 1 + +CONTAINS + + TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans) + + USE kind_mod, ONLY : I4 + USE pointer_mod, ONLY : pvt, ASSIGNMENT(=) + + IMPLICIT NONE + + INTEGER(I4), INTENT(IN) :: index + + ALLOCATE(ans%vect(2_I4)) + ans%vect=(/index,-index/) + + END FUNCTION iaef + +END PROGRAM test_prog Index: Fortran/gfortran/regression/where_operator_assign_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_operator_assign_2.f90 @@ -0,0 +1,104 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. +! +! Contributed by Paul Thomas +!****************************************************************************** +module global + type :: a + integer :: b + integer :: c + end type a + interface assignment(=) + module procedure a_to_a + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4), z(4), u(4, 4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = n%b + 1 + m%c = n%c + end subroutine a_to_a +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/) + y = x + z = x + l1 = (/t, f, f, t/) + + call test_where_1 + if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) STOP 1 + + call test_where_2 + if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) STOP 2 + if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) STOP 3 + + call test_where_3 + if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) STOP 4 + + y = x + call test_where_forall_1 + if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) STOP 5 + + l1 = (/t, f, t, f/) + call test_where_4 + if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) STOP 6 + +contains +!****************************************************************************** + subroutine test_where_1 ! Test a simple WHERE + where (l1) y = x + end subroutine test_where_1 +!****************************************************************************** + subroutine test_where_2 ! Test a WHERE blocks + where (l1) + y = a (0, 0) + z = z(4:1:-1) + elsewhere + y = x + z = a (0, 0) + end where + end subroutine test_where_2 +!****************************************************************************** + subroutine test_where_3 ! Test a simple WHERE with a function assignment + where (.not. l1) y = foo (x) + end subroutine test_where_3 +!****************************************************************************** + subroutine test_where_forall_1 ! Test a WHERE in a FORALL block + forall (i = 1:4) + where (.not. l1) + u(i, :) = x + elsewhere + u(i, :) = a(0, i) + endwhere + end forall + end subroutine test_where_forall_1 +!****************************************************************************** + subroutine test_where_4 ! Test a WHERE assignment with dependencies + where (l1(1:3)) + x(2:4) = x(1:3) + endwhere + end subroutine test_where_4 +end program test Index: Fortran/gfortran/regression/where_operator_assign_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_operator_assign_3.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. This tests that the character +! lengths are transmitted OK. +! +! Contributed by Paul Thomas +!****************************************************************************** +module global + type :: a + integer :: b + character(8):: c + end type a + interface assignment(=) + module procedure a_to_a, c_to_a, a_to_c + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = len ( trim(n%c)) + m%c = n%c + end subroutine a_to_a + elemental subroutine c_to_a (m, n) + character(8), intent(in) :: n + type(a), intent(out) :: m + m%b = m%b + 1 + m%c = n + end subroutine c_to_a + elemental subroutine a_to_c (m, n) + type(a), intent(in) :: n + character(8), intent(out) :: m + m = n%c + end subroutine a_to_c +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/) + y = x + l1 = (/t,f,f,t/) + + call test_where_char1 + call test_where_char2 + if (any(y .ne. & + (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) STOP 1 +contains + subroutine test_where_char1 ! Test a WHERE blocks + where (l1) + y = a (0, "null") + elsewhere + y = x + end where + end subroutine test_where_char1 + subroutine test_where_char2 ! Test a WHERE blocks + where (y%c .ne. "null") + y = a (99, "non-null") + endwhere + end subroutine test_where_char2 +end program test Index: Fortran/gfortran/regression/where_operator_assign_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/where_operator_assign_4.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! PR fortran/34661 ICE on user-defined assignments in where statements +! Testcase contributed by Joost VandeVondele + +MODULE M1 + IMPLICIT NONE + TYPE T1 + INTEGER :: I + END TYPE T1 + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE S1 + END INTERFACE +CONTAINS + SUBROUTINE S1(I,J) + TYPE(T1), INTENT(OUT) :: I(2) + TYPE(T1), INTENT(IN) :: J(2) + I%I=-J%I + END SUBROUTINE S1 +END MODULE M1 + +USE M1 +TYPE(T1) :: I(2),J(2) +I(:)%I=1 +WHERE (I(:)%I>0) + J=I ! { dg-error "Non-ELEMENTAL user-defined assignment in WHERE" } +END WHERE + +WHERE (I(:)%I>0) J=I ! { dg-error "Non-ELEMENTAL user-defined assignment in WHERE" } + +END Index: Fortran/gfortran/regression/whole_file_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_1.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! { dg-options "" } +! Tests the fix for PR22571 in which the derived types in a, b +! c and d were not detected to be different. In e and f, they +! are the same because they are sequence types. +! +! Contributed by Joost VandeVondele +! +subroutine a(p) + type t + integer :: t1 + end type + type(t) :: p + p%t1 = 42 +end subroutine + +subroutine b + type u + integer :: u1 + end type + type (u) :: q + call a(q) ! { dg-error "Type mismatch" } + print *, q%u1 +end subroutine + +subroutine c(p) + type u + integer :: u1 + end type + type(u) :: p + p%u1 = 42 +end subroutine + +subroutine d + type u + integer :: u1 + end type + type (u) :: q + call c(q) ! { dg-error "Type mismatch" } + print *, q%u1 +end subroutine + +subroutine e(p) + type u + sequence + integer :: u1 + end type + type(u) :: p + p%u1 = 42 +end subroutine + +subroutine f + type u + sequence + integer :: u1 + end type + type (u) :: q + call e(q) ! This is OK because the types are sequence. + print *, q%u1 +end subroutine Index: Fortran/gfortran/regression/whole_file_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_10.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Test the fix for the fifth problem in PR40011, where the +! entries were not resolved, resulting in a segfault. +! +! Contributed by Dominique d'Humieres +! +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 + external fac + external bifac + integer :: fac, bifac + 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/whole_file_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_11.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Tests the fix PR40011 comment 16 in which the derived type lists in +! different program units were getting mixed up. +! +! Contributed by Daniel Franck +! +MODULE module_foo + TYPE :: foo_node + TYPE(foo_node_private), POINTER :: p + END TYPE + + TYPE :: foo_node_private + TYPE(foo_node), DIMENSION(-1:1) :: link + END TYPE + + TYPE :: foo + TYPE(foo_node) :: root + END TYPE +END MODULE + +FUNCTION foo_insert() + USE module_foo, ONLY: foo, foo_node + + INTEGER :: foo_insert + TYPE(foo_node) :: parent, current + INTEGER :: cmp + + parent = current + current = current%p%link(cmp) +END FUNCTION + +FUNCTION foo_count() + USE module_foo, ONLY: foo + INTEGER :: foo_count +END FUNCTION Index: Fortran/gfortran/regression/whole_file_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_12.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! Tests the fix PR40011 comment 17 in which the explicit interface was +! being ignored and the missing argument was not correctly handled, which +! led to an ICE. +! +! Contributed by Dominique d'Humieres base?" , associated(base%this%this,base) + print *, "base%this%this=>?" , associated(base%this%this) + print *, "base%this=>?" , associated(base%this) +contains + subroutine check() + type(mytype),target :: j + base%this => j !have the variables point + j%this => base !to one another + end subroutine check !take j out of scope +end program test_equi Index: Fortran/gfortran/regression/whole_file_15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_15.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Test the fix for PR43450 in which the use of 'replica_env_type' +! caused an ICE in ep_types +! +! Contributed by Tobias Burnus +! +MODULE replica_types + TYPE replica_env_type + END TYPE replica_env_type +CONTAINS + SUBROUTINE rep_env_create(rep_env, para_env, input, nrep, prep,& + sync_v,keep_wf_history,row_force) + END SUBROUTINE rep_env_create + SUBROUTINE rep_envs_add_rep_env(rep_env) + TYPE(replica_env_type), POINTER :: rep_env + END SUBROUTINE rep_envs_add_rep_env +END MODULE replica_types +MODULE ep_types + USE replica_types + TYPE ep_env_type + TYPE(replica_env_type), POINTER :: mol_envs + END TYPE ep_env_type + TYPE ep_env_p_type + TYPE(ep_env_type), POINTER :: ep_env + END TYPE ep_env_p_type + TYPE(ep_env_p_type), DIMENSION(:), POINTER :: ep_envs +CONTAINS + SUBROUTINE ep_force_release() + END SUBROUTINE ep_force_release +END MODULE ep_types Index: Fortran/gfortran/regression/whole_file_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_16.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/31346 +! +program main + real, dimension(2) :: a + call foo(a) ! { dg-error "Explicit interface required" } +end program main + +subroutine foo(a) + real, dimension(:) :: a +end subroutine foo Index: Fortran/gfortran/regression/whole_file_17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_17.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-pedantic" } +! +! PR fortran/30668 +! + +integer(8) function two() + two = 2 +end function two + +CHARACTER(len=8) function string() + string = "gfortran" +end function string + + +program xx + INTEGER :: a + CHARACTER(len=4) :: s, string ! { dg-error "Character length mismatch" } + + a = two() ! { dg-error "Return type mismatch" } + s = string() +end program xx Index: Fortran/gfortran/regression/whole_file_18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_18.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Wno-unused-dummy-argument" } +! +! PR fortran/34260 +! + PROGRAM MAIN + REAL A + CALL SUB(A) ! { dg-error "Explicit interface required" } + END PROGRAM + + SUBROUTINE SUB(A,I) + REAL :: A + INTEGER, OPTIONAL :: I + END SUBROUTINE Index: Fortran/gfortran/regression/whole_file_19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_19.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Test the fix for pr40011 comment #42, in which the subroutine +! would just get lost with -fwhole-file. +! +! Contributed by Joost VandeVandole +! +SUBROUTINE c() + CALL a() +END SUBROUTINE c + +SUBROUTINE a() +END SUBROUTINE a + +MODULE M +CONTAINS + SUBROUTINE b() + CALL c() + END SUBROUTINE +END MODULE + +USE M +CALL b() +END Index: Fortran/gfortran/regression/whole_file_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "" } +! Tests the fix for PR26227 in which the interface mismatches +! below were not detected. +! +! Contributed by Andrew Pinski +! +function a(b) +REAL ::b +b = 2.0 +a = 1.0 +end function + +program gg +real :: h +character (5) :: chr = 'hello' +h = a(); ! { dg-error "Missing actual argument" } +call test ([chr]) ! { dg-error "Rank mismatch" } +end program gg + +subroutine test (a) + character (5) :: a + if (a .ne. 'hello') STOP 1 +end subroutine test + Index: Fortran/gfortran/regression/whole_file_20.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_20.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Procedures with dummy arguments that are coarrays or polymorphic +! must have an explicit interface in the calling routine. +! + +MODULE classtype + type :: t + integer :: comp + end type +END MODULE + +PROGRAM main + USE classtype + CLASS(t), POINTER :: tt + + INTEGER :: coarr[*] + + CALL coarray(coarr) ! { dg-error "Explicit interface required" } + CALL polymorph(tt) ! { dg-error "Explicit interface required" } +END PROGRAM + +SUBROUTINE coarray(a) + INTEGER :: a[*] +END SUBROUTINE + +SUBROUTINE polymorph(b) + USE classtype + CLASS(t) :: b +END SUBROUTINE Index: Fortran/gfortran/regression/whole_file_21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_21.f90 @@ -0,0 +1,25 @@ +! { dg-do link } +! PR fortran/40011 +! +! Contributed by Joost VandeVondele +! +! +! Before no "one" function was generated with -fwhole-file. +! +! +SUBROUTINE one ( ) +END SUBROUTINE one + +SUBROUTINE two ( ) +END SUBROUTINE two + +MODULE mod +CONTAINS + SUBROUTINE three ( ) + CALL two ( ) + END SUBROUTINE three + SUBROUTINE four ( ) + CALL one ( ) + END SUBROUTINE four +END MODULE mod +END Index: Fortran/gfortran/regression/whole_file_22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_22.f90 @@ -0,0 +1,37 @@ +! { dg-do link } +! { dg-options "-fwhole-program -O3 -g" } +! +! PR fortran/40873 +! + program prog + call one() + call two() + call test() + end program prog + subroutine one() + call three() + end subroutine one + subroutine two() + call three() + end subroutine two + subroutine three() + end subroutine three + +SUBROUTINE c() + CALL a() +END SUBROUTINE c + +SUBROUTINE a() +END SUBROUTINE a + +MODULE M +CONTAINS + SUBROUTINE b() + CALL c() + END SUBROUTINE +END MODULE + +subroutine test() +USE M +CALL b() +END Index: Fortran/gfortran/regression/whole_file_23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_23.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR fortran/40873 +! +! Failed to compile (segfault) with -fwhole-file. +! Cf. PR 40873 comment 24; test case taken from +! PR fortran/31867 comment 6. +! + +pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + lensum = (size (words)-1) * len (sep) + sum (len_trim (words)) +end function + +module util_mod + implicit none + interface + pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + end function + end interface + contains + function join (words, sep) result(str) +! trim and concatenate a vector of character variables, +! inserting sep between them + character (len=*), intent(in) :: words(:), sep + character (len=lensum (words, sep)) :: str + integer :: i, nw + nw = size (words) + str = "" + if (nw < 1) then + return + else + str = words(1) + end if + do i=2,nw + str = trim (str) // sep // words(i) + end do + end function join +end module util_mod +! +program xjoin + use util_mod, only: join + implicit none + character (len=5) :: words(2) = (/"two ","three"/) + write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'" +end program xjoin Index: Fortran/gfortran/regression/whole_file_24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_24.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/45077 +! +! Contributed by Dominique d'Humieres, based on a test +! case of Juergen Reuter. +! + +module iso_red + type, public :: varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string +end module iso_red + +module ifiles + use iso_red, string_t => varying_string +contains + function line_get_string_advance (line) result (string) + type(string_t) :: string + character :: line + end function line_get_string_advance +end module ifiles + +module syntax_rules + use iso_red, string_t => varying_string + use ifiles, only: line_get_string_advance +contains + subroutine syntax_init_from_ifile () + type(string_t) :: string + string = line_get_string_advance ("") + end subroutine syntax_init_from_ifile +end module syntax_rules +end Index: Fortran/gfortran/regression/whole_file_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_25.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fwhole-program" } +! +! PR fortran/45087 +! + +module ints + INTERFACE + SUBROUTINE NOZZLE() + END SUBROUTINE NOZZLE + END INTERFACE +end module ints + + SUBROUTINE NOZZLE() + END SUBROUTINE NOZZLE + program CORTESA + USE INTS + CALL NOZZLE () + END program CORTESA Index: Fortran/gfortran/regression/whole_file_26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_26.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fwhole-program --param ggc-min-expand=0 --param ggc-min-heapsize=0" } +! +! PR fortran/45087 +! + +module INTS + interface + subroutine NEXT + end subroutine NEXT + subroutine VALUE() + end subroutine VALUE + end interface +end module INTS + +subroutine NEXT +end subroutine NEXT + +subroutine VALUE() + use INTS, only: NEXT + CALL NEXT +end subroutine VALUE + +end Index: Fortran/gfortran/regression/whole_file_27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_27.f90 @@ -0,0 +1,208 @@ +! { dg-do compile } +! +! PR fortran/45125 +! +! Contributed by Salvatore Filippone and Dominique d'Humieres. +! + +module const_mod + ! This is the default integer + integer, parameter :: ndig=8 + integer, parameter :: int_k_ = selected_int_kind(ndig) + ! This is an 8-byte integer, and normally different from default integer. + integer, parameter :: longndig=12 + integer, parameter :: long_int_k_ = selected_int_kind(longndig) + ! + ! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION + ! and MPI_REAL + ! + integer, parameter :: dpk_ = kind(1.d0) + integer, parameter :: spk_ = kind(1.e0) + integer, save :: sizeof_dp, sizeof_sp + integer, save :: sizeof_int, sizeof_long_int + integer, save :: mpi_integer + + integer, parameter :: invalid_ = -1 + integer, parameter :: spmat_null_=0, spmat_bld_=1 + integer, parameter :: spmat_asb_=2, spmat_upd_=4 + + ! + ! + ! Error constants + integer, parameter, public :: success_=0 + integer, parameter, public :: err_iarg_neg_=10 +end module const_mod +module base_mat_mod + + use const_mod + + + type :: base_sparse_mat + integer, private :: m, n + integer, private :: state, duplicate + logical, private :: triangle, unitd, upper, sorted + contains + + procedure, pass(a) :: get_fmt => base_get_fmt + procedure, pass(a) :: set_null => base_set_null + procedure, pass(a) :: allocate_mnnz => base_allocate_mnnz + generic, public :: allocate => allocate_mnnz + end type base_sparse_mat + + interface + subroutine base_allocate_mnnz(m,n,a,nz) + import base_sparse_mat, long_int_k_ + integer, intent(in) :: m,n + class(base_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine base_allocate_mnnz + end interface + +contains + + function base_get_fmt(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'NULL' + end function base_get_fmt + + subroutine base_set_null(a) + implicit none + class(base_sparse_mat), intent(inout) :: a + + a%state = spmat_null_ + end subroutine base_set_null + + +end module base_mat_mod + +module d_base_mat_mod + + use base_mat_mod + + type, extends(base_sparse_mat) :: d_base_sparse_mat + contains + end type d_base_sparse_mat + + + + type, extends(d_base_sparse_mat) :: d_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + real(dpk_), allocatable :: val(:) + + contains + + procedure, pass(a) :: get_fmt => d_coo_get_fmt + procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz + + end type d_coo_sparse_mat + + + interface + subroutine d_coo_allocate_mnnz(m,n,a,nz) + import d_coo_sparse_mat + integer, intent(in) :: m,n + class(d_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + end subroutine d_coo_allocate_mnnz + end interface + +contains + + function d_coo_get_fmt(a) result(res) + implicit none + class(d_coo_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'COO' + end function d_coo_get_fmt + +end module d_base_mat_mod + +subroutine base_allocate_mnnz(m,n,a,nz) + use base_mat_mod, protect_name => base_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(base_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act + character(len=20) :: name='allocate_mnz', errfmt + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + errfmt=a%get_fmt() + write(0,*) 'Error: Missing ovverriding impl for allocate in class ',errfmt + + return + +end subroutine base_allocate_mnnz + +subroutine d_coo_allocate_mnnz(m,n,a,nz) + use d_base_mat_mod, protect_name => d_coo_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(d_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + info = success_ + if (m < 0) then + info = err_iarg_neg_ + endif + if (n < 0) then + info = err_iarg_neg_ + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = err_iarg_neg_ + endif +! !$ if (info == success_) call realloc(nz_,a%ia,info) +! !$ if (info == success_) call realloc(nz_,a%ja,info) +! !$ if (info == success_) call realloc(nz_,a%val,info) + if (info == success_) then +! !$ call a%set_nrows(m) +! !$ call a%set_ncols(n) +! !$ call a%set_nzeros(0) +! !$ call a%set_bld() +! !$ call a%set_triangle(.false.) +! !$ call a%set_unit(.false.) +! !$ call a%set_dupl(dupl_def_) + write(0,*) 'Allocated COO succesfully, should now set components' + else + write(0,*) 'COO allocation failed somehow. Go figure' + end if + return + +end subroutine d_coo_allocate_mnnz + + +program d_coo_err + use d_base_mat_mod + implicit none + + integer :: ictxt, iam, np + + ! solver parameters + type(d_coo_sparse_mat) :: acoo + + ! other variables + integer nnz, n + + n = 32 + nnz = n*9 + + call acoo%set_null() + call acoo%allocate(n,n,nz=nnz) + + stop +end program d_coo_err Index: Fortran/gfortran/regression/whole_file_28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_28.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Test the fix for the problem described in PR45077 comments #4 and #5. +! +! Contributed by Tobias Burnus +! +module iso_red + type, public :: varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string +end module iso_red Index: Fortran/gfortran/regression/whole_file_29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_29.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-compile-aux-modules "whole_file_28.f90" } +! Test the fix for the problem described in PR45077 comments #4 and #5. +! +! Contributed by Tobias Burnus +! +module ifiles + use iso_red, string_t => varying_string +contains + function line_get_string_advance (line) result (string) + type(string_t) :: string + character :: line + end function line_get_string_advance +end module ifiles + +module syntax_rules + use iso_red, string_t => varying_string + use ifiles, only: line_get_string_advance +contains + subroutine syntax_init_from_ifile () + type(string_t) :: string + string = line_get_string_advance ("") + end subroutine syntax_init_from_ifile +end module syntax_rules +end +! { dg-final { cleanup-modules "iso_red" } } Index: Fortran/gfortran/regression/whole_file_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_3.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "" } +! Tests the fix for PR26227 in which the interface mismatches +! below were not detected. +! +! Contributed by Andrew Pinski +! + SUBROUTINE PHLOAD (READER,*) + IMPLICIT NONE + EXTERNAL READER + CALL READER (*1) + 1 RETURN 1 + END SUBROUTINE + + program test + EXTERNAL R + call PHLOAD (R, 1) ! { dg-error "Missing alternate return specifier" } + CALL PHLOAD (R, 2) ! { dg-error "Missing alternate return specifier" } + CALL PHLOAD (R, *999) ! This one is OK + 999 continue + END program test Index: Fortran/gfortran/regression/whole_file_30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_30.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Test the fix for the problem described in PR46818. +! +! Contributed by Martien Hulsen +! and reduced by Tobias Burnus +! +! ============== system_defs.f90 ============= +module system_defs_m + type sysvector_t + integer :: probnr = 0 + real, allocatable, dimension(:) :: u + end type sysvector_t +end module system_defs_m Index: Fortran/gfortran/regression/whole_file_31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_31.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-compile-aux-modules "whole_file_30.f90" } +! Test the fix for the problem described in PR46818. +! +! Contributed by Martien Hulsen +! and reduced by Tobias Burnus +! +! ========== t.f90 =========================== +module convecreac_m + use system_defs_m + type(sysvector_t), pointer :: solution +end module convecreac_m + +program t + use convecreac_m + implicit none + type(sysvector_t), target :: sol + solution => sol +end program t +! { dg-final { cleanup-modules "system_defs_m" } } Index: Fortran/gfortran/regression/whole_file_32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_32.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-O -finline-small-functions" } +! Tests the fix for PR45743 in which the compilation failed with an ICE +! internal compiler error: verify_stmts failed. The source is the essential +! part of whole_file_3.f90. +! +! Contributed by Zdenek Sojka +! + SUBROUTINE PHLOAD (READER,*) + IMPLICIT NONE + EXTERNAL READER + CALL READER (*1) + 1 RETURN 1 + END SUBROUTINE + + program test + EXTERNAL R + CALL PHLOAD (R, *999) ! This one is OK + 999 continue + END program test Index: Fortran/gfortran/regression/whole_file_33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_33.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/48588 +! +! Contributed by Andres Legarra. +! + +MODULE LA_PRECISION +IMPLICIT NONE +INTEGER, PARAMETER :: dp = KIND(1.0D0) +END MODULE LA_PRECISION + +module lapack90 +INTERFACE + SUBROUTINE DGESV_F90( A, B, IPIV, INFO ) + USE la_precision, ONLY: wp => dp + IMPLICIT NONE + INTEGER, INTENT(OUT), OPTIONAL :: INFO + INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) + REAL(WP), INTENT(IN OUT) :: A(:,:), B(:,:) + END SUBROUTINE DGESV_F90 +END INTERFACE +end module + +SUBROUTINE DGESV_F90( A, B, IPIV, INFO ) + USE la_precision, ONLY: wp => dp + IMPLICIT NONE + INTEGER, INTENT(OUT), OPTIONAL :: INFO + INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:) + REAL(WP), INTENT(IN OUT) :: A(:,:), B(:,:) +END SUBROUTINE DGESV_F90 + +MODULE DENSEOP + USE LAPACK90 + implicit none + integer, parameter :: r8 = SELECTED_REAL_KIND( 15, 307 ) + real(r8)::denseop_tol=1.d-50 + + CONTAINS + + SUBROUTINE GEINV8 (x) + real(r8)::x(:,:) + real(r8),allocatable::x_o(:,:) + allocate(x_o(size(x,1),size(x,1))) + CALL dgesv_f90(x,x_o) + x=x_o + END SUBROUTINE GEINV8 +END MODULE DENSEOP Index: Fortran/gfortran/regression/whole_file_34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_34.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/48788 +! +! Contributed by Zdenek Sojka +! +function foo () +end function foo + character(4), external :: foo ! { dg-error "Return type mismatch of function" } + character(4) :: x + x = foo () +END Index: Fortran/gfortran/regression/whole_file_35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_35.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/50408 +! +! Contributed by Vittorio Zecca +! + module m + type int + integer :: val + end type int + interface ichar + module procedure uch + end interface + contains + function uch (c) + character (len=1), intent (in) :: c + type (int) :: uch + intrinsic ichar + uch%val = 127 - ichar (c) + end function uch + end module m + + program p + use m + print *,ichar('~') ! must print "1" + end program p Index: Fortran/gfortran/regression/whole_file_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! Tests the fix for PR24886 in which the mismatch between the +! character lengths of the actual and formal arguments of +! 'foo' was not detected. +! +! Contributed by Uttam Pawar +! + subroutine foo(y) + character(len=20) :: y + y = 'hello world' + end + + program test + character(len=10) :: x + call foo(x) ! { dg-warning "actual argument shorter" } + write(*,*) 'X=',x + pause + end Index: Fortran/gfortran/regression/whole_file_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_5.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } +! { dg-add-options bind_pic_locally } +! +! Check that inlining of functions declared BEFORE usage works. +! If yes, then the dump does not contain a call to F(). +! + +INTEGER FUNCTION f() + f = 42 +END FUNCTION + +PROGRAM main + INTEGER :: a, f + a = f() + print *, a, f() +END PROGRAM + +! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } } Index: Fortran/gfortran/regression/whole_file_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_6.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } +! { dg-add-options bind_pic_locally } +! +! Check that inlining of functions declared AFTER usage works. +! If yes, then the dump does not contain a call to F(). +! + +PROGRAM main + INTEGER :: a(3), f + a = f() + print *, a +END PROGRAM + +INTEGER FUNCTION f() + f = 42 +END FUNCTION + +! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } } Index: Fortran/gfortran/regression/whole_file_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_7.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Test the fixes for the first two problems in PR40011 +! +! Contributed by Dominique d'Humieres +! +! This function would not compile because -fwhole-file would +! try repeatedly to resolve the function because of the self +! reference. +RECURSIVE FUNCTION eval_args(q) result (r) + INTEGER NNODE + PARAMETER (NNODE = 10) + TYPE NODE + SEQUENCE + INTEGER car + INTEGER cdr + END TYPE NODE + TYPE(NODE) heap(NNODE) + INTEGER r, q + r = eval_args(heap(q)%cdr) +END FUNCTION eval_args + +function test(n) + real, dimension(2) :: test + integer :: n + test = n + return +end function test + +program arr ! The error was not picked up causing an ICE + real, dimension(2) :: res + res = test(2) ! { dg-error "Explicit interface required" } + print *, res +end program Index: Fortran/gfortran/regression/whole_file_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_8.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! Test the fix for the third problem in PR40011, where false +! type/rank mismatches were found in the main program calls. +! +! Contributed by Dominique d'Humieres +! +subroutine test_d(fn, val, res) + double precision fn + double precision val, res + + print *, fn(val), res +end subroutine + +subroutine test_c(fn, val, res) + complex fn + complex val, res + + print *, fn(val), res +end subroutine + +program specifics + + intrinsic dcos + intrinsic dcosh + intrinsic dexp + + intrinsic conjg + + call test_d (dcos, 1d0, dcos(1d0)) + call test_d (dcosh, 1d0, dcosh(1d0)) + call test_d (dexp, 1d0, dexp(1d0)) + + call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0))) + +end program Index: Fortran/gfortran/regression/whole_file_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/whole_file_9.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! Test the fix for the fourth problem in PR40011, where the +! entries were not resolved, resulting in a segfault. +! +! Contributed by Dominique d'Humieres +! +program test +interface + function bad_stuff(n) + integer :: bad_stuff (2) + integer :: n(2) + end function bad_stuff + recursive function rec_stuff(n) result (tmp) + integer :: n(2), tmp(2) + end function rec_stuff +end interface + integer :: res(2) + res = bad_stuff((/-19,-30/)) + +end program test + + recursive function bad_stuff(n) + integer :: bad_stuff (2) + integer :: n(2), tmp(2), ent = 0, sent = 0 + save ent, sent + ent = -1 + entry rec_stuff(n) result (tmp) + if (ent == -1) then + sent = ent + ent = 0 + end if + ent = ent + 1 + tmp = 1 + if(maxval (n) < 5) then + tmp = tmp + rec_stuff (n+1) + ent = ent - 1 + endif + if (ent == 1) then + if (sent == -1) then + bad_stuff = tmp + bad_stuff (1) + end if + ent = 0 + sent = 0 + end if + end function bad_stuff Index: Fortran/gfortran/regression/widechar_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fbackslash" } + + character(len=20,kind=4) :: s4 + character(len=20,kind=1) :: s1 + + s1 = "foo\u0000" + s1 = "foo\u00ff" + s1 = "foo\u0100" ! { dg-error "is not representable" } + s1 = "foo\u0101" ! { dg-error "is not representable" } + s1 = "foo\U00000101" ! { dg-error "is not representable" } + + s1 = 4_"foo bar" + s1 = 4_"foo\u00ff" + s1 = 4_"foo\u0101" ! { dg-error "cannot be converted" } + s1 = 4_"foo\u1101" ! { dg-error "cannot be converted" } + s1 = 4_"foo\UFFFFFFFF" ! { dg-error "cannot be converted" } + + s4 = "foo\u0000" + s4 = "foo\u00ff" + s4 = "foo\u0100" ! { dg-error "is not representable" } + s4 = "foo\U00000100" ! { dg-error "is not representable" } + + s4 = 4_"foo bar" + s4 = 4_"\xFF\x96" + s4 = 4_"\x00\x96" + s4 = 4_"foo\u00ff" + s4 = 4_"foo\u0101" + s4 = 4_"foo\u1101" + s4 = 4_"foo\Uab98EF56" + s4 = 4_"foo\UFFFFFFFF" + +end Index: Fortran/gfortran/regression/widechar_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_10.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-pedantic" } +! PR fortran/36534 +CHARACTER (kind=4,len=*) MY_STRING4(1:3) +PARAMETER ( MY_STRING4 = (/ "A" , "B", "C" /) ) +end Index: Fortran/gfortran/regression/widechar_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_11.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/107508 +! +use iso_c_binding +implicit none +character(len=:,kind=4), allocatable, target :: a4str(:), a4str2 +type(c_ptr) :: cptr, cptr2 + +allocate(character(len=7,kind=4) :: a4str(-2:3)) +allocate(character(len=9,kind=4) :: a4str2) + +cptr = c_loc(a4str) +cptr2 = c_loc(a4str2) + +if (len(a4str) /= 7) error stop +if (lbound(a4str,1) /= -2) error stop +if (ubound(a4str,1) /= 3) error stop +if (len(a4str2) /= 9) error stop + +a4str = [4_"sf456aq", 4_"3dtzu24", 4_"_4fh7sm", 4_"=ff85s7", 4_"j=8af4d", 4_".,A%Fsz"] +a4str2 = 4_"4f5g5f8a9" + +!print *, lbound(a4str), ubound(a4str) ! expected (-2:3) - actually: (1:6) + +if (len(a4str) /= 7) error stop +if (lbound(a4str,1) /= -2) error stop +if (ubound(a4str,1) /= 3) error stop +if (len(a4str2) /= 9) error stop +if (.not. c_associated (cptr, c_loc(a4str))) error stop +if (.not. c_associated (cptr2, c_loc(a4str2))) error stop +end + +! { dg-final { scan-tree-dump-times "__builtin_malloc" 4 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } } + +! { dg-final { scan-tree-dump-times "a4str.data = __builtin_malloc \\(168\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "a4str.data = __builtin_realloc \\(a4str.data, 168\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_malloc \\(36\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_realloc \\(\\(void \\*\\) a4str2, 36\\);" 1 "original" } } + +! Array: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment): +! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str != 7\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(D\\.\[0-9\]+ != 28\\) goto L\\." 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.a4str = 7;" 2 "original" } } + +! Scalar: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment): +! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str2 != 9\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\.a4str2 == 9\\) goto L\\." 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.a4str2 = 9;" 2 "original" } } Index: Fortran/gfortran/regression/widechar_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_2.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + s1 = "this is me!" + s4 = s1 + call check(s1, 4_"this is me! ") + call check2(s1, 4_"this is me! ") + s4 = "this is me!" + call check(s1, 4_"this is me! ") + call check2(s1, 4_"this is me! ") + + s1 = "" + s4 = s1 + call check(s1, 4_" ") + call check2(s1, 4_" ") + s4 = "" + call check(s1, 4_" ") + call check2(s1, 4_" ") + + s1 = " \xFF" + s4 = s1 + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + s4 = " \xFF" + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + + s1 = " \xFF" + s4 = s1 + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + s4 = " \xFF" + call check(s1, 4_" \xFF ") + call check2(s1, 4_" \xFF ") + +contains + subroutine check(s1,s4) + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4 + t1 = s4 + if (t1 /= s1) STOP 1 + if (len(s1) /= len(t1)) STOP 2 + if (len(s1) /= len(s4)) STOP 3 + if (len_trim(s1) /= len_trim(t1)) STOP 4 + if (len_trim(s1) /= len_trim(s4)) STOP 5 + end subroutine check + + subroutine check2(s1,s4) + character(kind=1,len=*) :: s1 + character(kind=4,len=*) :: s4 + character(kind=1,len=len(s1)) :: t1 + character(kind=4,len=len(s4)) :: t4 + + t1 = s4 + t4 = s1 + if (t1 /= s1) STOP 6 + if (t4 /= s4) STOP 7 + if (len(s1) /= len(t1)) STOP 8 + if (len(s1) /= len(s4)) STOP 9 + if (len(s1) /= len(t4)) STOP 10 + if (len_trim(s1) /= len_trim(t1)) STOP 11 + if (len_trim(s1) /= len_trim(s4)) STOP 12 + if (len_trim(s1) /= len_trim(t4)) STOP 13 + end subroutine check2 + +end Index: Fortran/gfortran/regression/widechar_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_3.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + print *, "" // "" + print *, "" // 4_"" ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // "" ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // 4_"" + + print *, s1 // "" + print *, s1 // 4_"" ! { dg-error "Operands of string concatenation operator" } + print *, s4 // "" ! { dg-error "Operands of string concatenation operator" } + print *, s4 // 4_"" + + print *, "" // s1 + print *, 4_"" // s1 ! { dg-error "Operands of string concatenation operator" } + print *, "" // s4 ! { dg-error "Operands of string concatenation operator" } + print *, 4_"" // s4 + + print *, s1 // t1 + print *, s1 // t4 ! { dg-error "Operands of string concatenation operator" } + print *, s4 // t1 ! { dg-error "Operands of string concatenation operator" } + print *, s4 // t4 + + print *, s1 .eq. "" + print *, s1 .eq. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .eq. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .eq. 4_"" + + print *, s1 == "" + print *, s1 == 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 == "" ! { dg-error "Operands of comparison operator" } + print *, s4 == 4_"" + + print *, s1 .ne. "" + print *, s1 .ne. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .ne. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .ne. 4_"" + + print *, s1 /= "" + print *, s1 /= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 /= "" ! { dg-error "Operands of comparison operator" } + print *, s4 /= 4_"" + + print *, s1 .le. "" + print *, s1 .le. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .le. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .le. 4_"" + + print *, s1 <= "" + print *, s1 <= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 <= "" ! { dg-error "Operands of comparison operator" } + print *, s4 <= 4_"" + + print *, s1 .ge. "" + print *, s1 .ge. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .ge. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .ge. 4_"" + + print *, s1 >= "" + print *, s1 >= 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 >= "" ! { dg-error "Operands of comparison operator" } + print *, s4 >= 4_"" + + print *, s1 .lt. "" + print *, s1 .lt. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .lt. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .lt. 4_"" + + print *, s1 < "" + print *, s1 < 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 < "" ! { dg-error "Operands of comparison operator" } + print *, s4 < 4_"" + + print *, s1 .gt. "" + print *, s1 .gt. 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 .gt. "" ! { dg-error "Operands of comparison operator" } + print *, s4 .gt. 4_"" + + print *, s1 > "" + print *, s1 > 4_"" ! { dg-error "Operands of comparison operator" } + print *, s4 > "" ! { dg-error "Operands of comparison operator" } + print *, s4 > 4_"" + + print *, "" == "" + print *, 4_"" == "" ! { dg-error "Operands of comparison operator" } + print *, "" .eq. "" + print *, 4_"" .eq. "" ! { dg-error "Operands of comparison operator" } + print *, "" /= "" + print *, 4_"" /= "" ! { dg-error "Operands of comparison operator" } + print *, "" .ne. "" + print *, 4_"" .ne. "" ! { dg-error "Operands of comparison operator" } + print *, "" .lt. "" + print *, 4_"" .lt. "" ! { dg-error "Operands of comparison operator" } + print *, "" < "" + print *, 4_"" < "" ! { dg-error "Operands of comparison operator" } + print *, "" .le. "" + print *, 4_"" .le. "" ! { dg-error "Operands of comparison operator" } + print *, "" <= "" + print *, 4_"" <= "" ! { dg-error "Operands of comparison operator" } + print *, "" .gt. "" + print *, 4_"" .gt. "" ! { dg-error "Operands of comparison operator" } + print *, "" > "" + print *, 4_"" > "" ! { dg-error "Operands of comparison operator" } + print *, "" .ge. "" + print *, 4_"" .ge. "" ! { dg-error "Operands of comparison operator" } + print *, "" >= "" + print *, 4_"" >= "" ! { dg-error "Operands of comparison operator" } + + end Index: Fortran/gfortran/regression/widechar_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_4.f90 @@ -0,0 +1,147 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + call test (4_"ccc ", 4_"bbb", 4_"ccc", 4_"ddd") + call test (4_" \xACp ", 4_" \x900000 ", 4_" \xACp ", 4_"ddd") + call test (4_" \xACp ", 4_" \x900000 ", 4_" \xACp ", 4_"ddd") + + call test2 (4_" \x900000 ", 4_" \xACp ", 4_"ddd") + +contains + + subroutine test(s4, t4, u4, v4) + character(kind=4,len=*) :: s4, t4, u4, v4 + + if (.not. (s4 >= t4)) STOP 1 + if (.not. (s4 > t4)) STOP 2 + if (.not. (s4 .ge. t4)) STOP 3 + if (.not. (s4 .gt. t4)) STOP 4 + if ( (s4 == t4)) STOP 5 + if (.not. (s4 /= t4)) STOP 6 + if ( (s4 .eq. t4)) STOP 7 + if (.not. (s4 .ne. t4)) STOP 8 + if ( (s4 <= t4)) STOP 9 + if ( (s4 < t4)) STOP 10 + if ( (s4 .le. t4)) STOP 11 + if ( (s4 .lt. t4)) STOP 12 + + if (.not. (s4 >= u4)) STOP 13 + if ( (s4 > u4)) STOP 14 + if (.not. (s4 .ge. u4)) STOP 15 + if ( (s4 .gt. u4)) STOP 16 + if (.not. (s4 == u4)) STOP 17 + if ( (s4 /= u4)) STOP 18 + if (.not. (s4 .eq. u4)) STOP 19 + if ( (s4 .ne. u4)) STOP 20 + if (.not. (s4 <= u4)) STOP 21 + if ( (s4 < u4)) STOP 22 + if (.not. (s4 .le. u4)) STOP 23 + if ( (s4 .lt. u4)) STOP 24 + + if ( (s4 >= v4)) STOP 25 + if ( (s4 > v4)) STOP 26 + if ( (s4 .ge. v4)) STOP 27 + if ( (s4 .gt. v4)) STOP 28 + if ( (s4 == v4)) STOP 29 + if (.not. (s4 /= v4)) STOP 30 + if ( (s4 .eq. v4)) STOP 31 + if (.not. (s4 .ne. v4)) STOP 32 + if (.not. (s4 <= v4)) STOP 33 + if (.not. (s4 < v4)) STOP 34 + if (.not. (s4 .le. v4)) STOP 35 + if (.not. (s4 .lt. v4)) STOP 36 + + end subroutine test + + subroutine test2(t4, u4, v4) + character(kind=4,len=*) :: t4, u4, v4 + + if (.not. (4_" \xACp " >= t4)) STOP 37 + if (.not. (4_" \xACp " > t4)) STOP 38 + if (.not. (4_" \xACp " .ge. t4)) STOP 39 + if (.not. (4_" \xACp " .gt. t4)) STOP 40 + if ( (4_" \xACp " == t4)) STOP 41 + if (.not. (4_" \xACp " /= t4)) STOP 42 + if ( (4_" \xACp " .eq. t4)) STOP 43 + if (.not. (4_" \xACp " .ne. t4)) STOP 44 + if ( (4_" \xACp " <= t4)) STOP 45 + if ( (4_" \xACp " < t4)) STOP 46 + if ( (4_" \xACp " .le. t4)) STOP 47 + if ( (4_" \xACp " .lt. t4)) STOP 48 + + if (.not. (4_" \xACp " >= u4)) STOP 49 + if ( (4_" \xACp " > u4)) STOP 50 + if (.not. (4_" \xACp " .ge. u4)) STOP 51 + if ( (4_" \xACp " .gt. u4)) STOP 52 + if (.not. (4_" \xACp " == u4)) STOP 53 + if ( (4_" \xACp " /= u4)) STOP 54 + if (.not. (4_" \xACp " .eq. u4)) STOP 55 + if ( (4_" \xACp " .ne. u4)) STOP 56 + if (.not. (4_" \xACp " <= u4)) STOP 57 + if ( (4_" \xACp " < u4)) STOP 58 + if (.not. (4_" \xACp " .le. u4)) STOP 59 + if ( (4_" \xACp " .lt. u4)) STOP 60 + + if ( (4_" \xACp " >= v4)) STOP 61 + if ( (4_" \xACp " > v4)) STOP 62 + if ( (4_" \xACp " .ge. v4)) STOP 63 + if ( (4_" \xACp " .gt. v4)) STOP 64 + if ( (4_" \xACp " == v4)) STOP 65 + if (.not. (4_" \xACp " /= v4)) STOP 66 + if ( (4_" \xACp " .eq. v4)) STOP 67 + if (.not. (4_" \xACp " .ne. v4)) STOP 68 + if (.not. (4_" \xACp " <= v4)) STOP 69 + if (.not. (4_" \xACp " < v4)) STOP 70 + if (.not. (4_" \xACp " .le. v4)) STOP 71 + if (.not. (4_" \xACp " .lt. v4)) STOP 72 + + end subroutine test2 + + subroutine test3(t4, u4, v4) + character(kind=4,len=*) :: t4, u4, v4 + + if (.not. (4_" \xACp " >= 4_" \x900000 ")) STOP 73 + if (.not. (4_" \xACp " > 4_" \x900000 ")) STOP 74 + if (.not. (4_" \xACp " .ge. 4_" \x900000 ")) STOP 75 + if (.not. (4_" \xACp " .gt. 4_" \x900000 ")) STOP 76 + if ( (4_" \xACp " == 4_" \x900000 ")) STOP 77 + if (.not. (4_" \xACp " /= 4_" \x900000 ")) STOP 78 + if ( (4_" \xACp " .eq. 4_" \x900000 ")) STOP 79 + if (.not. (4_" \xACp " .ne. 4_" \x900000 ")) STOP 80 + if ( (4_" \xACp " <= 4_" \x900000 ")) STOP 81 + if ( (4_" \xACp " < 4_" \x900000 ")) STOP 82 + if ( (4_" \xACp " .le. 4_" \x900000 ")) STOP 83 + if ( (4_" \xACp " .lt. 4_" \x900000 ")) STOP 84 + + if (.not. (4_" \xACp " >= 4_" \xACp ")) STOP 85 + if ( (4_" \xACp " > 4_" \xACp ")) STOP 86 + if (.not. (4_" \xACp " .ge. 4_" \xACp ")) STOP 87 + if ( (4_" \xACp " .gt. 4_" \xACp ")) STOP 88 + if (.not. (4_" \xACp " == 4_" \xACp ")) STOP 89 + if ( (4_" \xACp " /= 4_" \xACp ")) STOP 90 + if (.not. (4_" \xACp " .eq. 4_" \xACp ")) STOP 91 + if ( (4_" \xACp " .ne. 4_" \xACp ")) STOP 92 + if (.not. (4_" \xACp " <= 4_" \xACp ")) STOP 93 + if ( (4_" \xACp " < 4_" \xACp ")) STOP 94 + if (.not. (4_" \xACp " .le. 4_" \xACp ")) STOP 95 + if ( (4_" \xACp " .lt. 4_" \xACp ")) STOP 96 + + if ( (4_" \xACp " >= 4_"ddd")) STOP 97 + if ( (4_" \xACp " > 4_"ddd")) STOP 98 + if ( (4_" \xACp " .ge. 4_"ddd")) STOP 99 + if ( (4_" \xACp " .gt. 4_"ddd")) STOP 100 + if ( (4_" \xACp " == 4_"ddd")) STOP 101 + if (.not. (4_" \xACp " /= 4_"ddd")) STOP 102 + if ( (4_" \xACp " .eq. 4_"ddd")) STOP 103 + if (.not. (4_" \xACp " .ne. 4_"ddd")) STOP 104 + if (.not. (4_" \xACp " <= 4_"ddd")) STOP 105 + if (.not. (4_" \xACp " < 4_"ddd")) STOP 106 + if (.not. (4_" \xACp " .le. 4_"ddd")) STOP 107 + if (.not. (4_" \xACp " .lt. 4_"ddd")) STOP 108 + + end subroutine test3 + +end Index: Fortran/gfortran/regression/widechar_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_5.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + +module kinds + implicit none + integer, parameter :: one = 1, four = 4 +end module kinds + +module inner + use kinds + implicit none + character(kind=one,len=*), parameter :: inner1 = "abcdefg \xEF kl" + character(kind=four,len=*), parameter :: & + inner4 = 4_"\u9317x \U001298cef dea\u10De" +end module inner + +module middle + use inner + implicit none + character(kind=one,len=len(inner1)), dimension(2,2), parameter :: middle1 & + = reshape ([ character(kind=one,len=len(inner1)) :: inner1, ""], & + [ 2, 2 ], & + [ character(kind=one,len=len(inner1)) :: "foo", "ba " ]) + character(kind=four,len=len(inner4)), dimension(2,2), parameter :: middle4 & + = reshape ([ character(kind=four,len=len(inner4)) :: inner4, 4_""], & + [ 2, 2 ], & + [ character(kind=four,len=len(inner4)) :: 4_"foo", 4_"ba " ]) +end module middle + +module outer + use middle + implicit none + character(kind=one,len=*), parameter :: my1(2) = middle1(1,:) + character(kind=four,len=*), parameter :: my4(2) = middle4(1,:) +end module outer + +program test_modules + use outer, outer1 => my1, outer4 => my4 + implicit none + + if (len (inner1) /= len(inner4)) STOP 1 + if (len (inner1) /= len_trim(inner1)) STOP 2 + if (len (inner4) /= len_trim(inner4)) STOP 3 + + if (len(middle1) /= len(inner1)) STOP 4 + if (len(outer1) /= len(inner1)) STOP 5 + if (len(middle4) /= len(inner4)) STOP 6 + if (len(outer4) /= len(inner4)) STOP 7 + + if (any (len_trim (middle1) /= reshape([len(middle1), 0, 3, 2], [2,2]))) & + STOP 8 + if (any (len_trim (middle4) /= reshape([len(middle4), 0, 3, 2], [2,2]))) & + STOP 9 + if (any (len_trim (outer1) /= [len(outer1), 3])) STOP 10 + if (any (len_trim (outer4) /= [len(outer4), 3])) STOP 11 + +end program test_modules Index: Fortran/gfortran/regression/widechar_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_6.f90 @@ -0,0 +1,62 @@ +! { dg-do run } + +module mod + + interface cut + module procedure cut1 + module procedure cut4 + end interface cut + +contains + + function cut1 (s) + character(kind=1,len=*), intent(in) :: s + character(kind=1,len=max(0,len(s)-3)) :: cut1 + + cut1 = s(4:) + end function cut1 + + function cut4 (s) + character(kind=4,len=*), intent(in) :: s + character(kind=4,len=max(0,len(s)-3)) :: cut4 + + cut4 = s(4:) + end function cut4 + +end module mod + +program test + use mod + + if (len (cut1("")) /= 0 .or. cut1("") /= "") STOP 1 + if (len (cut1("1")) /= 0 .or. cut1("") /= "") STOP 2 + if (len (cut1("12")) /= 0 .or. cut1("") /= "") STOP 3 + if (len (cut1("123")) /= 0 .or. cut1("") /= "") STOP 4 + if (len (cut1("1234")) /= 1 .or. cut1("4") /= "") STOP 5 + if (len (cut1("12345")) /= 2 .or. cut1("45") /= "") STOP 6 + + if (len (cut4(4_"")) /= 0 .or. cut4(4_"") /= 4_"") STOP 7 + if (len (cut4(4_"1")) /= 0 .or. cut4(4_"") /= 4_"") STOP 8 + if (len (cut4(4_"12")) /= 0 .or. cut4(4_"") /= 4_"") STOP 9 + if (len (cut4(4_"123")) /= 0 .or. cut4(4_"") /= 4_"") STOP 10 + if (len (cut4(4_"1234")) /= 1 .or. cut4(4_"4") /= 4_"") STOP 11 + if (len (cut4(4_"12345")) /= 2 .or. cut4(4_"45") /= 4_"") STOP 12 + + if (kind (cut("")) /= kind("")) STOP 13 + if (kind (cut(4_"")) /= kind(4_"")) STOP 14 + + if (len (cut("")) /= 0 .or. cut("") /= "") STOP 15 + if (len (cut("1")) /= 0 .or. cut("") /= "") STOP 16 + if (len (cut("12")) /= 0 .or. cut("") /= "") STOP 17 + if (len (cut("123")) /= 0 .or. cut("") /= "") STOP 18 + if (len (cut("1234")) /= 1 .or. cut("4") /= "") STOP 19 + if (len (cut("12345")) /= 2 .or. cut("45") /= "") STOP 20 + + if (len (cut(4_"")) /= 0 .or. cut(4_"") /= 4_"") STOP 21 + if (len (cut(4_"1")) /= 0 .or. cut(4_"") /= 4_"") STOP 22 + if (len (cut(4_"12")) /= 0 .or. cut(4_"") /= 4_"") STOP 23 + if (len (cut(4_"123")) /= 0 .or. cut(4_"") /= 4_"") STOP 24 + if (len (cut(4_"1234")) /= 1 .or. cut(4_"4") /= 4_"") STOP 25 + if (len (cut(4_"12345")) /= 2 .or. cut(4_"45") /= 4_"") STOP 26 + +end program test Index: Fortran/gfortran/regression/widechar_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_7.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } + +program test + + character(kind=1,len=10) :: s1 = 4_"foobargee", t1 = 4_"" + character(kind=4,len=10) :: s4 = "foobargee", t4 = "" + + t1(5:5) = s1(6:6) + t4(5:5) = s4(6:6) + t4(5:5) = s1(6:6) + t1(5:5) = s4(6:6) + + call sub (t1, t4) + +end program test + +! { dg-final { scan-tree-dump-times "memmove" 0 "original" } } Index: Fortran/gfortran/regression/widechar_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_8.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! +! PR fortran/37025 +! +! Check whether transferring to character(kind=4) and transferring back works +! +implicit none +character(len=4,kind=4) :: str +integer(4) :: buffer(4) = [int(z'039f'),int(z'03cd'),int(z'03c7'), & + int(z'30b8') ], & + buffer2(4) + +open(6,encoding="UTF-8") +str = transfer(buffer, str) +!print *, str +!print *, 4_'\u039f\u03cd\u03c7\u30b8' +if (str /= 4_'\u039f\u03cd\u03c7\u30b8') STOP 1 +str = transfer([int(z'039f'),int(z'03cd'),int(z'03c7'), & + int(z'30b8') ], str) +if (str /= 4_'\u039f\u03cd\u03c7\u30b8') STOP 2 + +buffer2 = transfer(4_'\u039f\u03cd\u03c7\u30b8', buffer2, 4) +!print *, buffer +!print *, buffer2 +buffer2 = transfer(str, buffer2, 4) +if (any(buffer2 /= buffer)) STOP 3 +end Index: Fortran/gfortran/regression/widechar_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_9.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/37076 +! +! Before the result of concatenations was always a kind=1 string +! +program test3 + integer,parameter :: u = 4 + character(1,u),parameter :: nen=char(int(z'5e74'),u) !year + character(25,u) :: string + string = u_"2008"//nen + print *, u_"2008"//nen ! Compiles OK + print *, u_"2008"//nen//u_"8" ! Rejects this. +end program test3 Index: Fortran/gfortran/regression/widechar_IO_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_IO_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Wide chracter I/O test 1, formatted and mixed kind +! Test case developed by Jerry DeLisle +program test1 + integer, parameter :: k4 = 4 + character(len=10,kind=4) :: wide + character(len=10,kind=1) :: thin + character(kind=1,len=25) :: buffer + wide=k4_"Goodbye!" + thin="Hello!" + write(buffer, '(a)') wide + if (buffer /= "Goodbye!") STOP 1 + open(10, form="formatted", access="stream", status="scratch") + write(10, '(a)') thin + rewind(10) + read(10, '(a)') wide + if (wide /= k4_"Hello!") STOP 2 + write(buffer,*) thin, ">",wide,"<" + if (buffer /= " Hello! >Hello! <") STOP 3 +end program test1 Index: Fortran/gfortran/regression/widechar_IO_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_IO_2.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Wide chracter I/O test 2, formatted array write and read +! Test case developed by Jerry DeLisle +program chkdata + integer, parameter :: k4=4 + character(len=7, kind=k4), dimension(3) :: mychar + character(50) :: buffer + mychar(1) = k4_"abc1234" + mychar(2) = k4_"def5678" + mychar(3) = k4_"ghi9012" + buffer = "" + write(buffer,'(3(a))') mychar(2:3), mychar(1) + if (buffer /= "def5678ghi9012abc1234") STOP 1 + write(buffer,'(3(a))') mychar + if (buffer /= "abc1234def5678ghi9012") STOP 2 + mychar = "" + read(buffer,'(3(a))') mychar + if (any(mychar.ne.[ k4_"abc1234",k4_"def5678",k4_"ghi9012" ])) STOP 3 +end program chkdata Index: Fortran/gfortran/regression/widechar_IO_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_IO_3.f90 @@ -0,0 +1,23 @@ +! { dg-do run { target fd_truncate } } +! Wide character I/O test 3, unformatted arrays +! Test case developed by Jerry DeLisle +program test1 + integer, parameter :: k4 = 4 + character(len=10,kind=4) :: wide + character(len=10,kind=4), dimension(5,7) :: widearray + wide = k4_"abcdefg" + widearray = k4_"1234abcd" + open(10, form="unformatted", status="scratch") + write(10) wide + rewind(10) + wide = "wrong" + read(10) wide + if (wide /= k4_"abcdefg") STOP 1 + rewind(10) + write(10) widearray(2:4,3:7) + widearray(2:4,3:7)="" + rewind(10) + read(10) widearray(2:4,3:7) + close(10) + if (any(widearray.ne.k4_"1234abcd")) STOP 2 +end program test1 Index: Fortran/gfortran/regression/widechar_IO_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_IO_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options -fbackslash } +! Wide chracter I/O test 4, formatted ISO-8859-1 characters in string +! Test case developed by Jerry DeLisle +! Compile with -fbackslash +integer, parameter :: k4 = 4 +character(kind=1,len=15) :: buffer +character(kind=1, len=1) :: c1, c2 +character(kind=4,len=20) :: str = k4_'X\xF8öABC' ! ISO-8859-1 encoded string +buffer = "" +write(buffer,'(3a)')':',trim(str),':' +if (buffer.ne.':X\xF8öABC: ') STOP 1 +str = "" +read(buffer,'(3a)') c1,str(1:6),c2 +if (c1.ne.':') STOP 2 +if (str.ne.k4_'X\xF8öAB') STOP 3 +if (c2.ne.'C') STOP 4 +end Index: Fortran/gfortran/regression/widechar_compare_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_compare_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR 50192 - on little-endian systems, this used to fail. +program main + character(kind=4,len=2) :: c1, c2 + c1 = 4_' ' + c2 = 4_' ' + c1(1:1) = transfer(257, mold=c1(1:1)) + c2(1:1) = transfer(64, mold=c2(1:1)) + if (c1 < c2) STOP 1 +end program main Index: Fortran/gfortran/regression/widechar_intrinsics_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_1.f90 @@ -0,0 +1,116 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=100000" } + + character(kind=1,len=20) :: s1, t1, u1, v1 + character(kind=4,len=20) :: s4, t4, u4, v4 + + call date_and_time(date=s1) + call date_and_time(time=s1) + call date_and_time(zone=s1) + call date_and_time(s1, t1, u1) + + call date_and_time(date=s4) ! { dg-error "must be of kind 1" } + call date_and_time(time=s4) ! { dg-error "must be of kind 1" } + call date_and_time(zone=s4) ! { dg-error "must be of kind 1" } + call date_and_time(s4, t4, u4) ! { dg-error "must be of kind 1" } + + call get_command(s1) + call get_command(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + call get_command_argument(1, s1) + call get_command_argument(1, s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + call get_environment_variable("PATH", s1) + call get_environment_variable(s1) + call get_environment_variable(s1, t1) + call get_environment_variable(4_"PATH", s1) ! { dg-error "'CHARACTER\\(4,4\\)' to 'CHARACTER\\(\\*\\)'" } + call get_environment_variable(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + call get_environment_variable(s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + call get_environment_variable(s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + print *, lge(s1,t1) + print *, lge(s1,"foo") + print *, lge("foo",t1) + print *, lge("bar","foo") + + print *, lge(s1,t4) ! { dg-error "must be of kind 1" } + print *, lge(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lge("foo",t4) ! { dg-error "must be of kind 1" } + print *, lge("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lge(s4,t1) ! { dg-error "must be of kind 1" } + print *, lge(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lge(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lge(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lge(s4,t4) ! { dg-error "must be of kind 1" } + print *, lge(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lge(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lge(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s1,t1) + print *, lgt(s1,"foo") + print *, lgt("foo",t1) + print *, lgt("bar","foo") + + print *, lgt(s1,t4) ! { dg-error "must be of kind 1" } + print *, lgt(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lgt("foo",t4) ! { dg-error "must be of kind 1" } + print *, lgt("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s4,t1) ! { dg-error "must be of kind 1" } + print *, lgt(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lgt(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lgt(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lgt(s4,t4) ! { dg-error "must be of kind 1" } + print *, lgt(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lgt(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lgt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lle(s1,t1) + print *, lle(s1,"foo") + print *, lle("foo",t1) + print *, lle("bar","foo") + + print *, lle(s1,t4) ! { dg-error "must be of kind 1" } + print *, lle(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, lle("foo",t4) ! { dg-error "must be of kind 1" } + print *, lle("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, lle(s4,t1) ! { dg-error "must be of kind 1" } + print *, lle(s4,"foo") ! { dg-error "must be of kind 1" } + print *, lle(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, lle(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, lle(s4,t4) ! { dg-error "must be of kind 1" } + print *, lle(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, lle(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, lle(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, llt(s1,t1) + print *, llt(s1,"foo") + print *, llt("foo",t1) + print *, llt("bar","foo") + + print *, llt(s1,t4) ! { dg-error "must be of kind 1" } + print *, llt(s1,4_"foo") ! { dg-error "must be of kind 1" } + print *, llt("foo",t4) ! { dg-error "must be of kind 1" } + print *, llt("bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, llt(s4,t1) ! { dg-error "must be of kind 1" } + print *, llt(s4,"foo") ! { dg-error "must be of kind 1" } + print *, llt(4_"foo",t1) ! { dg-error "must be of kind 1" } + print *, llt(4_"bar","foo") ! { dg-error "must be of kind 1" } + + print *, llt(s4,t4) ! { dg-error "must be of kind 1" } + print *, llt(s4,4_"foo") ! { dg-error "must be of kind 1" } + print *, llt(4_"foo",t4) ! { dg-error "must be of kind 1" } + print *, llt(4_"bar",4_"foo") ! { dg-error "must be of kind 1" } + + print *, selected_char_kind("foo") + print *, selected_char_kind(4_"foo") ! { dg-error "must be of kind 1" } + print *, selected_char_kind(s1) + print *, selected_char_kind(s4) ! { dg-error "must be of kind 1" } + + end Index: Fortran/gfortran/regression/widechar_intrinsics_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_10.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1(3) + character(kind=4,len=3) :: s4(3) + + s1 = [ "abc", "def", "ghi" ] + s4 = s1 + s4 = [ "abc", "def", "ghi" ] + + if (any (cshift (s1, 0) /= s1)) STOP 1 + if (any (cshift (s4, 0) /= s4)) STOP 2 + if (any (cshift (s1, 3) /= s1)) STOP 3 + if (any (cshift (s4, 3) /= s4)) STOP 4 + if (any (cshift (s1, 6) /= s1)) STOP 5 + if (any (cshift (s4, 6) /= s4)) STOP 6 + if (any (cshift (s1, -3) /= s1)) STOP 7 + if (any (cshift (s4, -3) /= s4)) STOP 8 + if (any (cshift (s1, -6) /= s1)) STOP 9 + if (any (cshift (s4, -6) /= s4)) STOP 10 + + if (any (cshift (s1, 1) /= [ s1(2:3), s1(1) ])) STOP 11 + if (any (cshift (s1, -1) /= [ s1(3), s1(1:2) ])) STOP 12 + if (any (cshift (s1, 4) /= [ s1(2:3), s1(1) ])) STOP 13 + if (any (cshift (s1, -4) /= [ s1(3), s1(1:2) ])) STOP 14 + + if (any (cshift (s4, 1) /= [ s4(2:3), s4(1) ])) STOP 15 + if (any (cshift (s4, -1) /= [ s4(3), s4(1:2) ])) STOP 16 + if (any (cshift (s4, 4) /= [ s4(2:3), s4(1) ])) STOP 17 + if (any (cshift (s4, -4) /= [ s4(3), s4(1:2) ])) STOP 18 + + if (any (cshift (s1, 2) /= [ s1(3), s1(1:2) ])) STOP 19 + if (any (cshift (s1, -2) /= [ s1(2:3), s1(1) ])) STOP 20 + if (any (cshift (s1, 5) /= [ s1(3), s1(1:2) ])) STOP 21 + if (any (cshift (s1, -5) /= [ s1(2:3), s1(1) ])) STOP 22 + + if (any (cshift (s4, 2) /= [ s4(3), s4(1:2) ])) STOP 23 + if (any (cshift (s4, -2) /= [ s4(2:3), s4(1) ])) STOP 24 + if (any (cshift (s4, 5) /= [ s4(3), s4(1:2) ])) STOP 25 + if (any (cshift (s4, -5) /= [ s4(2:3), s4(1) ])) STOP 26 + + + if (any (eoshift (s1, 0) /= s1)) STOP 27 + if (any (eoshift (s4, 0) /= s4)) STOP 28 + if (any (eoshift (s1, 3) /= "")) STOP 29 + if (any (eoshift (s4, 3) /= 4_"")) STOP 30 + if (any (eoshift (s1, 3, " ") /= "")) STOP 31 + if (any (eoshift (s4, 3, 4_" ") /= 4_"")) STOP 32 + if (any (eoshift (s1, 3, " x ") /= " x")) STOP 33 + if (any (eoshift (s4, 3, 4_" x ") /= 4_" x")) STOP 34 + if (any (eoshift (s1, -3) /= "")) STOP 35 + if (any (eoshift (s4, -3) /= 4_"")) STOP 36 + if (any (eoshift (s1, -3, " ") /= "")) STOP 37 + if (any (eoshift (s4, -3, 4_" ") /= 4_"")) STOP 38 + if (any (eoshift (s1, -3, " x ") /= " x")) STOP 39 + if (any (eoshift (s4, -3, 4_" x ") /= 4_" x")) STOP 40 + if (any (eoshift (s1, 4) /= "")) STOP 41 + if (any (eoshift (s4, 4) /= 4_"")) STOP 42 + if (any (eoshift (s1, 4, " ") /= "")) STOP 43 + if (any (eoshift (s4, 4, 4_" ") /= 4_"")) STOP 44 + if (any (eoshift (s1, 4, " x ") /= " x")) STOP 45 + if (any (eoshift (s4, 4, 4_" x ") /= 4_" x")) STOP 46 + if (any (eoshift (s1, -4) /= "")) STOP 47 + if (any (eoshift (s4, -4) /= 4_"")) STOP 48 + if (any (eoshift (s1, -4, " ") /= "")) STOP 49 + if (any (eoshift (s4, -4, 4_" ") /= 4_"")) STOP 50 + if (any (eoshift (s1, -4, " x ") /= " x")) STOP 51 + if (any (eoshift (s4, -4, 4_" x ") /= 4_" x")) STOP 52 + + if (any (eoshift (s1, 1) /= [ s1(2:3), " " ])) STOP 53 + if (any (eoshift (s1, -1) /= [ " ", s1(1:2) ])) STOP 54 + if (any (eoshift (s1, 1, " x ") /= [ s1(2:3), " x " ])) STOP 55 + if (any (eoshift (s1, -1, " x ") /= [ " x ", s1(1:2) ])) STOP 56 + if (any (eoshift (s4, 1) /= [ s4(2:3), 4_" " ])) STOP 57 + if (any (eoshift (s4, -1) /= [ 4_" ", s4(1:2) ])) STOP 58 + if (any (eoshift (s4, 1, 4_" x ") /= [ s4(2:3), 4_" x " ])) STOP 59 + if (any (eoshift (s4, -1, 4_" x ") /= [ 4_" x ", s4(1:2) ])) STOP 60 + + if (any (eoshift (s1, 2) /= [ s1(3), " ", " " ])) STOP 61 + if (any (eoshift (s1, -2) /= [ " ", " ", s1(1) ])) STOP 62 + if (any (eoshift (s1, 2, " x ") /= [ s1(3), " x ", " x " ])) STOP 63 + if (any (eoshift (s1, -2, " x ") /= [ " x ", " x ", s1(1) ])) STOP 64 + if (any (eoshift (s4, 2) /= [ s4(3), 4_" ", 4_" " ])) STOP 65 + if (any (eoshift (s4, -2) /= [ 4_" ", 4_" ", s4(1) ])) STOP 66 + if (any (eoshift (s4, 2, 4_" x ") /= [ s4(3), 4_" x ", 4_" x " ])) STOP 67 + if (any (eoshift (s4, -2, 4_" x ") /= [ 4_" x ", 4_" x ", s4(1) ])) STOP 68 + +end Index: Fortran/gfortran/regression/widechar_intrinsics_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_2.f90 @@ -0,0 +1,129 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + +program failme + + integer :: i, j, array(20) + integer(kind=4) :: i4 + integer(kind=8) :: i8 + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + call ctime (i8, s1) + call ctime (i8, s4) ! { dg-error "must be of kind" } + + call chdir (s1) + call chdir (s1, i) + call chdir (s4) ! { dg-error "must be of kind" } + call chdir (s4, i) ! { dg-error "must be of kind" } + + call chmod (s1, t1) + call chmod (s1, t4) ! { dg-error "must be of kind" } + call chmod (s4, t1) ! { dg-error "must be of kind" } + call chmod (s4, t4) ! { dg-error "must be of kind" } + call chmod (s1, t1, i) + call chmod (s1, t4, i) ! { dg-error "must be of kind" } + call chmod (s4, t1, i) ! { dg-error "must be of kind" } + call chmod (s4, t4, i) ! { dg-error "must be of kind" } + + call fdate (s1) + call fdate (s4) ! { dg-error "must be of kind" } + + call gerror (s1) + call gerror (s4) ! { dg-error "must be of kind" } + + call getcwd (s1) + call getcwd (s1, i) + call getcwd (s4) ! { dg-error "must be of kind" } + call getcwd (s4, i) ! { dg-error "must be of kind" } + + call getenv (s1, t1) + call getenv (s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + call getenv (s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + call getenv (s4, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + call getarg (i, s1) + call getarg (i, s4) ! { dg-error "must be of kind" } + + call getlog (s1) + call getlog (s4) ! { dg-error "must be of kind" } + + call fgetc (j, s1) + call fgetc (j, s1, i) + call fgetc (j, s4) ! { dg-error "must be of kind" } + call fgetc (j, s4, i) ! { dg-error "must be of kind" } + + call fget (s1) + call fget (s1, i) + call fget (s4) ! { dg-error "must be of kind" } + call fget (s4, i) ! { dg-error "must be of kind" } + + call fputc (j, s1) + call fputc (j, s1, i) + call fputc (j, s4) ! { dg-error "must be of kind" } + call fputc (j, s4, i) ! { dg-error "must be of kind" } + + call fput (s1) + call fput (s1, i) + call fput (s4) ! { dg-error "must be of kind" } + call fput (s4, i) ! { dg-error "must be of kind" } + + call hostnm (s1) + call hostnm (s1, i) + call hostnm (s4) ! { dg-error "must be of kind" } + call hostnm (s4, i) ! { dg-error "must be of kind" } + + call link (s1, t1) + call link (s1, t4) ! { dg-error "must be of kind" } + call link (s4, t1) ! { dg-error "must be of kind" } + call link (s4, t4) ! { dg-error "must be of kind" } + call link (s1, t1, i) + call link (s1, t4, i) ! { dg-error "must be of kind" } + call link (s4, t1, i) ! { dg-error "must be of kind" } + call link (s4, t4, i) ! { dg-error "must be of kind" } + + call perror (s1) + call perror (s4) ! { dg-error "must be of kind" } + + call rename (s1, t1) + call rename (s1, t4) ! { dg-error "must be of kind" } + call rename (s4, t1) ! { dg-error "must be of kind" } + call rename (s4, t4) ! { dg-error "must be of kind" } + call rename (s1, t1, i) + call rename (s1, t4, i) ! { dg-error "must be of kind" } + call rename (s4, t1, i) ! { dg-error "must be of kind" } + call rename (s4, t4, i) ! { dg-error "must be of kind" } + + call lstat (s1, array) + call lstat (s1, array, i) + call lstat (s4, array) ! { dg-error "must be of kind" } + call lstat (s4, array, i) ! { dg-error "must be of kind" } + + call stat (s1, array) + call stat (s1, array, i) + call stat (s4, array) ! { dg-error "must be of kind" } + call stat (s4, array, i) ! { dg-error "must be of kind" } + + call symlnk (s1, t1) + call symlnk (s1, t4) ! { dg-error "must be of kind" } + call symlnk (s4, t1) ! { dg-error "must be of kind" } + call symlnk (s4, t4) ! { dg-error "must be of kind" } + call symlnk (s1, t1, i) + call symlnk (s1, t4, i) ! { dg-error "must be of kind" } + call symlnk (s4, t1, i) ! { dg-error "must be of kind" } + call symlnk (s4, t4, i) ! { dg-error "must be of kind" } + + call system (s1) + call system (s1, i) + call system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + call system (s4, i) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + call ttynam (i, s1) + call ttynam (i, s4) ! { dg-error "must be of kind" } + + call unlink (s1) + call unlink (s1, i) + call unlink (s4) ! { dg-error "must be of kind" } + call unlink (s4, i) ! { dg-error "must be of kind" } + +end program failme Index: Fortran/gfortran/regression/widechar_intrinsics_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } + +program failme + + integer :: i, array(20) + integer(kind=4) :: i4 + integer(kind=8) :: i8 + character(kind=1,len=20) :: s1, t1 + character(kind=4,len=20) :: s4, t4 + + print *, access (s1, t1) + print *, access (s1, t4) ! { dg-error "must be of kind" } + print *, access (s4, t1) ! { dg-error "must be of kind" } + print *, access (s4, t4) ! { dg-error "must be of kind" } + + print *, chdir (s1) + print *, chdir (s4) ! { dg-error "must be of kind" } + + print *, chmod (s1, t1) + print *, chmod (s1, t4) ! { dg-error "must be of kind" } + print *, chmod (s4, t1) ! { dg-error "must be of kind" } + print *, chmod (s4, t4) ! { dg-error "must be of kind" } + + print *, fget (s1) + print *, fget (s4) ! { dg-error "must be of kind" } + + print *, fgetc (i, s1) + print *, fgetc (i, s4) ! { dg-error "must be of kind" } + + print *, fput (s1) + print *, fput (s4) ! { dg-error "must be of kind" } + + print *, fputc (i, s1) + print *, fputc (i, s4) ! { dg-error "must be of kind" } + + print *, getcwd (s1) + print *, getcwd (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + print *, hostnm (s1) + print *, hostnm (s4) ! { dg-error "must be of kind" } + + print *, link (s1, t1) + print *, link (s1, t4) ! { dg-error "must be of kind" } + print *, link (s4, t1) ! { dg-error "must be of kind" } + print *, link (s4, t4) ! { dg-error "must be of kind" } + + print *, lstat (s1, array) + print *, lstat (s4, array) ! { dg-error "must be of kind" } + print *, stat (s1, array) + print *, stat (s4, array) ! { dg-error "must be of kind" } + + print *, rename (s1, t1) + print *, rename (s1, t4) ! { dg-error "must be of kind" } + print *, rename (s4, t1) ! { dg-error "must be of kind" } + print *, rename (s4, t4) ! { dg-error "must be of kind" } + + print *, symlnk (s1, t1) + print *, symlnk (s1, t4) ! { dg-error "must be of kind" } + print *, symlnk (s4, t1) ! { dg-error "must be of kind" } + print *, symlnk (s4, t4) ! { dg-error "must be of kind" } + + print *, system (s1) + print *, system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" } + + print *, unlink (s1) + print *, unlink (s4) ! { dg-error "must be of kind" } + +end program failme Index: Fortran/gfortran/regression/widechar_intrinsics_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_4.f90 @@ -0,0 +1,121 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + call test_adjust1 (" foo bar ", 4_" foo bar ") + s1 = " foo bar " ; s4 = 4_" foo bar " + call test_adjust2 (s1, s4) + + call test_adjust1 (" foo bar \xFF", 4_" foo bar \xFF") + s1 = " foo bar \xFF" ; s4 = 4_" foo bar \xFF" + call test_adjust2 (s1, s4) + + call test_adjust1 ("\0 foo bar \xFF", 4_"\0 foo bar \xFF") + s1 = "\0 foo bar \xFF" ; s4 = 4_"\0 foo bar \xFF" + call test_adjust2 (s1, s4) + + s4 = "\0 foo bar \xFF" + if (adjustl (s4) /= adjustl (4_"\0 foo bar \xFF ")) STOP 1 + if (adjustr (s4) /= adjustr (4_"\0 foo bar \xFF ")) STOP 2 + + s4 = " \0 foo bar \xFF" + if (adjustl (s4) /= adjustl (4_" \0 foo bar \xFF ")) STOP 3 + if (adjustr (s4) /= adjustr (4_" \0 foo bar \xFF ")) STOP 4 + + s4 = 4_" \U12345678\xeD bar \ufd30" + if (adjustl (s4) /= & + adjustl (4_" \U12345678\xeD bar \ufd30 ")) STOP 5 + if (adjustr (s4) /= & + adjustr (4_" \U12345678\xeD bar \ufd30 ")) STOP 6 + +contains + + subroutine test_adjust1 (s1, s4) + + character(kind=1,len=*) :: s1 + character(kind=4,len=*) :: s4 + + character(kind=1,len=len(s4)) :: t1 + character(kind=4,len=len(s1)) :: t4 + + if (len(s1) /= len(s4)) STOP 7 + if (len(t1) /= len(t4)) STOP 8 + + if (len_trim(s1) /= len_trim (s4)) STOP 9 + + t1 = adjustl (s4) + t4 = adjustl (s1) + if (t1 /= adjustl (s1)) STOP 10 + if (t4 /= adjustl (s4)) STOP 11 + if (len_trim (t1) /= len_trim (t4)) STOP 12 + if (len_trim (adjustl (s1)) /= len_trim (t4)) STOP 13 + if (len_trim (adjustl (s4)) /= len_trim (t1)) STOP 14 + + if (len_trim (t1) /= len (trim (t1))) STOP 15 + if (len_trim (s1) /= len (trim (s1))) STOP 16 + if (len_trim (t4) /= len (trim (t4))) STOP 17 + if (len_trim (s4) /= len (trim (s4))) STOP 18 + + t1 = adjustr (s4) + t4 = adjustr (s1) + if (t1 /= adjustr (s1)) STOP 19 + if (t4 /= adjustr (s4)) STOP 20 + if (len_trim (t1) /= len_trim (t4)) STOP 21 + if (len_trim (adjustr (s1)) /= len_trim (t4)) STOP 22 + if (len_trim (adjustr (s4)) /= len_trim (t1)) STOP 23 + if (len (t1) /= len_trim (t1)) STOP 24 + if (len (t4) /= len_trim (t4)) STOP 25 + + if (len_trim (t1) /= len (trim (t1))) STOP 26 + if (len_trim (s1) /= len (trim (s1))) STOP 27 + if (len_trim (t4) /= len (trim (t4))) STOP 28 + if (len_trim (s4) /= len (trim (s4))) STOP 29 + + end subroutine test_adjust1 + + subroutine test_adjust2 (s1, s4) + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + character(kind=1,len=len(s4)) :: t1 + character(kind=4,len=len(s1)) :: t4 + + if (len(s1) /= len(s4)) STOP 30 + if (len(t1) /= len(t4)) STOP 31 + + if (len_trim(s1) /= len_trim (s4)) STOP 32 + + t1 = adjustl (s4) + t4 = adjustl (s1) + if (t1 /= adjustl (s1)) STOP 33 + if (t4 /= adjustl (s4)) STOP 34 + if (len_trim (t1) /= len_trim (t4)) STOP 35 + if (len_trim (adjustl (s1)) /= len_trim (t4)) STOP 36 + if (len_trim (adjustl (s4)) /= len_trim (t1)) STOP 37 + + if (len_trim (t1) /= len (trim (t1))) STOP 38 + if (len_trim (s1) /= len (trim (s1))) STOP 39 + if (len_trim (t4) /= len (trim (t4))) STOP 40 + if (len_trim (s4) /= len (trim (s4))) STOP 41 + + t1 = adjustr (s4) + t4 = adjustr (s1) + if (t1 /= adjustr (s1)) STOP 42 + if (t4 /= adjustr (s4)) STOP 43 + if (len_trim (t1) /= len_trim (t4)) STOP 44 + if (len_trim (adjustr (s1)) /= len_trim (t4)) STOP 45 + if (len_trim (adjustr (s4)) /= len_trim (t1)) STOP 46 + if (len (t1) /= len_trim (t1)) STOP 47 + if (len (t4) /= len_trim (t4)) STOP 48 + + if (len_trim (t1) /= len (trim (t1))) STOP 49 + if (len_trim (s1) /= len (trim (s1))) STOP 50 + if (len_trim (t4) /= len (trim (t4))) STOP 51 + if (len_trim (s4) /= len (trim (s4))) STOP 52 + + end subroutine test_adjust2 + +end Index: Fortran/gfortran/regression/widechar_intrinsics_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_5.f90 @@ -0,0 +1,121 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + integer :: i, j + character(kind=4,len=5), dimension(3,3), parameter :: & + p = reshape([4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_" ", 4_"fa fe", & + 4_" ", 4_"foo ", 4_"nul\0l"], [3,3]) + + character(kind=4,len=5), dimension(3,3) :: m1 + character(kind=4,len=5), allocatable, dimension(:,:) :: m2 + + if (kind (p) /= 4) STOP 1 + if (kind (m1) /= 4) STOP 2 + if (kind (m2) /= 4) STOP 3 + + m1 = reshape (p, [3,3]) + + allocate (m2(3,3)) + m2(:,:) = reshape (m1, [3,3]) + + if (any (m1 /= p)) STOP 4 + if (any (m2 /= p)) STOP 5 + + if (size (p) /= 9) STOP 6 + if (size (m1) /= 9) STOP 7 + if (size (m2) /= 9) STOP 8 + if (size (p,1) /= 3) STOP 9 + if (size (m1,1) /= 3) STOP 10 + if (size (m2,1) /= 3) STOP 11 + if (size (p,2) /= 3) STOP 12 + if (size (m1,2) /= 3) STOP 13 + if (size (m2,2) /= 3) STOP 14 + + call check_shape (p, (/3,3/), 5) + call check_shape (p, shape(p), 5) + call check_shape (m1, (/3,3/), 5) + call check_shape (m1, shape(m1), 5) + call check_shape (m1, (/3,3/), 5) + call check_shape (m1, shape(m1), 5) + + deallocate (m2) + + + allocate (m2(3,4)) + m2 = reshape (m1, [3,4], p) + if (any (m2(1:3,1:3) /= p)) STOP 15 + if (any (m2(1:3,4) /= m1(1:3,1))) STOP 16 + call check_shape (m2, (/3,4/), 5) + deallocate (m2) + + allocate (m2(3,3)) + do i = 1, 3 + do j = 1, 3 + m2(i,j) = m1(i,j) + end do + end do + + m2 = transpose(m2) + if (any(transpose(p) /= m2)) STOP 17 + if (any(transpose(m1) /= m2)) STOP 18 + if (any(transpose(m2) /= p)) STOP 19 + if (any(transpose(m2) /= m1)) STOP 20 + + m1 = transpose(p) + if (any(transpose(p) /= m2)) STOP 21 + if (any(m1 /= m2)) STOP 22 + if (any(transpose(m2) /= p)) STOP 23 + if (any(transpose(m2) /= transpose(m1))) STOP 24 + deallocate (m2) + + allocate (m2(3,3)) + m2 = p + m1 = m2 + if (any (spread ( p, 1, 2) /= spread (m1, 1, 2))) STOP 25 + if (any (spread ( p, 1, 2) /= spread (m2, 1, 2))) STOP 26 + if (any (spread (m1, 1, 2) /= spread (m2, 1, 2))) STOP 27 + deallocate (m2) + + allocate (m2(3,3)) + m2 = p + m1 = m2 + if (any (pack (p, p /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) STOP 28 + if (any (len_trim (pack (p, p /= 4_"")) /= [2,1,4,5,5,3,5])) STOP 29 + if (any (pack (m1, m1 /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) STOP 30 + if (any (len_trim (pack (m1, m1 /= 4_"")) /= [2,1,4,5,5,3,5])) STOP 31 + if (any (pack (m2, m2 /= 4_"") /= [4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"])) STOP 32 + if (any (len_trim (pack (m2, m2 /= 4_"")) /= [2,1,4,5,5,3,5])) STOP 33 + deallocate (m2) + + allocate (m2(1,7)) + m2 = reshape ([4_" \xFF ", 4_"\0 ", 4_" foo ", & + 4_"\u1230\uD67Bde\U31DC8B30", 4_"fa fe", & + 4_"foo ", 4_"nul\0l"], [1,7]) + m1 = p + if (any (unpack(m2(1,:), p /= 4_"", 4_" ") /= p)) STOP 34 + if (any (unpack(m2(1,:), m1 /= 4_"", 4_" ") /= m1)) STOP 35 + deallocate (m2) + +contains + + subroutine check_shape (array, res, l) + character(kind=4,len=*), dimension(:,:) :: array + integer, dimension(:) :: res + integer :: l + + if (kind (array) /= 4) STOP 36 + if (len(array) /= l) STOP 37 + + if (size (res) /= size (shape (array))) STOP 38 + if (any (shape (array) /= res)) STOP 39 + end subroutine check_shape + +end Index: Fortran/gfortran/regression/widechar_intrinsics_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_6.f90 @@ -0,0 +1,109 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=3) :: s1 + character(kind=4, len=3) :: s4 + integer :: i + + s1 = "fo " + s4 = 4_"fo " + i = 3 + + ! Check the REPEAT intrinsic + + if (repeat (1_"foo", 2) /= 1_"foofoo") STOP 1 + if (repeat (1_"fo ", 2) /= 1_"fo fo ") STOP 2 + if (repeat (1_"fo ", 2) /= 1_"fo fo") STOP 3 + if (repeat (1_"fo ", 0) /= 1_"") STOP 4 + if (repeat (s1, 2) /= 1_"fo fo ") STOP 5 + if (repeat (s1, 2) /= 1_"fo fo") STOP 6 + if (repeat (s1, 2) /= s1 // s1) STOP 7 + if (repeat (s1, 3) /= s1 // s1 // s1) STOP 8 + if (repeat (s1, 1) /= s1) STOP 9 + if (repeat (s1, 0) /= "") STOP 10 + + if (repeat (4_"foo", 2) /= 4_"foofoo") STOP 11 + if (repeat (4_"fo ", 2) /= 4_"fo fo ") STOP 12 + if (repeat (4_"fo ", 2) /= 4_"fo fo") STOP 13 + if (repeat (4_"fo ", 0) /= 4_"") STOP 14 + if (repeat (s4, 2) /= 4_"fo fo ") STOP 15 + if (repeat (s4, 2) /= 4_"fo fo") STOP 16 + if (repeat (s4, 3) /= s4 // s4 // s4) STOP 17 + if (repeat (s4, 1) /= s4) STOP 18 + if (repeat (s4, 0) /= 4_"") STOP 19 + + call check_repeat (s1, s4) + call check_repeat ("", 4_"") + call check_repeat ("truc", 4_"truc") + call check_repeat ("truc ", 4_"truc ") + + ! Check NEW_LINE + + if (ichar(new_line ("")) /= 10) STOP 20 + if (len(new_line ("")) /= 1) STOP 21 + if (ichar(new_line (s1)) /= 10) STOP 22 + if (len(new_line (s1)) /= 1) STOP 23 + if (ichar(new_line (["",""])) /= 10) STOP 24 + if (len(new_line (["",""])) /= 1) STOP 25 + if (ichar(new_line ([s1,s1])) /= 10) STOP 26 + if (len(new_line ([s1,s1])) /= 1) STOP 27 + + if (ichar(new_line (4_"")) /= 10) STOP 28 + if (len(new_line (4_"")) /= 1) STOP 29 + if (ichar(new_line (s4)) /= 10) STOP 30 + if (len(new_line (s4)) /= 1) STOP 31 + if (ichar(new_line ([4_"",4_""])) /= 10) STOP 32 + if (len(new_line ([4_"",4_""])) /= 1) STOP 33 + if (ichar(new_line ([s4,s4])) /= 10) STOP 34 + if (len(new_line ([s4,s4])) /= 1) STOP 35 + + ! Check SIZEOF + + if (sizeof ("") /= 0) STOP 36 + if (sizeof (4_"") /= 0) STOP 37 + if (sizeof ("x") /= 1) STOP 38 + if (sizeof ("\xFF") /= 1) STOP 39 + if (sizeof (4_"x") /= 4) STOP 40 + if (sizeof (4_"\UFFFFFFFF") /= 4) STOP 41 + if (sizeof (s1) /= 3) STOP 42 + if (sizeof (s4) /= 12) STOP 43 + + if (sizeof (["a", "x", "z"]) / sizeof ("a") /= 3) STOP 44 + if (sizeof ([4_"a", 4_"x", 4_"z"]) / sizeof (4_"a") /= 3) STOP 45 + + call check_sizeof ("", 4_"", 0) + call check_sizeof ("x", 4_"x", 1) + call check_sizeof ("\xFF", 4_"\UFEBCE19E", 1) + call check_sizeof ("\xFF ", 4_"\UFEBCE19E ", 2) + call check_sizeof (s1, s4, 3) + +contains + + subroutine check_repeat (s1, s4) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + integer :: i + + do i = 0, 10 + if (len (repeat(s1, i)) /= i * len(s1)) STOP 46 + if (len (repeat(s4, i)) /= i * len(s4)) STOP 47 + + if (len_trim (repeat(s1, i)) & + /= max(0, (i - 1) * len(s1) + len_trim (s1))) STOP 48 + if (len_trim (repeat(s4, i)) & + /= max(0, (i - 1) * len(s4) + len_trim (s4))) STOP 49 + end do + end subroutine check_repeat + + subroutine check_sizeof (s1, s4, i) + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=*), intent(in) :: s4 + character(kind=4, len=len(s4)) :: t4 + integer, intent(in) :: i + + if (sizeof (s1) /= i) STOP 50 + if (sizeof (s4) / sizeof (4_" ") /= i) STOP 51 + if (sizeof (t4) / sizeof (4_" ") /= i) STOP 52 + end subroutine check_sizeof + +end Index: Fortran/gfortran/regression/widechar_intrinsics_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_7.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + character(kind=1, len=10) :: s1, t1 + character(kind=4, len=10) :: s4, t4 + + call check1("foobargeefoobargee", "arg", & + [ index ("foobargeefoobargee", "arg", .true.), & + index ("foobargeefoobargee", "arg", .false.), & + scan ("foobargeefoobargee", "arg", .true.), & + scan ("foobargeefoobargee", "arg", .false.), & + verify ("foobargeefoobargee", "arg", .true.), & + verify ("foobargeefoobargee", "arg", .false.) ], & + 4_"foobargeefoobargee", 4_"arg", & + [ index (4_"foobargeefoobargee", 4_"arg", .true.), & + index (4_"foobargeefoobargee", 4_"arg", .false.), & + scan (4_"foobargeefoobargee", 4_"arg", .true.), & + scan (4_"foobargeefoobargee", 4_"arg", .false.), & + verify (4_"foobargeefoobargee", 4_"arg", .true.), & + verify (4_"foobargeefoobargee", 4_"arg", .false.) ]) + + call check1("foobargeefoobargee", "", & + [ index ("foobargeefoobargee", "", .true.), & + index ("foobargeefoobargee", "", .false.), & + scan ("foobargeefoobargee", "", .true.), & + scan ("foobargeefoobargee", "", .false.), & + verify ("foobargeefoobargee", "", .true.), & + verify ("foobargeefoobargee", "", .false.) ], & + 4_"foobargeefoobargee", 4_"", & + [ index (4_"foobargeefoobargee", 4_"", .true.), & + index (4_"foobargeefoobargee", 4_"", .false.), & + scan (4_"foobargeefoobargee", 4_"", .true.), & + scan (4_"foobargeefoobargee", 4_"", .false.), & + verify (4_"foobargeefoobargee", 4_"", .true.), & + verify (4_"foobargeefoobargee", 4_"", .false.) ]) + call check1("foobargeefoobargee", "klm", & + [ index ("foobargeefoobargee", "klm", .true.), & + index ("foobargeefoobargee", "klm", .false.), & + scan ("foobargeefoobargee", "klm", .true.), & + scan ("foobargeefoobargee", "klm", .false.), & + verify ("foobargeefoobargee", "klm", .true.), & + verify ("foobargeefoobargee", "klm", .false.) ], & + 4_"foobargeefoobargee", 4_"klm", & + [ index (4_"foobargeefoobargee", 4_"klm", .true.), & + index (4_"foobargeefoobargee", 4_"klm", .false.), & + scan (4_"foobargeefoobargee", 4_"klm", .true.), & + scan (4_"foobargeefoobargee", 4_"klm", .false.), & + verify (4_"foobargeefoobargee", 4_"klm", .true.), & + verify (4_"foobargeefoobargee", 4_"klm", .false.) ]) + call check1("foobargeefoobargee", "gee", & + [ index ("foobargeefoobargee", "gee", .true.), & + index ("foobargeefoobargee", "gee", .false.), & + scan ("foobargeefoobargee", "gee", .true.), & + scan ("foobargeefoobargee", "gee", .false.), & + verify ("foobargeefoobargee", "gee", .true.), & + verify ("foobargeefoobargee", "gee", .false.) ], & + 4_"foobargeefoobargee", 4_"gee", & + [ index (4_"foobargeefoobargee", 4_"gee", .true.), & + index (4_"foobargeefoobargee", 4_"gee", .false.), & + scan (4_"foobargeefoobargee", 4_"gee", .true.), & + scan (4_"foobargeefoobargee", 4_"gee", .false.), & + verify (4_"foobargeefoobargee", 4_"gee", .true.), & + verify (4_"foobargeefoobargee", 4_"gee", .false.) ]) + call check1("foobargeefoobargee", "foo", & + [ index ("foobargeefoobargee", "foo", .true.), & + index ("foobargeefoobargee", "foo", .false.), & + scan ("foobargeefoobargee", "foo", .true.), & + scan ("foobargeefoobargee", "foo", .false.), & + verify ("foobargeefoobargee", "foo", .true.), & + verify ("foobargeefoobargee", "foo", .false.) ], & + 4_"foobargeefoobargee", 4_"foo", & + [ index (4_"foobargeefoobargee", 4_"foo", .true.), & + index (4_"foobargeefoobargee", 4_"foo", .false.), & + scan (4_"foobargeefoobargee", 4_"foo", .true.), & + scan (4_"foobargeefoobargee", 4_"foo", .false.), & + verify (4_"foobargeefoobargee", 4_"foo", .true.), & + verify (4_"foobargeefoobargee", 4_"foo", .false.) ]) + + call check1(" \b fe \b\0 bar cad", " \b\0", & + [ index (" \b fe \b\0 bar cad", " \b\0", .true.), & + index (" \b fe \b\0 bar cad", " \b\0", .false.), & + scan (" \b fe \b\0 bar cad", " \b\0", .true.), & + scan (" \b fe \b\0 bar cad", " \b\0", .false.), & + verify (" \b fe \b\0 bar cad", " \b\0", .true.), & + verify (" \b fe \b\0 bar cad", " \b\0", .false.) ], & + 4_" \uC096 fe \uC096\uB8DE bar cad", 4_" \uC096\uB8DE", & + [ index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + index (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + scan (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .true.), & + verify (4_" \uC096 fe \uC096\uB8DE bar cad", & + 4_" \uC096\uB8DE", .false.) ]) + +contains + + subroutine check1 (s1, t1, res1, s4, t4, res4) + character(kind=1, len=*) :: s1, t1 + character(kind=4, len=*) :: s4, t4 + integer :: res1(6), res4(6) + + if (any (res1 /= res4)) STOP 1 + + if (index (s1, t1, .true.) /= res1(1)) STOP 2 + if (index (s1, t1, .false.) /= res1(2)) STOP 3 + if (scan (s1, t1, .true.) /= res1(3)) STOP 4 + if (scan (s1, t1, .false.) /= res1(4)) STOP 5 + if (verify (s1, t1, .true.) /= res1(5)) STOP 6 + if (verify (s1, t1, .false.) /= res1(6)) STOP 7 + + if (index (s4, t4, .true.) /= res4(1)) STOP 8 + if (index (s4, t4, .false.) /= res4(2)) STOP 9 + if (scan (s4, t4, .true.) /= res4(3)) STOP 10 + if (scan (s4, t4, .false.) /= res4(4)) STOP 11 + if (verify (s4, t4, .true.) /= res4(5)) STOP 12 + if (verify (s4, t4, .false.) /= res4(6)) STOP 13 + + end subroutine check1 + +end Index: Fortran/gfortran/regression/widechar_intrinsics_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_8.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + logical, parameter :: bigendian = transfer ((/1_1,0_1,0_1,0_1/), 0_4) /= 1 + + character(kind=1,len=3) :: s1, t1, u1 + character(kind=4,len=3) :: s4, t4, u4 + + ! Test MERGE intrinsic + + call check_merge1 ("foo", "gee", .true., .false.) + call check_merge4 (4_"foo", 4_"gee", .true., .false.) + + if (merge ("foo", "gee", .true.) /= "foo") STOP 1 + if (merge ("foo", "gee", .false.) /= "gee") STOP 2 + if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") STOP 3 + if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") STOP 4 + + ! Test TRANSFER intrinsic + + if (bigendian) then + if (transfer (4_"x", " ") /= "\0\0\0x") STOP 5 + else + if (transfer (4_"x", " ") /= "x\0\0\0") STOP 6 + endif + if (transfer (4_"\U44444444", " ") /= "\x44\x44\x44\x44") STOP 7 + if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) STOP 8 + + call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)]) + call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)]) + +contains + + subroutine check_merge1 (s1, t1, t, f) + character(kind=1,len=*) :: s1, t1 + logical :: t, f + + if (merge (s1, t1, .true.) /= s1) STOP 9 + if (merge (s1, t1, .false.) /= t1) STOP 10 + if (len (merge (s1, t1, .true.)) /= len (s1)) STOP 11 + if (len (merge (s1, t1, .false.)) /= len (t1)) STOP 12 + if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) STOP 13 + if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) STOP 14 + + if (merge (s1, t1, t) /= s1) STOP 15 + if (merge (s1, t1, f) /= t1) STOP 16 + if (len (merge (s1, t1, t)) /= len (s1)) STOP 17 + if (len (merge (s1, t1, f)) /= len (t1)) STOP 18 + if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) STOP 19 + if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) STOP 20 + + end subroutine check_merge1 + + subroutine check_merge4 (s4, t4, t, f) + character(kind=4,len=*) :: s4, t4 + logical :: t, f + + if (merge (s4, t4, .true.) /= s4) STOP 21 + if (merge (s4, t4, .false.) /= t4) STOP 22 + if (len (merge (s4, t4, .true.)) /= len (s4)) STOP 23 + if (len (merge (s4, t4, .false.)) /= len (t4)) STOP 24 + if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) STOP 25 + if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) STOP 26 + + if (merge (s4, t4, t) /= s4) STOP 27 + if (merge (s4, t4, f) /= t4) STOP 28 + if (len (merge (s4, t4, t)) /= len (s4)) STOP 29 + if (len (merge (s4, t4, f)) /= len (t4)) STOP 30 + if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) STOP 31 + if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) STOP 32 + + end subroutine check_merge4 + + subroutine check_transfer_i (s, i) + character(kind=4,len=*) :: s + integer(kind=4), dimension(len(s)) :: i + + if (transfer (s, 0_4) /= ichar (s(1:1))) STOP 33 + if (transfer (s, 0_4) /= i(1)) STOP 34 + if (any (transfer (s, [0_4]) /= i)) STOP 35 + if (any (transfer (s, 0_4, len(s)) /= i)) STOP 36 + + end subroutine check_transfer_i + +end Index: Fortran/gfortran/regression/widechar_intrinsics_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_intrinsics_9.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + implicit none + character(kind=1,len=3) :: s1, t1 + character(kind=4,len=3) :: s4, t4 + + s1 = "foo" ; t1 = "bar" + call check_minmax_1 ("foo", "bar", min("foo","bar"), max("foo","bar")) + call check_minmax_1 ("bar", "foo", min("foo","bar"), max("foo","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = "bar" + call check_minmax_1 (" ", "bar", min(" ","bar"), max(" ","bar")) + call check_minmax_1 ("bar", " ", min(" ","bar"), max(" ","bar")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = " " ; t1 = " " + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (" ", " ", min(" "," "), max(" "," ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s1 = "d\xFF " ; t1 = "d " + call check_minmax_1 ("d\xFF ", "d ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 ("d ", "d\xFF ", min("d\xFF ","d "), max("d\xFF ","d ")) + call check_minmax_1 (s1, t1, min(s1,t1), max(s1,t1)) + call check_minmax_1 (t1, s1, min(s1,t1), max(s1,t1)) + + s4 = 4_" " ; t4 = 4_"xxx" + call check_minmax_2 (4_" ", 4_"xxx", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" ", min(4_" ", 4_"xxx"), & + max(4_" ", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + + s4 = 4_" \u1be3m" ; t4 = 4_"xxx" + call check_minmax_2 (4_" \u1be3m", 4_"xxx", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (4_"xxx", 4_" \u1be3m", min(4_" \u1be3m", 4_"xxx"), & + max(4_" \u1be3m", 4_"xxx")) + call check_minmax_2 (s4, t4, min(s4,t4), max(s4,t4)) + call check_minmax_2 (t4, s4, min(s4,t4), max(s4,t4)) + +contains + + subroutine check_minmax_1 (s1, s2, smin, smax) + implicit none + character(kind=1,len=*), intent(in) :: s1, s2, smin, smax + character(kind=4,len=len(s1)) :: w1, w2, wmin, wmax + + w1 = s1 ; w2 = s2 ; wmin = smin ; wmax = smax + if (min (w1, w2) /= wmin) STOP 1 + if (max (w1, w2) /= wmax) STOP 2 + if (min (s1, s2) /= smin) STOP 3 + if (max (s1, s2) /= smax) STOP 4 + end subroutine check_minmax_1 + + subroutine check_minmax_2 (s1, s2, smin, smax) + implicit none + character(kind=4,len=*), intent(in) :: s1, s2, smin, smax + + if (min (s1, s2) /= smin) STOP 5 + if (max (s1, s2) /= smax) STOP 6 + end subroutine check_minmax_2 + +end Index: Fortran/gfortran/regression/widechar_select_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_select_1.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + + call testme(test("foo"), test4(4_"foo"), 1) + call testme(test(""), test4(4_""), 1) + call testme(test("gee"), test4(4_"gee"), 4) + call testme(test("bar"), test4(4_"bar"), 1) + call testme(test("magi"), test4(4_"magi"), 4) + call testme(test("magic"), test4(4_"magic"), 2) + call testme(test("magic "), test4(4_"magic "), 2) + call testme(test("magica"), test4(4_"magica"), 4) + call testme(test("freeze"), test4(4_"freeze"), 3) + call testme(test("freeze "), test4(4_"freeze "), 3) + call testme(test("frugal"), test4(4_"frugal"), 3) + call testme(test("frugal "), test4(4_"frugal "), 3) + call testme(test("frugal \x01"), test4(4_"frugal \x01"), 3) + call testme(test("frugal \xFF"), test4(4_"frugal \xFF"), 4) + +contains + integer function test(s) + character(len=*) :: s + + select case (s) + case ("":"foo") + test = 1 + case ("magic") + test = 2 + case ("freeze":"frugal") + test = 3 + case default + test = 4 + end select + end function test + + integer function test4(s) + character(kind=4,len=*) :: s + + select case (s) + case (4_"":4_"foo") + test4 = 1 + case (4_"magic") + test4 = 2 + case (4_"freeze":4_"frugal") + test4 = 3 + case default + test4 = 4 + end select + end function test4 + + subroutine testme(x,y,z) + integer :: x, y, z + if (x /= y) STOP 1 + if (x /= z) STOP 2 + end subroutine testme +end Index: Fortran/gfortran/regression/widechar_select_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/widechar_select_2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + + character(kind=1,len=20) :: s1 + character(kind=4,len=20) :: s4 + + select case (s1) + case ("":4_"foo") ! { dg-error "must be of kind" } + test = 1 + case (4_"gee") ! { dg-error "must be of kind" } + test = 1 + case ("bar") + test = 1 + case default + test = 4 + end select + + select case (s4) + case ("":4_"foo") ! { dg-error "must be of kind" } + test = 1 + case (4_"gee") + test = 1 + case ("bar") ! { dg-error "must be of kind" } + test = 1 + case default + test = 4 + end select + + select case (s4) + case (4_"foo":4_"bar") + test = 1 + case (4_"foo":4_"gee") ! { dg-error "overlaps with CASE label" } + test = 1 + case (4_"foo") ! { dg-error "overlaps with CASE label" } + test = 1 + end select + +end Index: Fortran/gfortran/regression/winapi.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/winapi.f90 @@ -0,0 +1,23 @@ +! { dg-do run { target *-*-cygwin* *-*-mingw* } } +! { dg-options "-lkernel32" } +! Test case provided by Dennis Wassel. + +PROGRAM winapi + + USE, INTRINSIC :: iso_c_binding + IMPLICIT NONE + + INTERFACE + ! Specifically select the lstrlenA version for ASCII. + FUNCTION lstrlen(string) BIND(C, name = "lstrlenA") + USE, INTRINSIC :: iso_c_binding + IMPLICIT NONE + !GCC$ ATTRIBUTES STDCALL :: lstrlen + INTEGER (C_INT) :: lstrlen + CHARACTER(KIND=C_CHAR), INTENT(in) :: string(*) + END FUNCTION lstrlen + END INTERFACE + + IF (lstrlen(C_CHAR_"winapi"//C_NULL_CHAR) /= 6) STOP 1 + +END PROGRAM winapi Index: Fortran/gfortran/regression/write_0_pe_format.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_0_pe_format.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR libfortran/20101 +! With format "PE", 0.0 must still have "+00" as exponent +character(len=10) :: c1, c2 +write(c1,"(1pe9.2)") 0.0 +write(c2,"(1pe9.2)") 1.0 +if (trim(adjustl(c1)) .ne. "0.00E+00") STOP 1 +if (trim(adjustl(c2)) .ne. "1.00E+00") STOP 2 +end Index: Fortran/gfortran/regression/write_back.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_back.f @@ -0,0 +1,26 @@ +! { dg-do run { target fd_truncate } } +! PR 26499 : Positioning of EOF after backspaces and write. +! This test verifies that the last write truncates the file. +! Submitted by Jerry DeLisle . + program test + integer at,eof + dimension idata(5) + idata = -42 + open(unit=11,form='unformatted') + write(11)idata + write(11)idata + write(11)idata + backspace(11) + backspace(11) + write(11)idata + close(11, status="keep") + open(unit=11,form='unformatted') + rewind(11) + read(11)idata + read(11)idata + read(11, end=250)idata + STOP 1 + 250 continue + close(11, status="delete") + end + Index: Fortran/gfortran/regression/write_check.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_check.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-shouldfail "Compile-time specifier checking" } +! Check keyword checking for specifiers +! PR fortran/29452 +program test + implicit none + character(len=5) :: str + str = 'yes' + write(*,'(a)',advance=str) '' + str = 'no' + write(*,'(a)',advance=str) '' + str = 'NOT' + write(*,'(a)',advance=str) '' +end program test +! { dg-output "At line 13 of file.*" } +! { dg-output "Bad ADVANCE parameter in data transfer statement" } Index: Fortran/gfortran/regression/write_check2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_check2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Check keyword checking for specifiers +! PR fortran/29452 + character(len=20) :: str + write(13,'(a)',advance='yes') 'Hello:' + write(13,'(a)',advance='no') 'Hello:' + write(13,'(a)',advance='y') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." } + write(13,'(a)',advance='yet') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." } + write(13,'(a)',advance='yess') 'Hello:' ! { dg-error "ADVANCE= specifier at \\(1\\) must have value = YES or NO." } + end Index: Fortran/gfortran/regression/write_check3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_check3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR29936 Missed constraint on RECL=specifier in unformatted sequential WRITE +! Submitted by Jerry DeLisle +program us_recl + real, dimension(5) :: array = 5.4321 + integer :: istatus + open(unit=10, form="unformatted", access="sequential", RECL=16) + write(10, iostat=istatus) array + if (istatus == 0) STOP 1 + close(10, status="delete") +end program us_recl Index: Fortran/gfortran/regression/write_check4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_check4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/35840 +! +! The asynchronous specifier for a data transfer statement shall be +! an initialization expression +! +! Contributed by Tobias Burnus +! + character(2) :: no + no = "no" + open (unit=10, asynchronous = no) ! Ok, it isn't a transfer stmt + write(*,*, asynchronous="Y"//"E"//trim("S ")) ! Ok, it is an init expr + write(*,*, asynchronous=no) ! { dg-error "does not reduce to a constant expression" } + read (*,*, asynchronous="Y"//"e"//trim("S ")) + read (*,*, asynchronous=no) ! { dg-error "does not reduce to a constant expression" } +end Index: Fortran/gfortran/regression/write_check5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_check5.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! The asynchronous specifier for a data transfer statement shall be +! an initialization expression +! + +module write_check5 +contains + +function no() + implicit none + character(3) :: no + no = "yes" +endfunction + +end module + +use write_check5 +implicit none + +open (unit=10, asynchronous=no()) ! Ok, it isn't a transfer stmt +write(*,*, asynchronous=no()) ! { dg-error "must be an intrinsic function" } +read (*,*, asynchronous=no()) ! { dg-error "must be an intrinsic function" } +end Index: Fortran/gfortran/regression/write_direct_eor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_direct_eor.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR26509 : Writing beyond fixed length direct access records. +! Test case derived from PR. +! Submitted by Jerry Delisle . +program testrecl + implicit none + open(unit = 10, form = 'unformatted', access = 'direct', recl = 4) + write(unit=10,rec=1, err=100) 1d0 + STOP 1 + 100 continue + close(unit=10, status='delete') + end Index: Fortran/gfortran/regression/write_fmt_trim.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_fmt_trim.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR30200 write(*,myfmt="(1X,a,'xyz')") "A" prints Az' instead of Axyz +! Test case from PR, submitted by +program main + character (len=20) format + format = "(1X,a,'xyz')" + write(*,fmt=trim(format)) "A" ! Problem arose when trim was included here +end +! { dg-output " Axyz" } + Index: Fortran/gfortran/regression/write_invalid_format.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_invalid_format.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/35582 - ICE on invalid format +! Testcase contributed by +! Leandro Martinez + + real, parameter :: a = 1. + write(*,a) 'test' ! { dg-error "expression in FORMAT tag" } +end + Index: Fortran/gfortran/regression/write_padding.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_padding.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR25264 Verify that the internal unit, str, is not cleared +! before it is needed elsewhere. This is an extension. +! Test derived from test case by JPR. Contributed by +! Jerry DeLisle . +program write_padding + character(len=10) :: str + real :: atime + str = '123' + write( str, '(a3,i1)' ) trim(str),4 + if (str.ne."1234") STOP 1 +end program write_padding + Index: Fortran/gfortran/regression/write_recursive.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_recursive.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR26766 Recursive I/O with internal units +! Test case derived from example in PR +! Submitted by Jerry DeLisle +program pr26766 + implicit none + character (len=8) :: str, tmp + write (str, '(a)') bar (1234) + if (str.ne."abcd") STOP 1 + str = "wxyz" + write (str, '(2a4)') foo (1), bar (1) + if (str.ne."abcdabcd") STOP 2 + +contains + + function foo (i) result (s) + integer, intent(in) :: i + character (len=4) :: s, t + if (i < 0) then + s = "1234" + else + ! Internal I/O, allowed recursive in f2003, see section 9.11 + write (s, '(a)') "abcd" + end if + end function foo + + function bar (i) result (s) + integer, intent(in) :: i + character (len=4) :: s, t + if (i < 0) then + s = "4567" + else + write (s, '(a)') foo(i) + end if + end function bar + +end program pr26766 + + Index: Fortran/gfortran/regression/write_rewind_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_rewind_1.f @@ -0,0 +1,24 @@ +! { dg-do run { target fd_truncate } } +! PR 26499 : Positioning of EOF after write and rewind. +! Test case from Dale Ranta in PR. +! Submitted by Jerry DeLisle . + program test + dimension idata(100) + idata = -42 + open(unit=11,form='unformatted') + write(11)idata + write(11)idata + read(11,end= 1000 )idata + STOP 1 + 1000 continue + rewind 11 + write(11)idata + close(11,status='keep') + open(unit=11,form='unformatted') + rewind 11 + read(11)idata + read(11, end=250)idata + STOP 2 + 250 continue + close(11,status='delete') + end Index: Fortran/gfortran/regression/write_rewind_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_rewind_2.f @@ -0,0 +1,44 @@ +! { dg-do run } +! PR 26499 Test write with rewind sequences to make sure buffering and +! end-of-file conditions are handled correctly. Derived from test case by Dale +! Ranta. Submitted by Jerry DeLisle . + program test + dimension idata(1011) + idata = -42 + open(unit=11,form='unformatted') + idata(1) = -705 + idata( 1011) = -706 + write(11)idata + idata(1) = -706 + idata( 1011) = -707 + write(11)idata + idata(1) = -707 + idata( 1011) = -708 + write(11)idata + read(11,end= 1000 )idata + STOP 1 + 1000 continue + rewind 11 + read(11,end= 1001 )idata + if(idata(1).ne. -705.or.idata( 1011).ne. -706)STOP 2 + 1001 continue + close(11,status='keep') + open(unit=11,form='unformatted') + rewind 11 + read(11)idata + if(idata(1).ne.-705)then + STOP 3 + endif + read(11)idata + if(idata(1).ne.-706)then + STOP 4 + endif + read(11)idata + if(idata(1).ne.-707)then + STOP 5 + endif + close(11,status='delete') + stop + end + + Index: Fortran/gfortran/regression/write_to_null.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_to_null.F90 @@ -0,0 +1,16 @@ +! { dg-do run } +! pr18983 +! could not write to /dev/null + +#if defined _WIN32 +#define DEV_NULL "nul" +#else +#define DEV_NULL "/dev/null" +#endif + + integer i + open(10,file=DEV_NULL) + do i = 1,100 + write(10,*) "Hello, world" + end do + end Index: Fortran/gfortran/regression/write_zero_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/write_zero_array.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR30145 write statement fails to ignore zero-sized array +! Test case from PR, submitted by Jerry DeLisle +program zeros + implicit none + character(20) :: msg = "" + integer :: itemp(10) = 0 + integer :: ics + !This was OK + write(msg,*) 'itemp(6:0) = ',itemp(6:0),'a' + if (msg /= " itemp(6:0) = a") STOP 1 + !This did not work before patch, segfaulted + ics=6 + write(msg,*) 'itemp(ics:0) = ',itemp(ics:0),'a' + if (msg /= " itemp(ics:0) = a") STOP 2 +end program zeros + Index: Fortran/gfortran/regression/wtruncate.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wtruncate.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wall" } + +! This long comment line should not trigger a line-truncation warning with -Wall + + PROGRAM foo + WRITE (*,*) "Test" ! Neither this comment which exceeds the 72 character limit, too + WRITE (*,*) "This exactly 72 character long soruce line not, too." + END + Index: Fortran/gfortran/regression/wtruncate.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wtruncate.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wall" } + +! This long comment line should not trigger a line-truncation warning with -Wall even for free-form 132 character line limit (blah blah) + + PROGRAM foo + WRITE (*,*) "Test" ! Neither this comment which exceeds the 132 character limit with some random words, too (blah blah) + WRITE (*,*) "This exactly 132 character long soruce line not, too. How can people fill 132 characters without sensless stuff" + END + Index: Fortran/gfortran/regression/wtruncate_fix.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wtruncate_fix.f @@ -0,0 +1,12 @@ +c { dg-do compile } +c { dg-options "-Wall" } +c PR42852 -Wall warns about truncated lines when only a continuation character is truncated + print *, "Hello!" & !xxxxx + & // " World!" + print *, "Hello!" & xxxxx + & // " World!" + print *, "Hello!" // + & // " World!" + end +c { dg-warning "Line truncated" " " { target *-*-* } 6 } +c { dg-warning "Line truncated" " " { target *-*-* } 8 } Index: Fortran/gfortran/regression/wunused-parameter.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wunused-parameter.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-Wunused-parameter" } +! PR66605 +MODULE test + IMPLICIT NONE + INTEGER, PARAMETER :: wp = KIND(1.0D0) +CONTAINS +SUBROUTINE sub (neq, time, y, dydt) + IMPLICIT NONE + INTEGER :: neq + REAL(WP) :: time, y(neq), dydt(neq) + + dydt(1) = 1.0 / y(1) +END SUBROUTINE sub +END MODULE Index: Fortran/gfortran/regression/wunused-parameter_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/wunused-parameter_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-Wunused-parameter -Wunused-dummy-argument" } +! +! PR fortran/52789 +! +! Contributed by Mat Cross +! +! Check for unused parameter and dummy argument +! + +subroutine s(x) ! { dg-warning "Unused dummy argument" } +integer, parameter :: i = 0 ! { dg-warning "Unused parameter" } +end Index: Fortran/gfortran/regression/x_slash_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/x_slash_1.f @@ -0,0 +1,118 @@ +c { dg-do run { target fd_truncate } } +c { dg-options "-std=legacy" } +c +c This program tests the fixes to PR22570. +c +c Provided by Paul Thomas - pault@gcc.gnu.org +c + program x_slash + character*60 a + character*1 b, c + + open (10, status = "scratch") + +c Check that lines with only x-editing followed by a slash generate +c spaces and that subsequent lines have spaces where they should. +c Line 1 we ignore. +c Line 2 has nothing but x editing, followed by a slash. +c Line 3 has x editing finished off by a 1h* + + write (10, 100) + 100 format (1h1,58x,1h!,/,60x,/,59x,1h*,/) + rewind (10) + + read (10, 200) a + read (10, 200) a + do i = 1,60 + if (ichar(a(i:i)).ne.32) STOP 1 + end do + read (10, 200) a + 200 format (a60) + do i = 1,59 + if (ichar(a(i:i)).ne.32) STOP 2 + end do + if (a(60:60).ne."*") STOP 3 + rewind (10) + +c Check that sequences of t- and x-editing generate the correct +c number of spaces. +c Line 1 we ignore. +c Line 2 has tabs to the right of present position. +c Line 3 has tabs to the left of present position. + + write (10, 101) + 101 format (1h1,58x,1h#,/,t38,2x,1h ,tr10,9x,1h$,/, + > 6habcdef,tl4,2x,6hghijkl,t1,59x,1h*) + rewind (10) + + read (10, 200) a + read (10, 200) a + do i = 1,59 + if (ichar(a(i:i)).ne.32) STOP 4 + end do + if (a(60:60).ne."$") STOP 5 + read (10, 200) a + if (a(1:10).ne."abcdghijkl") STOP 6 + do i = 11,59 + if (ichar(a(i:i)).ne.32) STOP 7 + end do + if (a(60:60).ne."*") STOP 8 + rewind (10) + +c Now repeat the first test, with the write broken up into three +c separate statements. This checks that the position counters are +c correctly reset for each statement. + + write (10,102) "#" + write (10,103) + write (10,102) "$" + 102 format(59x,a1) + 103 format(60x) + rewind (10) + read (10, 200) a + read (10, 200) a + read (10, 200) a + do i = 11,59 + if (ichar(a(i:i)).ne.32) STOP 9 + end do + if (a(60:60).ne."$") STOP 10 + rewind (10) + +c Next we check multiple read x- and t-editing. +c First, tab to the right. + + read (10, 201) b, c +201 format (tr10,49x,a1,/,/,2x,t60,a1) + if ((b.ne."#").or.(c.ne."$")) STOP 11 + rewind (10) + +c Now break it up into three reads and use left tabs. + + read (10, 202) b +202 format (10x,tl10,59x,a1) + read (10, 203) +203 format () + read (10, 204) c +204 format (10x,t5,55x,a1) + if ((b.ne."#").or.(c.ne."$")) STOP 12 + close (10) + +c Now, check that trailing spaces are not transmitted when we have +c run out of data (Thanks to Jack Howarth for finding this one: +c http://gcc.gnu.org/ml/fortran/2005-07/msg00395.html). + + open (10, pad = "no", status = "scratch") + b = achar (0) + write (10, 105) 42 + 105 format (i10,1x,i10) + write (10, 106) + 106 format ("============================") + rewind (10) + read (10, 205, iostat = ier) i, b + 205 format (i10,a1) + if ((ier.eq.0).or.(ichar(b).ne.0)) STOP 13 + +c That's all for now, folks! + + end + Index: Fortran/gfortran/regression/x_slash_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/x_slash_2.f @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 34887 - reverse tabs followed by a slash used to confuse I/O. + program main + character(len=2) :: b, a + open(10,form="formatted") + write (10,'(3X, A, T1, A,/)') 'aa', 'bb' + rewind(10) + read (10,'(A2,1X,A2)') b,a + if (a /= 'aa' .or. b /= 'bb') STOP 1 + close(10,status="delete") + end Index: Fortran/gfortran/regression/zero_array_components_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_array_components_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Tests the fix for PR31620, in which zeroing the component a for the array, +! would zero all the components of the array. +! +! David Ham +! +program test_assign + type my_type + integer :: a + integer :: b + end type my_type + type(my_type), dimension(1) :: mine ! note that MINE is an array + mine%b=4 + mine%a=1 + mine%a=0 + if (any (mine%b .ne. 4)) STOP 1 +end program test_assign Index: Fortran/gfortran/regression/zero_length_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_length_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR libfortran/31210 +program test + implicit none + integer :: l = 0 + character(len=20) :: s + + write(s,'(A,I1)') foo(), 0 + if (trim(s) /= "0") STOP 1 + +contains + + function foo() + character(len=l) :: foo + foo = "XXXX" + end function + +end program test Index: Fortran/gfortran/regression/zero_length_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_length_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } + character(len=1) :: s + character(len=0) :: s0 + s = " " + s0 = "" + call bar ("") + call bar (s) + call bar (s0) + call bar (trim(s)) + call bar (min(s0,s0)) +contains + subroutine bar (s) + character(len=*), optional :: s + if (.not. present (S)) STOP 1 + end subroutine bar +end Index: Fortran/gfortran/regression/zero_sized_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_1.f90 @@ -0,0 +1,187 @@ +! { dg-do run } +! Transformational functions for zero-sized array and array sections +! Contributed by Francois-Xavier Coudert + +subroutine test_cshift + real :: tempn(1), tempm(1,2) + real,allocatable :: foo(:),bar(:,:),gee(:,:) + tempn = 2.0 + tempm = 1.0 + allocate(foo(0),bar(2,0),gee(0,7)) + if (any(cshift(foo,dim=1,shift=1)/= 0)) STOP 1 + if (any(cshift(tempn(2:1),dim=1,shift=1)/= 0)) STOP 2 + if (any(cshift(bar,shift=(/1,-1/),dim=1)/= 0)) STOP 3 + if (any(cshift(bar,shift=(/1,-1/),dim=2)/= 0)) STOP 4 + if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) STOP 5 + if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) STOP 6 + if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) STOP 7 + deallocate(foo,bar,gee) +end + +subroutine test_eoshift + real :: tempn(1), tempm(1,2) + real,allocatable :: foo(:),bar(:,:),gee(:,:) + tempn = 2.0 + tempm = 1.0 + allocate(foo(0),bar(2,0),gee(0,7)) + if (any(eoshift(foo,dim=1,shift=1)/= 0)) STOP 8 + if (any(eoshift(tempn(2:1),dim=1,shift=1)/= 0)) STOP 9 + if (any(eoshift(bar,shift=(/1,-1/),dim=1)/= 0)) STOP 10 + if (any(eoshift(bar,shift=(/1,-1/),dim=2)/= 0)) STOP 11 + if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) STOP 12 + if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) STOP 13 + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) STOP 14 + + if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) STOP 15 + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=42.0)/= 0)) STOP 16 + if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) STOP 17 + if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) STOP 18 + if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) STOP 19 + if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) STOP 20 + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) STOP 21 + + if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) STOP 22 + if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) STOP 23 + if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) STOP 24 + if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) STOP 25 + if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) STOP 26 + if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) STOP 27 + if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) STOP 28 + deallocate(foo,bar,gee) +end + +subroutine test_transpose + character(len=1) :: tempn(1,2) + character(len=1),allocatable :: foo(:,:), bar(:,:) + integer :: tempm(1,2) + integer,allocatable :: x(:,:), y(:,:) + tempn = 'a' + allocate(foo(3,0),bar(-2:-4,7:9)) + tempm = -42 + allocate(x(3,0),y(-2:-4,7:9)) + if (any(transpose(tempn(-7:-8,:)) /= 'b')) STOP 29 + if (any(transpose(tempn(:,9:8)) /= 'b')) STOP 30 + if (any(transpose(foo) /= 'b')) STOP 31 + if (any(transpose(bar) /= 'b')) STOP 32 + if (any(transpose(tempm(-7:-8,:)) /= 0)) STOP 33 + if (any(transpose(tempm(:,9:8)) /= 0)) STOP 34 + if (any(transpose(x) /= 0)) STOP 35 + if (any(transpose(y) /= 0)) STOP 36 + deallocate(foo,bar,x,y) +end + +subroutine test_reshape + character(len=1) :: tempn(1,2) + character(len=1),allocatable :: foo(:,:), bar(:,:) + integer :: tempm(1,2) + integer,allocatable :: x(:,:), y(:,:) + tempn = 'b' + tempm = -42 + allocate(foo(3,0),bar(-2:-4,7:9),x(3,0),y(-2:-4,7:9)) + + if (size(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(tempn(-7:-8,:),(/3,3/),pad=(/'a'/)) /= 'a')) STOP 37 + if (size(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(tempn(-7:-8,:),(/3,3,3/),pad=(/'a'/)) /= 'a')) STOP 38 + if (size(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(tempn(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) STOP 39 + if (size(reshape(foo,(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(foo,(/3,3/),pad=(/'a'/)) /= 'a')) STOP 40 + if (size(reshape(foo,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(foo,(/3,3,3/),pad=(/'a'/)) /= 'a')) STOP 41 + if (size(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(foo,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) STOP 42 + if (size(reshape(bar,(/3,3/),pad=(/'a'/))) /= 9 .or. & + any(reshape(bar,(/3,3/),pad=(/'a'/)) /= 'a')) STOP 43 + if (size(reshape(bar,(/3,3,3/),pad=(/'a'/))) /= 27 .or. & + any(reshape(bar,(/3,3,3/),pad=(/'a'/)) /= 'a')) STOP 44 + if (size(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/))) /= 2187 .or. & + any(reshape(bar,(/3,3,3,3,3,3,3/),pad=(/'a'/)) /= 'a')) STOP 45 + + if (size(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(tempm(-7:-8,:),(/3,3/),pad=(/7/)) /= 7)) STOP 46 + if (size(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(tempm(-7:-8,:),(/3,3,3/),pad=(/7/)) /= 7)) STOP 47 + if (size(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(tempm(-7:-8,:),(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) STOP 48 + if (size(reshape(x,(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(x,(/3,3/),pad=(/7/)) /= 7)) STOP 49 + if (size(reshape(x,(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(x,(/3,3,3/),pad=(/7/)) /= 7)) STOP 50 + if (size(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(x,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) STOP 51 + if (size(reshape(y,(/3,3/),pad=(/7/))) /= 9 .or. & + any(reshape(y,(/3,3/),pad=(/7/)) /= 7)) STOP 52 + if (size(reshape(y,(/3,3,3/),pad=(/7/))) /= 27 .or. & + any(reshape(y,(/3,3,3/),pad=(/7/)) /= 7)) STOP 53 + if (size(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/))) /= 2187 .or. & + any(reshape(y,(/3,3,3,3,3,3,3/),pad=(/7/)) /= 7)) STOP 54 + + deallocate(foo,bar,x,y) +end + +subroutine test_pack + integer :: tempn(1,5) + integer,allocatable :: foo(:,:) + tempn = 2 + allocate(foo(0,1:7)) + if (size(pack(foo,foo/=0)) /= 0 .or. any(pack(foo,foo/=0) /= -42)) STOP 55 + if (size(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(foo,foo/=0,(/1,3,4,5,1,0,7,9/))) /= 30) STOP 56 + if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0)) /= 0 .or. & + any(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0) /= -42)) STOP 57 + if (size(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(tempn(:,-4:-5),tempn(:,-4:-5)/=0,(/1,3,4,5,1,0,7,9/))) /= 30) & + STOP 58 + if (size(pack(foo,.true.)) /= 0 .or. any(pack(foo,.true.) /= -42)) & + STOP 59 + if (size(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(foo,.true.,(/1,3,4,5,1,0,7,9/))) /= 30) STOP 60 + if (size(pack(tempn(:,-4:-5),.true.)) /= 0 .or. & + any(pack(foo,.true.) /= -42)) STOP 61 + if (size(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 8 .or. & + sum(pack(tempn(:,-4:-5),.true.,(/1,3,4,5,1,0,7,9/))) /= 30) STOP 62 + deallocate(foo) +end + +subroutine test_unpack + integer :: tempn(1,5), tempv(5) + integer,allocatable :: foo(:,:), bar(:) + integer :: zero + tempn = 2 + tempv = 5 + zero = 0 + allocate(foo(0,1:7),bar(0:-1)) + if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. & + size(unpack(tempv,tempv/=0,tempv)) /= 5) STOP 63 + if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. & + size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) STOP 64 + if (any(unpack(tempv,tempv(1:zero)/=0,tempv) /= -47)) STOP 65 + if (any(unpack(tempv(5:4),tempv(1:zero)/=0,tempv) /= -47)) STOP 66 + if (any(unpack(bar,foo==foo,foo) /= -47)) STOP 67 + deallocate(foo,bar) +end + +subroutine test_spread + real :: tempn(1) + real,allocatable :: foo(:) + tempn = 2.0 + allocate(foo(0)) + if (any(spread(1,dim=1,ncopies=0) /= -17.0) .or. & + size(spread(1,dim=1,ncopies=0)) /= 0) STOP 68 + if (any(spread(foo,dim=1,ncopies=1) /= -17.0) .or. & + size(spread(foo,dim=1,ncopies=1)) /= 0) STOP 69 + if (any(spread(tempn(2:1),dim=1,ncopies=1) /= -17.0) .or. & + size(spread(tempn(2:1),dim=1,ncopies=1)) /= 0) STOP 70 + deallocate(foo) +end + +program test + call test_cshift + call test_eoshift + call test_transpose + call test_unpack + call test_spread + call test_pack + call test_reshape +end Index: Fortran/gfortran/regression/zero_sized_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_10.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { PR 85111 - this used to ICE. } +! Original test case by Gernhard Steinmetz. +program p + integer, parameter :: a(2,0) = reshape([1,2,3,4], shape(a)) + character, parameter :: ac(2,0) = reshape(['a','b','c','d'], shape(ac)) + integer, parameter :: b(2) = maxloc(a, dim=1) ! { dg-error "Different shape" } + integer, parameter :: c(2) = minloc(a, dim=1) ! { dg-error "Different shape" } + character, parameter :: d(2) = maxval(ac, dim=1) ! { dg-error "Different shape" } + end program p Index: Fortran/gfortran/regression/zero_sized_11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_11.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 65428 - this used to ICE. Original test case by FX Coudert. +program p + integer :: i + print *, [shape(1)] + print *, [[ integer :: ]] + print *, (/ (/ (i, i=1,0) /) /) +end Index: Fortran/gfortran/regression/zero_sized_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_12.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 65248 - this used to ICE. Test case by Tobias Burnus. + +program main + +! C7110 (R770) If type-spec is omitted, each ac-value expression in the +! array-constructor shall have the same declared type and kind type parameters + +! Should be fine as there is either no or only one ac-value: +print *, [[integer ::],[real::]] +print *, [[integer ::],[real::], [1], [real ::]] +print *, [[integer ::],[real::], ["ABC"], [real ::]] // "ABC" +print *, [integer :: [integer ::],[real::]] + +! OK - accepted +print *, [integer :: [1],[1.0]] +end Index: Fortran/gfortran/regression/zero_sized_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR30514 in which the bounds on m would cause an +! error and the rest would cause the compiler to go into an infinite +! loop. +! Contributed by Tobias Burnus +! +integer :: i(2:0), j(1:0), m(1:-1) +integer, parameter :: k(2:0) = 0, l(1:0) = 0 +i = k +j = l +m = 5 +end + Index: Fortran/gfortran/regression/zero_sized_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Testcase for PR libfortran/31001 + implicit none + + integer :: i, j, k + integer, allocatable :: mm(:) + logical, allocatable :: mask(:) + + do i = 2, -2, -1 + do k = 0, 1 + allocate (mm(i), mask(i)) + mm(:) = k + mask(:) = (mm == 0) + j = count (mask) + print *, pack (mm, mask) + if (size (pack (mm, mask)) /= j) STOP 1 + deallocate (mm, mask) + end do + end do +end Index: Fortran/gfortran/regression/zero_sized_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_4.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR35991 run-time abort for CSHIFT of zero sized array +! Divide by zero exception before the patch. + program try_gf0045 + call gf0045( 9, 8) + end + + subroutine GF0045(nf9,nf8) + REAL RDA(10) + REAL RDA1(0) + + RDA(NF9:NF8) = CSHIFT ( RDA1 ,1) + + END SUBROUTINE Index: Fortran/gfortran/regression/zero_sized_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_5.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! These used to segfault. +program main + real, dimension(1,0) :: a, b, c + integer, dimension(0) :: j + a = 0 + c = 0 + b = cshift (a,1) + b = cshift (a,j) + b = eoshift (a,1) + b = eoshift (a,1,boundary=c(1,:)) + b = eoshift (a, j, boundary=c(1,:)) +end program main Index: Fortran/gfortran/regression/zero_sized_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_6.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR38709 - ICE-on-invalid on zero-sized array in init-expr. + + INTEGER, PARAMETER :: a(1) = (/ 1 /) + INTEGER, PARAMETER :: i = a(shape(1)) ! { dg-error "Incompatible ranks" } +END Index: Fortran/gfortran/regression/zero_sized_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_7.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 80118 - this used to ICE +! Original test case by Marco Restelli +module m +implicit none + + integer, parameter :: not_empty(1) = 0 + integer, parameter :: empty1(0) = (/integer :: /) + integer, parameter :: empty2(0) = 0 + +contains + + subroutine sub(v) + integer, allocatable, intent(out) :: v(:) + v = 2*empty2 ! internal compiler error + end subroutine sub + +end module m Index: Fortran/gfortran/regression/zero_sized_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_8.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +program p + complex, parameter :: a(0) = 0 + real, parameter :: x(0) = 0 + integer, parameter :: z(0) = 0 + if (any(z > 0) .neqv. .false.) stop 1 + if (all(z > 0) .neqv. .true.) stop 2 + if (count(z > 0) /= 0) stop 3 + if (kind(count(z > 0, kind=1)) /= 1) stop 4 + if (iall(z) /= not(int(0, kind(z)))) stop 5 + if (iany(z) /= 0) stop 6 + if (iparity(z) /= 0) stop 7 + if (maxval(z) /= -huge(0) - 1) stop 8 + if (maxval(x) /= -huge(x)) stop 9 + if (minval(z) /= huge(0)) stop 10 + if (minval(x) /= huge(x)) stop 11 + if (norm2(x) /= 0) stop 12 + if (real(product(a)) /= 1 .and. aimag(product(a)) /= 0) stop 13 + if (product(x) /= 1) stop 14 + if (product(z) /= 1) stop 15 + if (real(sum(a)) /= 0 .and. aimag(sum(a)) /= 0) stop 13 + if (sum(x) /= 0) stop 14 + if (sum(z) /= 0) stop 15 + call q +end + +subroutine q + complex, parameter :: a(0) = 0 + real, parameter :: x(3,4,0) = 0 + integer, parameter :: z(3,4,0) = 0 + if (any(z > 0) .neqv. .false.) stop 101 + if (all(z > 0) .neqv. .true.) stop 102 + if (count(z > 0) /= 0) stop 103 + if (kind(count(z > 0, kind=1)) /= 1) stop 104 + if (iall(z) /= not(int(0, kind(z)))) stop 105 + if (iany(z) /= 0) stop 106 + if (iparity(z) /= 0) stop 107 + if (maxval(z) /= -huge(0) - 1) stop 108 + if (maxval(x) /= -huge(x)) stop 109 + if (minval(z) /= huge(0)) stop 110 + if (minval(x) /= huge(x)) stop 111 + if (norm2(x) /= 0) stop 112 + if (real(product(a)) /= 1 .and. aimag(product(a)) /= 0) stop 113 + if (product(x) /= 1) stop 114 + if (product(z) /= 1) stop 115 + if (real(sum(a)) /= 0 .and. aimag(sum(a)) /= 0) stop 13 + if (sum(x) /= 0) stop 14 + if (sum(z) /= 0) stop 15 +end +! { dg-prune-output "symmetric range implied by Standard" } Index: Fortran/gfortran/regression/zero_sized_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_sized_9.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +program main + implicit none + integer, parameter :: a(0,3) = 0 + integer, parameter :: b(3,0) = -42 + integer, parameter, dimension(3) :: a1 = minval(a,dim=1) + integer, parameter, dimension(0) :: a2 = minval(a,dim=2) + integer, parameter, dimension(0) :: b1 = minval(b,dim=1) + integer, parameter, dimension(3) :: b2 = minval(b,dim=2) + logical, parameter :: c(0,3) = .false. + logical, parameter :: d(3,0) = .false. + logical, parameter, dimension(3) :: tr = all(c,dim=1) + logical, parameter, dimension(3) :: fa = any(c,dim=1) + integer, parameter, dimension(3) :: ze = count(d,dim=2) + integer, parameter, dimension(3) :: ze2 = iany(b,dim=2) + integer, parameter, dimension(3) :: ze3 = iparity(a,dim=1) + real, parameter, dimension(0,3) :: r = 1.0 + real, parameter, dimension(3) :: n2 = norm2(r,dim=1) + integer, parameter, dimension(3) :: one = product(b,dim=2) + integer, parameter, dimension(3) :: ze4 = sum(a,dim=1) + if (any(a1 /= huge(0))) stop 1 + if (any(b2 /= huge(b2))) stop 2 + if (any(.not.tr)) stop 3 + if (any(fa)) stop 3 + if (any(ze /= 0)) stop 4 + if (any(ze2 /= 0)) stop 5 + if (any(ze3 /= 0)) stop 6 + if (any(n2 /= 0.0)) stop 7 + if (any(one /= 1)) stop 8 + if (any(ze4 /= 0)) stop 9 +end program main Index: Fortran/gfortran/regression/zero_stride_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/zero_stride_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 50130 - this caused an ICE. Test case supplied by Joost +! VandeVondele. +integer, parameter :: a(10)=0 +integer, parameter :: b(10)=a(1:10:0) ! { dg-error "Illegal stride of zero" } +END +