diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dependency_22.f90 | 28 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/module_equivalence_5.f90 | 34 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/namelist_18.f90 | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/namelist_54.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/namelist_55.f90 | 50 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/namelist_56.f90 | 21 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/transfer_array_intrinsic_5.f90 | 24 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/used_types_24.f90 | 33 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/vector_subscript_4.f90 | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/vector_subscript_5.f90 | 26 |
10 files changed, 245 insertions, 1 deletions
diff --git a/gcc/testsuite/gfortran.dg/dependency_22.f90 b/gcc/testsuite/gfortran.dg/dependency_22.f90 new file mode 100644 index 00000000000..bedf702767d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dependency_22.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR37723 in which the array element reference masked the dependency +! by inhibiting the test. +! +! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com> +! + program try_cg0071 + type seq + integer ia(10) + end type + TYPE(SEQ) UDA1R + type(seq) uda(1) + + do j1 = 1,10 + uda1r%ia(j1) = j1 + enddo + + uda = uda1r + UDA(1)%IA(1:9) = UDA(1)%IA(9:1:-1)+1 + + DO J1 = 1,9 + if (UDA1R%IA(10-J1)+1 /= Uda(1)%IA(J1)) call abort() + ENDDO + + end + + diff --git a/gcc/testsuite/gfortran.dg/module_equivalence_5.f90 b/gcc/testsuite/gfortran.dg/module_equivalence_5.f90 new file mode 100644 index 00000000000..de1d5043d79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_equivalence_5.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Fixes PR37787 where the EQUIVALENCE between QLA1 and QLA2 wasn't recognized +! in the dependency checking because the compiler was looking in the wrong name +! space. +! +! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com> +! +module stuff + integer, parameter :: r4_kv = 4 +contains + + SUBROUTINE CF0004 +! COPYRIGHT 1999 SPACKMAN & HENDRICKSON, INC. + REAL(R4_KV), dimension (10) :: QLA1, QLA2, QLA3, & + QCA = (/(i, i= 1, 10)/) + EQUIVALENCE (QLA1, QLA2) + QLA1 = QCA + QLA3 = QCA + QLA3( 2:10:3) = QCA ( 1:5:2) + 1 + QLA1( 2:10:3) = QLA2( 1:5:2) + 1 !failed because of dependency + if (any (qla1 .ne. qla3)) call abort + END SUBROUTINE +end module + +program try_cf004 + use stuff + nf1 = 1 + nf2 = 2 + call cf0004 +end + +! { dg-final { cleanup-modules "stuff" } } + diff --git a/gcc/testsuite/gfortran.dg/namelist_18.f90 b/gcc/testsuite/gfortran.dg/namelist_18.f90 index eba8b6bc573..d54d91f9a05 100644 --- a/gcc/testsuite/gfortran.dg/namelist_18.f90 +++ b/gcc/testsuite/gfortran.dg/namelist_18.f90 @@ -14,7 +14,7 @@ program namelist_18 read (10, '(a)', iostat = ier) buffer if (ier .ne. 0) call abort () close (10) - If ((buffer(5:5) /= "f") .or. (buffer(9:9) /= " ")) call abort () + If ((buffer(6:6) /= "f") .or. (buffer(9:9) /= """")) call abort () open (10, status = "scratch", delim ="quote") write (10, mynml) diff --git a/gcc/testsuite/gfortran.dg/namelist_54.f90 b/gcc/testsuite/gfortran.dg/namelist_54.f90 new file mode 100644 index 00000000000..25061c48fc5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_54.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR37707 Namelist read of array of derived type incorrect. +type s + integer m + integer n +end type s +type(s) :: a(3) +character*80 :: l = ' &namlis a%m=1,2, a%n=5,6, /' +namelist /namlis/ a +a%m=[87,88,89] +a%n=[97,98,99] +read(l,namlis) +if (a(1)%m /= 1 .or. a(2)%m /= 2 .or. a(1)%n /= 5 .or. a(2)%n /= 6 .or. & + & a(3)%m /= 89 .or. a(3)%n /= 99) call abort +end diff --git a/gcc/testsuite/gfortran.dg/namelist_55.f90 b/gcc/testsuite/gfortran.dg/namelist_55.f90 new file mode 100644 index 00000000000..20c7a219cd6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_55.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! PR37707 Namelist read of array of derived type incorrect +! Test case from PR, prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org> +TYPE geometry + INTEGER :: nlon,nlat,nlev,projection + INTEGER :: center,subcenter,process + REAL :: west,south,east,north + REAL :: dlon,dlat + REAL :: polat,polon + REAL :: lonc,latc + REAL :: projlat,projlat2,projlon + CHARACTER(LEN=1) :: arakawa ='#' + INTEGER :: truncx,truncy ! Spectral truncation + INTEGER :: cie ! Flag fort CI (0), CIE gridpoint (1) + ! or CIE spectral (-1) + INTEGER :: nlat_i,nlon_i ! I length in Y and X direction + INTEGER :: nlat_e ,nlon_e ! E length in Y and X direction + LOGICAL :: do_geo = .true. +END TYPE geometry + +TYPE shortkey + INTEGER :: PPP ! 2. Parameter + INTEGER :: NNN ! 12. Gridpoint or spectral field 0 = gridpoint, 1 = spectral + INTEGER :: INTPM + CHARACTER(LEN=16) :: name +END TYPE shortkey +INTEGER, PARAMETER :: maxl = 200 ! Maximum number of levels to be read from namelist +INTEGER, PARAMETER :: max_atmkey = 10 ! Maximum number of extra fields in the + +REAL :: ahalf(maxl),bhalf(maxl) +TYPE (geometry) :: outgeo ; SAVE outgeo ! Output geometry + +TYPE (shortkey) :: atmkey(max_atmkey) ; SAVE atmkey +TYPE (shortkey) :: mlevkey(max_atmkey) ; SAVE mlevkey + +character*600 :: l = " &NAMINTERP atmkey%ppp = 076,058,062,079, atmkey%nnn = 000,000,000,000, & + & atmkey%name ='LIQUID_WATER','SOLID_WATER','SNOW','RAIN', OUTGEO%NLEV=10, & + & AHALF=0.,1.,2.,3.,4.,5.,6.,7.,8.,9., BHALF=0.,1.,2.,3.,4.,5.,6.,7.,8.,9., /" + +namelist /naminterp/outgeo,ahalf,bhalf,atmkey +print *, outgeo%nlev +read(l,nml=naminterp) +if (outgeo%nlev /= 10) call abort +if (any(ahalf(1:10) .ne. [0.,1.,2.,3.,4.,5.,6.,7.,8.,9.])) call abort +if (any(bhalf(1:10) .ne. [0.,1.,2.,3.,4.,5.,6.,7.,8.,9.])) call abort +if (any(atmkey(1:4)%ppp .ne. [076,058,062,079])) call abort +if (any(atmkey(1:4)%nnn .ne. [0,0,0,0])) call abort +if (any(atmkey(1:4)%name .ne. ['LIQUID_WATER','SOLID_WATER ','SNOW ',& + &'RAIN '])) call abort +end diff --git a/gcc/testsuite/gfortran.dg/namelist_56.f90 b/gcc/testsuite/gfortran.dg/namelist_56.f90 new file mode 100644 index 00000000000..03fda759f5c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_56.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR37707 Namelist read of array of derived type incorrect +! Test case from Tobias Burnus + IMPLICIT NONE + integer :: j + character(len=5) :: str(4) + character(len=900) :: nlstr + namelist /nml/ str, j + str = '' + j = -42 + nlstr = '&nml str = "a", "b", "cde", j = 5 /' + read(nlstr,nml) + write(99,nml) + rewind(99) + j = -54 + str = 'XXXX' + read(99,nml) + if (j.ne.5) call abort + if (any(str.ne.["a ","b ","cde "," "])) call abort + close(99,status="delete") +end diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_5.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_5.f90 new file mode 100644 index 00000000000..f79dcc99c6f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 <fxcoudert@gcc.gnu.org> +! +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() + implicit none + integer foobar(size (transfer (x, [1]))) ! { dg-error "cannot appear" } + real x + end function +end program diff --git a/gcc/testsuite/gfortran.dg/used_types_24.f90 b/gcc/testsuite/gfortran.dg/used_types_24.f90 new file mode 100644 index 00000000000..44d2f5ec199 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/used_types_24.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests the fix for PR37794 a regression where a bit of redundant code caused an ICE. +! +! Contributed by Jonathan Hogg <J.Hogg@rl.ac.uk> +! +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 + +! { dg-final { cleanup-modules "m1 m2 test_mod" } } diff --git a/gcc/testsuite/gfortran.dg/vector_subscript_4.f90 b/gcc/testsuite/gfortran.dg/vector_subscript_4.f90 new file mode 100644 index 00000000000..204468456e1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vector_subscript_4.f90 @@ -0,0 +1,13 @@ +! { 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 <mikael.morin@tele2.fr> +! + integer :: i(-1:1) = 1, j(3) = 1, k(3) + k = j((/1,1,1/)+i) + end +! { dg-final { scan-tree-dump-times "A\.3\\\[3\\\]" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/vector_subscript_5.f90 b/gcc/testsuite/gfortran.dg/vector_subscript_5.f90 new file mode 100644 index 00000000000..88eb358e6bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/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 <jakub@gcc.gnu.org> +! +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/)))) call abort +end |