Initial revision

From-SVN: r15841

gcc/testsuite/g77.f-torture/compile/compile.exp

+# Expect driver script for GCC Regression Tests
+# Copyright (C) 1993, 1995, 1997 Free Software Foundation
+#
+# 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 2 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 this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 
+
+# These tests come from Torbjorn Granlund's (tege@cygnus.com)
+# F torture test suite, and other contributors.
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+# load support procs
+load_lib f-torture.exp
+
+foreach testcase [glob -nocomplain $srcdir/$subdir/*.f] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $testcase] then {
+	continue
+    }
+
+    f-torture $testcase
+}
+
+foreach testcase [glob -nocomplain $srcdir/$subdir/*.F] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $testcase] then {
+	continue
+    }
+
+    f-torture $testcase
+}

gcc/testsuite/g77.f-torture/compile/toon_1.f

+      SUBROUTINE AAP(NOOT)
+      DIMENSION NOOT(*)
+      END

gcc/testsuite/g77.f-torture/execute/alpha1.f

+      REAL*8 A,B,C
+      REAL*4 RARRAY(19)/19*(-1)/
+      INTEGER BOTTOM,RIGHT
+      INTEGER IARRAY(19)/0,0,0,0,0,0,0,0,0,0,0,0,13,14,0,0,0,0,0/
+      EQUIVALENCE (RARRAY(13),BOTTOM),(RARRAY(14),RIGHT)
+C
+      IF(I.NE.0) call exit(1)
+C gcc: Internal compiler error: program f771 got fatal signal 11
+C  at this point!
+      END

gcc/testsuite/g77.f-torture/execute/alpha2.f

+      IMPLICIT REAL*8 (A-H,O-Z)
+      COMMON /C/   A(9), INT
+      DATA A      /
+     1                 0.49999973986348730D01, 0.40000399113084100D01,
+     2                 0.29996921166596490D01, 0.20016917082678680D01,
+     3                 0.99126390351864390D00, 0.97963256554443300D-01,
+     4                -0.87360964813570100D-02, 0.16917082678692080D-02,
+     5                -0.26013651283774820D-05                         /
+      END

gcc/testsuite/g77.f-torture/execute/cabs.f

+      program cabs_1
+      complex      z0
+      real         r0
+      complex*16   z1
+      real*8       r1
+
+      z0 = cmplx(3.,4.)
+      r0 = cabs(z0)
+      if (r0 .ne. 5.) call exit(1)
+
+      z1 = dcmplx(3.d0,4.d0)
+      r1 = zabs(z1)
+      if (r1 .ne. 5.d0) call exit(1)
+      end

gcc/testsuite/g77.f-torture/execute/claus.f

+        PROGRAM TEST
+        REAL AB(3)
+        do i=1,3
+         AB(i)=i
+        enddo
+        k=1
+        n=2
+        ind=k-n+2
+	if (ind /= 1) call exit(1)
+	if (ab(ind) /= 1) call exit(1)
+	if (k-n+2 /= 1) call exit(1)
+	if (ab(k-n+2) /= 1) call exit(1)
+        END

gcc/testsuite/g77.f-torture/execute/complex_1.f

+      program complex_1
+      complex      z0, z1, z2
+
+      z0 = cmplx(0.,.5)
+      z1 = 1./z0
+      if (z1 .ne. cmplx(0.,-2)) call exit(1)
+
+      z0 = 10.*z0
+      if (z0 .ne. cmplx(0.,5.)) call exit(1)
+
+      z2 = cmplx(1.,2.)
+      z1 = z0/z2
+      if (z1 .ne. cmplx(2.,1.)) call exit(1)
+
+      z1 = z0*z2
+      if (z1 .ne. cmplx(-10.,5.)) call exit(1)
+      end
+

gcc/testsuite/g77.f-torture/execute/cpp.F

+!  Some versions of cpp will delete "//'World' as a C++ comment.
+      character*40    title
+      title = 'Hello '//'World'
+      if (title .ne. 'Hello World') stop 1
+      end

gcc/testsuite/g77.f-torture/execute/dcomplex.f

+      program foo
+      complex*16      z0, z1, z2
+
+      z0 = dcmplx(0.,.5)
+      z1 = 1./z0
+      if (z1 .ne. dcmplx(0.,-2)) call exit(1)
+
+      z0 = 10.*z0
+      if (z0 .ne. dcmplx(0.,5.)) call exit(1)
+
+      z2 = cmplx(1.,2.)
+      z1 = z0/z2
+      if (z1 .ne. dcmplx(2.,1.)) call exit(1)
+
+      z1 = z0*z2
+      if (z1 .ne. dcmplx(-10.,5.)) call exit(1)
+      end
+

gcc/testsuite/g77.f-torture/execute/erfc.f

+c============================================== test.f
+                real x, y
+		real*8 x1, y1
+		x=0.
+		y = erfc(x)
+		if (y .ne. 1.) call exit(1)
+
+		x=1.1
+		y = erfc(x)
+		if (abs(y - .1197949) .ge. 1.e-6) call exit(1)
+
+		x=10
+		y = erfc(x)
+		if (y .gt. 1.5e-44) call exit(1)
+
+		x1=0.
+		y1 = erfc(x1)
+		if (y1 .ne. 1.) call exit(1)
+
+		x1=1.1d0
+		y1 = erfc(x1)
+		if (abs(y1 - .1197949d0) .ge. 1.d-6) call exit(1)
+
+		x1=10
+		y1 = erfc(x1)
+		if (y1 .gt. 1.5d-44) call exit(1)
+		end
+c=================================================
+!output:
+!  0.  1.875
+!  1.10000002  1.48958981
+!  10.  5.00220949E-06
+!
+!The values should be:
+!erfc(0)=1
+!erfc(1.1)= 0.1197949
+!erfc(10)<1.543115467311259E-044

gcc/testsuite/g77.f-torture/execute/execute.exp

+# Copyright (C) 1991, 1992, 1993, 1995, 1997 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 2 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 this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 
+
+# Please email any bugs, comments, and/or additions to this file to:
+# bug-g77@prep.ai.mit.edu
+
+# This file was written by Rob Savoye. (rob@cygnus.com)
+# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com)
+
+#
+# These tests come from Torbjorn Granlund (tege@cygnus.com)
+# Fortran torture test suite.
+#
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+# load support procs
+load_lib f-torture.exp
+
+#
+# main test loop
+#
+
+foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $src] then {
+	continue
+    }
+
+    f-torture-execute $src
+}
+
+foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.F]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $src] then {
+	continue
+    }
+
+    f-torture-execute $src
+}

gcc/testsuite/g77.f-torture/execute/exp.f

+      a = 2**-2*1.
+      if (a .ne. .25) call exit(1)
+      end

gcc/testsuite/g77.f-torture/execute/large_vec.f

+      parameter (nmax=165000)
+      double precision x(nmax)
+      end

gcc/testsuite/g77.f-torture/execute/le.f

+      program fool
+
+      real     foo
+      integer  n
+      logical  t
+
+      foo = 2.5
+      n = 5
+
+      t = (n > foo)
+      if (t .neqv. .true.) call exit(1)
+      t = (n >= foo)
+      if (t .neqv. .true.) call exit(1)
+      t = (n < foo)
+      if (t .neqv. .false.) call exit(1)
+      t = (n <= 5)
+      if (t .neqv. .true.) call exit(1)
+      t = (n >= 5 )
+      if (t .neqv. .true.) call exit(1)
+      t = (n == 5)
+      if (t .neqv. .true.) call exit(1)
+      t = (n /= 5)
+      if (t .neqv. .false.) call exit(1)
+      t = (n /= foo)
+      if (t .neqv. .true.) call exit(1)
+      t = (n == foo)
+      if (t .neqv. .false.) call exit(1)
+
+      end

gcc/testsuite/g77.f-torture/execute/short.f

+      program short
+
+      parameter   (   N=2  )
+      common /chb/    pi,sig(0:N)
+      common /parm/   h(2,2)
+
+c  initialize some variables
+      h(2,2) = 1117
+      h(2,1) = 1178
+      h(1,2) = 1568
+      h(1,1) = 1621
+      sig(0) = -1.
+      sig(1) = 0.
+      sig(2) = 1.
+
+      call printout
+      stop
+      end
+
+c ******************************************************************
+
+      subroutine printout
+      parameter   (   N=2  )
+      common /chb/    pi,sig(0:N)
+      common /parm/   h(2,2)
+      dimension       yzin1(0:N), yzin2(0:N)
+
+c  function subprograms
+      z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
+
+c  a four-way average of rhobar
+      do 260  k=0,N
+        yzin1(k) = 0.25 * 
+     &       ( z(2,2,k) + z(1,2,k) +
+     &         z(2,1,k) + z(1,1,k) )
+  260       continue
+
+c  another four-way average of rhobar
+      do 270  k=0,N
+	rtmp1 = z(2,2,k)
+	rtmp2 = z(1,2,k)
+	rtmp3 = z(2,1,k)
+	rtmp4 = z(1,1,k)
+        yzin2(k) = 0.25 * 
+     &       ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
+  270       continue
+
+      do k=0,N
+	if (yzin1(k) .ne. yzin2(k)) call exit(1)
+      enddo
+      if (yzin1(0) .ne. -1371.) call exit(1)
+      if (yzin1(1) .ne. -685.5) call exit(1)
+      if (yzin1(2) .ne. 0.) call exit(1)
+
+      return
+      end
+