diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/gfortran.fortran-torture')
314 files changed, 9499 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/ChangeLog.g95 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/ChangeLog.g95 new file mode 100644 index 000000000..fee34e5df --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/ChangeLog.g95 @@ -0,0 +1,106 @@ +2003-07-24 Lifang Zeng <zlf605@hotmail.com> + + * execute/where_3.f90: Modified. + * execute/where_6.f90: New testcase. + +2003-07-09 Chun HUang <compiler@sohu.com> + + * execute/intrinsic_scan.f90: Test the SCAN intrinsic. + * execute/intrinsic_verify.f90: Test the VERIFY intrinsic. + +2003-07-02 Paul Brook <paul@nowt.org> + + * execite/initializer.f90: Test arrays with scalar initializer. + +2003-06-02 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * execute/intrinsic_associated.f90: New testcase. + * execute/intrinsic_associated_2.f90: New testcase. + +2003-06-01 Paul Brook <paul@nowt.org> + + * execute/power.f90: Check complex ** real. + +2003-05-20 Paul Brook <paul@nowt.org> + + * execute/forall_1.f90: Avoid many to one assignment. + +2003-05-20 Canqun Yang <canqun@yahoo.com.cn> + + * execute/forall_1.f90: Replace logical operator 'and' with 'or'. + +2003-05-19 Lifang Zeng <zlf605@hotmail.com> + + * execute/forall_1.f90: FORALL with negative stride, FORALL has + arbitrary number of indexes, and actual variables used as FORALL + indexes. + +2003-05-07 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * execute/der_point.f90: DERIVED type with components point to the + DERIVED type itself, and two DERIVED type with components point to + each other. + +2003-03-16 Paul Brook <paul@nowt.org> + + * execute/arrayarg.f90: Assumed shape dummy arrays aren't legal when + using an implicit interface. + * execute/arraysave.f90: Ditto. + * execute/bounds.f90: Ditto. + * lib/f95-torture.exp (TORTURE_OPTIONS): Check f77 arrays. + +2003-03-15 Paul Brook <paul@nowt.org> + + * execute/elemental.f90: Test expressions inside elemental functions. + +2003-03-14 Paul Brook <paul@nowt.org> + + * lib/f95-torture.exp (TORTURE_OPTIONS): Check different array + repacking strategies. + +2003-02-15 Paul Brook <paul@nowt.org> + + * execute/der_init.f90: Add tests for non-constant constructors. + +2003-02-08 Paul Brook <paul@nowt.org> + + * execute/constructor.f90: Additional tests for non-constant + constructors with unexpanded implicit do loops. + +2003-02-06 Paul Brook <paul@nowt.org> + + * execute/der_type.f90: Add extra tests for initializers and passing + components as arguments. + +2003-02-01 Paul Brook <paul@nowr.org> + + * execute/elemental.f90: Test intrinsic elemental conversion + routines. + +2003-01-28 Paul Brook <paul@nowt.org> + + * compile/mystery_proc.f90: New testcase. + +2003-01-27 Paul Brook <paul@nowt.org> + + * execute/intrinsic_minmax.f90: Add a couple more variations. + +2003-01-26 Paul Brook <paul@nowt.org> + + * execute/contained.f90: New testcase. + * execute/intrinsic_present.f90: New testcase. + +2003-01-22 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * compile/bergervoet2.f90, compile/ambig.f90, + compile/actual.f90, execute/integer_select.f90: + New testcases. + * execute/function_module_1.f90: Fix syntax error. + * execute/retarray.f90: Fix another syntax error. + + +Copyright (C) 2003 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/20080806-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/20080806-1.f90 new file mode 100644 index 000000000..3abc80ab1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/20080806-1.f90 @@ -0,0 +1,24 @@ +MODULE M1 + IMPLICIT NONE + TYPE mmm + COMPLEX(KIND=8), DIMENSION(:,:), POINTER :: data + END TYPE mmm + +CONTAINS + + SUBROUTINE S(ma,mb,mc) + TYPE(mmm), POINTER :: ma,mb,mc + COMPLEX(KIND=8), DIMENSION(:, :), & + POINTER :: a, b, c + INTEGER :: i,j + a=>ma%data + b=>mb%data + c=>mc%data + DO i=1,size(a,1) + DO j=1,size(a,2) + c(i,j)=a(i,j)*b(i,j) + ENDDO + ENDDO + END SUBROUTINE + +END MODULE M1 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/actual.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/actual.f90 new file mode 100644 index 000000000..871c08149 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/actual.f90 @@ -0,0 +1,38 @@ +module modull + +contains + +function fun( a ) + real, intent(in) :: a + real :: fun + fun = a +end function fun + +end module modull + + + +program t5 + +use modull + +real :: a, b + +b = foo( fun, a ) + +contains + +function foo( f, a ) + real, intent(in) :: a + interface + function f( x ) + real, intent(in) :: x + real :: f + end function f + end interface + real :: foo + + foo = f( a ) +end function foo + +end program t5 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/allocate.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/allocate.f90 new file mode 100644 index 000000000..f5cce41f7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/allocate.f90 @@ -0,0 +1,26 @@ +! Snippet to test various allocate statements + +program test_allocate + implicit none + type t + integer i + real r + end type + type pt + integer, pointer :: p + end type + integer, allocatable, dimension(:, :) :: a + type (t), pointer, dimension(:) :: b + type (pt), pointer :: c + integer, pointer:: p + integer n + + n = 10 + allocate (a(1:10, 4)) + allocate (a(5:n, n:14)) + allocate (a(6, 8)) + allocate (b(n)) + allocate (c) + allocate (c%p) + allocate (p) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/ambig.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/ambig.f90 new file mode 100644 index 000000000..3e5e07dad --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/ambig.f90 @@ -0,0 +1,26 @@ +MODULE TYPESP + TYPE DMT + REAL(KIND(1.D0)), POINTER :: ASPK(:) + END TYPE DMT +END MODULE TYPESP + +MODULE TCNST + Integer, Parameter :: DIM_TEMP_BUFFER=10000 + Real(Kind(1.d0)), Parameter :: COLROW_=0.33,PERCENT=0.7 +end MODULE TCNST + + +Subroutine DOWORK(A) + Use TYPESP + Use TCNST + Type(DMT), intent (inout) :: A + Real(Kind(1.d0)),Pointer :: ASPK(:) + Integer :: ISIZE, IDIM + + ISIZE=DIM_TEMP_BUFFER + + Allocate(ASPK(ISIZE),STAT=INFO) + IDIM = MIN(ISIZE,SIZE(A%ASPK)) + ASPK(1:IDIM) = A%ASPK(1:IDIM) + Return +End Subroutine DOWORK diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/arrayio.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/arrayio.f90 new file mode 100644 index 000000000..1eec0bb59 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/arrayio.f90 @@ -0,0 +1,12 @@ +! Program to test array IO. Should print the numbers 1-20 in order +program arrayio + implicit none + integer, dimension(5, 4) :: a + integer i, j + + do j=1,4 + a(:, j) = (/ (i + (j - 1) * 5, i=1,5) /) + end do + + write (*) a +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/bergervoet2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/bergervoet2.f90 new file mode 100644 index 000000000..eef33e425 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/bergervoet2.f90 @@ -0,0 +1,5 @@ + function testi() result(res) + integer :: res + res = 0 + end function testi + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp new file mode 100644 index 000000000..1a6d1f0cb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/compile.exp @@ -0,0 +1,39 @@ +# Expect driver script for GCC Regression Tests +# Copyright (C) 2003-2014 Free Software Foundation, Inc. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# <http://www.gnu.org/licenses/>. + +# These tests come from many different contributors. + +if $tracelevel then { + strace $tracelevel +} + +# load support procs +load_lib fortran-torture.exp +load_lib torture-options.exp + +torture-init +set-torture-options [get-fortran-torture-options] + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture $testcase +} + +torture-finish diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/complex_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/complex_1.f90 new file mode 100644 index 000000000..605ec665f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/complex_1.f90 @@ -0,0 +1,5 @@ +program test_gfortran2 + Complex(8) :: g, zh + Real(8) :: g_q + g = zh - zh/cmplx(0.0_8,-g_q) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_1.f90 new file mode 100644 index 000000000..60f31092e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_1.f90 @@ -0,0 +1,15 @@ +! Obscure failure that disappeared when the parameter was removed. +! Works OK now. +module mymod +implicit none +contains + subroutine test(i) + implicit none + integer i + end subroutine +end module mymod + +program error + use mymod +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_2.f90 new file mode 100644 index 000000000..76ef6c628 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_2.f90 @@ -0,0 +1,11 @@ +! Arrays declared in parent but used in the child. +program error + implicit none + integer, dimension (10) :: a +contains + subroutine test() + implicit none + a(1) = 0 + end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_3.f90 new file mode 100644 index 000000000..da5e8475c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_3.f90 @@ -0,0 +1,12 @@ +! Program to check using parent variables in more than one contained function +program contained_3 + implicit none + integer var +contains + subroutine one + var = 1 + end subroutine + subroutine two + var = 2 + end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_4.f90 new file mode 100644 index 000000000..233dab878 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_4.f90 @@ -0,0 +1,35 @@ +! Check contained functions with the same name. +module contained_4 + +contains + + subroutine foo1() + call bar() + contains + subroutine bar() + end subroutine bar + end subroutine foo1 + + subroutine foo2() + call bar() + contains + subroutine bar() + end subroutine bar + end subroutine foo2 + +end module contained_4 + +subroutine foo1() +call bar() +contains + subroutine bar() + end subroutine bar +end subroutine + +subroutine foo2() + call bar() +contains + subroutine bar() + end subroutine bar +end subroutine foo2 + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_5.f90 new file mode 100644 index 000000000..94946f76b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/contained_5.f90 @@ -0,0 +1,10 @@ +! Function returning an array continaed in a module. Caused problems 'cos +! we tried to add the dummy return vars to the parent scope. + +Module contained_5 +contains +FUNCTION test () + REAL, DIMENSION (1) :: test + test(1)=0.0 +END FUNCTION +end module diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/convert.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/convert.f90 new file mode 100644 index 000000000..777cd132c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/convert.f90 @@ -0,0 +1,37 @@ +! Program to test conversion. Does not actualy test the generated code +program convert + implicit none + integer(kind=4) i + integer(kind=8) m + real(kind=4) r + real(kind=8) q + complex(kind=4) c + complex(kind=8) z + + ! each of these should generate a single intrinsic conversion expression + i = int(i) + i = int(m) + i = int(r) + i = int(q) + i = int(c) + i = int(z) + m = int(i, kind=8) + m = int(m, kind=8) + m = int(r, kind=8) + m = int(q, kind=8) + m = int(c, kind=8) + m = int(z, kind=8) + r = real(i) + r = real(m) + r = real(r) + r = real(q) + r = real(c) + r = real(z, kind=4) + q = real(i, kind=8) + q = real(m, kind=8) + q = real(r, kind=8) + q = real(q, kind=8) + q = real(c, kind=8) + ! Note real(<complex>) returns the type kind of the argument. + q = real(z) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/data_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/data_1.f90 new file mode 100644 index 000000000..b28390993 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/data_1.f90 @@ -0,0 +1,11 @@ +! this tests the fix for PR 13826 +TYPE a + REAL x +END TYPE +TYPE(a) :: y +DATA y /a(1.)/ ! used to give an error about non-PARAMETER +END +! this tests the fix for PR 13940 +SUBROUTINE a +DATA i /z'f95f95'/ +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_1.f90 new file mode 100644 index 000000000..635727b66 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_1.f90 @@ -0,0 +1,10 @@ +!This used to ICE as we chose the wrong type for the +! temporary to hold type%var +! fortran/18157 +program testcase_fold + type :: struct + real :: var ! its julian sec + end type struct + type(struct), dimension(:), pointer :: mystruct + mystruct(:)%var = mystruct(:)%var +END Program testcase_fold diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_2.f90 new file mode 100644 index 000000000..29515f556 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_2.f90 @@ -0,0 +1,17 @@ +!This used to ICE as we chose the wrong type for the +! temporary to hold type%x +! fortran/18157 +MODULE bug + IMPLICIT NONE + TYPE :: my_type + REAL :: x + END TYPE + TYPE (my_type), DIMENSION(3) :: t + CONTAINS + SUBROUTINE foo + INTEGER, DIMENSION(8) :: c(3) + t(c)%x = t(c)%x + RETURN + END SUBROUTINE foo +END MODULE bug + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_3.f90 new file mode 100644 index 000000000..d31167cc4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/defined_type_3.f90 @@ -0,0 +1,10 @@ +!This used to ICE as we chose the wrong type for the +! temporary to hold type%var +! fortran/18157 +program testcase_fold + type :: struct + real :: var ! its julian sec + end type struct + type(struct), dimension(:), pointer :: mystruct + mystruct(1:2)%var = mystruct(2:3)%var +END Program testcase_fold diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/do_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/do_1.f90 new file mode 100644 index 000000000..396592c39 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/do_1.f90 @@ -0,0 +1,28 @@ +! test various forms of the DO statement +! inspired by PR14066 +LOGICAL L +DO i=1,10 +END DO +DO 10 i=1,20 + DO 20,j=1,10,2 +20 CONTINUE +10 END DO +L = .TRUE. +DO WHILE(L) + L = .FALSE. +END DO +DO 50 WHILE(.NOT.L) + L = .TRUE. +50 CONTINUE +DO + DO 30 + DO 40 +40 CONTINUE +30 END DO +END DO +outer: DO i=1,20 + inner: DO,j=i,30 + IF (j.EQ.2*i) CYCLE outer + END DO inner +END DO outer +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/dummyfn.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/dummyfn.f90 new file mode 100644 index 000000000..d54f64899 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/dummyfn.f90 @@ -0,0 +1,13 @@ +! Program to test array valued dummy functions +SUBROUTINE dummyfn(deriv) + implicit none + INTERFACE + FUNCTION deriv() + REAL :: deriv(4) + END FUNCTION deriv + END INTERFACE + + REAL :: dx(4) + + dx = deriv() +END SUBROUTINE diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty.f90 new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty.f90 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty_interface_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty_interface_1.f90 new file mode 100644 index 000000000..d90895423 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/empty_interface_1.f90 @@ -0,0 +1,4 @@ +! Program to test empty interfaces PR15051 +INTERFACE leer +END INTERFACE +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif-1.f90 new file mode 100644 index 000000000..bdce67db9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif-1.f90 @@ -0,0 +1,10 @@ +program emptyif + + implicit none + integer i,K(4) + + if (K(i)==0) then + ! do absolutely nothing + end if + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif.f90 new file mode 100644 index 000000000..bd12d502e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/emptyif.f90 @@ -0,0 +1,42 @@ +! Program to test empty IF statements +program emptyif + implicit none + logical c + logical d + + if (c) then + c = .true. + end if + + if (c) then + else + c = .true. + end if + + if (c) then + c = .true. + else + end if + + if (c) then + c = .true. + elseif (d) then + c = .true. + else + end if + + if (c) then + c = .true. + elseif (d) then + else + c = .true. + end if + + if (c) then + elseif (d) then + c = .true. + else + c = .true. + end if + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/enum_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/enum_1.f90 new file mode 100644 index 000000000..7a6b42403 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/enum_1.f90 @@ -0,0 +1,46 @@ +! Program to test parsing of ENUM in different program units + +program main + implicit none + interface + subroutine sub1 + end subroutine sub1 + end interface + integer :: i = 55 + + enum , bind (c) + enumerator :: a , b=5 + enumerator c, d + end enum + + call sub + call sub1 + i = fun() + +contains + + subroutine sub + enum, bind(c) + enumerator :: p = b, q = 10 + 50 + enumerator r, s + end enum + end subroutine sub + + function fun() + integer :: fun + enum, bind (c) + enumerator :: red, yellow = 23 + enumerator :: blue + enumerator :: green + end enum + fun = 1 + end function fun +end program main + +subroutine sub1 + implicit none + enum, bind(c) + enumerator x , y + enumerator :: z = 100 + end enum +end subroutine sub1 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/fnresvar.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/fnresvar.f90 new file mode 100644 index 000000000..fab9aa665 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/fnresvar.f90 @@ -0,0 +1,5 @@ +! Explicit function rsult variables +function fnresvar() result (r) + integer r + r = 0 +end function diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/forall-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/forall-1.f90 new file mode 100644 index 000000000..caaea088a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/forall-1.f90 @@ -0,0 +1,7 @@ + integer i, a(1) + logical(kind=8) s(1) + + s = .true. + a = 42 + forall (i=1:1, .not. s(1)) a(i) = 0 + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/gen_interf.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/gen_interf.f90 new file mode 100644 index 000000000..eb493411b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/gen_interf.f90 @@ -0,0 +1,19 @@ +! Program to test generic interfaces. +program gen_interf + implicit none + interface gen + function ifn (a) + integer :: a, ifn + end function + end interface + interface gsub + subroutine igsub (a) + integer a + end subroutine + end interface + + integer i + + call gsub (i) + i = gen(i) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit.f90 new file mode 100644 index 000000000..8a6c4f56d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit.f90 @@ -0,0 +1,13 @@ +implicit integer(a), logical(b-c), real(d-y), integer(z) +a = 1_4 +b = .true. +c = b +d = 1.0e2 +y = d +z = a +end +! test prompted by PR 16161 +! we used to match "character (c)" wrongly in the below, confusing the parser +subroutine b +implicit character (c) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_1.f90 new file mode 100644 index 000000000..f56bd63b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_1.f90 @@ -0,0 +1,32 @@ +! Test implicit character declarations. +! This requires some coordination between the typespec and variable name range +! matchers to get it right. +module implicit_1 + integer, parameter :: x = 10 + integer, parameter :: y = 6 + integer, parameter :: z = selected_int_kind(4) +end module +subroutine foo(n) + use implicit_1 + ! Test various combinations with and without character length + ! and type kind specifiers + implicit character(len=5) (a) + implicit character(n) (b) + implicit character*6 (c-d) + implicit character (e) + implicit character(x-y) (f) + implicit integer(z) (g) + implicit character (z) + + a1 = 'Hello' + b1 = 'world' + c1 = 'wibble' + d1 = 'hmmm' + e1 = 'n' + f1 = 'test' + g1 = 1 + x1 = 1.0 + y1 = 2.0 + z1 = 'A' +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_2.f90 new file mode 100644 index 000000000..c5b8456c8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/implicit_2.f90 @@ -0,0 +1,6 @@ +! PR 13372 -- we incorrectly added a symbol for p, which broke implicit typing +module t +implicit none +integer, parameter :: F = selected_real_kind(P = 6, R = 37) +end module t + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inline_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inline_1.f90 new file mode 100644 index 000000000..4c05baaaa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inline_1.f90 @@ -0,0 +1,17 @@ +program gfcbug43 + call try_fit (1) + call try_fit (1) +contains + subroutine try_fit (k) + call fit (1, debug=.true.) + end subroutine try_fit + subroutine fit (k, debug) + logical, intent(in), optional :: debug + do j = 1, 2 + maxerr1 = funk (r ,x1 , x1) + end do + if (debug) then + print *, "help" + end if + end subroutine fit +end program gfcbug43 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inquiry_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inquiry_1.f90 new file mode 100644 index 000000000..12d67fc5e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/inquiry_1.f90 @@ -0,0 +1,8 @@ +! Check that inquiry functions are allowed as specification expressions. +subroutine inquiry(x1) + implicit none + real, dimension(1:), intent(out) :: x1 + real, dimension(1:size(x1)) :: x3 + x3 = 0 + x1 = x3 +end subroutine diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/io_end.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/io_end.f90 new file mode 100644 index 000000000..f67ae57ae --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/io_end.f90 @@ -0,0 +1,9 @@ +! Check we can cope with end labels in IO statements +program m + implicit none + integer i + do while (.true.) + read(*, *, end = 1) i + end do +1 continue +end program m diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-1.f90 new file mode 100644 index 000000000..03cad93a5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-1.f90 @@ -0,0 +1,8 @@ +! PR fortran/33500 + +subroutine whatever() +logical(kind=1) :: l1, l2, l3 +if ((l1 .and. l2) .neqv. l3) then + l1 = .true. +endif +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-2.f90 new file mode 100644 index 000000000..c31443f94 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/logical-2.f90 @@ -0,0 +1,10 @@ +! Check for operand type validity after gimplification + +subroutine whatever() +logical(kind=1) :: l1 +logical(kind=2) :: l2 +logical(kind=4) :: l3 +if ((l1 .and. l2) .neqv. l3) then + l1 = .true. +endif +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 new file mode 100644 index 000000000..8d1d754f5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 @@ -0,0 +1,8 @@ +! from PR 14928 +! we used to not accept the two argument variant of MINLOC and MAXLOC when +! the MASK keyword was omitted. + real b(10) + integer c(1) + c = minloc(b,b<0) + c = maxloc(b,b>0) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_common.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_common.f90 new file mode 100644 index 000000000..f727881d7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_common.f90 @@ -0,0 +1,10 @@ +! We were incorrectly trying to create a variable for the common block itself, +! in addition to the variables it contains. +module FOO + implicit none + integer I + common /C/I +contains + subroutine BAR + end subroutine BAR +end module FOO diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_expr.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_expr.f90 new file mode 100644 index 000000000..a1ca83a9a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_expr.f90 @@ -0,0 +1,18 @@ +! This uncovered a bug in the reading/writing of expressions. +module module_expr_1 + integer a +end module + +module module_expr_2 + use module_expr_1 +contains + +subroutine myproc (p) + integer, dimension (a) :: p +end subroutine +end module + +program module_expr + use module_expr_1 + use module_expr_2 +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_proc.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_proc.f90 new file mode 100644 index 000000000..17386d4b8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_proc.f90 @@ -0,0 +1,14 @@ +! Check module procedures with arguments +module module_proc +contains +subroutine s(p) + integer p +end subroutine +end module + +program test +use module_proc +integer i +call s(i) +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_result.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_result.f90 new file mode 100644 index 000000000..105073596 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/module_result.f90 @@ -0,0 +1,9 @@ +! Result variables in module procedures +module module_result + implicit none +contains +function test () result (res) + integer res + res = 0 +end function +end module diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/name_clash.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/name_clash.f90 new file mode 100644 index 000000000..7b8c0c7d1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/name_clash.f90 @@ -0,0 +1,9 @@ +! This is the testcase from PR13249. +! the two different entities named AN_EXAMPLE shouldn't conflict + MODULE MOD + INTEGER FOO + END + PROGRAM MAIN + USE MOD + COMMON /FOO/ BAR + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args.f90 new file mode 100644 index 000000000..1e0b4a673 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args.f90 @@ -0,0 +1,6 @@ +! This caused problems because we created a symbol for P while +! trying to parse the argument list as a substring reference. +program named_args + implicit none + integer, parameter :: realdp = selected_real_kind(p=8,r=30) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args_2.f90 new file mode 100644 index 000000000..c2d36eb58 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/named_args_2.f90 @@ -0,0 +1,8 @@ +! this is the reduced testcase from pr13372 +! we wrongly add a symbol "P" to the module +! Currently (2004/06/09) a workaround is in place +! PR 15481 tracks any steps towards a real fix. +module typeSizes +implicit none + integer, parameter :: FourByteReal = selected_real_kind(P = 6, R = 37) +end module typeSizes diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/nested.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/nested.f90 new file mode 100644 index 000000000..1059684dd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/nested.f90 @@ -0,0 +1,23 @@ +! Program to test the nested functions +program intrinsic_pack + integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/) + integer, dimension(3, 3) :: a + integer, dimension(6) :: b + + a = reshape (val, (/3, 3/)) + b = 0 + b(1:6:3) = pack (a, a .ne. 0); + if (any (b(1:6:3) .ne. (/9, 7/))) call abort + b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/)); + if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort + +contains + subroutine tests_with_temp + ! A few tests which involve a temporary + if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort + if (any (pack(a, .true.) .ne. val)) call abort + if (size(pack (a, .false.)) .ne. 0) call abort + if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort + + end subroutine tests_with_temp +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/noncontinuation_1.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/noncontinuation_1.f new file mode 100644 index 000000000..5921f014d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/noncontinuation_1.f @@ -0,0 +1,3 @@ +! verifies that 0 in column six doesn't start a continuation line +!234567890 + 0 END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_1.f90 new file mode 100644 index 000000000..8921bcddc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_1.f90 @@ -0,0 +1,7 @@ +! legal +integer, parameter :: j = huge(j) +integer i + + if (j /= huge(i)) call abort +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_2.f90 new file mode 100644 index 000000000..e480751f1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_2.f90 @@ -0,0 +1,23 @@ +! Program to test initialization expressions involving subobjects +program parameter_2 + implicit none + type :: SS + integer :: I + integer :: J + end type SS + type :: TT + integer :: N + type (SS), dimension(2) :: o + end type + + type (SS), parameter :: s = SS (1, 2) + type (TT), parameter :: t = TT(42, (/ SS(3, 4), SS(8, 9) /)) + + integer, parameter :: a(2) = (/5, 10/) + integer, parameter :: d1 = s%i + integer, parameter :: d2 = a(2) + integer, parameter :: d4 = t%o(2)%j + + integer q1, q2, q3, q4 + common /c1/q1(d1), q2(d2), q3(a(1)), q4(d4) ! legal +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_3.f90 new file mode 100644 index 000000000..4f5b0d90b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/parameter_3.f90 @@ -0,0 +1,4 @@ +program tst + write (6,"(a,es15.8)") "2.0**(-0.0) = ",2.0**(-0.0) +end program tst + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr24136.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr24136.f new file mode 100644 index 000000000..87e3c61e0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr24136.f @@ -0,0 +1,43 @@ + subroutine electra(ro,t,ye,ee,pe,se + a ,eer,eet,per,pet,ser,set,keyps) + implicit real*8 (a-h,o-z) + common /nunu/ nu,dnudr,dnudb,eta,detadnu,nup + data facen,facpr,facs,rg /2.037300d+24,1.358200d+24,1.686304d-10 + 1,8.314339d+07/ + data a1,a2,a3,a4 /2.059815d-03,-7.027778d-03 + 1,4.219747d-02,-1.132427d+00/ + beta=facs*t + b32=b12*beta + u=(f62/f52)**2 + dudnu=2.0d0*u*(df62/f62-df52/f52) + x=beta*u + f=1.0d0+x*(2.5d0+x*(2.0d0+0.5d0*x)) + df=2.5d0+x*(4.0d0+1.5d0*x) + dfdb=u*df + fi32=f32+(f-1.0d0)*f52/u + dfidnu=dfidu*dudnu+df32+(f-1.0d0)*df52/u + dfidb=dfdb*f52/u + dfidbet=dfidb+dfidnu*dnudb + gs=sqrt(g) + dg=0.75d0*gs + dgdb=u*dg + dgdu=beta*dg + gi32=f32+(g-1.0d0)*f52/u + dgidu=(u*dgdu-g+1.0d0)*f52/us + dgidnu=dgidu*dudnu+df32+(g-1.0d0)*df52/u + dgidb=dgdb*f52/u + dgidbet=dgidb+dgidnu*dnudb + dgidroe=dgidnu*dnudr + em=facen*b52*fi32 + demdbet=facen*b32*(2.5d0*fi32+beta*dfidbet) + dpmdbet=facpr*b32*(2.5d0*gi32+beta*dgidbet) + demdroe=facen*b52*dfidroe + dpmdroe=facpr*b52*dgidroe + call divine(nup,fp12,dfp12,s12) + s42=2.0d0 + call divine(nup,fp42,dfp42,s42) + eer=(ye*(demdroe+depdroe)-(em+ep)/ro)/ro + eet=facs*(demdbet+depdbet)/ro + per=ye*(dpmdroe+dppdroe) + pet=facs*(dpmdbet+dppdbet) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr26806.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr26806.f90 new file mode 100644 index 000000000..fad5e9d56 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr26806.f90 @@ -0,0 +1,11 @@ +module solv_cap + integer, private, save :: Ng1=0, Ng2=0 +contains + subroutine FourirG(G) + real, intent(in out), dimension(0:,0:) :: G + complex, allocatable, dimension(:,:) :: t + allocate( t(0:2*Ng1-1,0:2*Ng2-1) ) + t(0:Ng1,0:Ng2-1) = G(:,0:Ng2-1) ! Fill one quadrant (one extra row) + t(0:Ng1,Ng2:2*Ng2-1) = G(:,Ng2:1:-1) ! This quadrant using symmetry + end subroutine FourirG +end module solv_cap diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr30147.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr30147.f90 new file mode 100644 index 000000000..b9c1533d5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr30147.f90 @@ -0,0 +1,14 @@ +MODULE input_cp2k_motion + IMPLICIT NONE + interface + SUBROUTINE keyword_create(variants) + CHARACTER(len=*), DIMENSION(:), & + INTENT(in) :: variants + end subroutine + end interface +CONTAINS + SUBROUTINE create_neb_section() + CALL keyword_create(variants=(/"K"/)) + END SUBROUTINE create_neb_section +END MODULE input_cp2k_motion + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32417.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32417.f90 new file mode 100644 index 000000000..913ce9498 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32417.f90 @@ -0,0 +1,15 @@ +! PR tree-opt/32417 +! this used to crash while running IV-opts +! aff_combination_add_elt was not ready to handle pointers correctly + +SUBROUTINE ONEINTS() + COMMON /INFOA / NAT,NUM + DIMENSION TINT(NUM*NUM,NAT,3,3,3),TINTM(NUM,NUM,NAT,3,3,3) + + CALL TINTS(IC) + DO ID=1,3 + DO IC=1,NAT + TINTM(J,I,IC,IAN,INU,ID) = TINT((I-1)*NUM+J,IC,IAN,INU,ID) + ENDDO + ENDDO +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32583.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32583.f new file mode 100644 index 000000000..61c9d98b8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32583.f @@ -0,0 +1,40 @@ + subroutine detune(iv,ekk,ep,beta,dtu,dtup,dfac) + implicit real*8 (a-h,o-z) + parameter(npart=64,nmac=1) + parameter(nele=700,nblo=300,nper=16, + &nelb=100,nblz=20000,nzfz=300000,mmul=11) + parameter(nran=280000,ncom=100,mran=500,mpa=6,nrco=5,nema=15) + parameter(mcor=10) + parameter(npos=20000,nlya=10000,ninv=1000,nplo=20000) + parameter(nmon1=600,ncor1=600) + parameter(pieni=1d-17) + parameter(zero=0.0d0,half=0.5d0,one=1.0d0) + parameter(two=2.0d0,three=3.0d0,four=4.0d0) + dimension dfac(10),dtu(2,5),ep(2),beta(2),dtup(2,5,0:4,0:4) + save + pi=four*atan(one) + iv2=2*iv + iv3=iv+1 + vtu1=-ekk*(half**iv2)*dfac(iv2)/pi + dtu1=zero + dtu2=zero + do 10 iv4=1,iv3 + iv5=iv4-1 + iv6=iv-iv5 + vor=one + if(mod(iv6,2).ne.0) vor=-one + vtu2=vor/(dfac(iv5+1)**2)/(dfac(iv6+1)**2)*(beta(1)**iv5)* (beta + + (2)**iv6) + if(iv5.ne.0) then + dtu1=dtu1+vtu2*iv5*(ep(1)**(iv5-1))*(ep(2)**iv6) + dtup(1,iv,iv5-1,iv6)=dtup(1,iv,iv5-1,iv6)+vtu2*iv5*vtu1 + endif + if(iv6.ne.0) then + dtu2=dtu2+vtu2*iv6*(ep(1)**iv5)*(ep(2)**(iv6-1)) + dtup(2,iv,iv5,iv6-1)=dtup(2,iv,iv5,iv6-1)+vtu2*iv6*vtu1 + endif + 10 continue + dtu(1,iv)=dtu(1,iv)+vtu1*dtu1 + dtu(2,iv)=dtu(2,iv)+vtu1*dtu2 + return + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32663.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32663.f new file mode 100644 index 000000000..03896adab --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr32663.f @@ -0,0 +1,147 @@ + SUBROUTINE DIMOID(DEN,RLMO,SSQU,STRI,ATMU,IATM,IWHI,MAPT,INAT, + * IATB,L1,L2,M1,M2,NATS,NOSI,NCAT,NSWE) +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +C + DIMENSION RLMO(L1,L1),SSQU(L1,L1),STRI(L2),ATMU(NATS),DEN(M2) + DIMENSION IATM(NATS,M1),IWHI(M1+NATS),MAPT(M1),INAT(M1+NATS) + DIMENSION IATB(NATS,M1) +C + PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, MXAO=2047) +C + LOGICAL GOPARR,DSKWRK,MASWRK +C + COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB, + * ZAN(MXATM),C(3,MXATM) + COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(400) + COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT), + * CF(MXGTOT),CG(MXGTOT), + * KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH), + * KNG(MXSH),KLOC(MXSH),KMIN(MXSH), + * KMAX(MXSH),NSHELL + COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB, + * MOOUTA(MXAO),MOOUTB(MXAO) + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK + COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO) +C +C + DO 920 II=1,M1 + INAT(II) = 0 + 920 CONTINUE +C + + DO 900 IO = NOUTA+1,NUMLOC + IZ = IO - NOUTA + DO 895 II=NST,NEND + ATMU(II) = 0.0D+00 + IATM(II,IZ) = 0 + 895 CONTINUE + IFUNC = 0 + DO 890 ISHELL = 1,NSHELL + IAT = KATOM(ISHELL) + IST = KMIN(ISHELL) + IEN = KMAX(ISHELL) + DO 880 INO = IST,IEN + IFUNC = IFUNC + 1 + IF (IAT.LT.NST.OR.IAT.GT.NEND) GOTO 880 + ZINT = 0.0D+00 + DO 870 II = 1,L1 + ZINT = ZINT + RLMO(II,IO)*SSQU(II,IFUNC) + 870 CONTINUE + ATMU(IAT) = ATMU(IAT) + RLMO(IFUNC,IO)*ZINT + 880 CONTINUE + 890 CONTINUE + IF (MASWRK) WRITE(IW,9010) IZ,(ATMU(II),II=NST,NEND) + 900 CONTINUE +C + NOSI = 0 + DO 700 II=1,M1 + NO=0 + DO 720 JJ=1,NAT + NO = NO + 1 + 720 CONTINUE + 740 CONTINUE + IF (NO.GT.1.OR.NO.EQ.0) THEN + NOSI = NOSI + 1 + IWHI(NOSI) = II + ENDIF + IF (MASWRK) + * WRITE(IW,9030) II,(IATM(J,II),A(IATM(J,II)),J=1,NO) + 700 CONTINUE +C + IF (MASWRK) THEN + WRITE(IW,9035) NOSI + IF (NOSI.GT.0) THEN + WRITE(IW,9040) (IWHI(I),I=1,NOSI) + WRITE(IW,9040) + ELSE + WRITE(IW,9040) + ENDIF + ENDIF +C + CALL DCOPY(L1*L1,RLMO,1,SSQU,1) + CALL DCOPY(M2,DEN,1,STRI,1) +C + IP2 = NOUTA + IS2 = M1+NOUTA-NOSI + DO 695 II=1,NAT + INAT(II) = 0 + 695 CONTINUE +C + DO 690 IAT=1,NAT + DO 680 IORB=1,M1 + IP1 = IORB + NOUTA + IF (IATM(1,IORB).NE.IAT) GOTO 680 + IF (IATM(2,IORB).NE.0) GOTO 680 + INAT(IAT) = INAT(IAT) + 1 + IP2 = IP2 + 1 + CALL DCOPY(L1,SSQU(1,IP1),1,RLMO(1,IP2),1) + CALL ICOPY(NAT,IATM(1,IORB),1,IATB(1,IP2-NOUTA),1) + MAPT(IORB) = IP2-NOUTA + 680 CONTINUE + DO 670 IORB=1,NOSI + IS1 = IWHI(IORB) + NOUTA + IF (IAT.EQ.NAT.AND.IATM(1,IWHI(IORB)).EQ.0) GOTO 675 + IF (IATM(1,IWHI(IORB)).NE.IAT) GOTO 670 + 675 CONTINUE + IS2 = IS2 + 1 + MAPT(IWHI(IORB)) = IS2-NOUTA + 670 CONTINUE + 690 CONTINUE +C + NSWE = 0 + NCAT = 0 + LASP = 1 + NLAST = 0 + DO 620 II=1,NAT + NSWE = NSWE + (IWHI(II)*(IWHI(II)-1))/2 + NCAT = NCAT + 1 + INAT(NCAT) = LASP + NLAST + LASP = INAT(NCAT) + NLAST = IWHI(II) + IWHI(NCAT) = II + 620 CONTINUE +C + DO 610 II=1,NOSI + NCAT = NCAT + 1 + INAT(NCAT) = LASP + NLAST + LASP = INAT(NCAT) + NLAST = 1 + IWHI(NCAT) = 0 + 610 CONTINUE +C + RETURN +C + 8000 FORMAT(/1X,'** MULLIKEN ATOMIC POPULATIONS FOR EACH NON-FROZEN ', + * 'LOCALIZED ORBITAL **') + 9000 FORMAT(/3X,'ATOM',2X,100(I2,1X,A4)) + 9005 FORMAT(1X,'LMO') + 9010 FORMAT(1X,I3,3X,100F7.3) + 9015 FORMAT(/1X,'** ATOMIC POPULATIONS GREATER THAN ',F4.2, + * ' ARE CONSIDERED MAJOR **') + 9020 FORMAT(/2X,'LMO',3X,'MAJOR CONTRIBUTIONS FROM ATOM(S)') + 9030 FORMAT(2X,I3,2X,100(I2,1X,A2,2X)) + 9035 FORMAT(/1X,'NO OF LMOS INVOLVING MORE THAN ONE ATOM =',I3) + 9040 FORMAT(1X,'THESE ARE LMOS :',100I3) +C + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr33276.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr33276.f90 new file mode 100644 index 000000000..0eaac1a49 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr33276.f90 @@ -0,0 +1,27 @@ +! PR fortran/33276 +! this used to crash due to an uninitialized variable in expand_iterator. + +module foo + type buffer_type + integer(kind=kind(1)) :: item_end + character(256) :: string + end type + type textfile_type + type(buffer_type) :: buffer + end type +contains + function rest_of_line(self) result(res) + type(textfile_type) :: self + intent(inout) :: self + character(128) :: res + res = self%buffer%string(self%buffer%item_end+1: ) + end function + + subroutine read_intvec_ptr(v) + integer(kind=kind(1)), dimension(:), pointer :: v + integer(kind=kind(1)) :: dim,f,l,i + + if (dim>0) then; v = (/ (i, i=f,l) /) + end if + end subroutine +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr36078.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr36078.f90 new file mode 100644 index 000000000..b7f0aa3c3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr36078.f90 @@ -0,0 +1,22 @@ + subroutine foo(func,p,eval) + real(kind=kind(1.0d0)), dimension(3,0:4,0:4,0:4) :: p + logical(kind=kind(.true.)), dimension(5,5,5) :: eval + interface + subroutine func(values,pt) + real(kind=kind(1.0d0)), dimension(:), intent(out) :: values + real(kind=kind(1.0d0)), dimension(:,:), intent(in) :: pt + end subroutine + end interface + real(kind=kind(1.0d0)), dimension(125,3) :: pt + integer(kind=kind(1)) :: n_pt + + n_pt = 1 + pt(1:n_pt,:) = & + reshape( & + pack( & + transpose(reshape(p,(/3,125/))), & + spread(reshape(eval,(/125/)),dim=2,ncopies=3)), & + (/n_pt,3/)) + + end subroutine + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr37236.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr37236.f new file mode 100644 index 000000000..8f7cc3695 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr37236.f @@ -0,0 +1,82 @@ +C + SUBROUTINE FFTRC (A,N,X,IWK,WK) +C SPECIFICATIONS FOR ARGUMENTS + INTEGER N,IWK(1) + REAL*8 A(N),WK(1) + COMPLEX*16 X(1) +C SPECIFICATIONS FOR LOCAL VARIABLES + INTEGER ND2P1,ND2,I,MTWO,M,IMAX,ND4,NP2,K,NMK,J + REAL*8 RPI,ZERO,ONE,HALF,THETA,TP,G(2),B(2),Z(2),AI, + 1 AR + COMPLEX*16 XIMAG,ALPH,BETA,GAM,S1,ZD + EQUIVALENCE (GAM,G(1)),(ALPH,B(1)),(Z(1),AR),(Z(2),AI), + 1 (ZD,Z(1)) + DATA ZERO/0.0D0/,HALF/0.5D0/,ONE/1.0D0/,IMAX/24/ + DATA RPI/3.141592653589793D0/ +C FIRST EXECUTABLE STATEMENT + IF (N .NE. 2) GO TO 5 +C N EQUAL TO 2 + ZD = DCMPLX(A(1),A(2)) + THETA = AR + TP = AI + X(2) = DCMPLX(THETA-TP,ZERO) + X(1) = DCMPLX(THETA+TP,ZERO) + GO TO 9005 + 5 CONTINUE +C N GREATER THAN 2 + ND2 = N/2 + ND2P1 = ND2+1 +C MOVE A TO X + J = 1 + DO 6 I=1,ND2 + X(I) = DCMPLX(A(J),A(J+1)) + J = J+2 + 6 CONTINUE +C COMPUTE THE CENTER COEFFICIENT + GAM = DCMPLX(ZERO,ZERO) + DO 10 I=1,ND2 + GAM = GAM + X(I) + 10 CONTINUE + TP = G(1)-G(2) + GAM = DCMPLX(TP,ZERO) +C DETERMINE THE SMALLEST M SUCH THAT +C N IS LESS THAN OR EQUAL TO 2**M + MTWO = 2 + M = 1 + DO 15 I=1,IMAX + IF (ND2 .LE. MTWO) GO TO 20 + MTWO = MTWO+MTWO + M = M+1 + 15 CONTINUE + 20 IF (ND2 .EQ. MTWO) GO TO 25 +C N IS NOT A POWER OF TWO, CALL FFTCC + CALL FFTCC (X,ND2,IWK,WK) + GO TO 30 +C N IS A POWER OF TWO, CALL FFT2C + 25 CALL FFT2C (X,M,IWK) + 30 ALPH = X(1) + X(1) = B(1) + B(2) + ND4 = (ND2+1)/2 + IF (ND4 .LT. 2) GO TO 40 + NP2 = ND2 + 2 + THETA = RPI/ND2 + TP = THETA + XIMAG = DCMPLX(ZERO,ONE) +C DECOMPOSE THE COMPLEX VECTOR X +C INTO THE COMPONENTS OF THE TRANSFORM +C OF THE INPUT DATA. + DO 35 K = 2,ND4 + NMK = NP2 - K + S1 = DCONJG(X(NMK)) + ALPH = X(K) + S1 + BETA = XIMAG*(S1-X(K)) + S1 = DCMPLX(DCOS(THETA),DSIN(THETA)) + X(K) = (ALPH+BETA*S1)*HALF + X(NMK) = DCONJG(ALPH-BETA*S1)*HALF + THETA = THETA + TP + 35 CONTINUE + 40 CONTINUE + X(ND2P1) = GAM + 9005 RETURN + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f new file mode 100644 index 000000000..5ead135d8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f @@ -0,0 +1,28 @@ + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) + DOUBLE PRECISION X( 2, 2 ) + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ ZERO, X, 2, SCALE, XNORM, IERR ) + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + END IF + END IF + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ XNORM, IERR ) + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40413.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40413.f90 new file mode 100644 index 000000000..d8fa73d69 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40413.f90 @@ -0,0 +1,46 @@ +module state_matrices + + implicit none + private + + public :: state_matrix_copy + public :: state_matrix_t + public :: matrix_element_t + + type :: matrix_element_t + private + integer, dimension(:), allocatable :: f + end type matrix_element_t + + type :: state_matrix_t + private + type(matrix_element_t), dimension(:), allocatable :: me + end type state_matrix_t + + type :: polarization_t + logical :: polarized = .false. + integer :: spin_type = 0 + integer :: multiplicity = 0 + type(state_matrix_t) :: state + end type polarization_t + +contains + + function polarization_copy (pol_in) result (pol) + type(polarization_t) :: pol + type(polarization_t), intent(in) :: pol_in + !!! type(state_matrix_t) :: state_dummy + pol%polarized = pol_in%polarized + pol%spin_type = pol_in%spin_type + pol%multiplicity = pol_in%multiplicity + !!! state_dummy = state_matrix_copy (pol_in%state) + !!! pol%state = state_dummy + pol%state = state_matrix_copy (pol_in%state) + end function polarization_copy + + function state_matrix_copy (state_in) result (state) + type(state_matrix_t) :: state + type(state_matrix_t), intent(in), target :: state_in + end function state_matrix_copy + +end module state_matrices diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f new file mode 100644 index 000000000..de7664ce6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f @@ -0,0 +1,18 @@ + SUBROUTINE VROT2(N,DIS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER(ZERO=0.0D+00) + COMMON /SYMSPD/ PTR(3,144) + DIMENSION DIS(3,2),TMP(3,2) + DO I = 1,3 + TMP1 = ZERO + DO J = 1,3 + TMP1 = TMP1 + PTR(I,N+J) + END DO + TMP(I,1) = TMP1 + END DO + DO I = 1,3 + DIS(I,1) = TMP(I,1) + END DO + RETURN + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f90 new file mode 100644 index 000000000..64b129efc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr40421.f90 @@ -0,0 +1,15 @@ +subroutine pr40421 (j, q, r) + double precision :: q(1,1), r(1,1,3) + save + integer :: i, j, m, n + double precision :: s, t, u + do i=1,2 + do m=1,j + do n=1,1 + s=q(n,m)*r(n,m,1) + t=q(n,m)*r(n,m,2) + u=q(n,m)*r(n,m,3) + end do + end do + end do +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr41654.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr41654.f90 new file mode 100644 index 000000000..aa61905de --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr41654.f90 @@ -0,0 +1,15 @@ +SUBROUTINE SCANBUFR (LBUFRIGNOREERROR, LBOPRPRO, LLSPLIT) +LOGICAL :: LBUFRIGNOREERROR, LBOPRPRO, LLSPLIT +INTEGER :: IBOTYP, IBSTYP +IF ((IBOTYP.eq.0).AND.(IBSTYP.eq.1)) GO TO 251 +IF ((IBOTYP.eq.0).AND.(IBSTYP.eq.3)) GO TO 251 +IF(LBUFRIGNOREERROR) THEN + goto 360 +ENDIF +251 CONTINUE +IF(LBOPRPRO.AND.LLSPLIT) THEN + CALL OBSCREEN +ENDIF +360 CONTINUE +END SUBROUTINE SCANBUFR + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr42781.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr42781.f90 new file mode 100644 index 000000000..952285063 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr42781.f90 @@ -0,0 +1,59 @@ +! ICE with gfortran 4.5 at -O1: +!gfcbug98.f90: In function ‘convert_cof’: +!gfcbug98.f90:36:0: internal compiler error: in pt_solutions_same_restrict_base, +!at tree-ssa-structalias.c:5072 +module foo + implicit none + type t_time + integer :: secs = 0 + end type t_time +contains + elemental function time_cyyyymmddhh (cyyyymmddhh) result (time) + type (t_time) :: time + character(len=10),intent(in) :: cyyyymmddhh + end function time_cyyyymmddhh + + function nf90_open(path, mode, ncid) + character(len = *), intent(in) :: path + integer, intent(in) :: mode + integer, intent(out) :: ncid + integer :: nf90_open + end function nf90_open +end module foo +!============================================================================== +module gfcbug98 + use foo + implicit none + + type t_fileinfo + character(len=10) :: atime = ' ' + end type t_fileinfo + + type t_body + real :: bg(10) + end type t_body +contains + subroutine convert_cof (ifile) + character(len=*) ,intent(in) :: ifile + + character(len=5) :: version + type(t_fileinfo) :: gattr + type(t_time) :: atime + type(t_body),allocatable :: tmp_dat(:) + real ,allocatable :: BDA(:, :, :) + + call open_input + call convert_data + contains + subroutine open_input + integer :: i,j + version = '' + j = nf90_open(ifile, 1, i) + end subroutine open_input + !-------------------------------------------------------------------------- + subroutine convert_data + BDA(1,:,1) = tmp_dat(1)% bg(:) + atime = time_cyyyymmddhh (gattr% atime) + end subroutine convert_data + end subroutine convert_cof +end module gfcbug98 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45598.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45598.f90 new file mode 100644 index 000000000..b8a883e53 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45598.f90 @@ -0,0 +1,13 @@ +program main +implicit none +character(len=10) :: digit_string = '123456789' +character :: digit_arr(10) +call copy(digit_string, digit_arr) +print '(1x, a1)',digit_arr(1:9) +contains + subroutine copy(in, out) + character, dimension(10) :: in, out + out(1:10) = in(1:10) + end subroutine copy +end program main + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45634.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45634.f90 new file mode 100644 index 000000000..ab0c33ad3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45634.f90 @@ -0,0 +1,5 @@ + SUBROUTINE RCRDRD (VTYP) + CHARACTER(4), INTENT(OUT) :: VTYP + CHARACTER(1), SAVE :: DBL = "D" + VTYP = DBL + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45738.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45738.f90 new file mode 100644 index 000000000..b0541e357 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr45738.f90 @@ -0,0 +1,11 @@ +PROGRAM TestInfinite + integer(8) :: bit_pattern_NegInf_i8 = -4503599627370496_8 + + integer(8) :: i + real(8) :: r + + r = transfer(bit_pattern_NegInf_i8_p,r) + i = transfer(r,i) + +END PROGRAM TestInfinite + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr49721-1.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr49721-1.f new file mode 100644 index 000000000..9ddd068cb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr49721-1.f @@ -0,0 +1,9 @@ + PARAMETER( LM=7 ) + PARAMETER( NM=2+2**LM, NV=NM**3 ) + PARAMETER( NR = (8*(NM**3+NM**2+5*NM-23+7*LM))/7 ) + COMMON /X/ U, V, R, A + REAL*8 U(NR),V(NV),R(NR),A(0:3) + DO 20 IT=1,NIT + CALL RESID(U,V,R,N,A) + 20 CONTINUE + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr57517.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr57517.f90 new file mode 100644 index 000000000..f32698aa3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/pr57517.f90 @@ -0,0 +1,13 @@ +SUBROUTINE cal_helicity (uh, ph, phb, wavg, ims, ime, its, ite) + INTEGER, INTENT( IN ) :: ims, ime, its, ite + REAL, DIMENSION( ims:ime), INTENT( IN ) :: ph, phb, wavg + REAL, DIMENSION( ims:ime), INTENT( INOUT ) :: uh + INTEGER :: i + REAL :: zu + DO i = its, ite + zu = (ph(i ) + phb(i)) + (ph(i-1) + phb(i-1)) + IF (wavg(i) .GT. 0) THEN + uh(i) = uh(i) + zu + ENDIF + END DO +END SUBROUTINE cal_helicity diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/shape_reshape.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/shape_reshape.f90 new file mode 100644 index 000000000..a8e632b1f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/shape_reshape.f90 @@ -0,0 +1,8 @@ +! This checks that the shape of the SHAPE intrinsic is known. +PROGRAM shape_reshape + INTEGER, ALLOCATABLE :: I(:,:) + ALLOCATE(I(2,2)) + I = RESHAPE((/1,2,3,4/),SHAPE=SHAPE(I)) + DEALLOCATE(I) +END PROGRAM + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/stoppause.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/stoppause.f90 new file mode 100644 index 000000000..9a936f09c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/stoppause.f90 @@ -0,0 +1,10 @@ +! Program to check the STOP and PAUSE intrinsics +program stoppause + + pause + pause 1 + pause 'Hello world' + stop + stop 42 + stop 'Go away' +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/strparm_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/strparm_1.f90 new file mode 100644 index 000000000..9625b10fe --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/strparm_1.f90 @@ -0,0 +1,6 @@ +! Check known length string parameters +subroutine test (s) + character(len=80) :: s + + s = "Hello World" +end subroutine diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/transfer-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/transfer-1.f90 new file mode 100644 index 000000000..9fa4bfc34 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/transfer-1.f90 @@ -0,0 +1,22 @@ +! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005. + integer(1), parameter :: zero = 0 + LOGICAL, PARAMETER :: bigend = IACHAR(TRANSFER(1,"a")) == zero + LOGICAL :: bigendian + call foo () +contains + subroutine foo () + integer :: chr, ans + if (bigend) then + ans = 1 + else + ans = 0 + end if + chr = IACHAR(TRANSFER(1,"a")) + bigendian = chr == 0_4 + if (bigendian) then + ans = 1 + else + ans = 0 + end if + end subroutine foo +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/vrp_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/vrp_1.f90 new file mode 100644 index 000000000..a8d0c295c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/vrp_1.f90 @@ -0,0 +1,17 @@ + SUBROUTINE STONUM(STRVAR,LENGTH) + CHARACTER STRVAR*(*) , CHK + LOGICAL MEND , NMARK , MMARK , EMARK + NMARK = .FALSE. + MMARK = .FALSE. + DO WHILE ( .NOT.MEND ) + IF ( CHK.GE.'0' .AND. CHK.LE.'9' ) THEN + IF ( CHK.EQ.'E' ) THEN + NMARK = .TRUE. + ELSEIF ( .NOT.MMARK .AND. CHK.EQ.'*' .AND. .NOT.NMARK ) & + & THEN + MMARK = .TRUE. + ENDIF + ENDIF + ENDDO + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/write.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/write.f90 new file mode 100644 index 000000000..50b83cc6a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/compile/write.f90 @@ -0,0 +1,5 @@ +! Program to test simple IO +program testwrite + write (*) 1 + write (*) "Hello World" +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 new file mode 100644 index 000000000..55a6f3cdf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/a_edit_1.f90 @@ -0,0 +1,17 @@ +! pr 15113 +! Ax edit descriptor x larger than destination +! A edit descriptor with no field width segfaults + character*16 C + character*4 D + data C / 'ABCDEFGHIJKLMNOP'/ + read(C,'(A7)')D + if (D.NE.'DEFG') then +! print*,D + call abort + endif + read(C,'(A)')D + if (D.NE.'ABCD') then +! print*,D + call abort + endif + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/adjustr.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/adjustr.f90 new file mode 100644 index 000000000..8264ba7f8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/adjustr.f90 @@ -0,0 +1,46 @@ +! pr 15294 - [gfortran] ADJUSTR intrinsic accesses corrupted pointer +! + program test_adjustr + implicit none + integer test_cases + parameter (test_cases=13) + integer i + character(len=10) s1(test_cases), s2(test_cases) + s1(1)='A' + s2(1)=' A' + s1(2)='AB' + s2(2)=' AB' + s1(3)='ABC' + s2(3)=' ABC' + s1(4)='ABCD' + s2(4)=' ABCD' + s1(5)='ABCDE' + s2(5)=' ABCDE' + s1(6)='ABCDEF' + s2(6)=' ABCDEF' + s1(7)='ABCDEFG' + s2(7)=' ABCDEFG' + s1(8)='ABCDEFGH' + s2(8)=' ABCDEFGH' + s1(9)='ABCDEFGHI' + s2(9)=' ABCDEFGHI' + s1(10)='ABCDEFGHIJ' + s2(10)='ABCDEFGHIJ' + s1(11)='' + s2(11)='' + s1(12)=' ' + s2(12)=' ' + s1(13)=' ' + s2(13)=' ' + do I = 1,test_cases + print*,i + print*, 's1 = "', s1(i), '"' + print*, 's2 = "', s2(i), '"' + print*, 'adjustr(s1) = "', adjustr(s1(i)), '"' + if (adjustr(s1(i)).ne.s2(i)) then + print*,'fail' + call abort + endif + enddo + + end program test_adjustr diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 new file mode 100644 index 000000000..61f717da7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/allocate.f90 @@ -0,0 +1,38 @@ +! Test allocation and deallocation. +program test_allocate + call t1 (.true.) + call t1 (.false.) + call t2 +contains + +! Implicit deallocation and saved aloocated variables. +subroutine t1(first) + real, allocatable, save :: p(:) + real, allocatable :: q(:) + logical first + + if (first) then + if (allocated (p)) call abort () + else + if (.not. allocated (p)) call abort () + end if + if (allocated (q)) call abort () + + if (first) then + allocate (p(5)) + else + deallocate (p) + end if + allocate (q(5)) +end subroutine + +! Explicit deallocation. +subroutine t2() + real, allocatable :: r(:) + + allocate (r(5)) + pr = 1.0 + deallocate (r) + if (allocated(r)) call abort () +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 new file mode 100644 index 000000000..5c77844e6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/alternate_return.f90 @@ -0,0 +1,18 @@ +program alt_return + implicit none + + call myproc (1, *10, 42) +20 continue + call abort () +10 continue + call myproc(2, *20, 42) + call myproc(3, *20, 42) +contains +subroutine myproc(n, *, i) + integer n, i + if (i .ne. 42) call abort () + if (n .eq. 1) return 1 + if (n .eq. 2) return +end subroutine +end program alt_return + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 new file mode 100644 index 000000000..263c795ed --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/args.f90 @@ -0,0 +1,22 @@ +! Program to test procudure args +subroutine test (a, b) + integer, intent (IN) :: a + integer, intent (OUT) :: b + + if (a .ne. 42) call abort + b = 43 +end subroutine + +program args + implicit none + external test + integer i, j + + i = 42 + j = 0 + CALL test (i, j) + if (i .ne. 42) call abort + if (j .ne. 43) call abort + i = 41 + CALL test (i + 1, j) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 new file mode 100644 index 000000000..d06167e68 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arithmeticif.f90 @@ -0,0 +1,25 @@ +! Program to test the arithmetic if statement +function testif (a) + implicit none + integer a, b, testif + + if (a) 1, 2, 3 + b = 2 + goto 4 + 1 b = -1 + goto 4 + 2 b = 0 + goto 4 + 3 b = 1 + 4 testif = b +end function + +program testwrite + implicit none + integer i + integer testif + + if (testif (-10) .ne. -1) call abort + if (testif (0) .ne. 0) call abort + if (testif (10) .ne. 1) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 new file mode 100644 index 000000000..b588d050b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg.f90 @@ -0,0 +1,145 @@ +! Program to test arrays +! The program outputs a series of numbers. +! Two digit numbers beginning with 0, 1, 2 or 3 is a normal. +! Three digit numbers starting with 4 indicate an error. +! Using 1D arrays isn't a sufficient test, the first dimension is often +! handled specially. + +! Fixed size parameter +subroutine f1 (a) + implicit none + integer, dimension (5, 8) :: a + + if (a(1, 1) .ne. 42) call abort + + if (a(5, 8) .ne. 43) call abort +end subroutine + + +program testprog + implicit none + integer, dimension(3:7, 4:11) :: a + a(:,:) = 0 + a(3, 4) = 42 + a(7, 11) = 43 + call test(a) +contains +subroutine test (parm) + implicit none + ! parameter + integer, dimension(2:, 3:) :: parm + ! Known size arry + integer, dimension(5, 8) :: a + ! Known size array with different bounds + integer, dimension(4:8, 3:10) :: b + ! Unknown size arrays + integer, dimension(:, :), allocatable :: c, d, e + ! Vectors + integer, dimension(5) :: v1 + integer, dimension(10, 10) :: v2 + integer n + external f1 + + ! Same size + allocate (c(5,8)) + ! Same size, different bounds + allocate (d(11:15, 12:19)) + ! A larger array + allocate (e(15, 24)) + a(:,:) = 0 + b(:,:) = 0 + c(:,:) = 0 + d(:,:) = 0 + a(1,1) = 42 + b(4, 3) = 42 + c(1,1) = 42 + d(11,12) = 42 + a(5, 8) = 43 + b(8, 10) = 43 + c(5, 8) = 43 + d(15, 19) = 43 + + v2(:, :) = 0 + do n=1,5 + v1(n) = n + end do + + v2 (3, 1::2) = v1 (5:1:-1) + v1 = v1 + 1 + + if (v1(1) .ne. 2) call abort + if (v2(3, 3) .ne. 4) call abort + + ! Passing whole arrays + call f1 (a) + call f1 (b) + call f1 (c) + call f2 (a) + call f2 (b) + call f2 (c) + ! passing expressions + a(1,1) = 41 + a(5,8) = 42 + call f1(a+1) + call f2(a+1) + a(1,1) = 42 + a(5,8) = 43 + call f1 ((a + b) / 2) + call f2 ((a + b) / 2) + ! Passing whole arrays as sections + call f1 (a(:,:)) + call f1 (b(:,:)) + call f1 (c(:,:)) + call f2 (a(:,:)) + call f2 (b(:,:)) + call f2 (c(:,:)) + ! Passing sections + e(:,:) = 0 + e(2, 3) = 42 + e(6, 10) = 43 + n = 3 + call f1 (e(2:6, n:10)) + call f2 (e(2:6, n:10)) + ! Vector subscripts + ! v1= index plus one, v2(3, ::2) = reverse of index + e(:,:) = 0 + e(2, 3) = 42 + e(6, 10) = 43 + call f1 (e(v1, n:10)) + call f2 (e(v1, n:10)) + ! Double vector subscript + e(:,:) = 0 + e(6, 3) = 42 + e(2, 10) = 43 + !These are not resolved properly + call f1 (e(v1(v2(3, ::2)), n:10)) + call f2 (e(v1(v2(3, ::2)), n:10)) + ! non-contiguous sections + e(:,:) = 0 + e(1, 1) = 42 + e(13, 22) = 43 + n = 3 + call f1 (e(1:15:3, 1:24:3)) + call f2 (e(::3, ::n)) + ! non-contiguous sections with bounds + e(:,:) = 0 + e(3, 4) = 42 + e(11, 18) = 43 + n = 19 + call f1 (e(3:11:2, 4:n:2)) + call f2 (e(3:11:2, 4:n:2)) + + ! Passing a dummy variable + call f1 (parm) + call f2 (parm) +end subroutine +! Assumed shape parameter +subroutine f2 (a) + integer, dimension (1:, 1:) :: a + + if (a(1, 1) .ne. 42) call abort + + if (a(5, 8) .ne. 43) call abort +end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 new file mode 100644 index 000000000..9cb5b613d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arrayarg2.f90 @@ -0,0 +1,21 @@ +! Program to test array arguments which depend on other array arguments +program arrayarg2 + integer, dimension(5) :: a, b + + a = (/1, 2, 3, 4, 5/) + b = (/2, 3, 4, 5, 6/) + + call test (a, b) + + if (any (b .ne. (/4, 7, 10, 13, 16/))) call abort +contains +subroutine test (x1, x2) + implicit none + integer, dimension(1:), intent(in) :: x1 + integer, dimension(1:), intent(inout) :: x2 + integer, dimension(1:size(x1)) :: x3 + + x3 = x1 * 2 + x2 = x2 + x3 +end subroutine test +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 new file mode 100644 index 000000000..94b234bd5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/arraysave.f90 @@ -0,0 +1,24 @@ +! Program to test arrays with the save attribute +program testarray + implicit none + integer, save, dimension (6, 5) :: a, b + + a = 0 + a(1, 1) = 42 + a(6, 5) = 43 + b(:,1:5) = a + + call fn (a) +contains +subroutine fn (a) + implicit none + integer, dimension(1:, 1:) :: a + integer, dimension(2) :: b + + b = ubound (a) + if (any (b .ne. (/6, 5/))) call abort + if (a(1, 1) .ne. 42) call abort + if (a(6, 5) .ne. 43) call abort +end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 new file mode 100644 index 000000000..b2c4657c6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/assumed_size.f90 @@ -0,0 +1,39 @@ +! Program to test assumed size arrays +subroutine test2(p) + integer, dimension(2, *) :: p + + if (any (p(:, 1:3) .ne. reshape((/1, 2, 4, 5, 7, 8/), (/2, 3/)))) & + call abort () +end subroutine + +program assumed_size + integer, dimension (3, 3) :: a + external test2 + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + + call test1(a, (/1, 2, 3, 4, 5, 6/)) + if (a(1,1) .ne. 0) call abort + a(1, 1) = 1 + call test1(a(1:2, :), (/1, 2, 4, 5, 7, 8/)) + if (a(1,1) .ne. 0) call abort + a(1, 1) = 1 + call test1(a(3:1:-1, :), (/3, 2, 1, 6, 5, 4/)) + if (a(3,1) .ne. 0) call abort + a(3, 1) = 3 + call test1(a(:, 2:3), (/4, 5, 6, 7, 8, 9/)) + if (a(1, 2) .ne. 0) call abort + a(1, 2) = 4 + + call test2(a(1:2, :)) + call test2((/1, 2, 4, 5, 7, 8/)) +contains +subroutine test1(p, q) + integer, dimension(*) :: p + integer, dimension(1:) :: q + + if (any (p(1:size(q)) .ne. q)) call abort () + p(1) = 0 +end subroutine + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.f90 new file mode 100644 index 000000000..8781fb2c9 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.f90 @@ -0,0 +1,14 @@ +! pr 15755 + implicit none + character*1 C + open(10) + write(10,*)'a' + write(10,*)'b' + write(10,*)'c' + rewind(10) + read(10,*)C + backspace(10) + read(10,*) C + if (C.ne.'a') call abort + close(10,STATUS='DELETE') + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/backspace.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 new file mode 100644 index 000000000..894cd5d56 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/bounds.f90 @@ -0,0 +1,38 @@ +! Program to test the upper and lower bound intrinsics +program testbounds + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(5) :: j + integer i + + ! Check compile time simplification + if (lbound(j,1).ne.1 .or. ubound(j,1).ne.5) call abort () + + allocate (a(3:8, 6:7)) + + ! With one parameter + j = 0; + j(3:4) = ubound(a) + if (j(3) .ne. 8) call abort + if (j(4) .ne. 7) call abort + + ! With two parameters, assigning to an array + j = lbound(a, 1) + if ((j(1) .ne. 3) .or. (j(5) .ne. 3)) call abort + + ! With a variable second parameter + i = 2 + i = lbound(a, i) + if (i .ne. 6) call abort + + call test(a) +contains +subroutine test (a) + real, dimension (1:, 1:) :: a + integer i + + i = 2 + if ((ubound(a, 1) .ne. 6) .or. (ubound(a, i) .ne. 2)) call abort +end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_passing.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_passing.f90 new file mode 100644 index 000000000..af06a84e4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_passing.f90 @@ -0,0 +1,22 @@ +! PR middle-end/20030 +! we were messing up the access in LSAME for +! the character arguments. + program foo + character*1 a1, a2, b + logical LSAME, x + a1='A' + a2='A' + b='B' + x = LSAME(a1,a2) + if ( .not. x ) then + call abort (); + endif + end + + logical function LSAME( CA, CB ) + character CA, CB + integer INTA, INTB + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) + LSAME = INTA.EQ.INTB + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 new file mode 100644 index 000000000..c42cea4fc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/character_select_1.f90 @@ -0,0 +1,12 @@ +CHARACTER(LEN=6) :: C = "STEVEN" + +SELECT CASE (C) + CASE ("AAA":"EEE") + CALL abort + CASE ("R":"T") + CONTINUE + CASE DEFAULT + CALL abort +END SELECT +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 new file mode 100644 index 000000000..edec983d3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/cmplx.f90 @@ -0,0 +1,48 @@ +! Test complex munbers +program testcmplx + implicit none + complex(kind=4) c, d + complex(kind=8) z + real(kind=4) x, y + real(kind=8) q + + ! cmplx intrinsic + x = 3 + y = 4 + c = cmplx(x,y) + if (c .ne. (3.0, 4.0)) call abort + x = 4 + y = 3 + z = cmplx(x, y, 8) + if (z .ne. (4.0, 3.0)) call abort + z = c + if (z .ne. (3.0, 4.0)) call abort + + ! dcmplx intrinsic + x = 3 + y = 4 + z = dcmplx (x, y) + if (z .ne. (3.0, 4.0)) call abort + + ! conjucates and aimag + c = (1.0, 2.0) + c = conjg (c) + x = aimag (c) + if (abs (c - (1.0, -2.0)) .gt. 0.001) call abort + if (x .ne. -2.0) call abort + z = (2.0, 1.0) + z = conjg (z) + q = aimag (z) + if (z .ne. (2.0, -1.0)) call abort + if (q .ne. -1.0) call abort + + ! addition, subtraction and multiplication + c = (1, 3) + d = (5, 2) + if (c + d .ne. ( 6, 5)) call abort + if (c - d .ne. (-4, 1)) call abort + if (c * d .ne. (-1, 17)) call abort + + ! test for constant folding + if ((35.,-10.)**0.NE.(1.,0.)) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 new file mode 100644 index 000000000..2ea1788eb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common.f90 @@ -0,0 +1,53 @@ +! Program to test COMMON and EQUIVALENCE. +program common + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + b = 100 + c = 200 + call common_pass + call common_par (a, b,c) + call global_equiv + call local_equiv +end + +! Use common block to pass values +subroutine common_pass + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort +end subroutine + +! Common variables as argument +subroutine common_par (a, b, c) + real (kind=8) a(8), b(5), c(5) + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort + if (any (b .ne. (/100,100,100,100,100/))) call abort + if (any (c .ne. (/200,200,200,200,200/))) call abort +end subroutine + +! Global equivalence +subroutine global_equiv + real (kind=8) a(8), b(5), c(5), x(8), y(4), z(4) + common /com2/b, c, y, z + equivalence (a(1), b(2)) + equivalence (x(4), y(1)) + b = 100 + c = 200 + y = 300 + z = 400 + if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort + if (any (x .ne. (/200,200,200,300,300,300,300,400/))) call abort +end + +! Local equivalence +subroutine local_equiv + real (kind=8) a(8), b(10) + equivalence (a(1), b(3)) + b(1:5) = 100 + b(6:10) = 200 + if (any (a .ne. (/100,100,100,200,200,200,200,200/))) call abort +end subroutine diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_2.f90 new file mode 100644 index 000000000..8bcdbb87a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_2.f90 @@ -0,0 +1,20 @@ +! PR fortran/16336 -- the two common blocks used to clash +MODULE bar +INTEGER :: I +COMMON /X/I +contains +subroutine set_i() +i = 5 +end subroutine set_i +END MODULE bar + +USE bar +INTEGER :: J +COMMON /X/J +j = 1 +i = 2 +if (j.ne.i) call abort() +if (j.ne.2) call abort() +call set_i() +if (j.ne.5) call abort() +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_init_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_init_1.f90 new file mode 100644 index 000000000..9e5aec0f7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_init_1.f90 @@ -0,0 +1,24 @@ +! Program to test initialization of common blocks. +subroutine test() + character(len=15) :: c + integer d, e + real f + common /block2/ c + common /block/ d, e, f + + if ((d .ne. 42) .or. (e .ne. 43) .or. (f .ne. 2.0)) call abort () + if (c .ne. "Hello World ") call abort () +end subroutine + +program prog + integer a(2) + real b + character(len=15) :: s + common /block/ a, b + common /block2/ s + data b, a/2.0, 42, 43/ + data s /"Hello World"/ + + call test () +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 new file mode 100644 index 000000000..936c41e32 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/common_size.f90 @@ -0,0 +1,10 @@ +! The size of common 'com1' should be 80, instead of 112. +program common_size + real (kind=8) a(8) + real (kind=8) b(5), c(5) + common /com1/b,c + equivalence (a(1), b(2)) + b = 100 + c = 200 + if ((a (4) .ne. 100) .or. (a(5) .ne. 200)) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 new file mode 100644 index 000000000..96cb89d72 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/constructor.f90 @@ -0,0 +1,29 @@ +! Program to test array constructors +program constructors + integer, dimension (4) :: a + integer, dimension (3, 2) :: b + integer i, j, k, l, m, n + + a = (/1, (i,i=2,4)/) + do i = 1, 4 + if (a(i) .ne. i) call abort + end do + + b = reshape ((/0, 1, 2, 3, 4, 5/), (/3, 2/)) + 1 + do i=1,3 + if (b(i, 1) .ne. i) call abort + if (b(i, 2) .ne. i + 3) call abort + end do + + k = 1 + l = 2 + m = 3 + n = 4 + ! The remainder assumes constant constructors work ok. + a = (/n, m, l, k/) + if (any (a .ne. (/4, 3, 2, 1/))) call abort + a = (/((/i+10, 42/), i = k, l)/) + if (any (a .ne. (/11, 42, 12, 42/))) call abort + a = (/(I, I=k,l) , (J, J=m,n)/) + if (any (a .ne. (/1, 2, 3, 4/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 new file mode 100644 index 000000000..3c7117744 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained.f90 @@ -0,0 +1,16 @@ +program contained + implicit none + integer i + + i = 0; + call testproc (40) + if (i .ne. 42) call abort +contains + subroutine testproc (p) + implicit none + integer p + + if (p .ne. 40) call abort + i = p + 2 + end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 new file mode 100644 index 000000000..cae94b704 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained2.f90 @@ -0,0 +1,28 @@ +! Program to check resolution of symbols with the same name +program contained2 + implicit none + integer var1 + + var1 = 42 + if (f1() .ne. 1) call abort + call f2() + if (var1 .ne. 42) call abort +contains + +function f1 () + implicit none + integer f1 + integer var1 + integer f2 + + var1 = 1 + f2 = var1 + f1 = f2 +end function + +subroutine f2() + implicit none + if (f1() .ne. 1) call abort +end subroutine + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained_3.f90 new file mode 100644 index 000000000..d0de1f449 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/contained_3.f90 @@ -0,0 +1,22 @@ +! Program to test contained functions calling their siblings. +! This is tricky because we don't find the declaration for the sibling +! function until after the caller has been parsed. +program contained_3 + call test +contains + subroutine test + if (sub(3) .ne. 6) call abort + end subroutine + integer function sub(i) + integer i + if (i .gt. 1) then + sub = sub2(i) * i + else + sub = 1 + end if + end function + integer function sub2(i) + integer i + sub2 = sub(i - 1) + end function +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 new file mode 100644 index 000000000..680449f3e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/csqrt_1.f90 @@ -0,0 +1,78 @@ +! PR 14396 +! These we failing on targets which do not provide the c99 complex math +! functions. +! Extracted from intrinsic77.f in the g77 testsuite. + logical fail + common /flags/ fail + fail = .false. + call square_root + if (fail) call abort + end + subroutine square_root + intrinsic sqrt, dsqrt, csqrt + real x, a + x = 4.0 + a = 2.0 + call c_r(SQRT(x),a,'SQRT(real)') + call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)') + call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)') + call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)') + call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)') + call p_r_r(SQRT,x,a,'SQRT') + call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT') + call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT') + end + subroutine failure(label) +! Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + subroutine c_r(a,b,label) +! Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + subroutine c_d(a,b,label) +! Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_c(a,b,label) +! Check if COMPLEX a equals b, and fail otherwise + complex a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + subroutine p_r_r(f,x,a,label) +! Check if REAL f(x) equals a for REAL x + real f,x,a + character*(*) label + call c_r(f(x),a,label) + end + subroutine p_d_d(f,x,a,label) +! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x + double precision f,x,a + character*(*) label + call c_d(f(x),a,label) + end + subroutine p_c_c(f,x,a,label) +! Check if COMPLEX f(x) equals a for COMPLEX x + complex f,x,a + character*(*) label + call c_c(f(x),a,label) + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 new file mode 100644 index 000000000..d2d86a2d7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data.f90 @@ -0,0 +1,72 @@ + ! Program to test data statement + program data + call sub1() + call sub2() + end + subroutine sub1() + integer i + type tmp + integer, dimension(4)::a + real :: r + end type + type tmp1 + type (tmp) t1(4) + integer b + end type + type (tmp1) tmp2(2) + ! Full array and scalar component initializer + data tmp2(2)%t1(2)%r, tmp2(1)%t1(3)%a, tmp2(1)%b/220,136,137,138,139,10/ + data tmp2(2)%t1(4)%a,tmp2(2)%t1(3)%a/241,242,4*5,233,234/ + ! implied DO + data (tmp2(1)%t1(2)%a(i),i=4,1,-1)/124,123,122,121/ + ! array section + data tmp2(1)%t1(4)%a(4:1:-1)/144,143,142,141/ + data tmp2(1)%t1(1)%a(1:4:2)/111,113/ + ! array element reference + data tmp2(2)%t1(2)%a(3), tmp2(2)%t1(2)%a(1)/223,221/ + + if (any(tmp2(1)%t1(1)%a .ne. (/111,0,113,0/))) call abort + if (tmp2(1)%t1(1)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(2)%a .ne. (/121,122,123,124/))) call abort + if (tmp2(1)%t1(2)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(3)%a .ne. (/136,137,138,139/))) call abort + if (tmp2(1)%t1(3)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(1)%t1(4)%a .ne. (/141,142,143,144/))) call abort + if (tmp2(1)%t1(4)%r .ne. 0.0) call abort + if (tmp2(1)%b .ne. 10) call abort + + if (any(tmp2(2)%t1(1)%a .ne. (/0,0,0,0/))) call abort + if (tmp2(2)%t1(1)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(2)%a .ne. (/221,0,223,0/))) call abort + if (tmp2(2)%t1(2)%r .ne. 220.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(3)%a .ne. (/5,5,233,234/))) call abort + if (tmp2(2)%t1(3)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + if (any(tmp2(2)%t1(4)%a .ne. (/241,242,5,5/))) call abort + if (tmp2(2)%t1(4)%r .ne. 0.0) call abort + if (tmp2(2)%b .ne. 0) call abort + + end + subroutine sub2() + integer a(4,4), b(10) + integer i,j,k + real r,t + data i,j,r,k,t,b(5),b(2),((a(i,j),i=1,4,1),j=4,1,-1)/1,2,3,4,5,5,2,& + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/ + if ((i.ne.1) .and. (j.ne.2).and.(k.ne.4)) call abort + if ((r.ne.3.0).and.(t.ne.5.0)) call abort + if (any(b.ne.(/0,2,0,0,5,0,0,0,0,0/))) call abort + if (any(a.ne.reshape((/13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4/),(/4,4/)))) call abort + end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 new file mode 100644 index 000000000..0aa44f605 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_2.f90 @@ -0,0 +1,17 @@ +! Check more array variants of the data statement +program data_2 + implicit none + type t + integer i + end type t + integer, dimension(3) :: a + type (t), dimension(3) :: b + integer, dimension(2,2) :: c + data a(:), b%i /1, 2, 3, 4, 5, 6/ + data c(1, :), c(2, :) /7, 8, 9, 10/ + + if (any (a .ne. (/1, 2, 3/))) call abort () + if (any (b%i .ne. (/4, 5, 6/))) call abort () + if ((any (c(1, :) .ne. (/7, 8/))) & + .or. (any (c(2,:) .ne. (/9, 10/)))) call abort () +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_3.f90 new file mode 100644 index 000000000..bdeaaa871 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_3.f90 @@ -0,0 +1,19 @@ +! Check initialization of character variables via the DATA statement +CHARACTER*4 a +CHARACTER*6 b +CHARACTER*2 c +CHARACTER*4 d(2) +CHARACTER*4 e + +DATA a(1:2) /'aa'/ +DATA a(3:4) /'b'/ +DATA b(2:6), c /'AAA', '12345'/ +DATA d /2*'1234'/ +DATA e(4:4), e(1:3) /'45', '123A'/ + +IF (a.NE.'aab ') CALL abort() +IF (b.NE.' AAA ') CALL abort() +IF (c.NE.'12') CALL abort() +IF (d(1).NE.d(2) .OR. d(1).NE.'1234') CALL abort() +IF (e.NE.'1234') CALL abort() +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_4.f90 new file mode 100644 index 000000000..4b5c10e6a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/data_4.f90 @@ -0,0 +1,6 @@ + CHARACTER*4 A(3),B(3),C(3) + DATA A /'A',"A",'A'/ + DATA B /3*'A'/ + DATA C /'A', 2*'A'/ + IF (ANY(A.NE.B).OR.ANY(A.NE.C)) CALL ABORT + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/date_time_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/date_time_1.f90 new file mode 100644 index 000000000..78310c1d8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/date_time_1.f90 @@ -0,0 +1,26 @@ +! Check the DATE_AND_TIME intrinsic. +! Call teh intrinsic with a variety of arguments, but does not check the +! returned values. +CHARACTER(8) :: d, d1 +CHARACTER(10) :: t, t1 +CHARACTER(5) :: z, z1 +INTEGER :: v(8), v1(8) + +CALL DATE_AND_TIME + +CALL DATE_AND_TIME(DATE=d) +CALL DATE_AND_TIME(TIME=t) +CALL DATE_AND_TIME(ZONE=z) + +CALL DATE_AND_TIME(VALUES=v) + +CALL DATE_AND_TIME(DATE=d, TIME=t) +CALL DATE_AND_TIME(DATE=d, VALUES=v) +CALL DATE_AND_TIME(TIME=t, ZONE=z) + +CALL DATE_AND_TIME(DATE=d, TIME=t, ZONE=z) +CALL DATE_AND_TIME(TIME=t, ZONE=z, VALUES=v) + +CALL DATE_AND_TIME(DATE=d, TIME=t, ZONE=z, VALUES=v) + +END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 new file mode 100644 index 000000000..c8eec5c73 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/dep_fails.f90 @@ -0,0 +1,50 @@ +! This gives incorrect results when compiled with +! the intel and pgf90 compilers +Program Strange + + Implicit None + + Type Link + Integer, Dimension(2) :: Next + End Type Link + + Integer, Parameter :: N = 2 + Integer, dimension (2, 4) :: results + Integer :: i, j + + Type(Link), Dimension(:,:), Pointer :: Perm + Integer, Dimension(2) :: Current + + Allocate (Perm(N,N)) + +! Print*, 'Spanned by indices' + Do i = 1, N**2 + Perm(mod(i-1,N)+1, (i-1)/N+1)%Next = (/ Mod(i,N) + 1, Mod(i/N+1,N)+1/) +! Write(*,100) mod(i-1,N)+1, (i-1)/N+1, Perm(mod(i-1,N)+1, (i-1)/N+1)%Next +! Expected output: +! Spanned by indices +! 1 1---> 2 2 +! 2 1---> 1 1 +! 1 2---> 2 1 +! 2 2---> 1 2 + End Do + +! Print*, 'Spanned as a cycle' + Current = (/1,1/) + Do i = 1, n**2 + results (:, i) = Perm(Current(1), Current(2))%Next +! Write(*,100) Current, Perm(Current(1), Current(2))%Next +! Expected output: +! 1 1---> 2 2 +! 2 2---> 1 2 +! 1 2---> 2 1 +! 2 1---> 1 1 + Current = Perm(Current(1), Current(2))%Next + End Do + + if (any(results .ne. reshape ((/2,2,1,2,2,1,1,1/), (/2, 4/)))) call abort + +! 100 Format( 2I3, '--->', 2I3) + DeAllocate (Perm) + +End Program Strange diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 new file mode 100644 index 000000000..72531f9ac --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init.f90 @@ -0,0 +1,32 @@ +! Program to test derived type initializers and constructors +program der_init + implicit none + type t + integer :: i + integer :: j = 4 + end type + integer :: m, n + + ! Explicit initializer + type (t) :: var = t(1, 2) + ! Type (default) initializer + type (t) :: var2 + ! Initialization of arrays + type (t), dimension(2) :: var3 + type (t), dimension(2) :: var4 = (/t(7, 9), t(8, 6)/) + + if (var%i .ne. 1 .or. var%j .ne. 2) call abort + if (var2%j .ne. 4) call abort + var2 = t(6, 5) + if (var2%i .ne. 6 .or. var2%j .ne. 5) call abort + + if ((var3(1)%j .ne. 4) .or. (var3(2)%j .ne. 4)) call abort + if ((var4(1)%i .ne. 7) .or. (var4(2)%i .ne. 8) & + .or. (var4(1)%j .ne. 9) .or. (var4(2)%j .ne. 6)) call abort + + ! Non-constant constructor + n = 1 + m = 5 + var2 = t(n, n + m) + if (var2%i .ne. 1 .or. var2%j .ne. 6) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_2.f90 new file mode 100644 index 000000000..d0448a55b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_2.f90 @@ -0,0 +1,15 @@ +! PR 15314 +! We were looking at the type of the initialization expression, not the type +! of the field. +program der_init_2 + implicit none + type foo + integer :: a(3) = 42 + integer :: b = 123 + end type + + type (foo) :: v + + if ((v%b .ne. 123) .or. any (v%a .ne. 42)) call abort (); +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_3.f90 new file mode 100644 index 000000000..21b79092f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_3.f90 @@ -0,0 +1,12 @@ +! PR15365 +! Default initializers were being missed +program main + type xyz + integer :: x = 123 + end type xyz + + type (xyz) :: a !! ok + type (xyz) b !!! not initialized !!! + if (a%x.ne.123) call abort + if (b%x.ne.123) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_4.f90 new file mode 100644 index 000000000..644ef65e1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_4.f90 @@ -0,0 +1,15 @@ +! PR13930 +! We were trying to assign a default initializer to dummy variables. +program der_init_4 + type t + integer :: i = 42 + end type + + call foo(t(5)) +contains +subroutine foo(a) + type (t), intent(in) :: a + + if (a%i .ne. 5) call abort +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_5.f90 new file mode 100644 index 000000000..c81d9260e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_init_5.f90 @@ -0,0 +1,16 @@ +! Check that null initialization of pointer components works. +! PR 15969 prompted these +! the commented out tests are cases where we still fail +program der_init_5 + type t + type(t), pointer :: a => NULL() + real, pointer :: b => NULL() + character, pointer :: c => NULL() + integer, pointer, dimension(:) :: d => NULL() + end type t + type (t) :: p + if (associated(p%a)) call abort() + if (associated(p%b)) call abort() +! if (associated(p%c)) call abort() + if (associated(p%d)) call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 new file mode 100644 index 000000000..b1b421bc6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_io.f90 @@ -0,0 +1,67 @@ +! Program to test IO of derived types +program derived_io + character(400) :: buf1, buf2, buf3 + + type xyz_type + integer :: x + character(11) :: y + logical :: z + end type xyz_type + + type abcdef_type + integer :: a + logical :: b + type (xyz_type) :: c + integer :: d + real(4) :: e + character(11) :: f + end type abcdef_type + + type (xyz_type), dimension(2) :: xyz + type (abcdef_type) abcdef + + xyz(1)%x = 11111 + xyz(1)%y = "hello world" + xyz(1)%z = .true. + xyz(2)%x = 0 + xyz(2)%y = "go away" + xyz(2)%z = .false. + + abcdef%a = 0 + abcdef%b = .true. + abcdef%c%x = 111 + abcdef%c%y = "bzz booo" + abcdef%c%z = .false. + abcdef%d = 3 + abcdef%e = 4.0 + abcdef%f = "kawabanga" + + write (buf1, *), xyz(1)%x, xyz(1)%y, xyz(1)%z + ! Use function call to ensure it is only evaluated once + write (buf2, *), xyz(bar()) + if (buf1.ne.buf2) call abort + + write (buf1, *), abcdef + write (buf2, *), abcdef%a, abcdef%b, abcdef%c, abcdef%d, abcdef%e, abcdef%f + write (buf3, *), abcdef%a, abcdef%b, abcdef%c%x, abcdef%c%y, & + abcdef%c%z, abcdef%d, abcdef%e, abcdef%f + if (buf1.ne.buf2) call abort + if (buf1.ne.buf3) call abort + + call foo(xyz(1)) + + contains + + subroutine foo(t) + type (xyz_type) t + write (buf1, *), t%x, t%y, t%z + write (buf2, *), t + if (buf1.ne.buf2) call abort + end subroutine foo + + integer function bar() + integer, save :: i = 1 + bar = i + i = i + 1 + end function +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 new file mode 100644 index 000000000..1dcb07c21 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_point.f90 @@ -0,0 +1,45 @@ +! Program to test DERIVED type with components point to the DERIVED +! type itself, and two DERIVED type with componets point to each +! other. +program nest_derived + type record + integer :: value + type(record), pointer :: rp + end type record + + type record1 + integer value + type(record2), pointer :: r1p + end type + + type record2 + integer value + type(record1), pointer :: r2p + end type + + type(record), target :: e1, e2, e3 + type(record1), target :: r1 + type(record2), target :: r2 + nullify(r1%r1p,r2%r2p,e1%rp,e2%rp,e3%rp) + + r1%r1p => r2 + r2%r2p => r1 + e1%rp => e2 + e2%rp => e3 + + r1%value = 11 + r2%value = 22 + + e1%value = 33 + e1%rp%value = 44 + e1%rp%rp%value = 55 + + if (r1%r1p%value .ne. 22) call abort + if (r2%r2p%value .ne. 11) call abort + if (e1%value .ne. 33) call abort + if (e2%value .ne. 44) call abort + if (e3%value .ne. 55) call abort + if (r1%value .ne. 11) call abort + if (r2%value .ne. 22) call abort + +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 new file mode 100644 index 000000000..6a2716407 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/der_type.f90 @@ -0,0 +1,45 @@ +! Program to test derived types +program der_type + implicit none + type t1 + integer, dimension (4, 5) :: a + integer :: s + end type + + type my_type + character(20) :: c + type (t1), dimension (4, 3) :: ca + type (t1) :: r + end type + + type init_type + integer :: i = 13 + integer :: j = 14 + end type + + type (my_type) :: var + type (init_type) :: def_init + type (init_type) :: is_init = init_type (10, 11) + integer i; + + if ((def_init%i .ne. 13) .or. (def_init%j .ne. 14)) call abort + if ((is_init%i .ne. 10) .or. (is_init%j .ne. 11)) call abort + ! Passing a component as a parameter tests getting the addr of a component + call test_call(def_init%i) + var%c = "Hello World" + if (var%c .ne. "Hello World") call abort + var%r%a(:, :) = 0 + var%ca(:, :)%s = 0 + var%r%a(1, 1) = 42 + var%r%a(4, 5) = 43 + var%ca(:, :)%s = var%r%a(:, 1:5:2) + if (var%ca(1, 1)%s .ne. 42) call abort + if (var%ca(4, 3)%s .ne. 43) call abort +contains + subroutine test_call (p) + integer p + + if (p .ne. 13) call abort + end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 new file mode 100644 index 000000000..deba9a6bf --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/direct_io.f90 @@ -0,0 +1,21 @@ +! demonstrates basic direct access using variables for REC +! pr14872 + OPEN(UNIT=10,ACCESS='DIRECT',RECL=128) + DO I = 1,10 + WRITE(10,REC=I,ERR=10)I + ENDDO + CLOSE(10) + OPEN(UNIT=10,ACCESS='DIRECT',RECL=128) + DO I = 1,10 + READ(10,REC=I,ERR=10)J + IF (J.NE.I) THEN +! PRINT*,' READ ',J,' EXPECTED ',I + CALL ABORT + ENDIF + ENDDO + CLOSE(10,STATUS='DELETE') + STOP + 10 CONTINUE +! PRINT*,' ERR= RETURN FROM READ OR WRITE' + CALL ABORT + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 new file mode 100644 index 000000000..79a511cde --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/elemental.f90 @@ -0,0 +1,32 @@ +! Program to test elemental functions. +program test_elemental + implicit none + integer, dimension (2, 4) :: a + integer, dimension (2, 4) :: b + integer(kind = 8), dimension(2) :: c + + a = reshape ((/2, 3, 4, 5, 6, 7, 8, 9/), (/2, 4/)) + b = 0 + b(2, :) = e_fn (a(1, :), 1) + if (any (b .ne. reshape ((/0, 1, 0, 3, 0, 5, 0, 7/), (/2, 4/)))) call abort + a = e_fn (a(:, 4:1:-1), 1 + b) + if (any (a .ne. reshape ((/7, 7, 5, 3, 3, -1, 1, -5/), (/2, 4/)))) call abort + ! This tests intrinsic elemental conversion functions. + c = 2 * a(1, 1) + if (any (c .ne. 14)) call abort + + ! This triggered bug due to building ss chains in the wrong order. + b = 0; + a = a - e_fn (a, b) + if (any (a .ne. 0)) call abort + + ! Check expressions involving constants + a = e_fn (b + 1, 1) + if (any (a .ne. 0)) call abort +contains + +elemental integer(kind=4) function e_fn (p, q) + integer, intent(in) :: p, q + e_fn = p - q +end function +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 new file mode 100644 index 000000000..242bee8b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/empty_format.f90 @@ -0,0 +1,14 @@ +! from NIST test FM406.FOR + CHARACTER*10 A10VK + A10VK = 'XXXXXXXXXX' + WRITE(A10VK,39110) +39110 FORMAT() +! +! the empty format should fill the target of the internal +! write with blanks. +! + IF (A10VK.NE.'') THEN +! PRINT*,A10VK + CALL ABORT + ENDIF + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 new file mode 100644 index 000000000..0c19fa571 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/emptyif.f90 @@ -0,0 +1,20 @@ +! Test empty if statements. We Used to fail this because we folded +! the if stmt before we finished building it. +program emptyif + implicit none + integer i + + i=1 + if(i .le. 0) then + else + i = 2 + endif + if (i .ne. 2) call abort() + + if (i .eq. 0) then + elseif (i .eq. 2) then + i = 3 + end if + if (i .ne. 3) call abort() +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 new file mode 100644 index 000000000..bef8a98df --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 @@ -0,0 +1,74 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer a, b, f1, e1 + f1 = 15 + a + return + entry e1 (b) + e1 = 42 + b + end function + function f2 () + real f2, e2 + entry e2 () + e2 = 45 + end function + function f3 () + double precision a, b, f3, e3 + entry e3 () + f3 = 47 + end function + function f4 (a) result (r) + double precision a, b, r, s + r = 15 + a + return + entry e4 (b) result (s) + s = 42 + b + end function + function f5 () result (r) + integer r, s + entry e5 () result (s) + r = 45 + end function + function f6 () result (r) + real r, s + entry e6 () result (s) + s = 47 + end function + function f7 () + entry e7 () + e7 = 163 + end function + function f8 () result (r) + entry e8 () + e8 = 115 + end function + function f9 () + entry e9 () result (r) + r = 119 + end function + + program entrytest + integer f1, e1, f5, e5 + real f2, e2, f6, e6, f7, e7, f8, e8, f9, e9 + double precision f3, e3, f4, e4, d + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 () .ne. 45) call abort () + if (e2 () .ne. 45) call abort () + if (f3 () .ne. 47) call abort () + if (e3 () .ne. 47) call abort () + d = 17 + if (f4 (d) .ne. 32) call abort () + if (e4 (d) .ne. 59) call abort () + if (f5 () .ne. 45) call abort () + if (e5 () .ne. 45) call abort () + if (f6 () .ne. 47) call abort () + if (e6 () .ne. 47) call abort () + if (f7 () .ne. 163) call abort () + if (e7 () .ne. 163) call abort () + if (f8 () .ne. 115) call abort () + if (e8 () .ne. 115) call abort () + if (f9 () .ne. 119) call abort () + if (e9 () .ne. 119) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_10.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_10.f90 new file mode 100644 index 000000000..0c21d76e3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_10.f90 @@ -0,0 +1,13 @@ + function foo () + foo = 4 + foo = foo / 2 + return + entry bar () + bar = 9 + bar = bar / 3 + end + + program entrytest + if (foo () .ne. 2) call abort () + if (bar () .ne. 3) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_11.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_11.f90 new file mode 100644 index 000000000..916891fde --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_11.f90 @@ -0,0 +1,16 @@ +! PR fortran/23663 + function i (n) + i = n + i = max (i, 6) + return + entry j (n) + j = n + j = max (j, 3) + end + + program entrytest + if (i (8).ne.8) call abort + if (i (4).ne.6) call abort + if (j (0).ne.3) call abort + if (j (7).ne.7) call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 new file mode 100644 index 000000000..5db39db6a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 @@ -0,0 +1,51 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + character*(*) function f1 (str, i, j) + character str*(*), e1*(*), e2*(*) + integer i, j + f1 = str (i:j) + return + entry e1 (str, i, j) + i = i + 1 + entry e2 (str, i, j) + j = j - 1 + e2 = str (i:j) + end function + + character*5 function f3 () + character e3*(*), e4*(*) + integer i + f3 = 'ABCDE' + return + entry e3 (i) + entry e4 (i) + if (i .gt. 0) then + e3 = 'abcde' + else + e4 = 'UVWXY' + endif + end function + + program entrytest + character f1*16, e1*16, e2*16, str*16, ret*16 + character f3*5, e3*5, e4*5 + integer i, j + str = 'ABCDEFGHIJ' + i = 2 + j = 6 + ret = f1 (str, i, j) + if ((i .ne. 2) .or. (j .ne. 6)) call abort () + if (ret .ne. 'BCDEF') call abort () + ret = e1 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 5)) call abort () + if (ret .ne. 'CDE') call abort () + ret = e2 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 4)) call abort () + if (ret .ne. 'CD') call abort () + if (f3 () .ne. 'ABCDE') call abort () + if (e3 (1) .ne. 'abcde') call abort () + if (e4 (1) .ne. 'abcde') call abort () + if (e3 (0) .ne. 'UVWXY') call abort () + if (e4 (0) .ne. 'UVWXY') call abort () + end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 new file mode 100644 index 000000000..7174fa878 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 @@ -0,0 +1,40 @@ + subroutine f1 (n, *, i) + integer n, i + if (i .ne. 42) call abort () + entry e1 (n, *) + if (n .eq. 1) return 1 + if (n .eq. 2) return + return + entry e2 (n, i, *, *, *) + if (i .ne. 46) call abort () + if (n .ge. 4) return + return n + entry e3 (n, i) + if ((i .ne. 48) .or. (n .ne. 61)) call abort () + end subroutine + + program alt_return + implicit none + + call f1 (1, *10, 42) +20 continue + call abort () +10 continue + call f1 (2, *20, 42) + call f1 (3, *20, 42) + call e1 (2, *20) + call e1 (1, *30) + call abort () +30 continue + call e2 (1, 46, *40, *20, *20) + call abort () +40 continue + call e2 (2, 46, *20, *50, *20) + call abort () +50 continue + call e2 (3, 46, *20, *20, *60) + call abort () +60 continue + call e2 (4, 46, *20, *20, *20) + call e3 (61, 48) + end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 new file mode 100644 index 000000000..f74440c13 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 @@ -0,0 +1,64 @@ +! Test alternate entry points for functions when the result types +! of all entry points don't match + + integer function f1 (a) + integer a, b + double precision e1 + f1 = 15 + a + return + entry e1 (b) + e1 = 42 + b + end function + complex function f2 (a) + integer a + logical e2 + entry e2 (a) + if (a .gt. 0) then + e2 = a .lt. 46 + else + f2 = 45 + endif + end function + function f3 (a) result (r) + integer a, b + real r + logical s + complex c + r = 15 + a + return + entry e3 (b) result (s) + s = b .eq. 42 + return + entry g3 (b) result (c) + c = b + 11 + end function + function f4 (a) result (r) + logical r + integer a, s + double precision t + entry e4 (a) result (s) + entry g4 (a) result (t) + r = a .lt. 0 + if (a .eq. 0) s = 16 + a + if (a .gt. 0) t = 17 + a + end function + + program entrytest + integer f1, e4 + real f3 + double precision e1, g4 + logical e2, e3, f4 + complex f2, g3 + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 (0) .ne. 45) call abort () + if (.not. e2 (45)) call abort () + if (e2 (46)) call abort () + if (f3 (17) .ne. 32) call abort () + if (.not. e3 (42)) call abort () + if (e3 (41)) call abort () + if (g3 (12) .ne. 23) call abort () + if (.not. f4 (-5)) call abort () + if (e4 (0) .ne. 16) call abort () + if (g4 (2) .ne. 19) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 new file mode 100644 index 000000000..2fd927f4e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 @@ -0,0 +1,51 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (str, i, j) result (r) + character str*(*), r1*(*), r2*(*), r*(*) + integer i, j + r = str (i:j) + return + entry e1 (str, i, j) result (r1) + i = i + 1 + entry e2 (str, i, j) result (r2) + j = j - 1 + r2 = str (i:j) + end function + + function f3 () result (r) + character r3*5, r4*5, r*5 + integer i + r = 'ABCDE' + return + entry e3 (i) result (r3) + entry e4 (i) result (r4) + if (i .gt. 0) then + r3 = 'abcde' + else + r4 = 'UVWXY' + endif + end function + + program entrytest + character f1*16, e1*16, e2*16, str*16, ret*16 + character f3*5, e3*5, e4*5 + integer i, j + str = 'ABCDEFGHIJ' + i = 2 + j = 6 + ret = f1 (str, i, j) + if ((i .ne. 2) .or. (j .ne. 6)) call abort () + if (ret .ne. 'BCDEF') call abort () + ret = e1 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 5)) call abort () + if (ret .ne. 'CDE') call abort () + ret = e2 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 4)) call abort () + if (ret .ne. 'CD') call abort () + if (f3 () .ne. 'ABCDE') call abort () + if (e3 (1) .ne. 'abcde') call abort () + if (e4 (1) .ne. 'abcde') call abort () + if (e3 (0) .ne. 'UVWXY') call abort () + if (e4 (0) .ne. 'UVWXY') call abort () + end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 new file mode 100644 index 000000000..a75c513a1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 @@ -0,0 +1,109 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer, dimension (2, 2) :: a, b, f1, e1 + f1 (:, :) = 15 + a (1, 1) + return + entry e1 (b) + e1 (:, :) = 42 + b (1, 1) + end function + function f2 () + real, dimension (2, 2) :: f2, e2 + entry e2 () + e2 (:, :) = 45 + end function + function f3 () + double precision, dimension (2, 2) :: a, b, f3, e3 + entry e3 () + f3 (:, :) = 47 + end function + function f4 (a) result (r) + double precision, dimension (2, 2) :: a, b, r, s + r (:, :) = 15 + a (1, 1) + return + entry e4 (b) result (s) + s (:, :) = 42 + b (1, 1) + end function + function f5 () result (r) + integer, dimension (2, 2) :: r, s + entry e5 () result (s) + r (:, :) = 45 + end function + function f6 () result (r) + real, dimension (2, 2) :: r, s + entry e6 () result (s) + s (:, :) = 47 + end function + + program entrytest + interface + function f1 (a) + integer, dimension (2, 2) :: a, f1 + end function + function e1 (b) + integer, dimension (2, 2) :: b, e1 + end function + function f2 () + real, dimension (2, 2) :: f2 + end function + function e2 () + real, dimension (2, 2) :: e2 + end function + function f3 () + double precision, dimension (2, 2) :: f3 + end function + function e3 () + double precision, dimension (2, 2) :: e3 + end function + function f4 (a) + double precision, dimension (2, 2) :: a, f4 + end function + function e4 (b) + double precision, dimension (2, 2) :: b, e4 + end function + function f5 () + integer, dimension (2, 2) :: f5 + end function + function e5 () + integer, dimension (2, 2) :: e5 + end function + function f6 () + real, dimension (2, 2) :: f6 + end function + function e6 () + real, dimension (2, 2) :: e6 + end function + end interface + integer, dimension (2, 2) :: i, j + real, dimension (2, 2) :: r + double precision, dimension (2, 2) :: d, e + i (:, :) = 6 + j = f1 (i) + if (any (j .ne. 21)) call abort () + i (:, :) = 7 + j = e1 (i) + j (:, :) = 49 + if (any (j .ne. 49)) call abort () + r = f2 () + if (any (r .ne. 45)) call abort () + r = e2 () + if (any (r .ne. 45)) call abort () + e = f3 () + if (any (e .ne. 47)) call abort () + e = e3 () + if (any (e .ne. 47)) call abort () + d (:, :) = 17 + e = f4 (d) + if (any (e .ne. 32)) call abort () + e = e4 (d) + if (any (e .ne. 59)) call abort () + j = f5 () + if (any (j .ne. 45)) call abort () + j = e5 () + if (any (j .ne. 45)) call abort () + r = f6 () + if (any (r .ne. 47)) call abort () + r = e6 () + if (any (r .ne. 47)) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 new file mode 100644 index 000000000..28a8a3f78 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 @@ -0,0 +1,106 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer a, b + integer, pointer :: f1, e1 + allocate (f1) + f1 = 15 + a + return + entry e1 (b) + allocate (e1) + e1 = 42 + b + end function + function f2 () + real, pointer :: f2, e2 + entry e2 () + allocate (e2) + e2 = 45 + end function + function f3 () + double precision, pointer :: f3, e3 + entry e3 () + allocate (f3) + f3 = 47 + end function + function f4 (a) result (r) + double precision a, b + double precision, pointer :: r, s + allocate (r) + r = 15 + a + return + entry e4 (b) result (s) + allocate (s) + s = 42 + b + end function + function f5 () result (r) + integer, pointer :: r, s + entry e5 () result (s) + allocate (r) + r = 45 + end function + function f6 () result (r) + real, pointer :: r, s + entry e6 () result (s) + allocate (s) + s = 47 + end function + + program entrytest + interface + function f1 (a) + integer a + integer, pointer :: f1 + end function + function e1 (b) + integer b + integer, pointer :: e1 + end function + function f2 () + real, pointer :: f2 + end function + function e2 () + real, pointer :: e2 + end function + function f3 () + double precision, pointer :: f3 + end function + function e3 () + double precision, pointer :: e3 + end function + function f4 (a) + double precision a + double precision, pointer :: f4 + end function + function e4 (b) + double precision b + double precision, pointer :: e4 + end function + function f5 () + integer, pointer :: f5 + end function + function e5 () + integer, pointer :: e5 + end function + function f6 () + real, pointer :: f6 + end function + function e6 () + real, pointer :: e6 + end function + end interface + double precision d + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 () .ne. 45) call abort () + if (e2 () .ne. 45) call abort () + if (f3 () .ne. 47) call abort () + if (e3 () .ne. 47) call abort () + d = 17 + if (f4 (d) .ne. 32) call abort () + if (e4 (d) .ne. 59) call abort () + if (f5 () .ne. 45) call abort () + if (e5 () .ne. 45) call abort () + if (f6 () .ne. 47) call abort () + if (e6 () .ne. 47) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 new file mode 100644 index 000000000..c68d75af7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 @@ -0,0 +1,24 @@ +module entry_8_m +type t + integer i + real x (5) +end type t +end module entry_8_m + +function f (i) + use entry_8_m + type (t) :: f,g + f % i = i + return + entry g (x) + g%x = x +end function f + +use entry_8_m +type (t) :: f, g, res + +res = f (42) +if (res%i /= 42) call abort () +res = g (1.) +if (any (res%x /= 1.)) call abort () +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_9.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_9.f90 new file mode 100644 index 000000000..d29f4b834 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/entry_9.f90 @@ -0,0 +1,24 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer a, f1, e1 + f1 = 15 + a + return + entry e1 + e1 = 42 + end function + function f2 () + real f2, e2 + entry e2 + e2 = 45 + end function + + program entrytest + integer f1, e1 + real f2, e2 + if (f1 (6) .ne. 21) call abort () + if (e1 () .ne. 42) call abort () + if (f2 () .ne. 45) call abort () + if (e2 () .ne. 45) call abort () + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_1.f90 new file mode 100644 index 000000000..838b70c38 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_1.f90 @@ -0,0 +1,28 @@ +! Program to test the default initialisation of enumerators + +program main + implicit none + + enum, bind (c) + enumerator :: red , yellow, blue + enumerator :: green + end enum + + enum, bind (c) + enumerator :: a , b , c = 10 + enumerator :: d + end enum + + + if (red /= 0 ) call abort + if (yellow /= 1) call abort + if (blue /= 2) call abort + if (green /= 3) call abort + + if (a /= 0 ) call abort + if (b /= 1) call abort + if (c /= 10) call abort + if (d /= 11) call abort + + +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_2.f90 new file mode 100644 index 000000000..d0acf6595 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_2.f90 @@ -0,0 +1,29 @@ +! Program to test the incremental assignment of enumerators + +program main + implicit none + + enum, bind (c) + enumerator :: red = 4 , yellow, blue + enumerator green + end enum + + enum, bind (c) + enumerator :: sun = -10 , mon, tue + enumerator :: wed = 10, sat + end enum + + + if (red /= 4 ) call abort + if (yellow /= (red + 1)) call abort + if (blue /= (yellow + 1)) call abort + if (green /= (blue + 1)) call abort + + + if (sun /= -10 ) call abort + if (mon /= (sun + 1)) call abort + if (tue /= (mon + 1)) call abort + if (wed /= 10) call abort + if (sat /= (wed+1)) call abort + +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_3.f90 new file mode 100644 index 000000000..71ab35d11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_3.f90 @@ -0,0 +1,57 @@ +! Program to test the initialisation range of enumerators +! and kind values check + +program main + implicit none + + enum, bind (c) + enumerator :: red , yellow =255 , blue + end enum + + enum, bind (c) + enumerator :: r , y = 32767, b + end enum + + enum, bind (c) + enumerator :: aa , bb = 65535, cc + end enum + + enum, bind (c) + enumerator :: m , n = 2147483645, o + end enum + + + if (red /= 0 ) call abort + if (yellow /= 255) call abort + if (blue /= 256) call abort + + if (r /= 0 ) call abort + if (y /= 32767) call abort + if (b /= 32768) call abort + + if (kind (red) /= 4) call abort + if (kind (yellow) /= 4) call abort + if (kind (blue) /= 4) call abort + + if (kind(r) /= 4 ) call abort + if (kind(y) /= 4) call abort + if (kind(b) /= 4) call abort + + if (aa /= 0 ) call abort + if (bb /= 65535) call abort + if (cc /= 65536) call abort + + if (kind (aa) /= 4 ) call abort + if (kind (bb) /= 4) call abort + if (kind (cc) /= 4) call abort + + + if (m /= 0 ) call abort + if (n /= 2147483645) call abort + if (o /= 2147483646) call abort + + if (kind (m) /= 4 ) call abort + if (kind (n) /= 4) call abort + if (kind (o) /= 4) call abort + +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_4.f90 new file mode 100644 index 000000000..ff329dc7d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/enum_4.f90 @@ -0,0 +1,19 @@ +! Program to test the default initialisation of enumerators inside different program unit + +module mod + implicit none + enum, bind (c) + enumerator :: red , yellow, blue + enumerator :: green + end enum +end module mod + +program main + use mod + implicit none + + if (red /= 0 ) call abort + if (yellow /= 1) call abort + if (blue /= 2) call abort + if (green /= 3) call abort +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_1.f90 new file mode 100644 index 000000000..b4719fcaa --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_1.f90 @@ -0,0 +1,15 @@ +program prog + common /block/ i + equivalence (a, b, c), (i, j, k ,l) + a = 1.0 + b = 2.0 + c = 3.0 + i = 1 + j = 2 + k = 3 + l = 4 + + if ((a .ne. 3.0) .or. (b .ne. 3.0) .or. (c .ne. 3.0)) call abort () + if ((i .ne. 4) .or. (j .ne. 4) .or. (k .ne. 4) .or. (l .ne. 4)) & + call abort () +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_2.f90 new file mode 100644 index 000000000..1c88ff996 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_2.f90 @@ -0,0 +1,46 @@ + subroutine test1 + character*8 c + character*1 d, f + dimension d(2), f(2) + character*4 e + equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2)) + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort + if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort + end subroutine test1 + subroutine test2 + equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2)) + character*8 c + character*1 d, f + dimension d(2), f(2) + character*4 e + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort + if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort + end subroutine test2 + subroutine test3 + character*8 c + character*1 d, f + character*4 e + equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2)) + dimension d(2), f(2) + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort + if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort + end subroutine test3 + subroutine test4 + dimension d(2), f(2) + equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2)) + character*8 c + character*1 d, f + character*4 e + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort + if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort + end subroutine test4 + program main + call test1 + call test2 + call test3 + call test4 + end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_3.f90 new file mode 100644 index 000000000..75103e200 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_3.f90 @@ -0,0 +1,13 @@ + subroutine test1 + type t + sequence + character(8) c + end type t + type(t) :: tc, td + equivalence (tc, td) + tc%c='abcdefgh' + if (tc%c.ne.'abcdefgh'.or.td%c(1:1).ne.'a') call abort + end subroutine test1 + program main + call test1 + end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_4.f90 new file mode 100644 index 000000000..9c232786d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_4.f90 @@ -0,0 +1,54 @@ + subroutine test1 + character*8 c + character*2 d, f + dimension d(2), f(2) + character*4 e + equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4)) + equivalence (c(6:6), f(2)(:)) + d(1)='AB' + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort + if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort + end subroutine test1 + subroutine test2 + equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4)) + equivalence (c(6:6), f(2)(1:)) + character*8 c + character*2 d, f + dimension d(2), f(2) + character*4 e + d(1)='AB' + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort + if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort + end subroutine test2 + subroutine test3 + character*8 c + character*2 d, f + character*4 e + equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4)) + equivalence (c(6:6), f(2)(:1)) + dimension d(2), f(2) + d(1)='AB' + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort + if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort + end subroutine test3 + subroutine test4 + dimension d(2), f(2) + equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4)) + equivalence (c(6:6), f(2)(1:2)) + character*8 c + character*2 d, f + character*4 e + d(1)='AB' + c='abcdefgh' + if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort + if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort + end subroutine test4 + program main + call test1 + call test2 + call test3 + call test4 + end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f new file mode 100644 index 000000000..61f374c55 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_5.f @@ -0,0 +1,225 @@ +C This testcase was miscompiled on i?86/x86_64, the scheduler +C swapped write to DMACH(1) with following read from SMALL(1), +C at -O2+, as the front-end didn't signal in any way this kind +C of type punning is ok. +C The testcase is from blas, http://www.netlib.org/blas/d1mach.f + + DOUBLE PRECISION FUNCTION D1MACH(I) + INTEGER*4 I +C +C DOUBLE-PRECISION MACHINE CONSTANTS +C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C D1MACH( 5) = LOG10(B) +C + INTEGER*4 SMALL(2) + INTEGER*4 LARGE(2) + INTEGER*4 RIGHT(2) + INTEGER*4 DIVER(2) + INTEGER*4 LOG10(2) + INTEGER*4 SC, CRAY1(38), J + COMMON /D9MACH/ CRAY1 + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC + DOUBLE PRECISION DMACH(5) + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) +C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. +C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF +C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR +C MANY MACHINES YET. +C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 +C ON THE NEXT LINE + DATA SC/0/ +C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. +C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY +C mail netlib@research.bell-labs.com +C send old1mach from blas +C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGER*4S. +C DATA SMALL(1),SMALL(2) / 8388608, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / +C DATA DIVER(1),DIVER(2) / 620756992, 0 / +C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ +C +C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. + IF (SC .NE. 987) THEN + DMACH(1) = 1.D13 + IF ( SMALL(1) .EQ. 1117925532 + * .AND. SMALL(2) .EQ. -448790528) THEN +* *** IEEE BIG ENDIAN *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2146435071 + LARGE(2) = -1 + RIGHT(1) = 1017118720 + RIGHT(2) = 0 + DIVER(1) = 1018167296 + DIVER(2) = 0 + LOG10(1) = 1070810131 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(2) .EQ. 1117925532 + * .AND. SMALL(1) .EQ. -448790528) THEN +* *** IEEE LITTLE ENDIAN *** + SMALL(2) = 1048576 + SMALL(1) = 0 + LARGE(2) = 2146435071 + LARGE(1) = -1 + RIGHT(2) = 1017118720 + RIGHT(1) = 0 + DIVER(2) = 1018167296 + DIVER(1) = 0 + LOG10(2) = 1070810131 + LOG10(1) = 1352628735 + ELSE IF ( SMALL(1) .EQ. -2065213935 + * .AND. SMALL(2) .EQ. 10752) THEN +* *** VAX WITH D_FLOATING *** + SMALL(1) = 128 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 9344 + RIGHT(2) = 0 + DIVER(1) = 9472 + DIVER(2) = 0 + LOG10(1) = 546979738 + LOG10(2) = -805796613 + ELSE IF ( SMALL(1) .EQ. 1267827943 + * .AND. SMALL(2) .EQ. 704643072) THEN +* *** IBM MAINFRAME *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 856686592 + RIGHT(2) = 0 + DIVER(1) = 873463808 + DIVER(2) = 0 + LOG10(1) = 1091781651 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 1120022684 + * .AND. SMALL(2) .EQ. -448790528) THEN +* *** CONVEX C-1 *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 1019215872 + RIGHT(2) = 0 + DIVER(1) = 1020264448 + DIVER(2) = 0 + LOG10(1) = 1072907283 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 815547074 + * .AND. SMALL(2) .EQ. 58688) THEN +* *** VAX G-FLOATING *** + SMALL(1) = 16 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 15552 + RIGHT(2) = 0 + DIVER(1) = 15568 + DIVER(2) = 0 + LOG10(1) = 1142112243 + LOG10(2) = 2046775455 + ELSE + DMACH(2) = 1.D27 + 1 + DMACH(3) = 1.D27 + LARGE(2) = LARGE(2) - RIGHT(2) + IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN + CRAY1(1) = 67291416 + DO 10 J = 1, 20 + CRAY1(J+1) = CRAY1(J) + CRAY1(J) + 10 CONTINUE + CRAY1(22) = CRAY1(21) + 321322 + DO 20 J = 22, 37 + CRAY1(J+1) = CRAY1(J) + CRAY1(J) + 20 CONTINUE + IF (CRAY1(38) .EQ. SMALL(1)) THEN +* *** CRAY *** + CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) + SMALL(2) = 0 + CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) + CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) + CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) + RIGHT(2) = 0 + CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) + DIVER(2) = 0 + CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) + CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) + ELSE + WRITE(*,9000) + STOP 779 + END IF + ELSE + WRITE(*,9000) + STOP 779 + END IF + END IF + SC = 987 + END IF +* SANITY CHECK + IF (DMACH(4) .GE. 1.0D0) STOP 778 + IF (I .LT. 1 .OR. I .GT. 5) THEN + WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' + STOP + END IF + D1MACH = DMACH(I) + RETURN + 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ + *' appropriate for your machine.') +* /* Standard C source for D1MACH -- remove the * in column 1 */ +*#include <stdio.h> +*#include <float.h> +*#include <math.h> +*double d1mach_(long *i) +*{ +* switch(*i){ +* case 1: return DBL_MIN; +* case 2: return DBL_MAX; +* case 3: return DBL_EPSILON/FLT_RADIX; +* case 4: return DBL_EPSILON; +* case 5: return log10((double)FLT_RADIX); +* } +* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); +* exit(1); return 0; /* some compilers demand return values */ +*} + END + SUBROUTINE I1MCRY(A, A1, B, C, D) +**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** + INTEGER*4 A, A1, B, C, D + A1 = 16777216*B + C + A = 16777216*A1 + D + END + + PROGRAM MAIN + DOUBLE PRECISION D1MACH + EXTERNAL D1MACH + PRINT *,D1MACH(1) + PRINT *,D1MACH(2) + PRINT *,D1MACH(3) + PRINT *,D1MACH(4) + PRINT *,D1MACH(5) + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_init_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_init_1.f90 new file mode 100644 index 000000000..d918097c5 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/equiv_init_1.f90 @@ -0,0 +1,94 @@ +! Program to test initialization of equivalence blocks. PR13742. +! Some forms are not yet implemented. These are indicated by !!$ + +subroutine test0s + character*10 :: x = "abcdefghij" + character*10 :: y + equivalence (x,y) + + character*10 :: xs(10) + character*10 :: ys(10) + equivalence (xs,ys) + data xs /10*"abcdefghij"/ + + if (y.ne."abcdefghij") call abort + if (ys(1).ne."abcdefghij") call abort + if (ys(10).ne."abcdefghij") call abort +end + +subroutine test0 + integer :: x = 123 + integer :: y + equivalence (x,y) + if (y.ne.123) call abort +end + +subroutine test1 + integer :: a(3) + integer :: x = 1 + integer :: y + integer :: z = 3 + equivalence (a(1), x) + equivalence (a(3), z) + if (x.ne.1) call abort + if (z.ne.3) call abort + if (a(1).ne.1) call abort + if (a(3).ne.3) call abort +end + +subroutine test2 + integer :: x + integer :: z + integer :: a(3) = 123 + equivalence (a(1), x) + equivalence (a(3), z) + if (x.ne.123) call abort + if (z.ne.123) call abort +end + +subroutine test3 + integer :: x +!!$ integer :: y = 2 + integer :: z + integer :: a(3) + equivalence (a(1),x), (a(2),y), (a(3),z) + data a(1) /1/, a(3) /3/ + if (x.ne.1) call abort +!!$ if (y.ne.2) call abort + if (z.ne.3) call abort +end + +subroutine test4 + integer a(2) + integer b(2) + integer c + equivalence (a(2),b(1)), (b(2),c) + data a/1,2/ + data c/3/ + if (b(1).ne.2) call abort + if (b(2).ne.3) call abort +end + +!!$subroutine test5 +!!$ integer a(2) +!!$ integer b(2) +!!$ integer c +!!$ equivalence (a(2),b(1)), (b(2),c) +!!$ data a(1)/1/ +!!$ data b(1)/2/ +!!$ data c/3/ +!!$ if (a(2).ne.2) call abort +!!$ if (b(2).ne.3) call abort +!!$ print *, "Passed test5" +!!$end + +program main + call test0s + call test0 + call test1 + call test2 + call test3 + call test4 +!!$ call test5 +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp new file mode 100644 index 000000000..cd6fc45ad --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/execute.exp @@ -0,0 +1,43 @@ +# Copyright (C) 2003-2014 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# <http://www.gnu.org/licenses/>. + +# This file was written by Rob Savoye. (rob@cygnus.com) +# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com) + +# +# These tests come from many different contributors. +# + +if $tracelevel then { + strace $tracelevel +} + +# load support procs +load_lib fortran-torture.exp +load_lib torture-options.exp + +torture-init +set-torture-options [get-fortran-torture-options] + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + fortran-torture-execute $testcase +} + +torture-finish diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 new file mode 100644 index 000000000..cb2f5eacd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/f2_edit_1.f90 @@ -0,0 +1,10 @@ +! check F2.x edit descriptors +! PR 14746 + CHARACTER*15 LINE + RCON21 = 9. + RCON22 = .9 + WRITE(LINE,'(F2.0,1H,,F2.1)')RCON21,RCON22 + READ(LINE,'(F2.0,1X,F2.1)')XRCON21,XRCON22 + IF (RCON21.NE.XRCON21) CALL ABORT + IF (RCON22.NE.XRCON22) CALL ABORT + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 new file mode 100644 index 000000000..b60e67fb0 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall.f90 @@ -0,0 +1,17 @@ +! Program to test the FORALL construct +program testforall + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + integer i + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + forall (i=1:3) + b(i) = sum (a(:, i)) + end forall + + if (b(1) .ne. 6) call abort + if (b(2) .ne. 15) call abort + if (b(3) .ne. 24) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 new file mode 100644 index 000000000..806dede70 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_1.f90 @@ -0,0 +1,61 @@ +! Program to test FORALL construct +program forall_1 + + call actual_variable () + call negative_stride () + call forall_index () + +contains + subroutine actual_variable () + integer:: x = -1 + integer a(3,4) + j = 100 + + ! Actual variable 'x' and 'j' used as FORALL index + forall (x = 1:3, j = 1:4) + a (x,j) = j + end forall + if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if ((x.ne.-1).or.(j.ne.100)) call abort + + call actual_variable_2 (x, j, a) + end subroutine + + subroutine actual_variable_2(x, j, a) + integer x,j,x1,j1 + integer a(3,4), b(3,4) + + ! Actual variable 'x' and 'j' used as FORALL index. + forall (x=3:1:-1, j=4:1:-1) + a(x,j) = j + b(x,j) = j + end forall + + if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if (any (b.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort + if ((x.ne.-1).or.(j.ne.100)) call abort + end subroutine + + subroutine negative_stride () + integer a(3,4) + integer x, j + + ! FORALL with negative stride + forall (x = 3:1:-1, j = 4:1:-1) + a(x,j) = j + x + end forall + if (any (a.ne.reshape ((/2,3,4,3,4,5,4,5,6,5,6,7/), (/3,4/)))) call abort + end subroutine + + subroutine forall_index + integer a(32,32) + + ! FORALL with arbitrary number indexes + forall (i1=1:2,i2=1:2,i3=1:2,i4=1:2,i5=1:2,i6=1:2,i7=1:2,i8=1:2,i9=1:2,& + i10=1:2) + a(i1+2*i3+4*i5+8*i7+16*i9-30,i2+2*i4+4*i6+8*i8+16*i10-30) = 1 + end forall + if ((a(5,5).ne.1).or. (a(32,32).ne.1)) call abort + end subroutine + +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 new file mode 100644 index 000000000..92a4ff102 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_2.f90 @@ -0,0 +1,20 @@ +!program to test nested forall construct and forall mask +program test + implicit none + integer a(4,4) + integer i, j + + do i=1,4 + do j=1,4 + a(j,i) = j-i + enddo + enddo + forall (i=2:4, a(1,i).GT.-2) + forall (j=1:4, a(j,2).GT.0) + a(j,i) = a(j,i-1) + end forall + end forall + if (any (a.ne.reshape ((/0,1,2,3,-1,0,2,3,-2,-1,0,1,-3,-2,-1,0/),& + (/4,4/)))) call abort +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 new file mode 100644 index 000000000..cab075795 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_3.f90 @@ -0,0 +1,37 @@ +! PR fortran/15080 +! Really test forall with temporary +program evil_forall + implicit none + type t + logical valid + integer :: s + integer, dimension(:), pointer :: p + end type + type (t), dimension (5) :: v + integer i + + allocate (v(1)%p(2)) + allocate (v(2)%p(8)) + v(3)%p => NULL() + allocate (v(4)%p(8)) + allocate (v(5)%p(2)) + + v(:)%valid = (/.true., .true., .false., .true., .true./) + v(:)%s = (/1, 8, 999, 6, 2/) + v(1)%p(:) = (/9, 10/) + v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/) + v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/) + v(5)%p(:) = (/11, 12/) + + + forall (i=1:5,v(i)%valid) + v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s) + end forall + + if (any(v(1)%p(:) .ne. (/11, 10/))) call abort + if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort + if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort + if (any(v(5)%p(:) .ne. (/9, 10/))) call abort + + ! I should really free the memory I've allocated. +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 new file mode 100644 index 000000000..f2dded735 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_4.f90 @@ -0,0 +1,27 @@ +! Program to test nested forall +program forall2 + implicit none + integer a(4,4,2) + integer i, j, k, n + + a(:,:,1) = reshape((/ 1, 2, 3, 4,& + 5, 6, 7, 8,& + 9,10,11,12,& + 13,14,15,16/), (/4,4/)) + a(:,:,2) = a(:,:,1) + 16 + n=4 + k=1 + ! Mirror half the matrix + forall (i=k:n) + forall (j=1:5-i) + a(i,j,:) = a(j,i,:) + end forall + end forall + + if (any (a(:,:,1) & + .ne. reshape((/ 1, 5, 9,13,& + 2, 6,10, 8,& + 3, 7,11,12,& + 4,14,15,16/),(/4,4/)))) call abort + if (any (a(:,:,2) .ne. a(:,:,1) + 16)) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 new file mode 100644 index 000000000..0595adf0c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_5.f90 @@ -0,0 +1,28 @@ +! Program to test FORALL with pointer assignment inside it. +program forall_5 + type element + integer, pointer, dimension(:)::p + end type + + type (element) q(5) + integer, target, dimension(25)::t + + n = 5 + do i = 1,5 + q(i)%p => t((i-1)*n + 1:i*n) + enddo + + forall (i = 2:5) + q(i)%p => q(i-1)%p + end forall + + do i = 1, 25 + t(i) = i + enddo + + if (any(q(1)%p .ne. (/1,2,3,4,5/))) call abort + if (any(q(2)%p .ne. (/1,2,3,4,5/))) call abort + if (any(q(3)%p .ne. (/6,7,8,9,10/))) call abort + if (any(q(4)%p .ne. (/11,12,13,14,15/))) call abort + if (any(q(5)%p .ne. (/16,17,18,19,20/))) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 new file mode 100644 index 000000000..b277814fb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_6.f90 @@ -0,0 +1,25 @@ +! Program to test FORALL with scalar pointer assignment inside it. +program forall_6 + type element + real, pointer :: p + end type + + type (element) q(5) + real, target, dimension(5) :: t + integer i; + + t = (/1.0, 2.0, 3.0, 4.0, 5.0/) + + do i = 1,5 + q(i)%p => t(i) + end do + + forall (i = 1:5) + q(i)%p => q(6 - i)%p + end forall + + + do i = 1,5 + if (q(i)%p .ne. t(6 - i)) call abort + end do +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 new file mode 100644 index 000000000..4a2892810 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/forall_7.f90 @@ -0,0 +1,88 @@ +! tests FORALL statements with a mask +program forall_7 + real, dimension (5, 5, 5, 5) :: a, b, c, d + + a (:, :, :, :) = 4 + forall (i = 1:5) + a (i, i, 6 - i, i) = 7 + end forall + forall (i = 1:5) + a (i, 6 - i, i, i) = 7 + end forall + forall (i = 1:5) + a (6 - i, i, i, i) = 7 + end forall + forall (i = 1:5:2) + a (1, 2, 3, i) = 0 + end forall + + b = a + c = a + d = a + + forall (i = 1:5, j = 1:5, k = 1:5, ((a (i, j, k, i) .gt. 6) .or. (a (i, j, k, j) .gt. 6))) + forall (l = 1:5, a (1, 2, 3, l) .lt. 2) + a (i, j, k, l) = i - j + k - l + 0.5 + end forall + end forall + + forall (l = 1:5, b (1, 2, 3, l) .lt. 2) + forall (i = 1:5, j = 1:5, k = 1:5, ((b (i, j, k, i) .gt. 6) .or. (b (i, j, k, j) .gt. 6))) + b (i, j, k, l) = i - j + k - l + 0.5 + end forall + end forall + + forall (i = 1:5, j = 1:5, k = 1:5, ((c (i, j, k, i) .gt. 6) .or. (c (i, j, k, j) .gt. 6))) + forall (l = 1:5, c (1, 2, 3, l) .lt. 2) + c (i, j, k, l) = i - j + k - l + 0.5 + c (l, k, j, i) + end forall + end forall + + forall (l = 1:5, d (1, 2, 3, l) .lt. 2) + forall (i = 1:5, j = 1:5, k = 1:5, ((d (i, j, k, i) .gt. 6) .or. (d (i, j, k, j) .gt. 6))) + d (i, j, k, l) = i - j + k - l + 0.5 + d (l, k, j, i) + end forall + end forall + + do i = 1, 5 + do j = 1, 5 + do k = 1, 5 + do l = 1, 5 + r = 4 + if ((i == j .and. k == 6 - i) .or. (i == k .and. j == 6 - i)) then + if (l /= 2 .and. l /= 4) then + r = 1 + elseif (l == i) then + r = 7 + end if + elseif (j == k .and. i == 6 - j) then + if (l /= 2 .and. l /= 4) then + r = 1 + elseif (l == j) then + r = 7 + end if + elseif (i == 1 .and. j == 2 .and. k == 3 .and. l /= 2 .and. l /= 4) then + r = 0 + end if + s = r + if (r == 1) then + r = i - j + k - l + 0.5 + if (((l == k .and. j == 6 - l) .or. (l == j .and. k == 6 - l)) .and. (i == l)) then + s = r + 7 + elseif (k == j .and. l == 6 - k .and. i == k) then + s = r + 7 + elseif (l /= 1 .or. k /= 2 .or. j /= 3 .or. i == 2 .or. i == 4) then + s = r + 4 + else + s = r + end if + end if + if (a (i, j, k, l) /= r) call abort () + if (c (i, j, k, l) /= s) call abort () + end do + end do + end do + end do + + if (any (a /= b .or. c /= d)) call abort () +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 new file mode 100644 index 000000000..e57ff161d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/function_module_1.f90 @@ -0,0 +1,36 @@ +! This can fail because BB is not resolved correctly. +module M1 + +INTEGER p + +CONTAINS +subroutine AA () + implicit NONE + p = BB () + CONTAINS + subroutine AA_1 () + implicit NONE + integer :: i + i = BB () + end subroutine + + function BB() + integer :: BB + BB = 1 + end function +end subroutine + +function BB() + implicit NONE + integer :: BB + BB = 2 +end function +end module + +program P1 + USE M1 + implicit none + p = 0 + call AA () + if (p /= 1) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 new file mode 100644 index 000000000..7189991f7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 @@ -0,0 +1,30 @@ +! Check that getarg does somethig sensible. +program getarg_1 + CHARACTER*10 ARGS, ARGS2 + INTEGER*4 I + INTEGER*2 I2 + I = 0 + CALL GETARG(I,ARGS) + ! This should return the invoking command. The actual value depends + ! on the OS, but a blank string is wrong no matter what. + ! ??? What about deep embedded systems? + + I2 = 0 + CALL GETARG(I2,ARGS2) + if (args2.ne.args) call abort + + if (args.eq.'') call abort + I = 1 + CALL GETARG(I,ARGS) + if (args.ne.'') call abort + I = -1 + CALL GETARG(I,ARGS) + if (args.ne.'') call abort + ! Assume we won't have been called with more that 4 args. + I = 4 + CALL GETARG(I,ARGS) + if (args.ne.'') call abort + I = 1000 + CALL GETARG(I,ARGS) + if (args.ne.'') call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.x new file mode 100644 index 000000000..6356b439e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.x @@ -0,0 +1,5 @@ +if [istarget "spu-*-*"] { + # We need -mstdmain to enable argument processing on SPU. + lappend additional_flags "-mstdmain" +} +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 new file mode 100644 index 000000000..aa7b17def --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/hollerith.f90 @@ -0,0 +1,9 @@ +! PR 14038- 'H' in hollerith causes mangling of string +program hollerith + IMPLICIT NONE + CHARACTER*4 LINE +100 FORMAT (4H12H4) + WRITE(LINE,100) + IF (LINE .NE. '12H4') call abort () +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/in-pack.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/in-pack.f90 new file mode 100644 index 000000000..b9ea26832 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/in-pack.f90 @@ -0,0 +1,92 @@ +! Check in_pack and in_unpack for integer and comlex types, with +! alignment issues thrown in for good measure. + +program main + implicit none + + complex(kind=4) :: a4(5),b4(5),aa4(5),bb4(5) + real(kind=4) :: r4(100) + equivalence(a4(1),r4(1)),(b4(1),r4(12)) + + complex(kind=8) :: a8(5),b8(5),aa8(5),bb8(5) + real(kind=8) :: r8(100) + equivalence(a8(1),r8(1)),(b8(1),r8(12)) + + integer(kind=4) :: i4(5),ii4(5) + integer(kind=8) :: i8(5),ii8(5) + + integer :: i + + a4 = (/(cmplx(i,-i,kind=4),i=1,5)/) + b4 = (/(2*cmplx(i,-i,kind=4),i=1,5)/) + call csub4(a4(5:1:-1),b4(5:1:-1),5) + aa4 = (/(cmplx(5-i+1,i-5-1,kind=4),i=1,5)/) + if (any(aa4 /= a4)) call abort + bb4 = (/(2*cmplx(5-i+1,i-5-1,kind=4),i=1,5)/) + if (any(bb4 /= b4)) call abort + + a8 = (/(cmplx(i,-i,kind=8),i=1,5)/) + b8 = (/(2*cmplx(i,-i,kind=8),i=1,5)/) + call csub8(a8(5:1:-1),b8(5:1:-1),5) + aa8 = (/(cmplx(5-i+1,i-5-1,kind=8),i=1,5)/) + if (any(aa8 /= a8)) call abort + bb8 = (/(2*cmplx(5-i+1,i-5-1,kind=8),i=1,5)/) + if (any(bb8 /= b8)) call abort + + i4 = (/(i, i=1,5)/) + call isub4(i4(5:1:-1),5) + ii4 = (/(5-i+1,i=1,5)/) + if (any(ii4 /= i4)) call abort + + i8 = (/(i,i=1,5)/) + call isub8(i8(5:1:-1),5) + ii8 = (/(5-i+1,i=1,5)/) + if (any(ii8 /= i8)) call abort + +end program main + +subroutine csub4(a,b,n) + implicit none + complex(kind=4), dimension(n) :: a,b + complex(kind=4), dimension(n) :: aa, bb + integer :: n, i + aa = (/(cmplx(n-i+1,i-n-1,kind=4),i=1,n)/) + if (any(aa /= a)) call abort + bb = (/(2*cmplx(n-i+1,i-n-1,kind=4),i=1,5)/) + if (any(bb /= b)) call abort + a = (/(cmplx(i,-i,kind=4),i=1,5)/) + b = (/(2*cmplx(i,-i,kind=4),i=1,5)/) +end subroutine csub4 + +subroutine csub8(a,b,n) + implicit none + complex(kind=8), dimension(n) :: a,b + complex(kind=8), dimension(n) :: aa, bb + integer :: n, i + aa = (/(cmplx(n-i+1,i-n-1,kind=8),i=1,n)/) + if (any(aa /= a)) call abort + bb = (/(2*cmplx(n-i+1,i-n-1,kind=8),i=1,5)/) + if (any(bb /= b)) call abort + a = (/(cmplx(i,-i,kind=8),i=1,5)/) + b = (/(2*cmplx(i,-i,kind=8),i=1,5)/) +end subroutine csub8 + +subroutine isub4(a,n) + implicit none + integer(kind=4), dimension(n) :: a + integer(kind=4), dimension(n) :: aa + integer :: n, i + aa = (/(n-i+1,i=1,n)/) + if (any(aa /= a)) call abort + a = (/(i,i=1,5)/) +end subroutine isub4 + +subroutine isub8(a,n) + implicit none + integer(kind=8), dimension(n) :: a + integer(kind=8), dimension(n) :: aa + integer :: n, i + aa = (/(n-i+1,i=1,n)/) + if (any(aa /= a)) call abort + a = (/(i,i=1,5)/) +end subroutine isub8 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initialization_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initialization_1.f90 new file mode 100644 index 000000000..2ccb45a23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initialization_1.f90 @@ -0,0 +1,10 @@ +! PR 15963 -- checks character comparison in initialization expressions +character(8), parameter :: a(5) = (/ "H", "E", "L", "L", "O" /) +call x(a) +contains +subroutine x(a) +character(8), intent(in) :: a(:) +integer :: b(count(a < 'F')) +if (size(b) /= 1) call abort() +end subroutine x +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 new file mode 100644 index 000000000..55cc185f3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/initializer.f90 @@ -0,0 +1,26 @@ +! Program to test static variable initialization +! returns the parameter from the previous invocation, or 42 on the first call. +function test (parm) + implicit none + integer test, parm + integer :: val = 42 + + test = val + val = parm +end function + +program intializer + implicit none + integer test + character(11) :: c = "Hello World" + character(15) :: d = "Teststring" + integer, dimension(3) :: a = 1 + + if (any (a .ne. 1)) call abort + if (test(11) .ne. 42) call abort + ! The second call should return + if (test(0) .ne. 11) call abort + + if (c .ne. "Hello World") call abort + if (d .ne. "Teststring") call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 new file mode 100644 index 000000000..8deb6b863 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_1.f90 @@ -0,0 +1,9 @@ +! PR 14831 + CHARACTER*4 BLANK + CHARACTER*10 ACCESS + OPEN(UNIT=9,ACCESS='SEQUENTIAL') + INQUIRE(UNIT=9,ACCESS=ACCESS,BLANK=BLANK) + IF(BLANK.NE.'NULL') CALL ABORT + IF(ACCESS.NE.'SEQUENTIAL') CALL ABORT + CLOSE(UNIT=9,STATUS='DELETE') + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 new file mode 100644 index 000000000..481051702 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_2.f90 @@ -0,0 +1,7 @@ +! PR 14837 + INTEGER UNIT + OPEN(FILE='CSEQ', UNIT=23) + INQUIRE(FILE='CSEQ',NUMBER=UNIT) + IF (UNIT.NE.23) CALL ABORT + CLOSE(UNIT, STATUS='DELETE') + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 new file mode 100644 index 000000000..29d25812a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_3.f90 @@ -0,0 +1,14 @@ +! pr14836 + OPEN(UNIT=9, ACCESS='DIRECT', RECL=80, FORM='UNFORMATTED') + INQUIRE(UNIT=9,NEXTREC=NREC) + WRITE(UNIT=9,REC=5) 1 + INQUIRE(UNIT=9,NEXTREC=NREC) +! PRINT*,NREC + IF (NREC.NE.6) CALL ABORT + READ(UNIT=9,REC=1) MVI + INQUIRE(UNIT=9,NEXTREC=NREC) + IF (NREC.NE.2) CALL ABORT +! PRINT*,NREC + CLOSE(UNIT=9,STATUS='DELETE') + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 new file mode 100644 index 000000000..2fa69cc3f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_4.f90 @@ -0,0 +1,21 @@ +! pr 14904 +! inquire lastrec not correct when two records written +! with one write statement + OPEN(UNIT=10,ACCESS='DIRECT',FORM='FORMATTED',RECL=120) + 100 FORMAT(I4) + WRITE(UNIT=10,REC=1,FMT=100)1 + INQUIRE(UNIT=10,NEXTREC=J) + IF (J.NE.2) THEN +! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 2' + CALL ABORT + ENDIF + 200 FORMAT(I4,/,I4) + WRITE(UNIT=10,REC=2,FMT=200)2,3 + INQUIRE(UNIT=10,NEXTREC=J) + IF (J.NE.4) THEN +! PRINT*,'NEXTREC RETURNED ',J,' EXPECTED 4' + CALL ABORT + ENDIF + CLOSE(UNIT=10,STATUS='DELETE') + END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 new file mode 100644 index 000000000..1077650d8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 @@ -0,0 +1,32 @@ +! PR fortran/21647 +program inquire_5 + integer (kind = 8) :: unit8 + logical (kind = 8) :: exist8 + integer (kind = 4) :: unit4 + logical (kind = 4) :: exist4 + integer (kind = 2) :: unit2 + logical (kind = 2) :: exist2 + integer (kind = 1) :: unit1 + logical (kind = 1) :: exist1 + character (len = 6) :: del + unit8 = 78 + open (file = 'inquire_5.txt', unit = unit8) + unit8 = -1 + exist8 = .false. + unit4 = -1 + exist4 = .false. + unit2 = -1 + exist2 = .false. + unit1 = -1 + exist1 = .false. + inquire (file = 'inquire_5.txt', number = unit8, exist = exist8) + if (unit8 .ne. 78 .or. .not. exist8) call abort + inquire (file = 'inquire_5.txt', number = unit4, exist = exist4) + if (unit4 .ne. 78 .or. .not. exist4) call abort + inquire (file = 'inquire_5.txt', number = unit2, exist = exist2) + if (unit2 .ne. 78 .or. .not. exist2) call abort + inquire (file = 'inquire_5.txt', number = unit1, exist = exist1) + if (unit1 .ne. 78 .or. .not. exist1) call abort + del = 'delete' + close (unit = 78, status = del) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 new file mode 100644 index 000000000..765356d26 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select.f90 @@ -0,0 +1,71 @@ +PROGRAM Test_INTEGER_select + +! Every wrong branch leads to destruction. + + INTEGER, PARAMETER :: maxI = HUGE (maxI) + INTEGER, PARAMETER :: minI = -1 * maxI + INTEGER :: I = 0 + + SELECT CASE (I) + CASE (:-1) + CALL abort + CASE (1:) + CALL abort + CASE DEFAULT + CONTINUE + END SELECT + + SELECT CASE (I) + CASE (3,2,1) + CALL abort + CASE (0) + CONTINUE + CASE DEFAULT + call abort + END SELECT + +! Not aborted by here, so it worked +! See about weird corner cases + + I = maxI + + SELECT CASE (I) + CASE (:-1) + CALL abort + CASE (1:) + CONTINUE + CASE DEFAULT + CALL abort + END SELECT + + SELECT CASE (I) + CASE (3,2,1,:0) + CALL abort + CASE (maxI) + CONTINUE + CASE DEFAULT + call abort + END SELECT + + I = minI + + SELECT CASE (I) + CASE (:-1) + CONTINUE + CASE (1:) + CALL abort + CASE DEFAULT + CALL abort + END SELECT + + SELECT CASE (I) + CASE (3:,2,1,0) + CALL abort + CASE (minI) + CONTINUE + CASE DEFAULT + call abort + END SELECT + +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 new file mode 100644 index 000000000..18bc79b43 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/integer_select_1.f90 @@ -0,0 +1,31 @@ +INTEGER :: I = 1 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (1) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +I = -3 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (1) + CONTINUE + CASE DEFAULT + CONTINUE +END SELECT + +I = -5 +SELECT CASE (I) + CASE (-3:-5) ! Can never be matched + CALL abort + CASE (-5) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 new file mode 100644 index 000000000..1e492977b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90 @@ -0,0 +1,11 @@ +! PR 14901 +! Internal writes were appending CR after the last char +! written by the format statement. + CHARACTER*10 A + WRITE(A,'(3HGCC)') + IF (A.NE.'GCC ') THEN +! PRINT*,'A was not filled correctly by internal write' +! PRINT*,' A = ',A + CALL ABORT + ENDIF + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 new file mode 100644 index 000000000..9e44657ba --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_abs.f90 @@ -0,0 +1,33 @@ +! Program to test the ABS intrinsic +program intrinsic_abs + implicit none + integer i + real(kind=4) r + real(kind=8) q + complex z + + i = 42 + i = abs(i) + if (i .ne. 42) call abort + i = -43 + i = abs(i) + if (i .ne. 43) call abort + + r = 42.0 + r = abs(r) + if (r .ne. 42.0) call abort + r = -43.0 + r = abs(r) + if (r .ne. 43.0) call abort + + q = 42.0_8 + q = abs(q) + if (q .ne. 42.0_8) call abort + q = -43.0_8 + q = abs(q) + if (q .ne. 43.0_8) call abort + + z = (3, 4) + r = abs(z) + if (r .ne. 5) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 new file mode 100644 index 000000000..fba0a0897 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_achar.f90 @@ -0,0 +1,9 @@ +! Program to test the ACHAR and IACHAR intrinsics +program intrinsic_achar + integer i + + i = 32 + if (achar(i) .ne. " ") call abort + i = iachar("A") + if ((i .ne. 65) .or. char(i) .ne. "A") call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 new file mode 100644 index 000000000..16e816c6b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_aint_anint.f90 @@ -0,0 +1,55 @@ +! Program to test AINT and ANINT intrinsics + +subroutine real4test (op, res1, res2) + implicit none + real(kind=4) :: op + real(kind=4) :: res1, res2 + + if (diff(aint(op), res1) .or. & + diff(anint(op), res2)) call abort +contains +function diff(a, b) + real(kind=4) :: a, b + logical diff + + diff = (abs (a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +subroutine real8test (op, res1, res2) + implicit none + real(kind=8) :: op + real(kind=8) :: res1, res2 + + if (diff(aint(op), res1) .or. & + diff(anint(op), res2)) call abort +contains +function diff(a, b) + real(kind=8) :: a, b + logical diff + + diff = (abs(a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +program aint_aninttest + implicit none + + call real4test (3.456, 3.0, 3.0) + call real4test (-2.798, -2.0, -3.0) + call real4test (3.678, 3.0, 4.0) + call real4test (-1.375, -1.0, -1.0) + call real4test (-0.5, 0.0,-1.0) + call real4test (0.4, 0.0,0.0) + + call real8test (3.456_8, 3.0_8, 3.0_8) + call real8test (-2.798_8, -2.0_8, -3.0_8) + call real8test (3.678_8, 3.0_8, 4.0_8) + call real8test (-1.375_8, -1.0_8, -1.0_8) + call real8test (-0.5_8, 0.0_8,-1.0_8) + call real8test (0.4_8, 0.0_8,0.0_8) + + ! Check large numbers + call real4test (2e34, 2e34, 2e34) + call real4test (-2e34, -2e34, -2e34) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 new file mode 100644 index 000000000..4e392c569 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_anyall.f90 @@ -0,0 +1,41 @@ +! Program to test the ANY and ALL intrinsics +program anyall + implicit none + logical, dimension(3, 3) :: a + logical, dimension(3) :: b + character(len=10) line + + a = .false. + if (any(a)) call abort + a(1, 1) = .true. + a(2, 3) = .true. + if (.not. any(a)) call abort + b = any(a, 1) + if (.not. b(1)) call abort + if (b(2)) call abort + if (.not. b(3)) call abort + b = .false. + write (line, 9000) any(a,1) + read (line, 9000) b + if (.not. b(1)) call abort + if (b(2)) call abort + if (.not. b(3)) call abort + + a = .true. + if (.not. all(a)) call abort + a(1, 1) = .false. + a(2, 3) = .false. + if (all(a)) call abort + b = all(a, 1) + if (b(1)) call abort + if (.not. b(2)) call abort + if (b(3)) call abort + b = .false. + write (line, 9000) all(a,1) + read (line, 9000) b + if (b(1)) call abort + if (.not. b(2)) call abort + if (b(3)) call abort + +9000 format (9L1) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 new file mode 100644 index 000000000..22ea6f0a6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 @@ -0,0 +1,134 @@ +! Program to test the ASSOCIATED intrinsic. +program intrinsic_associated + call pointer_to_section () + call associate_1 () + call pointer_to_derived_1 () + call associated_2 () +end + +subroutine pointer_to_section () + integer, dimension(5, 5), target :: xy + integer, dimension(:, :), pointer :: window + data xy /25*0/ + logical t + + window => xy(2:4, 3:4) + window = 10 + window (1, 1) = 0101 + window (3, 2) = 4161 + window (3, 1) = 4101 + window (1, 2) = 0161 + + t = associated (window, xy(2:4, 3:4)) + if (.not.t) call abort () + ! Check that none of the array got mangled + if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) & + .or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort () + if (any (xy(:, 1:2) .ne. 0)) call abort () + if (any (xy(:, 5) .ne. 0)) call abort () + if (any (xy (1, 3:4) .ne. 0)) call abort () + if (any (xy (5, 3:4) .ne. 0)) call abort () + if (xy(3, 3) .ne. 10) call abort () + if (xy(3, 4) .ne. 10) call abort () + if (any (xy(2:4, 3:4) .ne. window)) call abort () +end + +subroutine sub1 (a, ap) + integer, pointer :: ap(:, :) + integer, target :: a(10, 10) + + ap => a +end + +subroutine nullify_pp (a) + integer, pointer :: a(:, :) + + if (.not. associated (a)) call abort () + nullify (a) +end + +subroutine associate_1 () + integer, pointer :: a(:, :), b(:, :) + interface + subroutine nullify_pp (a) + integer, pointer :: a(:, :) + end subroutine nullify_pp + end interface + + allocate (a(80, 80)) + b => a + if (.not. associated(a)) call abort () + if (.not. associated(b)) call abort () + call nullify_pp (a) + if (associated (a)) call abort () + if (.not. associated (b)) call abort () +end + +subroutine pointer_to_derived_1 () + type record + integer :: value + type(record), pointer :: rp + end type record + + type record1 + integer value + type(record2), pointer :: r1p + end type + + type record2 + integer value + type(record1), pointer :: r2p + end type + + type(record), target :: e1, e2, e3 + type(record1), target :: r1 + type(record2), target :: r2 + + nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp) + if (associated (r1%r1p)) call abort () + if (associated (r2%r2p)) call abort () + if (associated (e2%rp)) call abort () + if (associated (e1%rp)) call abort () + if (associated (e3%rp)) call abort () + r1%r1p => r2 + r2%r2p => r1 + r1%value = 11 + r2%value = 22 + e1%rp => e2 + e2%rp => e3 + e1%value = 33 + e1%rp%value = 44 + e1%rp%rp%value = 55 + if (.not. associated (r1%r1p)) call abort () + if (.not. associated (r2%r2p)) call abort () + if (.not. associated (e1%rp)) call abort () + if (.not. associated (e2%rp)) call abort () + if (associated (e3%rp)) call abort () + if (r1%r1p%value .ne. 22) call abort () + if (r2%r2p%value .ne. 11) call abort () + if (e1%value .ne. 33) call abort () + if (e2%value .ne. 44) call abort () + if (e3%value .ne. 55) call abort () + if (r1%value .ne. 11) call abort () + if (r2%value .ne. 22) call abort () + +end + +subroutine associated_2 () + integer, pointer :: xp(:, :) + integer, target :: x(10, 10) + integer, target :: y(100, 100) + interface + subroutine sub1 (a, ap) + integer, pointer :: ap(:, :) + integer, target :: a(10, 10) + end + endinterface + + xp => y + if (.not. associated (xp)) call abort () + call sub1 (x, xp) + if (associated (xp, y)) call abort () + if (.not. associated (xp, x)) call abort () +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 new file mode 100644 index 000000000..5f353b2f8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated_2.f90 @@ -0,0 +1,36 @@ +! Program to test the ASSOCIATED intrinsic with cross-kinds +program intrinsic_associated_2 + logical*4 :: t4, L44, L48 + logical*8 :: t8, L84, L88 + real*4, pointer :: a4p(:, :) + real*8, pointer :: a8p(:, :) + real*4, target :: a4(10, 10) + real*8, target :: a8(10, 10) + + t4 = .true. + t8 = .true. + t8 = t4 + a4p => a4 + a8p => a8 + L44 = t4 .and. associated (a4p, a4) + L84 = t8 .and. associated (a4p, a4) + L48 = t4 .and. associated (a8p, a8) + L88 = t8 .and. associated (a8p, a8) + if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort () + + nullify (a4p, a8p) + L44 = t4 .and. associated (a4p, a4) + L84 = t8 .and. associated (a4p, a4) + L48 = t4 .and. associated (a8p, a8) + L88 = t8 .and. associated (a8p, a8) + if (L44 .and. L84 .and. L48 .and. L88) call abort () + + a4p => a4(1:10:2, 1:10:2) + a8p => a8(1:4, 1:4) + L44 = t4 .and. associated (a4p, a4(1:10:2, 1:10:2)) + L84 = t8 .and. associated (a4p, a4(1:10:2, 1:10:2)) + L48 = t4 .and. associated (a8p, a8(1:4, 1:4)) + L88 = t8 .and. associated (a8p, a8(1:4, 1:4)) + if (.not. (L44 .and. L84 .and. L48 .and. L88)) call abort () +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 new file mode 100644 index 000000000..7dcda255b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_bitops.f90 @@ -0,0 +1,32 @@ +! Program to test intrinsic bitops +program intrinsic_bitops + implicit none + integer(kind=4) :: i, j, k, o, t + integer(kind=8) :: a, b, c + + o = 0 + i = 2 + j = 3 + k = 12 + a = 5 + + if (.not. btest (i, o+1)) call abort + if (btest (i, o+2)) call abort + if (iand (i, j) .ne. 2) call abort + if (ibclr (j, o+1) .ne. 1) call abort + if (ibclr (j, o+2) .ne. 3) call abort + if (ibits (k, o+1, o+2) .ne. 2) call abort + if (ibset (j, o+1) .ne. 3) call abort + if (ibset (j, o+2) .ne. 7) call abort + if (ieor (i, j) .ne. 1) call abort + if (ior (i, j) .ne. 3) call abort + if (ishft (k, o+2) .ne. 48) call abort + if (ishft (k, o-3) .ne. 1) call abort + if (ishft (k, o) .ne. 12) call abort + if (ishftc (k, o+30) .ne. 3) call abort + if (ishftc (k, o-30) .ne. 48) call abort + if (ishftc (k, o+1, o+3) .ne. 9) call abort + if (not (i) .ne. -3) call abort + if (ishftc (a, 1, bit_size(a)) .ne. 10) call abort + if (ishftc (1, 1, 32) .ne. 2) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 new file mode 100644 index 000000000..0892d629c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_count.f90 @@ -0,0 +1,34 @@ +! Program to test the COUNT intrinsic +program intrinsic_count + implicit none + logical(kind=4), dimension (3, 5) :: a + integer(kind=4), dimension (3) :: b + integer i + character(len=10) line + + a = .false. + if (count(a) .ne. 0) call abort + a = .true. + if (count(a) .ne. 15) call abort + a(1, 1) = .false. + a(2, 2) = .false. + a(2, 5) = .false. + if (count(a) .ne. 12) call abort + write (line, 9000) count(a) + read (line, 9000) i + if (i .ne. 12) call abort + + b(1:3) = count(a, 2); + if (b(1) .ne. 4) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 5) call abort + b = 0 + write (line, 9000) count(a,2) + read (line, 9000) b + if (b(1) .ne. 4) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 5) call abort + +9000 format(3I3) + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 new file mode 100644 index 000000000..f188cd8f4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_cshift.f90 @@ -0,0 +1,43 @@ +! Program to test the cshift intrinsic +program intrinsic_cshift + integer, dimension(3, 3) :: a + integer, dimension(3, 3, 2) :: b + + ! Scalar shift + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, 1, 1) + if (any (a .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, -2, dim = 2) + if (any (a .ne. reshape ((/4, 5, 6, 7, 8, 9, 1, 2, 3/), (/3, 3/)))) & + call abort + + ! Array shift + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, (/1, 0, -1/)) + if (any (a .ne. reshape ((/2, 3, 1, 4, 5, 6, 9, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = cshift (a, (/2, -2, 0/), dim = 2) + if (any (a .ne. reshape ((/7, 5, 3, 1, 8, 6, 4, 2, 9/), (/3, 3/)))) & + call abort + + ! Test arrays > rank 2 + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,& + 18, 19/), (/3, 3, 2/)) + b = cshift (b, 1) + if (any (b .ne. reshape ((/2, 3, 1, 5, 6, 4, 8, 9, 7, 12, 13, 11, 15,& + 16, 14, 18, 19, 17/), (/3, 3, 2/)))) & + call abort + + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17,& + 18, 19/), (/3, 3, 2/)) + b = cshift (b, reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)), 3) + if (any (b .ne. reshape ((/11, 2, 13, 4, 15, 6, 17, 8, 19, 1, 12, 3,& + 14, 5, 16, 7, 18, 9/), (/3, 3, 2/)))) & + call abort + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 new file mode 100644 index 000000000..4753de360 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dim.f90 @@ -0,0 +1,20 @@ +! Program to test the DIM intrinsic +program intrinsic_dim + implicit none + integer i, j + real(kind=4) :: r, s + real(kind=8) :: p, q + + i = 1 + j = 4 + if (dim (i, j) .ne. 0) call abort + if (dim (j, i) .ne. 3) call abort + r = 1.0 + s = 4.0 + if (dim (r, s) .ne. 0.0) call abort + if (dim (s, r) .ne. 3.0) call abort + p = 1.0 + q = 4.0 + if (dim (p, q) .ne. 0.0) call abort + if (dim (q, p) .ne. 3.0) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 new file mode 100644 index 000000000..5444dd6da --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dotprod.f90 @@ -0,0 +1,25 @@ +! Program to test the DOT_PRODUCT intrinsic +program testforall + implicit none + integer, dimension (3) :: a + integer, dimension (3) :: b + real, dimension(3) :: c + real r + complex, dimension (2) :: z1 + complex, dimension (2) :: z2 + complex z + + a = (/1, 2, 3/); + b = (/4, 5, 6/); + c = (/4, 5, 6/); + + if (dot_product(a, b) .ne. 32) call abort + + r = dot_product(a, c) + if (abs(r - 32.0) .gt. 0.001) call abort + + z1 = (/(1.0, 2.0), (2.0, 3.0)/) + z2 = (/(3.0, 4.0), (4.0, 5.0)/) + z = dot_product (z1, z2) + if (abs (z - (34.0, -4.0)) .gt. 0.001) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 new file mode 100644 index 000000000..feb336793 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dprod.f90 @@ -0,0 +1,13 @@ +! Program to test DPROD intrinsic +program intrinsic_dprod + implicit none + real r, s, t + double precision dp + + ! 6d60 doesn't fit in a 4-byte real + r = 2e30 + s = 4e30 + dp = dprod (r, s) + if ((dp .gt. 8.001d60) .or. (dp .lt. 7.999d60)) call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 new file mode 100644 index 000000000..2e8a34014 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_dummy.f90 @@ -0,0 +1,23 @@ +! Program to test passing intrinsic functions as actual arguments for +! dummy procedures. +subroutine test (proc) + implicit none + real proc + real a, b, c + + a = 1.0 + b = sin (a) + c = proc (a) + + if (abs (b - c) .gt. 0.001) call abort + +end subroutine + +program dummy + implicit none + external test + intrinsic sin + + call test (sin) +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 new file mode 100644 index 000000000..c4bbcdd68 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_eoshift.f90 @@ -0,0 +1,102 @@ +! Program to test the eoshift intrinsic +program intrinsic_eoshift + integer, dimension(3, 3) :: a + integer, dimension(3, 3, 2) :: b + integer, dimension(3) :: bo, sh + + ! Scalar shift and scalar bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 1, 99, 1) + if (any (a .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 9999, 99, 1) + if (any (a .ne. 99)) call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -2, dim = 2) + if (any (a .ne. reshape ((/0, 0, 0, 0, 0, 0, 1, 2, 3/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -9999, 99, 1) + if (any (a .ne. 99)) call abort + + ! Array shift and scalar bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/1, 0, -1/), 99, 1) + if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 99, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/9999, 0, -9999/), 99, 1) + if (any (a .ne. reshape ((/99, 99, 99, 4, 5, 6, 99, 99, 99/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/2, -2, 0/), dim = 2) + if (any (a .ne. reshape ((/7, 0, 3, 0, 0, 6, 0, 2, 9/), (/3, 3/)))) & + call abort + + ! Scalar shift and array bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 1, (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/2, 3, 99, 5, 6, -1, 8, 9, 42/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, 9999, (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), & + (/3, 3/)))) call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -9999, (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/99, 99, 99, -1, -1, -1, 42, 42, 42/), & + (/3, 3/)))) call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, -2, (/99, -1, 42/), 2) + if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + bo = (/99, -1, 42/) + a = eoshift (a, -2, bo, 2) + if (any (a .ne. reshape ((/99, -1, 42, 99, -1, 42, 1, 2, 3/), (/3, 3/)))) & + call abort + + ! Array shift and array bound. + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/1, 0, -1/), (/99, -1, 42/), 1) + if (any (a .ne. reshape ((/2, 3, 99, 4, 5, 6, 42, 7, 8/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/2, -2, 0/), (/99, -1, 42/), 2) + if (any (a .ne. reshape ((/7, -1, 3, 99, -1, 6, 99, 2, 9/), (/3, 3/)))) & + call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + sh = (/ 3, -1, -3 /) + bo = (/-999, -99, -9 /) + a = eoshift(a, shift=sh, boundary=bo) + if (any (a .ne. reshape ((/ -999, -999, -999, -99, 4, 5, -9, -9, -9 /), & + shape(a)))) call abort + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = eoshift (a, (/9999, -9999, 0/), (/99, -1, 42/), 2) + if (any (a .ne. reshape ((/99, -1, 3, 99, -1, 6, 99, -1, 9/), (/3, 3/)))) & + call abort + + ! Test arrays > rank 2 + b(:, :, 1) = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + b(:, :, 2) = 10 + reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + b = eoshift (b, 1, 99, 1) + if (any (b(:, :, 1) .ne. reshape ((/2, 3, 99, 5, 6, 99, 8, 9, 99/), (/3, 3/)))) & + call abort + if (any (b(:, :, 2) .ne. reshape ((/12, 13, 99, 15, 16, 99, 18, 19, 99/), (/3, 3/)))) & + call abort + + ! TODO: Test array sections +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 new file mode 100644 index 000000000..c469cb434 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90 @@ -0,0 +1,84 @@ +!Program to test EXPONENT and FRACTION intrinsic function. + +program test_exponent_fraction + real x + integer*4 i + real*8 y + integer*8 j + equivalence (x, i), (y, j) + + x = 3. + call test_4(x) + + x = 0. + call test_4(x) + + i = o'00000000001' + call test_4(x) + + i = o'00010000000' + call test_4(x) + + i = o'17700000000' + call test_4(x) + + i = o'00004000001' + call test_4(x) + + i = o'17737777777' + call test_4(x) + + i = o'10000000000' + call test_4(x) + + i = o'0000010000' + call test_4(x) + + y = 0.5 + call test_8(y) + + y = 0. + call test_8(y) + + j = o'00000000001' + call test_8(y) + + y = 0.2938735877D-38 + call test_8(y) + + y = -1.469369D-39 + call test_8(y) + + y = z'7fe00000' + call test_8(y) + + y = -5.739719D+42 + call test_8(y) +end + +subroutine test_4(x) +real*4 x,y +integer z +y = fraction (x) +z = exponent(x) +if (z .gt. 0) then + y = (y * 2.) * (2. ** (z - 1)) +else + y = (y / 2.) * (2. ** (z + 1)) +end if +if (abs (x - y) .gt. spacing (max (abs (x), abs (y)))) call abort() +end + +subroutine test_8(x) +real*8 x, y +integer z +y = fraction (x) +z = exponent(x) +if (z .gt. 0) then + y = (y * 2._8) * (2._8 ** (z - 1)) +else + y = (y / 2._8) * (2._8 ** (z + 1)) +end if +if (abs (x - y) .gt. spacing (max (abs (x), abs(y)))) call abort() +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.x new file mode 100644 index 000000000..dad399dcb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.x @@ -0,0 +1,2 @@ +add-ieee-options +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 new file mode 100644 index 000000000..76f0aae53 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 @@ -0,0 +1,15 @@ +! Program to test the INDEX intrinsic +program test + character(len=10) a + integer w + if (index("FORTRAN", "R") .ne. 3) call abort + if (index("FORTRAN", "R", .TRUE.) .ne. 5) call abort + if (w ("FORTRAN") .ne. 3) call abort +end + +function w(str) + character(len=7) str + integer w + w = index(str, "R") +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 new file mode 100644 index 000000000..43578ed54 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_integer.f90 @@ -0,0 +1,18 @@ +! Program to test the real->integer conversion routines. +program intrinsic_integer + implicit none + + call test (0.0, (/0, 0, 0, 0/)) + call test (0.3, (/0, 1, 0, 0/)) + call test (0.7, (/0, 1, 0, 1/)) + call test (-0.3, (/-1, 0, 0, 0/)) + call test (-0.7, (/-1, 0, 0, -1/)) +contains +subroutine test(val, res) + real :: val + integer, dimension(4) :: res + + if ((floor(val) .ne. res(1)) .or. (ceiling(val) .ne. res(2)) & + .or. (int(val) .ne. res(3)) .or. (nint(val) .ne. res(4))) call abort +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_leadz.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_leadz.f90 new file mode 100644 index 000000000..80b61c83d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_leadz.f90 @@ -0,0 +1,46 @@ +program test_intrinsic_leadz + implicit none + + call test_leadz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8) + stop + + contains + + subroutine test_leadz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8) + integer(kind=1) :: z1, i1, e1 + integer(kind=2) :: z2, i2, e2 + integer(kind=4) :: z4, i4, e4 + integer(kind=8) :: z8, i8, e8 + + if (leadz(0_1) /= 8) call abort() + if (leadz(0_2) /= 16) call abort() + if (leadz(0_4) /= 32) call abort() + if (leadz(0_8) /= 64) call abort() + + if (leadz(1_1) /= 7) call abort() + if (leadz(1_2) /= 15) call abort() + if (leadz(1_4) /= 31) call abort() + if (leadz(1_8) /= 63) call abort() + + if (leadz(8_1) /= 4) call abort() + if (leadz(8_2) /= 12) call abort() + if (leadz(8_4) /= 28) call abort() + if (leadz(8_8) /= 60) call abort() + + if (leadz(z1) /= 8) call abort() + if (leadz(z2) /= 16) call abort() + if (leadz(z4) /= 32) call abort() + if (leadz(z8) /= 64) call abort() + + if (leadz(i1) /= 7) call abort() + if (leadz(i2) /= 15) call abort() + if (leadz(i4) /= 31) call abort() + if (leadz(i8) /= 63) call abort() + + if (leadz(e1) /= 4) call abort() + if (leadz(e2) /= 12) call abort() + if (leadz(e4) /= 28) call abort() + if (leadz(e8) /= 60) call abort() + end subroutine test_leadz + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 new file mode 100644 index 000000000..9db8d407a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_len.f90 @@ -0,0 +1,31 @@ +! Program to test the LEN intrinsic +program test + character(len=10) a + character(len=8) w + type person + character(len=10) name + integer age + end type person + type(person) Tom + integer n + a = w (n) + + if ((a .ne. "01234567") .or. (n .ne. 8)) call abort + if (len(Tom%name) .ne. 10) call abort + call array_test() +end + +function w(i) + character(len=8) w + integer i + w = "01234567" + i = len(w) +end + +! This is the testcase from PR 15211 converted to a subroutine +subroutine array_test + implicit none + character(len=10) a(4) + if (len(a) .NE. 10) call abort() +end subroutine array_test + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 new file mode 100644 index 000000000..9364f1e1d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_matmul.f90 @@ -0,0 +1,32 @@ +! Program to test the MATMUL intrinsic +program intrinsic_matmul + implicit none + integer, dimension(2, 3) :: a + integer, dimension(3, 2) :: b + integer, dimension(2) :: x + integer, dimension(3) :: y + integer, dimension(2, 2) :: r + integer, dimension(3) :: v + real, dimension (2,2) :: aa + real, dimension (4,2) :: cc + + a = reshape((/1, 2, 2, 3, 3, 4/), (/2, 3/)) + b = reshape((/1, 2, 3, 3, 4, 5/), (/3, 2/)) + x = (/1, 2/) + y = (/1, 2, 3/) + + r = matmul(a, b) + if (any(r .ne. reshape((/14, 20, 26, 38/), (/2, 2/)))) call abort + + v = matmul(x, a) + if (any(v .ne. (/5, 8, 11/))) call abort + + v(1:2) = matmul(a, y) + if (any(v(1:2) .ne. (/14, 20/))) call abort + + aa = reshape((/ 1.0, 1.0, 0.0, 1.0/), shape(aa)) + cc = 42. + cc(1:2,1:2) = matmul(aa, transpose(aa)) + if (any(cc(1:2,1:2) .ne. reshape((/ 1.0, 1.0, 1.0, 2.0 /), (/2,2/)))) call abort + if (any(cc(3:4,1:2) .ne. 42.)) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 new file mode 100644 index 000000000..b4fc18f4d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_merge.f90 @@ -0,0 +1,15 @@ +! Program to test the MERGE intrinsic +program intrinsic_merge + integer, dimension(3) :: a, b + integer i + + a = (/-1, 2, 3/) + + i = 5 + if (merge (-1, 1, i .gt. 3) .ne. -1) call abort + i = 1 + if (merge (-1, 1, i .ge. 3) .ne. 1) call abort + + b = merge(a, 0, a .ge. 0) + if (any (b .ne. (/0, 2, 3/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 new file mode 100644 index 000000000..02feaad15 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_minmax.f90 @@ -0,0 +1,37 @@ +! Program to test min and max intrinsics +program intrinsic_minmax + implicit none + integer i, j, k, m + real r, s, t, u + + i = 1 + j = -2 + k = 3 + m = 4 + if (min (i, k) .ne. 1) call abort + if (min (i, j, k, m) .ne. -2) call abort + if (max (i, k) .ne. 3) call abort + if (max (i, j, k, m) .ne. 4) call abort + if (max (i+1, j) .ne. 2) call abort + + r = 1 + s = -2 + t = 3 + u = 4 + if (min (r, t) .ne. 1) call abort + if (min (r, s, t, u) .ne. -2) call abort + if (max (r, t) .ne. 3) call abort + if (max (r, s, t, u) .ne. 4) call abort + + if (max (4d0, r) .ne. 4d0) call abort + if (amax0 (i, j) .ne. 1.0) call abort + if (min1 (r, s) .ne. -2) call abort + + ! Test simplify. + if (min (1, -2, 3, 4) .ne. -2) call abort + if (max (1, -2, 3, 4) .ne. 4) call abort + if (amax0 (1, -2) .ne. 1.0) call abort + if (min1 (1., -2.) .ne. -2) call abort + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 new file mode 100644 index 000000000..03273e1b2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc.f90 @@ -0,0 +1,117 @@ +! Program to test the MINLOC and MAXLOC intrinsics +program testmmloc + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m, tr + integer i + character(len=10) line + + a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/)); + tr = .true. + + b = minloc (a, 1) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + b = -1 + write (line, 9000) minloc(a,1) + read (line, 9000) b + if (b(1) .ne. 1) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + + m = .true. + m(1, 1) = .false. + m(1, 2) = .false. + b = minloc (a, 1, m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + b = minloc (a, 1, m .and. tr) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + b = -1 + write (line, 9000) minloc(a, 1, m) + read (line, 9000) b + if (b(1) .ne. 2) call abort + if (b(2) .ne. 2) call abort + if (b(3) .ne. 3) call abort + + b(1:2) = minloc(a) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 1) call abort + b = -1 + write (line, 9000) minloc(a) + read (line, 9000) b + if (b(1) .ne. 1) call abort + if (b(2) .ne. 1) call abort + if (b(3) .ne. 0) call abort + + b(1:2) = minloc(a, mask=m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 1) call abort + b(1:2) = minloc(a, mask=m .and. tr) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 1) call abort + b = -1 + write (line, 9000) minloc(a, mask=m) + read (line, 9000) b + if (b(1) .ne. 2) call abort + if (b(2) .ne. 1) call abort + if (b(3) .ne. 0) call abort + + b = maxloc (a, 1) + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 1) call abort + b = -1 + write (line, 9000) maxloc(a, 1) + read (line, 9000) b + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 1) call abort + + m = .true. + m(1, 2) = .false. + m(1, 3) = .false. + b = maxloc (a, 1, m) + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 2) call abort + b = maxloc (a, 1, m .and. tr) + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 2) call abort + b = -1 + write (line, 9000) maxloc(a, 1, m) + read (line, 9000) b + if (b(1) .ne. 3) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 2) call abort + + b(1:2) = maxloc(a) + if (b(1) .ne. 1) call abort + if (b(2) .ne. 3) call abort + b = -1 + write (line, 9000) maxloc(a) + read (line, 9000) b + if (b(1) .ne. 1) call abort + if (b(2) .ne. 3) call abort + + b(1:2) = maxloc(a, mask=m) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 3) call abort + b(1:2) = maxloc(a, mask=m .and. tr) + if (b(1) .ne. 2) call abort + if (b(2) .ne. 3) call abort + b = -1 + write (line, 9000) maxloc(a, mask=m) + read (line, 9000) b + if (b(1) .ne. 2) call abort + if (b(2) .ne. 3) call abort + if (b(3) .ne. 0) call abort + +9000 format (3I3) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 new file mode 100644 index 000000000..5f0b5b5da --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_2.f90 @@ -0,0 +1,22 @@ +program intrinsic_mmloc_2 + real a(-1:1), b(2:3), c(1:2) + integer, dimension(1):: i + real (kind = 8), dimension(-1:1) :: vc + + a = 0 + b = 0 + c = 0 + a(-1) = 1 + b(2) = 1 + c(1) = 1 + + if (maxloc (a, 1) .ne. 1) call abort() + if (maxloc (b, 1) .ne. 1) call abort() + if (maxloc (c, 1) .ne. 1) call abort() + + + ! We were giving MINLOC and MAXLOC the wrong return type + vc = (/4.0d0, 2.50d1, 1.0d1/) + i = minloc (vc) + if (i(1) .ne. 1) call abort() +END PROGRAM diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 new file mode 100644 index 000000000..078a08d70 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_3.f90 @@ -0,0 +1,40 @@ +! Check we do the right thing with extreme values. +! From PR12704 +program intrinsic_mmloc_3 + integer, dimension(2) :: d + integer, dimension(2,2) :: a + logical, dimension(2) :: k + logical, dimension(2,2) :: l + + k = .true. + l = .true. + + d = -huge (d) + if (maxloc (d, 1) .ne. 1) call abort () + + d = huge (d) + if (minloc (d, 1) .ne. 1) call abort () + + d = -huge (d) + if (maxloc (d, 1, k) .ne. 1) call abort () + + d = huge (d) + if (minloc (d, 1, k) .ne. 1) call abort () + + a = -huge (a) + d = maxloc (a) + if (any (d .ne. 1)) call abort () + + a = huge (a) + d = minloc (a) + if (any (d .ne. 1)) call abort () + + a = -huge (a) + d = maxloc (a, l) + if (any (d .ne. 1)) call abort () + + a = huge (a) + d = minloc (a, l) + if (any (d .ne. 1)) call abort () + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 new file mode 100644 index 000000000..2a53fb012 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmloc_4.f90 @@ -0,0 +1,13 @@ +! Check zero sized arrays work correcly +! From PR12704 +program intrinsic_mmloc_4 + integer, allocatable, dimension(:) :: d + integer, allocatable, dimension(:,:) :: a + integer, dimension(2) :: b + + allocate (d(0)) + if (maxloc (d, 1) .ne. 0) call abort() + allocate (a(1, 0)) + b = minloc (a) + if (any (b .ne. 0)) call abort() +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 new file mode 100644 index 000000000..cfd1a5b2d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mmval.f90 @@ -0,0 +1,45 @@ +! Program to test the MINVAL and MAXVAL intrinsics +program testmmval + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m, tr + integer i + character (len=9) line + + a = reshape ((/1, 2, 3, 5, 4, 6, 9, 8, 7/), (/3, 3/)); + + tr = .true. + + b = minval (a, 1) + if (any(b .ne. (/1, 4, 7/))) call abort + write (line, 9000) minval (a, 1) + if (line .ne. ' 1 4 7') call abort + + m = .true. + m(1, 1) = .false. + m(1, 2) = .false. + b = minval (a, 1, m) + if (any(b .ne. (/2, 4, 7/))) call abort + b = minval (a, 1, m .and. tr) + if (any(b .ne. (/2, 4, 7/))) call abort + write (line, 9000) minval(a, 1, m) + if (line .ne. ' 2 4 7') call abort + + b = maxval (a, 1) + if (any(b .ne. (/3, 6, 9/))) call abort + write (line, 9000) maxval (a, 1) + if (line .ne. ' 3 6 9') call abort + + m = .true. + m(1, 2) = .false. + m(1, 3) = .false. + b = maxval (a, 1, m) + if (any(b .ne. (/3, 6, 8/))) call abort + b = maxval (a, 1, m .and. tr) + if (any(b .ne. (/3, 6, 8/))) call abort + write (line, 9000) maxval(a, 1, m) + if (line .ne. ' 3 6 8') call abort + +9000 format(3I3) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 new file mode 100644 index 000000000..4fdf42c37 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mod_ulo.f90 @@ -0,0 +1,67 @@ +! Program to test MOD and MODULO intrinsics +subroutine integertest (ops, res) + implicit none + integer, dimension(2) :: ops + integer, dimension(2) :: res + + if ((mod(ops(1), ops(2)) .ne. res(1)) .or. & + (modulo(ops(1), ops(2)) .ne. res(2))) call abort +end subroutine + +subroutine real4test (ops, res) + implicit none + real(kind=4), dimension(2) :: ops + real(kind=4), dimension(2) :: res + + if (diff(mod(ops(1), ops(2)), res(1)) .or. & + diff(modulo(ops(1), ops(2)), res(2))) call abort +contains +function diff(a, b) + real(kind=4) :: a, b + logical diff + + diff = (abs (a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +subroutine real8test (ops, res) + implicit none + real(kind=8), dimension(2) :: ops + real(kind=8), dimension(2) :: res + + if (diff(mod(ops(1), ops(2)), res(1)) .or. & + diff(modulo(ops(1), ops(2)), res(2))) call abort +contains +function diff(a, b) + real(kind=8) :: a, b + logical diff + + diff = (abs(a - b) .gt. abs(a * 1e-6)) +end function +end subroutine + +program mod_modulotest + implicit none + + call integertest ((/8, 5/), (/3, 3/)) + call integertest ((/-8, 5/), (/-3, 2/)) + call integertest ((/8, -5/), (/3, -2/)) + call integertest ((/-8, -5/), (/-3, -3/)) + call integertest ((/ 2, -1/), (/0, 0/)) + + call real4test ((/3.0, 2.5/), (/0.5, 0.5/)) + call real4test ((/-3.0, 2.5/), (/-0.5, 2.0/)) + call real4test ((/3.0, -2.5/), (/0.5, -2.0/)) + call real4test ((/-3.0, -2.5/), (/-0.5, -0.5/)) + call real4test ((/ 2.0, -1.0/), (/ 0.0, 0.0 /)) + + call real8test ((/3.0_8, 2.5_8/), (/0.5_8, 0.5_8/)) + call real8test ((/-3.0_8, 2.5_8/), (/-0.5_8, 2.0_8/)) + call real8test ((/3.0_8, -2.5_8/), (/0.5_8, -2.0_8/)) + call real8test ((/-3.0_8, -2.5_8/), (/-0.5_8, -0.5_8/)) + call real8test ((/ 2.0_8, -1.0_8/), (/ 0.0_8, 0.0_8 /)) + + ! Check large numbers + call real4test ((/2e34, 1.0/), (/0.0, 0.0/)) + call real4test ((/2e34, 1.5e34/), (/0.5e34, 0.5e34/)) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mvbits.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mvbits.f90 new file mode 100644 index 000000000..3437e9f0c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_mvbits.f90 @@ -0,0 +1,16 @@ +! Test the MVBITS intrinsic subroutine +INTEGER*4 :: from, to, result +integer*8 :: from8, to8 + +DATA from / z'0003FFFC' / +DATA to / z'77760000' / +DATA result / z'7777FFFE' / + +CALL mvbits(from, 2, 16, to, 1) +if (to /= result) CALL abort() + +to8 = 0_8 +from8 = b'1011'*2_8**32 +call mvbits (from8, 33, 3, to8, 2) +if (to8 /= b'10100') call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 new file mode 100644 index 000000000..364a3ac34 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.f90 @@ -0,0 +1,77 @@ +!Program to test NEAREST intrinsic function. + +program test_nearest + real s, r, x, y, inf, max + integer i, infi, maxi + equivalence (s,i) + equivalence (inf,infi) + equivalence (max,maxi) + + r = 2.0 + s = 3.0 + call test_n (s, r) + + i = z'00800000' + call test_n (s, r) + + i = z'007fffff' + call test_n (s, r) + + i = z'00800100' + call test_n (s, r) + + s = 0 + x = nearest(s, r) + y = nearest(s, -r) + if (.not. (x .gt. s .and. y .lt. s )) call abort() + +! ??? This is pretty sketchy, but passes on most targets. + infi = z'7f800000' + maxi = z'7f7fffff' + + call test_up(max, inf) + call test_up(-inf, -max) + call test_down(inf, max) + call test_down(-max, -inf) + +! ??? Here we require the F2003 IEEE_ARITHMETIC module to +! determine if denormals are supported. If they are, then +! nearest(0,1) is the minimum denormal. If they are not, +! then it's the minimum normalized number, TINY. This fails +! much more often than the infinity test above, so it's +! disabled for now. + +! call test_up(0, min) +! call test_up(-min, 0) +! call test_down(0, -min) +! call test_down(min, 0) +end + +subroutine test_up(s, e) + real s, e, x + + x = nearest(s, 1.0) + if (x .ne. e) call abort() +end + +subroutine test_down(s, e) + real s, e, x + + x = nearest(s, -1.0) + if (x .ne. e) call abort() +end + +subroutine test_n(s1, r) + real r, s1, x + + x = nearest(s1, r) + if (nearest(x, -r) .ne. s1) call abort() + x = nearest(s1, -r) + if (nearest(x, r) .ne. s1) call abort() + + s1 = -s1 + x = nearest(s1, r) + if (nearest(x, -r) .ne. s1) call abort() + x = nearest(s1, -r) + if (nearest(x, r) .ne. s1) call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.x new file mode 100644 index 000000000..ec00f036c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_nearest.x @@ -0,0 +1,10 @@ +if [istarget "spu-*-*"] { + # No Inf/NaN support on SPU. + return 1 +} +if [istarget "powerpc-ibm-aix*"] { + # z'7f7fffff' value not preserved by lfs instruction. + return 1 +} +add-ieee-options +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 new file mode 100644 index 000000000..28cd1cd8f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 @@ -0,0 +1,24 @@ +! Program to test the PACK intrinsic +program intrinsic_pack + integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/) + integer, dimension(3, 3) :: a + integer, dimension(6) :: b + + a = reshape (val, (/3, 3/)) + b = 0 + b(1:6:3) = pack (a, a .ne. 0); + if (any (b(1:6:3) .ne. (/9, 7/))) call abort + b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/)); + if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort + + call tests_with_temp() +contains + subroutine tests_with_temp + ! A few tests which involve a temporary + if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort + if (any (pack(a, .true.) .ne. val)) call abort + if (size(pack (a, .false.)) .ne. 0) call abort + if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort + + end subroutine tests_with_temp +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 new file mode 100644 index 000000000..d2e998135 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_present.f90 @@ -0,0 +1,40 @@ +! Program to test the PRESENT intrinsic +program intrinsic_present + implicit none + integer a + integer, pointer :: b + integer, dimension(10) :: c + integer, pointer, dimension(:) :: d + + if (testvar()) call abort () + if (.not. testvar(a)) call abort () + if (testptr()) call abort () + if (.not. testptr(b)) call abort () + if (testarray()) call abort () + if (.not. testarray(c)) call abort () + if (testparray()) call abort () + if (.not. testparray(d)) call abort () + +contains +logical function testvar (p) + integer, optional :: p + testvar = present(p) +end function + +logical function testptr (p) + integer, pointer, optional :: p + testptr = present(p) +end function + +logical function testarray (p) + integer, dimension (10), optional :: p + testarray = present(p) +end function + +logical function testparray (p) + integer, pointer, dimension(:), optional :: p + testparray = present(p) +end function + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 new file mode 100644 index 000000000..6ada0a421 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_product.f90 @@ -0,0 +1,47 @@ +! Program to test the PRODUCT intrinsic +program testproduct + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m, tr + character(len=12) line + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + b = product (a, 1) + + tr = .true. + + if (any(b .ne. (/6, 120, 504/))) call abort + + write (line, 9000) product(a,1) + if (line .ne. ' 6 120 504') call abort + + if (product (a) .ne. 362880) call abort + + write (line, 9010) product(a) + if (line .ne. '362880') call abort + + m = .true. + m(1, 1) = .false. + m(2, 1) = .false. + + b = product (a, 2, m) + if (any(b .ne. (/28, 40, 162/))) call abort + + b = product (a, 2, m .and. tr) + if (any(b .ne. (/28, 40, 162/))) call abort + + write (line, 9000) product(a, 2, m) + if (line .ne. ' 28 40 162') call abort + + if (product (a, mask=m) .ne. 181440) call abort + + if (product (a, mask=m .and. tr) .ne. 181440) call abort + + write (line, 9010) product(a, mask=m) + if (line .ne. '181440') call abort + +9000 format (3I4) +9010 format (I6) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 new file mode 100644 index 000000000..e74cf6494 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_rrspacing.f90 @@ -0,0 +1,29 @@ +!Program to test RRSPACING intrinsic function. + +program test_rrspacing + call test_real4(3.0) + call test_real4(33.0) + call test_real4(-3.0) + call test_real8(3.0_8) + call test_real8(33.0_8) + call test_real8(-33.0_8) +end +subroutine test_real4(orig) + real x,y,orig + integer p + x = orig + p = 24 + y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p) + x = rrspacing(x) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end + +subroutine test_real8(orig) + real*8 x,y,t,orig + integer p + x = orig + p = 53 + y = abs (x * 2.0 ** (- exponent (x))) * (2.0 ** p) + x = rrspacing(x) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 new file mode 100644 index 000000000..775c4d7b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_scale.f90 @@ -0,0 +1,29 @@ +!Program to test SCALE intrinsic function. + +program test_scale + call test_real4 (3.0, 2) + call test_real4 (33.0, -2) + call test_real4 (-3., 2) + call test_real4 (0., 3) + call test_real8 (0._8, 3) + call test_real8 (3.0_8, 4) + call test_real8 (33.0_8, -4) + call test_real8 (-33._8, 4) +end +subroutine test_real4 (orig, i) + real x,y,orig + integer i + x = orig + y = x * (2.0 ** i) + x = scale (x, i) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end + +subroutine test_real8 (orig, i) + real*8 x,y,orig + integer i + x = orig + y = x * (2.0 ** i) + x = scale (x, i) + if (abs (x - y) .gt. abs(x * 1e-6)) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 new file mode 100644 index 000000000..6f934e591 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.f90 @@ -0,0 +1,87 @@ +!Program to test SET_EXPONENT intrinsic function. + +program test_set_exponent + call test_real4() + call test_real8() +end + +subroutine test_real4() + real*4 x,y + integer*4 i,n + equivalence(x, i) + + n = -148 + x = 1024.0 + y = set_exponent (x, n) + if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort() + + n = 8 + x = 1024.0 + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = 128 + i = 8388607 + x = transfer (i, x) ! z'007fffff' Positive denormalized floating-point. + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = -148 + x = -1024.0 + y = set_exponent (x, n) + if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort() + + n = 8 + x = -1024.0 + y = set_exponent (x, n) + if (y .ne. -128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 128 + i = -2139095041 + x = transfer (i, x) ! z'807fffff' Negative denormalized floating-point. + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + +end + +subroutine test_real8() + implicit none + real*8 x, y + integer*8 i, n + equivalence(x, i) + + n = -1073 + x = 1024.0_8 + y = set_exponent (x, n) + if ((y .ne. 0.0_8) .and. (exponent (y) .ne. n)) call abort() + + n = 8 + x = 1024.0_8 + y = set_exponent (x, n) + if (y .ne. 128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 1024 + i = 4503599627370495_8 + x = transfer (i, x) !z'000fffffffffffff' Positive denormalized floating-point. + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() + + n = -1073 + x = -1024.0 + y = set_exponent (x, n) + if ((y .ne. 0.0) .and. (exponent (y) .ne. n)) call abort() + + n = 8 + x = -1024.0 + y = set_exponent (x, n) + if (y .ne. -128.0) call abort() + if (exponent (y) .ne. n) call abort() + + n = 1024 + i = -9218868437227405313_8 + x = transfer (i, x)!z'800fffffffffffff' Negative denormalized floating-point. + y = set_exponent (x, n) + if (exponent (y) .ne. n) call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.x new file mode 100644 index 000000000..e49cd40f2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_set_exponent.x @@ -0,0 +1,6 @@ +if [istarget "spu-*-*"] { + # No denormal support on SPU. + return 1 +} +add-ieee-options +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 new file mode 100644 index 000000000..e1c5f7b4b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_shape.f90 @@ -0,0 +1,22 @@ +! Program to test the shape intrinsic +program testbounds + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(2) :: j + integer i + + allocate (a(3:8, 6:7)) + + j = shape (a); + if (any (j .ne. (/ 6, 2 /))) call abort + + call test(a) +contains + +subroutine test (a) + real, dimension (1:, 1:) :: a + + if (any (shape (a) .ne. (/ 6, 2 /))) call abort +end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 new file mode 100644 index 000000000..b231dc66e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_si_kind.f90 @@ -0,0 +1,35 @@ +! Program to test SELECTED_INT_KIND intrinsic function. +Program test_si_kind + integer*1 i1 + integer*2 i2 + integer*4 i4 + integer*8 i8 + integer res + real t + + t = huge (i1) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 1) call abort + + t = huge (i2) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 2) call abort + + t = huge (i4) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 4) call abort + + t = huge (i8) + t = log10 (t) + res = selected_int_kind (int (t)) + if (res .ne. 8) call abort + + i4 = huge (i4) + res = selected_int_kind (i4) + if (res .ne. (-1)) call abort + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 new file mode 100644 index 000000000..fbc457d91 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sign.f90 @@ -0,0 +1,31 @@ +! Program to test SIGN intrinsic +program intrinsic_sign + implicit none + integer i, j + real r, s + + i = 2 + j = 3 + if (sign (i, j) .ne. 2) call abort + i = 4 + j = -5 + if (sign (i, j) .ne. -4) call abort + i = -6 + j = 7 + if (sign (i, j) .ne. 6) call abort + i = -8 + j = -9 + if (sign (i, j) .ne. -8) call abort + r = 1 + s = 2 + if (sign (r, s) .ne. 1) call abort + r = 1 + s = -2 + if (sign (r, s) .ne. -1) call abort + s = 0 + if (sign (r, s) .ne. 1) call abort + ! Will fail on machines which cannot represent negative zero. + s = -s ! Negative zero + if (sign (r, s) .ne. -1) call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 new file mode 100644 index 000000000..729c55f22 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_size.f90 @@ -0,0 +1,37 @@ +! Program to test the SIZE intrinsics +program testsize + implicit none + real, dimension(:, :), allocatable :: a + integer, dimension(5) :: j + integer, dimension(2, 3) :: b + integer i + + if (size (b(2, :), 1) .ne. 3) call abort + + allocate (a(3:8, 5:7)) + + ! With one parameter + if (size(a) .ne. 18) call abort + + ! With two parameters, assigning to an array + j = size(a, 1) + if (any (j .ne. (/6, 6, 6, 6, 6/))) call abort + + ! With a variable second parameter + i = 2 + i = size(a, i) + if (i .ne. 3) call abort + + call test(a) +contains + +subroutine test (a) + real, dimension (1:, 1:) :: a + integer i + + i = 2 + if ((size(a, 1) .ne. 6) .or. (size(a, i) .ne. 3)) call abort + if (size (a) .ne. 18 ) call abort +end subroutine +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 new file mode 100644 index 000000000..24b31dac2 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.f90 @@ -0,0 +1,35 @@ +!Program to test SPACING intrinsic function. + +program test_spacing + call test_real4(3.0) + call test_real4(33.0) + call test_real4(-3.) + call test_real4(0.0) + call test_real8(0.0_8) + call test_real8(3.0_8) + call test_real8(33.0_8) + call test_real8(-33._8) +end +subroutine test_real4(orig) + real x,y,t,orig + integer p + x = orig + p = 24 + y = 2.0 ** (exponent (x) - p) + t = tiny(x) + x = spacing(x) + if ((abs (x - y) .gt. abs(x * 1e-6)) & + .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort +end + +subroutine test_real8(orig) + real*8 x,y,t,orig + integer p + x = orig + p = 53 + y = 2.0 ** (exponent (x) - p) + t = tiny (x) + x = spacing(x) + if ((abs (x - y) .gt. abs(x * 1e-6)) & + .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.x new file mode 100644 index 000000000..dad399dcb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spacing.x @@ -0,0 +1,2 @@ +add-ieee-options +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 new file mode 100644 index 000000000..8a89b2d73 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_spread.f90 @@ -0,0 +1,17 @@ +program foo + integer, dimension (2, 3) :: a + integer, dimension (2, 2, 3) :: b + character (len=80) line1, line2, line3 + + a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/)) + b = spread (a, 1, 2) + if (any (b .ne. reshape ((/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6/), & + (/2, 2, 3/)))) & + call abort + write(line1, 9000) b + write(line2, 9000) spread (a, 1, 2) + if (line1 /= line2) call abort + write(line3, 9000) spread (a, 1, 2) + 0 + if (line1 /= line3) call abort +9000 format(12I3) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 new file mode 100644 index 000000000..c34a6ca55 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 @@ -0,0 +1,62 @@ +! Program to test SELECTED_REAL_KIND intrinsic function. +Program test_sr_kind + integer res, i4, i8, t + real*4 r4 + real*8 r8 + + i4 = int (log10 (huge (r4))) + t = - int (log10 (tiny (r4))) + if (i4 .gt. t) i4 = t + + i8 = int (log10 (huge (r8))) + t = - int (log10 (tiny (r8))) + if (i8 .gt. t) i8 = t + + res = selected_real_kind (r = i4) + if (res .ne. 4) call abort + + res = selected_real_kind (r = i8) + if (res .ne. 8) call abort + +! We can in fact have kinds wider than r8. How do we want to check? +! res = selected_real_kind (r = (i8 + 1)) +! if (res .ne. -2) call abort + + res = selected_real_kind (p = precision (r4)) + if (res .ne. 4) call abort + + res = selected_real_kind (p = precision (r4), r = i4) + if (res .ne. 4) call abort + + res = selected_real_kind (p = precision (r4), r = i8) + if (res .ne. 8) call abort + +! res = selected_real_kind (p = precision (r4), r = i8 + 1) +! if (res .ne. -2) call abort + + res = selected_real_kind (p = precision (r8)) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r8), r = i4) + if (res .ne. 8) call abort + + res = selected_real_kind (p = precision (r8), r = i8) + if (res .ne. 8) call abort + +! res = selected_real_kind (p = precision (r8), r = i8 + 1) +! if (res .ne. -2) call abort + +! res = selected_real_kind (p = (precision (r8) + 1)) +! if (res .ne. -1) call abort + +! res = selected_real_kind (p = (precision (r8) + 1), r = i4) +! if (res .ne. -1) call abort + +! res = selected_real_kind (p = (precision (r8) + 1), r = i8) +! if (res .ne. -1) call abort + +! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1) +! if (res .ne. -3) call abort + +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 new file mode 100644 index 000000000..879fa0320 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sum.f90 @@ -0,0 +1,47 @@ +! Program to test the FORALL construct +program testforall + implicit none + integer, dimension (3, 3) :: a + integer, dimension (3) :: b + logical, dimension (3, 3) :: m, tr + integer i + character(len=9) line + + a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)); + + tr = .true. + + if (sum(a) .ne. 45) call abort + write (line, 9000) sum(a) + if (line .ne. ' 45 ') call abort + b = sum (a, 1) + if (b(1) .ne. 6) call abort + if (b(2) .ne. 15) call abort + if (b(3) .ne. 24) call abort + write (line, 9000) sum (a, 1) + if (line .ne. ' 6 15 24') call abort + + m = .true. + m(1, 1) = .false. + m(2, 1) = .false. + + if (sum (a, mask=m) .ne. 42) call abort + if (sum (a, mask=m .and. tr) .ne. 42) call abort + + write(line, 9000) sum (a, mask=m) + if (line .ne. ' 42 ') call abort + + b = sum (a, 2, m) + if (b(1) .ne. 11) call abort + if (b(2) .ne. 13) call abort + if (b(3) .ne. 18) call abort + + b = sum (a, 2, m .and. tr) + if (b(1) .ne. 11) call abort + if (b(2) .ne. 13) call abort + if (b(3) .ne. 18) call abort + write (line, 9000) sum (a, 2, m) + if (line .ne. ' 11 13 18') call abort + +9000 format(3I3) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trailz.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trailz.f90 new file mode 100644 index 000000000..948c806b4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trailz.f90 @@ -0,0 +1,46 @@ +program test_intrinsic_trailz + implicit none + + call test_trailz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8) + stop + + contains + + subroutine test_trailz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8) + integer(kind=1) :: z1, i1, e1 + integer(kind=2) :: z2, i2, e2 + integer(kind=4) :: z4, i4, e4 + integer(kind=8) :: z8, i8, e8 + + if (trailz(0_1) /= 8) call abort() + if (trailz(0_2) /= 16) call abort() + if (trailz(0_4) /= 32) call abort() + if (trailz(0_8) /= 64) call abort() + + if (trailz(1_1) /= 0) call abort() + if (trailz(1_2) /= 0) call abort() + if (trailz(1_4) /= 0) call abort() + if (trailz(1_8) /= 0) call abort() + + if (trailz(8_1) /= 3) call abort() + if (trailz(8_2) /= 3) call abort() + if (trailz(8_4) /= 3) call abort() + if (trailz(8_8) /= 3) call abort() + + if (trailz(z1) /= 8) call abort() + if (trailz(z2) /= 16) call abort() + if (trailz(z4) /= 32) call abort() + if (trailz(z8) /= 64) call abort() + + if (trailz(i1) /= 0) call abort() + if (trailz(i2) /= 0) call abort() + if (trailz(i4) /= 0) call abort() + if (trailz(i8) /= 0) call abort() + + if (trailz(e1) /= 3) call abort() + if (trailz(e2) /= 3) call abort() + if (trailz(e4) /= 3) call abort() + if (trailz(e8) /= 3) call abort() + end subroutine test_trailz + +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 new file mode 100644 index 000000000..e1f268e31 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_transpose.f90 @@ -0,0 +1,24 @@ +! Program to test the transpose intrinsic +program intrinsic_transpose + integer, dimension (3, 3) :: a, b + complex(kind=8), dimension (2, 2) :: c, d + complex(kind=4), dimension (2, 2) :: e + + a = 0 + b = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)) + a = transpose (b) + if (any (a .ne. reshape ((/1, 4, 7, 2, 5, 8, 3, 6, 9/), (/3, 3/)))) & + call abort + c = (0.0, 0.0) + d = reshape ((/(1d0,2d0), (3d0, 4d0), (5d0, 6d0), (7d0, 8d0)/), (/2, 2/)) + c = transpose (d); + if (any (c .ne. reshape ((/(1d0, 2d0), (5d0, 6d0), & + (3d0, 4d0), (7d0, 8d0)/), (/2, 2/)))) & + call abort (); + + e = reshape ((/(1.0,2.0), (3.0, 4.0), (5.0, 6.0), (7.0, 8.0)/), (/2, 2/)) + e = transpose (e); + if (any (e .ne. reshape ((/(1.0, 2.0), (5.0, 6.0), & + (3.0, 4.0), (7.0, 8.0)/), (/2, 2/)))) & + call abort (); +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 new file mode 100644 index 000000000..d57610cca --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 @@ -0,0 +1,23 @@ +! Program to test the TRIM and REPEAT intrinsics. +program intrinsic_trim + character(len=8) a + character(len=4) b,work + a='1234 ' + b=work(8,a) + if (llt(b,"1234")) call abort() + a=' ' + b=trim(a) + if (b .gt. "") call abort() + b='12' + a=repeat(b,0) + if (a .gt. "") call abort() + a=repeat(b,2) + if (a .ne. "12 12 ") call abort() +end + +function work(i,a) + integer i + character(len=i) a + character(len=4) work + work = trim(a) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 new file mode 100644 index 000000000..88f09c321 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 @@ -0,0 +1,21 @@ +! Program to test the UNPACK intrinsic +program intrinsic_unpack + integer, dimension(3, 3) :: a, b + logical, dimension(3, 3) :: mask; + character(len=50) line1, line2 + integer i + + mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,& + &.false.,.false.,.true./), (/3, 3/)); + a = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/)); + b = unpack ((/2, 3, 4/), mask, a) + if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) & + call abort + write (line1,'(10I4)') b + write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a) + if (line1 .ne. line2) call abort + b = -1 + b = unpack ((/2, 3, 4/), mask, 0) + if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) & + call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 new file mode 100644 index 000000000..8b22b03a7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_1.f90 @@ -0,0 +1,16 @@ +! Test that IOLENGTH works for dynamic arrays +program iolength_1 + implicit none + ! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?) + integer, parameter :: int32 = selected_int_kind(9) + integer(int32), allocatable :: a(:) + integer :: iol, alength + real :: r + call random_number(r) + alength = nint(r*20) + allocate(a(alength)) + inquire (iolength = iol) a + if ( 4*alength /= iol) then + call abort + end if +end program iolength_1 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_2.f90 new file mode 100644 index 000000000..ac6577863 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_2.f90 @@ -0,0 +1,24 @@ +! Test that IOLENGTH works for derived types containing arrays +module iolength_2_mod + integer, parameter :: & + ! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?) + int32 = selected_int_kind(9), & + ! IEEE double precision, i.e. 8 bytes + dp = selected_real_kind(15, 307) + type foo + ! This type should take up 5*4+4+8=32 bytes + integer(int32) :: a(5), b + real(dp) :: c + end type foo +end module iolength_2_mod + +program iolength_2 + use iolength_2_mod + implicit none + integer :: iol + type(foo) :: d + inquire (iolength = iol) d + if ( 32 /= iol) then + call abort + end if +end program iolength_2 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 new file mode 100644 index 000000000..23f14c636 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/iolength_3.f90 @@ -0,0 +1,15 @@ +! Test that IOLENGTH works for io list containing more than one entry +program iolength_3 + implicit none + integer, parameter :: & + ! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?) + int32 = selected_int_kind(9), & + ! IEEE double precision, i.e. 8 bytes + dp = selected_real_kind(15, 307) + integer(int32) :: a, b, iol + real(dp) :: c + inquire (iolength = iol) a, b, c + if ( 16 /= iol) then + call abort + end if +end program iolength_3 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 new file mode 100644 index 000000000..0a20b4bde --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.f90 @@ -0,0 +1,54 @@ +! pr 14942, list directed io + program d + implicit none + integer i, j, m, n, nin, k + real x(3,4) + data x / 1,1,1,2,2,2,3,3,3,4,4,4 / + real y(3,4) + data y / 1,1,1,2,2,2,3,3,3,4,4,4 / + logical debug ! set me true to see the output + debug = .FALSE. + nin = 1 + n = 4 + open(unit = nin) + write(nin,*) n + do I = 1,3 + write(nin,*)(x(i,j), j=1, n) + end do + m = 3 + n = 4 + write(nin,*) m,n + do I = 1,3 + write(nin,*)(x(i,j), j=1, n) + enddo + close(nin) +! ok, the data file is written + open(unit = nin) + read(nin, fmt = *) n + if (debug ) write(*,'(A,I2)') 'n = ', n + do i = 1, 3 + do K = 1,n + x(i,k) = -1 + enddo + read(nin, fmt = *) (x(i,j), j=1, n) + if (debug) write(*, *) (x(i,j), j=1, n) + do K = 1,n + if (x(i,k).ne.y(i,k)) call abort + end do + end do + m = 0 + n = 0 + read(nin, fmt = *) m, n + if (debug) write(*,'(A,I2,2X,A,I2)') 'm = ', m, 'n = ', n + do i = 1, m + do K = 1,n + x(i,k) = -1 + enddo + read(nin, fmt = *) (x(i,j), j=1, n) + if (debug) write(*, *) (x(i,j), j=1, n) + do K = 1,n + if (x(i,k).ne.y(i,k)) call abort + end do + end do + close(nin, status='delete') + end program d diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/list_read_1.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 new file mode 100644 index 000000000..60c077c43 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/logical_select_1.f90 @@ -0,0 +1,55 @@ +LOGICAL :: L = .FALSE. + +SELECT CASE (L) + CASE (.TRUE.) + CALL abort + CASE (.FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.TRUE., .FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.FALSE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (L) + CASE (.NOT. .TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (.NOT. L) + CASE (.TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +SELECT CASE (Truth_or_Dare() .OR. L) + CASE (.TRUE.) + CONTINUE + CASE DEFAULT + CALL abort +END SELECT + +CONTAINS + + FUNCTION Truth_or_Dare () + LOGICAL Truth_or_Dare + Truth_or_Dare = .TRUE. + END FUNCTION + +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 new file mode 100644 index 000000000..f84e91f25 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mainsub.f90 @@ -0,0 +1,17 @@ +! Program to test compilation of subroutines following the main program +program mainsub + implicit none + integer i + external test + + i = 0 + call test (i) + if (i .ne. 42) call abort +end program + +subroutine test (p) + implicit none + integer p + + p = 42 +end subroutine diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 new file mode 100644 index 000000000..c21da09da --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/math.f90 @@ -0,0 +1,100 @@ +! Program to test mathematical intrinsics +subroutine dotest (n, val4, val8, known) + implicit none + real(kind=4) val4, known + real(kind=8) val8 + integer n + + if (abs (val4 - known) .gt. 0.001) call abort + if (abs (real (val8, kind=4) - known) .gt. 0.001) call abort +end subroutine + +subroutine dotestc (n, val4, val8, known) + implicit none + complex(kind=4) val4, known + complex(kind=8) val8 + integer n + if (abs (val4 - known) .gt. 0.001) call abort + if (abs (cmplx (val8, kind=4) - known) .gt. 0.001) call abort +end subroutine + +program testmath + implicit none + real(kind=4) r, two4, half4 + real(kind=8) q, two8, half8 + complex(kind=4) cr + complex(kind=8) cq + external dotest, dotestc + + two4 = 2.0 + two8 = 2.0_8 + half4 = 0.5 + half8 = 0.5_8 + r = sin (two4) + q = sin (two8) + call dotest (1, r, q, 0.9093) + r = cos (two4) + q = cos (two8) + call dotest (2, r, q, -0.4161) + r = tan (two4) + q = tan (two8) + call dotest (3, r, q, -2.1850) + r = asin (half4) + q = asin (half8) + call dotest (4, r, q, 0.5234) + r = acos (half4) + q = acos (half8) + call dotest (5, r, q, 1.0472) + r = atan (half4) + q = atan (half8) + call dotest (6, r, q, 0.4636) + r = atan2 (two4, half4) + q = atan2 (two8, half8) + call dotest (7, r, q, 1.3258) + r = exp (two4) + q = exp (two8) + call dotest (8, r, q, 7.3891) + r = log (two4) + q = log (two8) + call dotest (9, r, q, 0.6931) + r = log10 (two4) + q = log10 (two8) + call dotest (10, r, q, 0.3010) + r = sinh (two4) + q = sinh (two8) + call dotest (11, r, q, 3.6269) + r = cosh (two4) + q = cosh (two8) + call dotest (12, r, q, 3.7622) + r = tanh (two4) + q = tanh (two8) + call dotest (13, r, q, 0.9640) + r = sqrt (two4) + q = sqrt (two8) + call dotest (14, r, q, 1.4142) + + r = atan2 (0.0, 1.0) + q = atan2 (0.0_8, 1.0_8) + call dotest (15, r, q, 0.0) + r = atan2 (-1.0, 1.0) + q = atan2 (-1.0_8, 1.0_8) + call dotest (16, r, q, -0.7854) + r = atan2 (0.0, -1.0) + q = atan2 (0.0_8, -1.0_8) + call dotest (17, r, q, 3.1416) + r = atan2 (-1.0, -1.0) + q = atan2 (-1.0_8, -1.0_8) + call dotest (18, r, q, -2.3562) + r = atan2 (1.0, 0.0) + q = atan2 (1.0_8, 0.0_8) + call dotest (19, r, q, 1.5708) + r = atan2 (-1.0, 0.0) + q = atan2 (-1.0_8, 0.0_8) + call dotest (20, r, q, -1.5708) + + cr = log ((-1.0, -1.0)) + cq = log ((-1.0_8, -1.0_8)) + call dotestc (21, cr, cq, (0.3466, -2.3562)) + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_init_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_init_1.f90 new file mode 100644 index 000000000..9996935f6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_init_1.f90 @@ -0,0 +1,9 @@ +! PR 13077: we used to fail when reading the module +module m1 +real, dimension(4) :: a +data a(1:3:2) /2*1.0/ +end module m1 +use m1 +if (a(1).NE.1.) call abort() +if (a(1).NE.a(3)) call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 new file mode 100644 index 000000000..86fd7914b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface.f90 @@ -0,0 +1,39 @@ +! We were incorrectly mangling procedures in interfaces in modules + +module module_interface + interface + subroutine foo () + end subroutine foo + end interface +contains +subroutine cs +end subroutine + +subroutine cproc + interface + subroutine bar () + end subroutine + end interface + call bar () + call foo () + call cs () +end subroutine +end module + +subroutine foo () +end subroutine + +subroutine bar () +end subroutine + +program module_interface_proc + use module_interface + interface + subroutine bar () + end subroutine + end interface + + call cproc () + call foo () + call bar () +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 new file mode 100644 index 000000000..dba736654 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/module_interface_2.f90 @@ -0,0 +1,29 @@ +! Test generic interfaces declared in modules. +! We used to get the name mangling wrong for these. +module module_interface_2 + interface foo + subroutine myfoo (i) + integer i + end subroutine + module procedure bar + end interface +contains +subroutine bar (r) + real r + + if (r .ne. 1.0) call abort () +end subroutine +end module + +subroutine myfoo (i) + integer i + + if (i .ne. 42) call abort () +end subroutine + +program test + use module_interface_2 + + call foo (42) + call foo (1.0) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 new file mode 100644 index 000000000..06fa21614 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/mystery_proc.f90 @@ -0,0 +1,23 @@ +! Program to test dummy procedures +subroutine bar() +end subroutine + +subroutine foo2(p) + external p + + call p() +end subroutine + +subroutine foo(p) + external p + ! We never actually discover if this is a function or a subroutine + call foo2(p) +end subroutine + +program intrinsic_minmax + implicit none + external bar + + call foo(bar) +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.f90 new file mode 100644 index 000000000..2ded0cbbb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.f90 @@ -0,0 +1,88 @@ +!pr 12839- F2003 formatting of Inf /Nan +! Modified for PR47434 + implicit none + character*40 l + character*12 fmt + real zero, pos_inf, neg_inf, nan + zero = 0.0 + +! need a better way of generating these floating point +! exceptional constants. + + pos_inf = 1.0/zero + neg_inf = -1.0/zero + nan = zero/zero + +! check a field width = 0 + fmt = '(F0.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.'Inf') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.'-Inf') call abort + write(l,fmt=fmt)nan + if (l.ne.'NaN') call abort + +! check a field width < 3 + fmt = '(F2.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.'**') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.'**') call abort + write(l,fmt=fmt)nan + if (l.ne.'**') call abort + +! check a field width = 3 + fmt = '(F3.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.'Inf') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.'***') call abort + write(l,fmt=fmt)nan + if (l.ne.'NaN') call abort + +! check a field width > 3 + fmt = '(F4.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.' Inf') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.'-Inf') call abort + write(l,fmt=fmt)nan + if (l.ne.' NaN') call abort + +! check a field width = 7 + fmt = '(F7.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.' Inf') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.' -Inf') call abort + write(l,fmt=fmt)nan + if (l.ne.' NaN') call abort + +! check a field width = 8 + fmt = '(F8.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.'Infinity') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.' -Inf') call abort + write(l,fmt=fmt)nan + if (l.ne.' NaN') call abort + +! check a field width = 9 + fmt = '(F9.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.' Infinity') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.'-Infinity') call abort + write(l,fmt=fmt)nan + if (l.ne.' NaN') call abort + +! check a field width = 14 + fmt = '(F14.0)' + write(l,fmt=fmt)pos_inf + if (l.ne.' Infinity') call abort + write(l,fmt=fmt)neg_inf + if (l.ne.' -Infinity') call abort + write(l,fmt=fmt)nan + if (l.ne.' NaN') call abort + end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.x new file mode 100644 index 000000000..2d2b6ee8e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.x @@ -0,0 +1,6 @@ +if [istarget "spu-*-*"] { + # No Inf/NaN support on SPU. + return 1 +} +add-ieee-options +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 new file mode 100644 index 000000000..d2d545625 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nestcons.f90 @@ -0,0 +1,9 @@ +! Program to test array expressions in array constructors. +program nestcons + implicit none + integer, parameter :: w1(3)= (/ 5, 6, 7/) + integer, dimension(6) :: w2 + + w2 = (/ 1, 2, w1(3:1:-1), 3 /) + if (any (w2 .ne. (/ 1, 2, 7, 6, 5, 3/))) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nullarg.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nullarg.f90 new file mode 100644 index 000000000..67e65f81f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/nullarg.f90 @@ -0,0 +1,13 @@ +! This is the testcase from PR 12841. We used to report a type/rank mismatch +! when passing NULL() as an argument to a function. + MODULE T + PUBLIC :: A + CONTAINS + SUBROUTINE A(B) + REAL, POINTER :: B + IF (ASSOCIATED(B)) CALL ABORT() + END SUBROUTINE A + END MODULE T + USE T + CALL A(NULL()) + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/open_replace.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/open_replace.f90 new file mode 100644 index 000000000..11d0d0946 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/open_replace.f90 @@ -0,0 +1,6 @@ +! pr 16196 +! open with 'REPLACE' creates the file if it does not exist. + PROGRAM iobug + OPEN(UNIT=10,FILE='gfcoutput.txt',status='REPLACE') + CLOSE(10,status='DELETE') + END PROGRAM iobug diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/optstring_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/optstring_1.f90 new file mode 100644 index 000000000..58c397d16 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/optstring_1.f90 @@ -0,0 +1,21 @@ +! Test optional character arguments. We still need to pass a string +! length for the absent arguments +program optional_string_1 + implicit none + + call test(1, "test"); + call test(2, c=42, b="Hello World") +contains +subroutine test(i, a, b, c) + integer :: i + character(len=4), optional :: a + character(len=*), optional :: b + integer, optional :: c + if (i .eq. 1) then + if (a .ne. "test") call abort + else + if (b .ne. "Hello World") call abort + if (c .ne. 42) call abort + end if +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 new file mode 100644 index 000000000..8a8af7385 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_1.f90 @@ -0,0 +1,12 @@ +! Program to test array parameter variables. +program parameter_1 + implicit none + integer i + INTEGER, PARAMETER :: ii(10) = (/ (I,I=1,10) /) + REAL, PARAMETER :: rr(10) = ii + + do i = 1, 10 + if (ii(i) /= i) call abort() + if (rr(i) /= i) call abort() + end do +end program parameter_1 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_2.f90 new file mode 100644 index 000000000..1e9710472 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/parameter_2.f90 @@ -0,0 +1,7 @@ +module m + parameter (p = -1.) ! negative numbers used to get output incorrectly +end module m + +use m +if (p .ne. -1.) CALL abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 new file mode 100644 index 000000000..839ecf02f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/partparm.f90 @@ -0,0 +1,15 @@ +! Program to test +subroutine test (p) + integer, dimension (3) :: p + + if (any (p .ne. (/ 2, 4, 6/))) call abort +end subroutine + +program partparm + implicit none + integer, dimension (2, 3) :: a + external test + + a = reshape ((/ 1, 2, 3, 4, 5, 6/), (/ 2, 3/)) + call test (a(2, :)) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 new file mode 100644 index 000000000..7fc3eebb1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/plusconst_1.f90 @@ -0,0 +1,15 @@ +! PR14005 +! The GMP conversion routines object to a leading "+" +program plusconst_1 + implicit none + real p + integer i + data p /+3.1415/ + data i /+42/ + real :: q = +1.234 + integer :: j = +100 + + if ((p .ne. 3.1415) .or. (i .ne. 42) .or. (q .ne. 1.234) .or. (j .ne. 100)) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 new file mode 100644 index 000000000..6866470dd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/power.f90 @@ -0,0 +1,75 @@ +! Program to test the power (**) operator +program testpow + implicit none + real(kind=4) r, s, two + real(kind=8) :: q + complex(kind=4) :: c, z + real, parameter :: del = 0.0001 + integer i, j + + i = 2 + j = i ** 10 + if (abs (j - 1024) .gt. del) call abort + j = i ** (-10) + if (abs (j - 0) .gt. del) call abort + j = i ** 0 + if (abs (j - 1) .gt. del) call abort + i = 1 + j = i ** 10 + if (abs (j - 1) .gt. del) call abort + j = i ** (-10) + if (abs (j - 1) .gt. del) call abort + j = i ** 0 + if (abs (j - 1) .gt. del) call abort + i = -1 + j = i ** 10 + if (abs (j - 1) .gt. del) call abort + j = i ** (-10) + if (abs (j - 1) .gt. del) call abort + j = i ** 0 + if (abs (j - 1) .gt. del) call abort + j = i ** 11 + if (abs (j - (-1)) .gt. del) call abort + j = i ** (-11) + if (abs (j - (-1)) .gt. del) call abort + + c = (2.0, 3.0) + z = c ** 2 + if (abs(z - (-5.0, 12.0)) .gt. del) call abort + z = c ** 7 + if (abs(z - (6554.0, 4449.0)) .gt. del) call abort + + two = 2.0 + + r = two ** 1 + if (abs (r - 2.0) .gt. del) call abort + r = two ** 2 + if (abs (r - 4.0) .gt. del) call abort + r = two ** 3 + if (abs (r - 8.0) .gt. del) call abort + r = two ** 4 + if (abs (r - 16.0) .gt. del) call abort + r = two ** 0 + if (abs (r - 1.0) .gt. del) call abort + r = two ** (-1) + if (abs (r - 0.5) .gt. del) call abort + r = two ** (-2) + if (abs (r - 0.25) .gt. del) call abort + r = two ** (-4) + if (abs (r - 0.0625) .gt. del) call abort + s = 3.0 + r = two ** s + if (abs (r - 8.0) .gt. del) call abort + s = -3.0 + r = two ** s + if (abs (r - 0.125) .gt. del) call abort + i = 3 + r = two ** i + if (abs (r - 8.0) .gt. del) call abort + i = -3 + r = two ** i + if (abs (r - 0.125) .gt. del) call abort + c = (2.0, 3.0) + c = c ** two + if (abs(c - (-5.0, 12.0)) .gt. del) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr19269-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr19269-1.f90 new file mode 100644 index 000000000..03224c380 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr19269-1.f90 @@ -0,0 +1,16 @@ +program main + call test (reshape ((/ 'a', 'b', 'c', 'd' /), (/ 2, 2 /))) +contains + subroutine test (a) + character (len = *), dimension (:, :) :: a + + if (size (a, 1) .ne. 2) call abort + if (size (a, 2) .ne. 2) call abort + if (len (a) .ne. 1) call abort + + if (a (1, 1) .ne. 'a') call abort + if (a (2, 1) .ne. 'b') call abort + if (a (1, 2) .ne. 'c') call abort + if (a (2, 2) .ne. 'd') call abort + end subroutine test +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 new file mode 100644 index 000000000..8d5ee658d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-1.f90 @@ -0,0 +1,15 @@ +program main + implicit none + real, dimension (:), pointer :: x + x => null () + x => test (x) + if (.not. associated (x)) call abort + if (size (x) .ne. 10) call abort +contains + function test (p) + real, dimension (:), pointer :: p, test + if (associated (p)) call abort + allocate (test (10)) + if (associated (p)) call abort + end function test +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 new file mode 100644 index 000000000..f90a73577 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr23373-2.f90 @@ -0,0 +1,15 @@ +program main + implicit none + real, dimension (:), pointer :: x + x => null () + x => test () + if (.not. associated (x)) call abort + if (size (x) .ne. 10) call abort +contains + function test() + real, dimension (:), pointer :: test + if (associated (x)) call abort + allocate (test (10)) + if (associated (x)) call abort + end function test +end program main diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32140.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32140.f90 new file mode 100644 index 000000000..a756e2779 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32140.f90 @@ -0,0 +1,16 @@ +MODULE TEST +CONTAINS +PURE FUNCTION s2a_3(s1,s2,s3) RESULT(a) + CHARACTER(LEN=*), INTENT(IN) :: s1, s2, s3 + CHARACTER(LEN=4), DIMENSION(3) :: a + + a(1)=s1; a(2)=s2; a(3)=s3 +END FUNCTION +END MODULE + +USE TEST +character(len=12) :: line +write(line,'(3A4)') s2a_3("a","bb","ccc") +IF (line.NE."a bb ccc") CALL ABORT() +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32604.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32604.f90 new file mode 100644 index 000000000..3eac72907 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr32604.f90 @@ -0,0 +1,61 @@ +MODULE TEST + IMPLICIT NONE + INTEGER, PARAMETER :: dp=KIND(0.0D0) + TYPE mulliken_restraint_type + INTEGER :: ref_count + REAL(KIND = dp) :: strength + REAL(KIND = dp) :: TARGET + INTEGER :: natoms + INTEGER, POINTER, DIMENSION(:) :: atoms + END TYPE mulliken_restraint_type +CONTAINS + SUBROUTINE INIT(mulliken) + TYPE(mulliken_restraint_type), INTENT(INOUT) :: mulliken + ALLOCATE(mulliken%atoms(1)) + mulliken%atoms(1)=1 + mulliken%natoms=1 + mulliken%target=0 + mulliken%strength=0 + END SUBROUTINE INIT + SUBROUTINE restraint_functional(mulliken_restraint_control,charges, & + charges_deriv,energy,order_p) + TYPE(mulliken_restraint_type), & + INTENT(IN) :: mulliken_restraint_control + REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv + REAL(KIND=dp), INTENT(OUT) :: energy, order_p + + INTEGER :: I + REAL(KIND=dp) :: dum + + charges_deriv=0.0_dp + order_p=0.0_dp + + DO I=1,mulliken_restraint_control%natoms + order_p=order_p+charges(mulliken_restraint_control%atoms(I),1) & + -charges(mulliken_restraint_control%atoms(I),2) + ENDDO + +energy=mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target)**2 + +dum=2*mulliken_restraint_control%strength*(order_p-mulliken_restraint_control%target) + DO I=1,mulliken_restraint_control%natoms + charges_deriv(mulliken_restraint_control%atoms(I),1)= dum + charges_deriv(mulliken_restraint_control%atoms(I),2)= -dum + ENDDO +END SUBROUTINE restraint_functional + +END MODULE + + USE TEST + IMPLICIT NONE + TYPE(mulliken_restraint_type) :: mulliken + REAL(KIND=dp), DIMENSION(:, :), POINTER :: charges, charges_deriv + REAL(KIND=dp) :: energy,order_p + ALLOCATE(charges(1,2),charges_deriv(1,2)) + charges(1,1)=2.0_dp + charges(1,2)=1.0_dp + CALL INIT(mulliken) + CALL restraint_functional(mulliken,charges,charges_deriv,energy,order_p) + write(6,*) order_p +END + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr40021.f b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr40021.f new file mode 100644 index 000000000..ddd269f2a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr40021.f @@ -0,0 +1,40 @@ +C Derived from lapack + PROGRAM test + DOUBLE PRECISION DA + INTEGER I, N + DOUBLE PRECISION DX(9),DY(9) + + EXTERNAL DAXPY + N=5 + DA=1.0 + DATA DX/-2, -1, -3, -4, 1, 2, 10, 15, 14/ + DATA DY/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/ + CALL DAXPY (N,DA,DX,DY) + DO 10 I = 1, N + if (DX(I).ne.DY(I)) call abort +10 CONTINUE + STOP + END + + SUBROUTINE DAXPY(N,DA,DX,DY) + DOUBLE PRECISION DA + INTEGER N + DOUBLE PRECISION DX(*),DY(*) + INTEGER I,IX,IY,M,MP1 + INTRINSIC MOD + IF (N.LE.0) RETURN + 20 M = MOD(N,4) + IF (M.EQ.0) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF (N.LT.4) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I+1) = DY(I+1) + DA*DX(I+1) + DY(I+2) = DY(I+2) + DA*DX(I+2) + DY(I+3) = DY(I+3) + DA*DX(I+3) + 50 CONTINUE + RETURN + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr43390.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr43390.f90 new file mode 100644 index 000000000..b54eef99f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr43390.f90 @@ -0,0 +1,9 @@ + logical :: l1(4) + logical :: l2(4) + l1 = (/.TRUE.,.FALSE.,.TRUE.,.FALSE./) + l2 = (/.FALSE.,.TRUE.,.FALSE.,.TRUE./) + if (dot_product (l1, l2)) call abort () + l2 = .TRUE. + if (.not.dot_product (l1, l2)) call abort () +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr54767.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr54767.f90 new file mode 100644 index 000000000..f95bff1b3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr54767.f90 @@ -0,0 +1,31 @@ +SUBROUTINE XXX (IL, IU) + implicit none + integer, INTENT(IN) :: IL, IU + + integer :: NXX (14) = (/ 0, 1, 2, 3, 4, 5, 6, 7, 9, 10, 11, 12, 13, 14 /) + integer :: ivvv, ia, ja, iaii + logical :: qop + + QOP=.FALSE. + + DO IA=IL,IU + JA=NXX(IA) + IF (.NOT. QOP .and. JA.GT.0) THEN + IAII=IA + QOP=.TRUE. + ENDIF + + IF (QOP) THEN + ivvv=IA-IAII+1 ! mis-compiled + ENDIF + ENDDO + + IF (ivvv.NE.2) THEN + call abort + ENDIF +END subroutine + +program p + implicit none + CALL XXX (1, 3) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr57396.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr57396.f90 new file mode 100644 index 000000000..8ea92924a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/pr57396.f90 @@ -0,0 +1,33 @@ +module testmod + implicit none + + contains + + subroutine foo(n) + integer, intent(in) :: n + real :: r(0:n,-n:n), a(0:n,-n:n), dj + integer :: k, j + + ! initialize with some dummy values + do j = -n, n + a(:, j) = j + r(:,j) = j + 1 + end do + + ! here be dragons + do k = 0, n + dj = r(k, k - 2) * a(k, k - 2) + r(k,k) = a(k, k - 1) * dj + enddo + + if (r(0,0) .ne. -2.) call abort + + end subroutine + +end module + +program test + use testmod + implicit none + call foo(5) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 new file mode 100644 index 000000000..37718f5fc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/procarg.f90 @@ -0,0 +1,29 @@ +! Pogram to test +subroutine myp (a) + implicit none + integer a + + if (a .ne. 42) call abort +end subroutine + +subroutine test2 (p) + implicit none + external p + + call p(42) +end subroutine + +subroutine test (p) + implicit none + external p, test2 + + call p(42) + call test2(p) +end subroutine + +program arrayio + implicit none + external test, myp + + call test (myp) +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 new file mode 100644 index 000000000..2675f0866 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/ptr.f90 @@ -0,0 +1,20 @@ +program ptr + implicit none + integer, pointer, dimension(:) :: a, b + integer, pointer :: p + integer, target :: i + + allocate (a(1:6)) + + a = (/ 1, 2, 3, 4, 5, 6 /) + b => a + if (any (b .ne. (/ 1, 2, 3, 4, 5, 6 /))) call abort + b => a(1:6:2) + if (any (b .ne. (/ 1, 3, 5/))) call abort + + p => i + i = 42 + if (p .ne. 42) call abort + p => a(4) + if (p .ne. 4) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_1.f90 new file mode 100644 index 000000000..900a724da --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_1.f90 @@ -0,0 +1,33 @@ +! PR15619 +! Check that random_seed works as expected. +! Does not check the quality of random numbers, hence should never fail. +program test_random + implicit none + integer, allocatable :: seed(:) + real, dimension(10) :: a, b + integer n; + + call random_seed (size=n) + allocate (seed(n)) + + ! Exercise the generator a bit. + call random_number (a) + + ! Remeber the seed and get 10 more. + call random_seed (get=seed) + call random_number (a) + + ! Get the same 10 numbers in two blocks, remebering the seed in the middle + call random_seed (put=seed) + call random_number (b(1:5)) + call random_seed(get=seed) + call random_number (b(6:10)) + if (any (a .ne. b)) call abort + + ! Get the last 5 numbers again. + call random_seed (put=seed) + call random_number (b(6:10)) + if (any (a .ne. b)) call abort +end program + + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_2.f90 new file mode 100644 index 000000000..166683305 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_2.f90 @@ -0,0 +1,24 @@ +! Check that the real(4) and real(8) random number generators return the same +! sequence of values. +program random_4 + integer, dimension(:), allocatable :: seed + real(kind=4), dimension(10) :: r4 + real(kind=8), dimension(10) :: r8 + real, parameter :: delta = 0.0001 + integer n + + call random_seed (size=n) + allocate (seed(n)) + call random_seed (get=seed) + ! Test both array valued and scalar routines. + call random_number(r4) + call random_number (r4(10)) + + ! Reset the seed and get the real(8) values. + call random_seed (put=seed) + call random_number(r8) + call random_number (r8(10)) + + if (any ((r4 - r8) .gt. delta)) call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_init.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_init.f90 new file mode 100644 index 000000000..36394589d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/random_init.f90 @@ -0,0 +1,11 @@ +! pr 15149 +! verify the random number generator is functional + program test_random + implicit none + real :: r(5) = 0.0 + + call random_number(r) + if (all (r .eq. 0)) call abort + end program + + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 new file mode 100644 index 000000000..b4bc8239b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_eof.f90 @@ -0,0 +1,6 @@ +! PR 13919, segfault when file is empty + open(unit=8,status='scratch') + read(8,*,end=1)i + call abort +1 continue + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.f90 new file mode 100644 index 000000000..7cf949204 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.f90 @@ -0,0 +1,15 @@ +! pr 16080, segfault on reading an empty string + implicit none + integer t + character*20 temp_name + character*2 quotes + open(unit=7,status='SCRATCH') + quotes = '""""' ! "" in the file + write(7,*)1 + write(7,'(A)')quotes + temp_name = 'hello' ! make sure the read overwrites it + rewind(7) + read(7, *) t + read(7, *) temp_name + if (temp_name.ne.'') call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/read_null_string.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 new file mode 100644 index 000000000..a0bdc97c4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray.f90 @@ -0,0 +1,45 @@ +! Program to test functions returning arrays + +program testfnarray + implicit none + integer, dimension (6, 5) :: a + integer n + +! These first two shouldn't require a temporary. + a = 0 + a = test(6, 5) + if (a(1,1) .ne. 42) call abort + if (a(6,5) .ne. 43) call abort + + a = 0 + a(1:6:2, 2:5) = test2() + if (a(1,2) .ne. 42) call abort + if (a(5,5) .ne. 43) call abort + + a = 1 + ! This requires a temporary + a = test(6, 5) - a + if (a(1,1) .ne. 41) call abort + if (a(6,5) .ne. 42) call abort + + contains + + function test (x, y) + implicit none + integer x, y + integer, dimension (1:x, 1:y) :: test + + test(1, 1) = 42 + test(x, y) = 43 + end function + + function test2 () result (foo) + implicit none + integer, dimension (3, 4) :: foo + + foo(1, 1) = 42 + foo(3, 4) = 43 + end function + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 new file mode 100644 index 000000000..ab14dd03c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/retarray_2.f90 @@ -0,0 +1,20 @@ +! Procedure to test module procedures returning arrays. +! The array spec only gets applied to the result variable, not the function +! itself. As a result we missed it during resolution, and used the wrong +! calling convention (functions returning arrays must always have explicit +! interfaces). +module retarray_2 +contains + function z(a) result (aout) + integer, dimension(4) :: aout,a + aout = a + end function z +end module retarray_2 + +program retarray + use retarray_2 + integer, dimension(4) :: b, a=(/1,2,3,4/) + b = z(a) + if (any (b .ne. (/1, 2, 3, 4/))) call abort +end + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_1.f90 new file mode 100644 index 000000000..c838baa98 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_1.f90 @@ -0,0 +1,29 @@ + subroutine foo (b) + logical b + integer i, j + character*24 s + save + if (b) then + i = 26 + j = 131 + s = 'This is a test string' + else + if (i .ne. 26 .or. j .ne. 131) call abort + if (s .ne. 'This is a test string') call abort + end if + end subroutine foo + subroutine bar (s) + character*42 s + if (s .ne. '0123456789012345678901234567890123456') call abort + 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 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_2.f90 new file mode 100644 index 000000000..c3775bbec --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/save_2.f90 @@ -0,0 +1,23 @@ +! PR fortran/18518 + program main + call foo + call bar + call foo + end program main + + subroutine foo + integer i,g,h + data i/0/ + equivalence (g,h) + save g + if (i == 0) then + i = 1 + h = 12345 + end if + if (h .ne. 12345) call abort + end subroutine foo + + subroutine bar + integer a(10) + a = 34 + end subroutine bar diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 new file mode 100644 index 000000000..63004c827 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize.f90 @@ -0,0 +1,23 @@ +! Program to test the scalarizer +program testarray + implicit none + integer, dimension (6, 5) :: a, b + integer n + + a = 0 + do n = 1, 5 + a(4, n) = n + end do + + b(:, 5:1:-1) = a + a(1:5, 2) = a(4, :) + 1 + + ! The following expression should cause loop reordering + a(:, 2:4) = a(:, 1:3) + + do n = 1, 5 + if (a(n, 3) .ne. (n + 1)) call abort + if (b(4, n) .ne. (6 - n)) call abort + end do +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 new file mode 100644 index 000000000..608c051d3 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize2.f90 @@ -0,0 +1,24 @@ +! Program to test the scalarizer +program testarray + implicit none + integer, dimension (:, :), allocatable :: a, b + integer n + + allocate(a(6, 5), b(6, 5)) + a = 0 + do n = 1, 5 + a(4, n) = n + end do + + b(:, 5:1:-1) = a + a(1:5, 2) = a(4, :) + 1 + + ! The following expression should cause loop reordering + a(:, 2:4) = a(:, 1:3) + + do n = 1, 5 + if (a(n, 3) .ne. (n + 1)) call abort + if (b(4, n) .ne. (6 - n)) call abort + end do +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 new file mode 100644 index 000000000..76d41484c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/scalarize3.f90 @@ -0,0 +1,8 @@ +program foo + integer, dimension(3, 2) :: a + + a = reshape ((/1, 2, 3, 4, 5, 6/), (/3, 2/)) + a = a(3:1:-1, 2:1:-1); + + if (any (a .ne. reshape ((/6, 5, 4, 3, 2, 1/), (/3, 2/)))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/select_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/select_1.f90 new file mode 100644 index 000000000..2fe5b6847 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/select_1.f90 @@ -0,0 +1,17 @@ +! from PR 15962, we used to require constant expressions instead of +! initialization expressions in case-statements +function j(k) +integer :: k +integer :: j +integer, parameter :: i(2) = (/1,2/) + +select case(k) +case (1:size(i)) + j = i(k) +case default + j = 0 +end select +end function + +if (j(2).NE.2 .OR. j(11).NE.0) call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.f90 new file mode 100644 index 000000000..e16888829 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.f90 @@ -0,0 +1,81 @@ +! pr 15472 +! sequential access files +! +! this test verifies the most basic sequential unformatted I/O +! write 3 records of various sizes +! then read them back +! and compare with what was written +! + 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*4 r(size) + integer i + m(1) = Z'11111111' + m(2) = Z'22222222' + n = Z'33333333' + do i = 1,size + r(i) = i + end do + write(9)m ! an array of 2 + write(9)n ! an integer + write(9)r ! an array of reals +! 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 + + rewind(9) + read(9)m + read(9)n + read(9)r +! +! check results + if (m(1).ne.Z'11111111') then + if (debug) then + print '(A,Z8)','m(1) incorrect. m(1) = ',m(1) + else + call abort + endif + endif + + if (m(2).ne.Z'22222222') then + if (debug) then + print '(A,Z8)','m(2) incorrect. m(2) = ',m(2) + else + call abort + endif + endif + + if (n.ne.Z'33333333') then + if (debug) then + print '(A,Z8)','n incorrect. n = ',n + else + call abort + 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 + call abort + endif + endif + end do +! use hexdump to look at the file "fort.9" + if (debug) then + close(9) + else + close(9,status='DELETE') + endif + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/seq_io.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 new file mode 100644 index 000000000..29f44a7dd --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.f90 @@ -0,0 +1,14 @@ +! pr 14762 - '/' not working in format + INTEGER N(5) + DATA N/1,2,3,4,5/ + OPEN(UNIT=7) + 100 FORMAT(I4) + WRITE(7,100)N + CLOSE(7) + OPEN(7) + 200 FORMAT(I4,///I4) + READ(7,200)I,J + CLOSE(7, STATUS='DELETE') + IF (I.NE.1) CALL ABORT + IF (J.NE.4) CALL ABORT + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/slash_edit.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 new file mode 100644 index 000000000..be8e3f748 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/spec_abs.f90 @@ -0,0 +1,12 @@ +!pr 14056 + INTRINSIC IABS + INTEGER FF324 + IVCOMP = FF324(IABS,-7) + IF (IVCOMP.NE.8) CALL ABORT + END + INTEGER FUNCTION FF324(NINT, IDON03) + FF324 = NINT(IDON03) + 1 +! **** THE NAME NINT IS A DUMMY ARGUMENT +! AND NOT AN INTRINSIC FUNCTION REFERENCE ***** + RETURN + END diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 new file mode 100644 index 000000000..96977fd11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90 @@ -0,0 +1,311 @@ +! Program to test intrinsic functions as actual arguments +! +! Please keep the content of this file in sync with gfortran.dg/specifics_1.f90 +subroutine test_c(fn, val, res) + complex fn + complex val, res + + if (diff(fn(val),res)) call abort +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)) call abort +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)) call abort +contains +function diff(a,b) + real a,b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_cdabs(fn, val, res) + double precision fn, res + double complex val + + if (diff(fn(val),res)) call abort +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)) call abort +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d(fn, val, res) + double precision fn + double precision val, res + + if (diff(fn(val), res)) call abort +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_r2(fn, val1, val2, res) + real fn + real val1, val2, res + + if (diff(fn(val1, val2), res)) call abort +contains +function diff(a, b) + real a, b + logical diff + diff = (abs(a - b) .gt. 0.00001) +end function +end subroutine + +subroutine test_d2(fn, val1, val2, res) + double precision fn + double precision val1, val2, res + + if (diff(fn(val1, val2), res)) call abort +contains +function diff(a, b) + double precision a, b + logical diff + diff = (abs(a - b) .gt. 0.00001d0) +end function +end subroutine + +subroutine test_dprod(fn) + double precision fn + if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort +end subroutine + +subroutine test_nint(fn,val,res) + integer fn, res + real val + if (res .ne. fn(val)) call abort +end subroutine + +subroutine test_idnint(fn,val,res) + integer fn, res + double precision val + if (res .ne. fn(val)) call abort +end subroutine + +subroutine test_idim(fn,val1,val2,res) + integer fn, res, val1, val2 + if (res .ne. fn(val1,val2)) call abort +end subroutine + +subroutine test_iabs(fn,val,res) + integer fn, res, val + if (res .ne. fn(val)) call abort +end subroutine + +subroutine test_len(fn,val,res) + integer fn, res + character(len=*) val + if (res .ne. fn(val)) call abort +end subroutine + +subroutine test_index(fn,val1,val2,res) + integer fn, res + character(len=*) val1, val2 + if (fn(val1,val2) .ne. res) call abort +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 + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 new file mode 100644 index 000000000..e8788025a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 @@ -0,0 +1,87 @@ +! Program to test STATEMENT function +program st_fuction + call simple_case + call with_function_call + call with_character_dummy + call with_derived_type_dummy + call with_pointer_dummy + call multiple_eval + +contains + subroutine simple_case + integer st1, st2 + integer c(10, 10) + st1 (i, j) = i + j + st2 (i, j) = c(i, j) + + if (st1 (1, 2) .ne. 3) call abort + c = 3 + if (st2 (1, 2) .ne. 3 .or. st2 (2, 3) .ne. 3) call abort + end subroutine + + subroutine with_function_call + integer fun, st3 + st3 (i, j) = fun (i) + fun (j) + + if (st3 (fun (2), 4) .ne. 16) call abort + end subroutine + + subroutine with_character_dummy + character (len=4) s1, s2, st4 + character (len=10) st5, s0 + st4 (i, j) = "0123456789"(i:j) + st5 (s1, s2) = s1 // s2 + + if (st4 (1, 4) .ne. "0123" ) call abort + if (st5 ("01", "02") .ne. "01 02 ") call abort ! { dg-warning "Character length of actual argument shorter" } + end subroutine + + subroutine with_derived_type_dummy + type person + integer age + character (len=50) name + end type person + type (person) me, p, tom + type (person) st6 + st6 (p) = p + + me%age = 5 + me%name = "Tom" + tom = st6 (me) + if (tom%age .ne. 5) call abort + if (tom%name .gt. "Tom") call abort + end subroutine + + subroutine with_pointer_dummy + character(len=4), pointer:: p, p1 + character(len=4), target:: i + character(len=6) a + a (p) = p // '10' + + p1 => i + i = '1234' + if (a (p1) .ne. '123410') call abort + end subroutine + + subroutine multiple_eval + integer st7, fun2, fun + + st7(i) = i + fun(i) + + if (st7(fun2(10)) .ne. 3) call abort + end subroutine +end + +! This functon returns the argument passed on the previous call. +integer function fun2 (i) + integer i + integer, save :: val = 1 + + fun2 = val + val = i +end function + +integer function fun (i) + integer i + fun = i * 2 +end function diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 new file mode 100644 index 000000000..b851a942e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 @@ -0,0 +1,23 @@ +! Check that character valued statement functions honour length parameters +program st_function_1 + character(8) :: foo + character(15) :: bar + character(6) :: p + character (7) :: s + foo(p) = p // "World" + bar(p) = p // "World" + + ! Expression longer than function, actual arg shorter than dummy. + call check (foo("Hello"), "Hello Wo") ! { dg-warning "Character length of actual argument shorter" } + + ! Expression shorter than function, actual arg longer than dummy. + ! Result shorter than type + s = "Hello" + call check (bar(s), "Hello World ") +contains +subroutine check(a, b) + character (len=*) :: a, b + + if ((a .ne. b) .or. (len(a) .ne. len(b))) call abort () +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 new file mode 100644 index 000000000..2dec73562 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/st_function_2.f90 @@ -0,0 +1,21 @@ +! PR15620 +! Check that evaluating a statement function doesn't affect the value of +! its dummy argument variables. +program st_function_2 + integer fn, a, b + fn(a, b) = a + b + if (foo(1) .ne. 43) call abort + + ! Check that values aren't modified when avaluating the arguments. + a = 1 + b = 5 + if (fn (b + 2, a + 3) .ne. 11) call abort +contains +function foo (x) + integer z, y, foo, x + bar(z) = z*z + z = 42 + t = bar(x) + foo = t + z +end function +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 new file mode 100644 index 000000000..6342e1a40 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/stack_varsize.f90 @@ -0,0 +1,30 @@ +! Program to test the stack variable size limit. +program stack + call sub1 + call sub2 (1) +contains + + ! Local variables larger than 32768 in byte size shall be placed in static + ! storage area, while others be put on stack by default. + subroutine sub1 + real a, b(32768/4), c(32768/4+1) + integer m, n(1024,4), k(1024,1024) + a = 10.0 + b = 20.0 + c = 30.0 + m = 10 + n = 20 + k = 30 + if ((a .ne. 10.0).or.(b(1) .ne. 20.0).or.(c(1) .ne. 30.0)) call abort + if ((m .ne. 10).or.(n(256,4) .ne. 20).or.(k(1,1024) .ne. 30)) call abort + end subroutine + + ! Local variables defined in recursive subroutine are always put on stack. + recursive subroutine sub2 (n) + real a (32769) + a (1) = 42 + if (n .ge. 1) call sub2 (n-1) + if (a(1) .ne. 42) call abort + a (1) = 0 + end subroutine +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 new file mode 100644 index 000000000..579e35a70 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/straret.f90 @@ -0,0 +1,18 @@ +! Test assumed length character functions. + +character*(*) function f() + f = "Hello" +end function + +character*6 function g() + g = "World" +end function + +program straret + character*6 f, g + character*12 v + + + v = f() // g() + if (v .ne. "Hello World ") call abort () +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 new file mode 100644 index 000000000..95e9b0385 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_1.f90 @@ -0,0 +1,13 @@ +subroutine foo(i) +character c +integer i +character(1),parameter :: hex_chars(0:15)=& + (/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/) + +c = hex_chars(i) +if (c.ne.'3') call abort() +end + +program strarray_1 +call foo(3) +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 new file mode 100644 index 000000000..dbb3b89e4 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_2.f90 @@ -0,0 +1,14 @@ +subroutine foo(i,c) +character c +integer i +character(1),parameter :: hex_chars(0:15)=& + (/'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/) + +c = hex_chars(i) +end + +program strarray_2 + character c + call foo(3,c) + if (c.ne.'3') call abort() +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 new file mode 100644 index 000000000..9d369c7f1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_3.f90 @@ -0,0 +1,50 @@ +program strarray_3 + character(len=5), dimension(2) :: c + + c(1) = "Hello" + c(2) = "World" + + call foo1(c) + call foo2(c, 2) + call foo3(c, 5) + call foo4(c, 5, 2) + call foo5(c(2:1:-1)) +contains +subroutine foo1(a) + implicit none + character(len=5), dimension(2) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo2(a, m) + implicit none + integer m + character(len=5), dimension(m) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo3(a, n) + implicit none + integer n + character(len=n), dimension(:) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo4(a, n, m) + implicit none + integer n, m + character(len=n), dimension(m) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +subroutine foo5(a) + implicit none + character(len=2), dimension(5) :: a + + if ((a(1) .ne. "Wo") .or. (a(3) .ne. "dH") .or. (a(5) .ne. "lo")) call abort +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 new file mode 100644 index 000000000..c33f4b53d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strarray_4.f90 @@ -0,0 +1,39 @@ +program strarray_4 + character(len=5), dimension(2) :: c + + c(1) = "Hello" + c(2) = "World" + + call foo1(c) + call foo2(c, 2) + call foo3(c, 5, 2) +contains +subroutine foo1(a) + implicit none + character(len=5), dimension(2) :: a + character(len=5), dimension(2) :: b + + b = a; + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine + +subroutine foo2(a, m) + implicit none + integer m + character(len=5), dimension(m) :: a + character(len=5), dimension(m) :: b + + b = a + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine + +subroutine foo3(a, n, m) + implicit none + integer n, m + character(len=n), dimension(m) :: a + character(len=n), dimension(m) :: b + + b = a + if ((b(1) .ne. "Hello") .or. (b(2) .ne. "World")) call abort +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 new file mode 100644 index 000000000..26980901c --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcmp.f90 @@ -0,0 +1,16 @@ +program test + implicit none + character(len=20) :: foo + + foo="hello" + + if (llt(foo, "hello")) call abort + if (.not. lle(foo, "hello")) call abort + if (lgt("hello", foo)) call abort + if (.not. lge("hello", foo)) call abort + + if (.not. llt(foo, "world")) call abort + if (.not. lle(foo, "world")) call abort + if (lgt(foo, "world")) call abort + if (lge(foo, "world")) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 new file mode 100644 index 000000000..aa51ccf4b --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strcommon_1.f90 @@ -0,0 +1,28 @@ +! PR14081 character variables in common blocks. + +subroutine test1 + implicit none + common /block/ c + character(len=12) :: c + + if (c .ne. "Hello World") call abort +end subroutine + +subroutine test2 + implicit none + common /block/ a + character(len=6), dimension(2) :: a + + if ((a(1) .ne. "Hello") .or. (a(2) .ne. "World")) call abort +end subroutine + +program strcommon_1 + implicit none + common /block/ s, t + character(len=6) :: s, t + s = "Hello " + t = "World " + call test1 + call test2 +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 new file mode 100644 index 000000000..f220f4a47 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/string.f90 @@ -0,0 +1,15 @@ +! Program to test string handling +program string + implicit none + character(len=5) :: a, b + character(len=20) :: c + + a = 'Hello' + b = 'World' + c = a//b + + if (c .ne. 'HelloWorld') call abort + if (c .eq. 'WorldHello') call abort + if (a//'World' .ne. 'HelloWorld') call abort + if (a .ge. b) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 new file mode 100644 index 000000000..17f9aa277 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strlen.f90 @@ -0,0 +1,34 @@ +! Program to test the LEN and LEN_TRIM intrinsics. +subroutine test (c) + character(*) c + character(len(c)) d + + d = c + if (len(d) .ne. 20) call abort + if (d .ne. "Longer Test String") call abort + c = "Hello World" +end subroutine + +subroutine test2 (c) + character (*) c + character(len(c)) d + + d = c + if (len(d) .ne. 6) call abort + if (d .ne. "Foobar") call abort +end subroutine + +program strlen + implicit none + character(20) c + character(5) a, b + integer i + + c = "Longer Test String" + call test (c) + + if (len(c) .ne. 20) call abort + if (len_trim(c) .ne. 11) call abort + + call test2 ("Foobar"); +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 new file mode 100644 index 000000000..7346fff5d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/strret.f90 @@ -0,0 +1,25 @@ +! Program to test caracter string return values +function test () + implicit none + character(len=10) :: test + test = "World" +end function + +function test2 () result (r) + implicit none + character(len=5) :: r + r = "Hello" +end function + +program strret + implicit none + character(len=15) :: s + character(len=10) :: test + character(len=5) :: test2 + + s = test () + if (s .ne. "World") call abort + + s = "Hello " // test () + if (s .ne. test2 () //" World") call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/t_edit.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/t_edit.f90 new file mode 100644 index 000000000..9746f3194 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/t_edit.f90 @@ -0,0 +1,11 @@ +!pr 14897 T edit descriptor broken + implicit none + character*80 line + WRITE(line,'(T5,A,T10,A,T15,A)')'AA','BB','CC' + if (line.ne.' AA BB CC ') call abort + WRITE(line,'(5HAAAAA,TL4,4HABCD)') + if (line.ne.'AABCD') call abort + END + + + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 new file mode 100644 index 000000000..f2291cd83 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/test_slice.f90 @@ -0,0 +1,17 @@ +! Program to test handling of reduced rank array sections. This uncovered +! bugs in simplify_shape and the scalarization of array sections. +program test_slice + implicit none + + real (kind = 8), dimension(2, 2, 2) :: x + real (kind = 8) :: min, max + + x = 1.0 + if (minval(x(1, 1:2, 1:1)) .ne. 1.0) call abort () + if (maxval(x(1, 1:2, 1:1)) .ne. 1.0) call abort () + if (any (shape(x(1, 1:2, 1:1)) .ne. (/2, 1/))) call abort () + + if (any (shape(x(1, 1:2, 1)) .ne. (/2/))) call abort () + if (any (shape(x(1:1, 1:2, 1:1)) .ne. (/1, 2, 1/))) call abort () + +end program test_slice diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer1.f90 new file mode 100644 index 000000000..855fe9df1 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer1.f90 @@ -0,0 +1,10 @@ +program chop + integer ix, iy + real x, y + x = 1. + y = x + ix = transfer(x,ix) + iy = transfer(y,iy) + print '(2z20.8)', ix, iy + if (ix /= iy) call abort +end program chop diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer2.f90 new file mode 100644 index 000000000..b57841c30 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/transfer2.f90 @@ -0,0 +1,19 @@ +program test_convert + + implicit none + character(len=4) :: byte_string + character(len=1),dimension(4) :: byte_array + integer*4 :: value,value1,n,i + + byte_string(1:1) = char(157) + byte_string(2:2) = char(127) + byte_string(3:3) = char(100) + byte_string(4:4) = char(0) + + byte_array(1:4) = (/char(157),char(127),char(100),char(0)/) + + value = transfer(byte_string(1:4),value) + value1 = transfer(byte_array(1:4),value1) + + if (value .ne. value1) call abort() +end program test_convert diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 new file mode 100644 index 000000000..66895b02a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.f90 @@ -0,0 +1,14 @@ +! PR 14565 +program unopened_unit_1 + Integer I,J + Do I = 1,10 + Write(99,*)I + End Do + Rewind(99) + Do I = 1,10 + Read(99,*)J + If (J.ne.I) Call abort + End Do + Close(99, Status='Delete') +End program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.x b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.x new file mode 100644 index 000000000..b4a54bb23 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/unopened_unit_1.x @@ -0,0 +1,7 @@ +load_lib target-supports.exp + +if { ! [check_effective_target_fd_truncate] } { + return 1 +} + +return 0 diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 new file mode 100644 index 000000000..4fceb4766 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/userop.f90 @@ -0,0 +1,67 @@ +module uops + implicit none + interface operator (.foo.) + module procedure myfoo + end interface + + interface operator (*) + module procedure boolmul + end interface + + interface assignment (=) + module procedure int2bool + end interface + +contains +function myfoo (lhs, rhs) + implicit none + integer myfoo + integer, intent(in) :: lhs, rhs + + myfoo = lhs + rhs +end function + +! This is deliberately different from integer multiplication +function boolmul (lhs, rhs) + implicit none + logical boolmul + logical, intent(IN) :: lhs, rhs + + boolmul = lhs .and. .not. rhs +end function + +subroutine int2bool (lhs, rhs) + implicit none + logical, intent(out) :: lhs + integer, intent(in) :: rhs + + lhs = rhs .ne. 0 +end subroutine +end module + +program me + use uops + implicit none + integer i, j + logical b, c + + b = .true. + c = .true. + if (b * c) call abort + c = .false. + if (.not. (b * c)) call abort + if (c * b) call abort + b = .false. + if (b * c) call abort + + i = 0 + b = i + if (b) call abort + i = 2 + b = i + if (.not. b) call abort + + j = 3 + if ((i .foo. j) .ne. 5) call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 new file mode 100644 index 000000000..b4323ca81 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where17.f90 @@ -0,0 +1,15 @@ +! Check to ensure only the first true clause in WHERE is +! executed. +program where_17 + integer :: a(3) + + a = (/1, 2, 3/) + where (a .eq. 1) + a = 2 + elsewhere (a .le. 2) + a = 3 + elsewhere (a .le. 3) + a = 4 + endwhere + if (any (a .ne. (/2, 3, 4/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 new file mode 100644 index 000000000..403646460 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where18.f90 @@ -0,0 +1,26 @@ +! Check to ensure mask is calculated first in WHERE +! statements. +program where_18 + integer :: a(4) + integer :: b(3) + integer :: c(3) + equivalence (a(1), b(1)), (a(2), c(1)) + + a = (/1, 1, 1, 1/) + where (b .eq. 1) + c = 2 + elsewhere (b .eq. 2) + c = 3 + endwhere + if (any (a .ne. (/1, 2, 2, 2/))) & + call abort + + a = (/1, 1, 1, 1/) + where (c .eq. 1) + b = 2 + elsewhere (b .eq. 2) + b = 3 + endwhere + if (any (a .ne. (/2, 2, 2, 1/))) & + call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 new file mode 100644 index 000000000..3c41b8997 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where19.f90 @@ -0,0 +1,23 @@ +! Check to ensure result is calculated from unmodified +! version of the right-hand-side in WHERE statements. +program where_19 + integer :: a(4) + integer :: b(3) + integer :: c(3) + equivalence (a(1), b(1)), (a(2), c(1)) + + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = b + endwhere + if (any (a .ne. (/1, 2, 2, 3/))) & + call abort () + + a = (/1, 2, 3, 4/) + where (c .gt. 1) + b = c + endwhere + if (any (a .ne. (/2, 3, 4, 4/))) & + call abort () +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 new file mode 100644 index 000000000..b0456500d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where20.f90 @@ -0,0 +1,54 @@ +! Test the dependency checking in simple where. This +! did not work and was fixed as part of the patch for +! pr24519. +! +program where_20 + integer :: a(4) + integer :: b(3) + integer :: c(3) + integer :: d(3) = (/1, 2, 3/) + equivalence (a(1), b(1)), (a(2), c(1)) + +! This classic case worked before the patch. + a = (/1, 2, 3, 4/) + where (b .gt. 1) a(2:4) = a(1:3) + if (any(a .ne. (/1,2,2,3/))) call abort () + +! This is the original manifestation of the problem +! and is repeated in where_19.f90. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = b + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Mask to.destination dependency. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + c = d + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Source to.destination dependency. + a = (/1, 2, 3, 4/) + where (d .gt. 1) + c = b + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +! Check the simple where. + a = (/1, 2, 3, 4/) + where (b .gt. 1) c = b + if (any(a .ne. (/1,2,2,3/))) call abort () + +! This was OK before the patch. + a = (/1, 2, 3, 4/) + where (b .gt. 1) + where (d .gt. 1) + c = b + end where + endwhere + if (any(a .ne. (/1,2,2,3/))) call abort () + +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where21.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where21.f90 new file mode 100644 index 000000000..6826b87b6 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where21.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! Test fix for PR fortran/30207. +program a + implicit none + integer, parameter :: i(4) = (/ 1, 1, 1, 1 /) + integer :: z(4) = (/ 1, 1, -1, -1 /) + where(z < 0) z(:) = 1 + if (any(z /= i)) call abort +end program a diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 new file mode 100644 index 000000000..ba1f8a625 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_1.f90 @@ -0,0 +1,41 @@ +! Program to test WHERE inside FORALL +program where_1 + integer :: A(5,5) + + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + ! Where inside FORALL. + ! WHERE masks must be evaluated before executing the assignments + forall (I=1:5) + where (A(I,:) .EQ. 0) + A(:,I) = I + elsewhere (A(I,:) >2) + A(I,:) = 6 + endwhere + end forall + + if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 3, 0, & + 0, 1, 4, 2, 0, 0, 5, 6, 6, 5/), (/5, 5/)))) call abort + + ! Where inside DO + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + do I=1,5 + where (A(I,:) .EQ. 0) + A(:,I) = I + elsewhere (A(I,:) >2) + A(I,:) = 6 + endwhere + enddo + + if (any (A .ne. reshape ((/1, 1, 1, 1, 1, 0, 1, 2, 1, 2, 0, 1, 2, 6, 0, & + 0, 1, 0, 2, 0, 0, 0, 5, 5, 5/), (/5, 5/)))) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_10.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_10.f90 new file mode 100644 index 000000000..c5a85cec8 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_10.f90 @@ -0,0 +1,23 @@ +! Check whether conditional ELSEWHEREs work +! (with final unconditional ELSEWHERE) +program where_10 + integer :: a(5) + integer :: b(5) + + a = (/1, 2, 3, 4, 5/) + b = (/0, 0, 0, 0, 0/) + where (a .eq. 1) + b = 3 + elsewhere (a .eq. 2) + b = 1 + elsewhere (a .eq. 3) + b = 4 + elsewhere (a .eq. 4) + b = 1 + elsewhere + b = 5 + endwhere + if (any (b .ne. (/3, 1, 4, 1, 5/))) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_11.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_11.f90 new file mode 100644 index 000000000..f2eb69f2e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_11.f90 @@ -0,0 +1,23 @@ +! Check whether conditional ELSEWHEREs work +! (without unconditional ELSEWHERE) +program where_11 + integer :: a(5) + integer :: b(5) + + a = (/1, 2, 3, 4, 5/) + b = (/0, 0, 0, 0, 0/) + where (a .eq. 1) + b = 3 + elsewhere (a .eq. 2) + b = 1 + elsewhere (a .eq. 3) + b = 4 + elsewhere (a .eq. 4) + b = 1 + elsewhere (a .eq. 5) + b = 5 + endwhere + if (any (b .ne. (/3, 1, 4, 1, 5/))) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_12.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_12.f90 new file mode 100644 index 000000000..c95dc979f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_12.f90 @@ -0,0 +1,9 @@ +! Check empty WHEREs work +program where_12 + integer :: a(5) + + a = (/1, 2, 3, 4, 5/) + where (a .eq. 1) + endwhere +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_13.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_13.f90 new file mode 100644 index 000000000..ce8d5822e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_13.f90 @@ -0,0 +1,10 @@ +! Check empty WHERE and empty ELSEWHERE works +program where_13 + integer :: a(5) + + a = (/1, 2, 3, 4, 5/) + where (a .eq. 2) + elsewhere + endwhere +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_14.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_14.f90 new file mode 100644 index 000000000..640bdf574 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_14.f90 @@ -0,0 +1,15 @@ +! Check whether an empty ELSEWHERE works +program where_14 + integer :: a(5) + integer :: b(5) + + a = (/1, 2, 3, 4, 5/) + b = (/0, 0, 0, 0, 0/) + where (a .eq. 1) + b = 3 + elsewhere + endwhere + if (any (b .ne. (/3, 0, 0, 0, 0/))) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_15.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_15.f90 new file mode 100644 index 000000000..ffbebb728 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_15.f90 @@ -0,0 +1,15 @@ +! Check whether an empty WHERE works +program where_15 + integer :: a(5) + integer :: b(5) + + a = (/1, 2, 3, 4, 5/) + b = (/0, 0, 0, 0, 0/) + where (a .eq. 1) + elsewhere + b = 2 + endwhere + if (any (b .ne. (/0, 2, 2, 2, 2/))) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_16.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_16.f90 new file mode 100644 index 000000000..19f012a11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_16.f90 @@ -0,0 +1,39 @@ +! Check whether nested WHEREs work +program where_16 + integer :: a(9) + integer :: b(9) + integer :: c(9) + + a = (/0, 0, 0, 1, 1, 1, 2, 2, 2/) + b = (/0, 1, 2, 0, 1, 2, 0, 1, 2/) + c = (/0, 0, 0, 0, 0, 0, 0, 0, 0/) + + where (a .eq. 0) + where (b .eq. 0) + c = 1 + else where (b .eq. 1) + c = 2 + else where + c = 3 + endwhere + elsewhere (a .eq. 1) + where (b .eq. 0) + c = 4 + else where (b .eq. 1) + c = 5 + else where + c = 6 + endwhere + elsewhere + where (b .eq. 0) + c = 7 + else where (b .eq. 1) + c = 8 + else where + c = 9 + endwhere + endwhere + if (any (c .ne. (/1, 2, 3, 4, 5, 6, 7, 8, 9/))) & + call abort +end program + diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 new file mode 100644 index 000000000..25a8dc9e7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_2.f90 @@ -0,0 +1,22 @@ +! Program to test the WHERE constructs +program where_2 + integer temp(10), reduce(10) + + temp = 10 + reduce(1:3) = -1 + reduce(4:6) = 0 + reduce(7:8) = 5 + reduce(9:10) = 10 + + WHERE (reduce < 0) + temp = 100 + ELSE WHERE (reduce .EQ. 0) + temp = 200 + temp + ELSE WHERE + WHERE (reduce > 6) temp = temp + sum(reduce) + temp = 300 + temp + END WHERE + + if (any (temp .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) & + call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 new file mode 100644 index 000000000..a9f7ef7bc --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_3.f90 @@ -0,0 +1,21 @@ +! Program to test WHERE on unknown size arrays +program where_3 + integer A(10, 2) + + A = 0 + call sub(A) + +contains + +subroutine sub(B) + integer, dimension(:, :) :: B + + B(1:5, 1) = 0 + B(6:10, 1) = 5 + where (B(:,1)>0) + B(:,1) = B(:,1) + 10 + endwhere + if (any (B .ne. reshape ((/0, 0, 0, 0, 0, 15, 15, 15, 15, 15, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/), (/10, 2/)))) call abort +end subroutine +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 new file mode 100644 index 000000000..104096b35 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_4.f90 @@ -0,0 +1,13 @@ +! Tests WHERE statement with a data dependency +program where_4 + integer, dimension(5) :: a + integer, dimension(5) :: b + + a = (/1, 2, 3, 4, 5/) + b = (/1, 0, 1, 0, 1/) + + where (b .ne. 0) + a(:) = a(5:1:-1) + endwhere + if (any (a .ne. (/5, 2, 3, 4, 1/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 new file mode 100644 index 000000000..58d24ecbb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_5.f90 @@ -0,0 +1,13 @@ +! Tests WHERE satement with non-integer array in the mask expression +program where_5 + integer, dimension(5) :: a + real(kind=8), dimension(5) :: b + + a = (/1, 2, 3, 4, 5/) + b = (/1d0, 0d0, 1d0, 0d0, 1d0/) + + where (b .ne. 0d0) + a(:) = a(:) + 10 + endwhere + if (any (a .ne. (/11, 2, 13, 4, 15/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 new file mode 100644 index 000000000..274598b8d --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_6.f90 @@ -0,0 +1,23 @@ +! Program to test WHERE inside FORALL and the WHERE assignment need temporary +program where_6 + integer :: A(5,5) + + A(1,:) = (/1,0,0,0,0/) + A(2,:) = (/2,1,1,1,0/) + A(3,:) = (/1,2,2,0,2/) + A(4,:) = (/2,1,0,2,3/) + A(5,:) = (/1,0,0,0,0/) + + ! Where inside FORALL. + ! WHERE masks must be evaluated before executing the assignments + m=5 + forall (I=1:4) + where (A(I,:) .EQ. 0) + A(1:m,I) = A(1:m,I+1) + I + elsewhere (A(I,:) >2) + A(I,1:m) = 6 + endwhere + end forall + if (any (A .ne. reshape ((/1,2,6,2,1,0,1,2,1,2,0,1,2,5,0,0,1,6,2,0,0,0,2,& + 6,0/), (/5, 5/)))) call abort +end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_7.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_7.f90 new file mode 100644 index 000000000..49dc5952a --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_7.f90 @@ -0,0 +1,53 @@ +! Really test where inside forall with temporary +program evil_where + implicit none + type t + logical valid + integer :: s + integer, dimension(:), pointer :: p + end type + type (t), dimension (5) :: v + integer i + + allocate (v(1)%p(2)) + allocate (v(2)%p(8)) + v(3)%p => NULL() + allocate (v(4)%p(8)) + allocate (v(5)%p(2)) + + v(:)%valid = (/.true., .true., .false., .true., .true./) + v(:)%s = (/1, 8, 999, 6, 2/) + v(1)%p(:) = (/9, 10/) + v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/) + v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/) + v(5)%p(:) = (/11, 12/) + + forall (i=1:5,v(i)%valid) + where (v(i)%p(1:v(i)%s).gt.4) + v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s) + end where + end forall + + if (any(v(1)%p(:) .ne. (/11, 10/))) call abort + if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 17, 18, 19, 20/))) call abort + if (any(v(4)%p(:) .ne. (/1, 2, 3, 4, 5, 6, 19, 20/))) call abort + if (any(v(5)%p(:) .ne. (/9, 10/))) call abort + + v(1)%p(:) = (/9, 10/) + v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/) + v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/) + v(5)%p(:) = (/11, 12/) + + forall (i=1:5,v(i)%valid) + where (v(i)%p(1:v(i)%s).le.4) + v(i)%p(1:v(i)%s) = v(6-i)%p(1:v(i)%s) + end where + end forall + + if (any(v(1)%p(:) .ne. (/9, 10/))) call abort + if (any(v(2)%p(:) .ne. (/13, 14, 15, 16, 5, 6, 7, 8/))) call abort + if (any(v(4)%p(:) .ne. (/13, 14, 15, 16, 17, 18, 19, 20/))) call abort + if (any(v(5)%p(:) .ne. (/11, 12/))) call abort + + ! I should really free the memory I've allocated. +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_8.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_8.f90 new file mode 100644 index 000000000..58a26bd34 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/where_8.f90 @@ -0,0 +1,28 @@ +program where_8 + implicit none + type t + logical valid + integer :: s + integer, dimension(8) :: p + end type + type (t), dimension (5) :: v + integer i + + v(:)%valid = (/.true., .true., .false., .true., .true./) + v(:)%s = (/1, 8, 999, 6, 2/) + v(1)%p(:) = (/9, 10, 0, 0, 0, 0, 0, 0/) + v(2)%p(:) = (/1, 2, 3, 4, 5, 6, 7, 8/) + v(4)%p(:) = (/13, 14, 15, 16, 17, 18, 19, 20/) + v(5)%p(:) = (/11, 12, 0, 0, 0, 0, 0, 0/) + + forall (i=1:5,v(i)%valid) + where (v(i)%p(1:v(i)%s).gt.4) + v(i)%p(1:v(i)%s) = 21 + end where + end forall + + if (any(v(1)%p(:) .ne. (/21, 10, 0, 0, 0, 0, 0, 0/))) call abort + if (any(v(2)%p(:) .ne. (/1, 2, 3, 4, 21, 21, 21, 21/))) call abort + if (any(v(4)%p(:) .ne. (/21, 21, 21, 21, 21, 21, 19, 20/))) call abort + if (any(v(5)%p(:) .ne. (/21, 21, 0, 0, 0, 0, 0, 0/))) call abort +end program diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_a_1.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_a_1.f90 new file mode 100644 index 000000000..18cb103cb --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_a_1.f90 @@ -0,0 +1,14 @@ +! pr 15311 +! output with 'A' edit descriptor + program write_a_1 + character*25 s +! string = format + write(s,'(A11)') "hello world" + if (s.ne."hello world") call abort +! string < format + write(s,'(A2)') "hello world" + if (s.ne."he") call abort +! string > format + write(s,'(A18)') "hello world" + if (s.ne." hello world") call abort + end diff --git a/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 new file mode 100644 index 000000000..4e0060702 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/gfortran.fortran-torture/execute/write_logical.f90 @@ -0,0 +1,23 @@ +! PR 14334, L edit descriptor does not work +! +! this test uses L1 and L4 to print TRUE and FALSE + logical true,false + character*10 b + true = .TRUE. + false = .FALSE. + b = '' + write (b, '(L1)') true + if (b(1:1) .ne. 'T') call abort + + b = '' + write (b, '(L1)') false + if (b(1:1) .ne. 'F') call abort + + b = '' + write(b, '(L4)') true + if (b(1:4) .ne. ' T') call abort + + b = '' + write(b, '(L4)') false + if (b(1:4) .ne. ' F') call abort + end |