diff options
Diffstat (limited to 'gcc/testsuite/g77.f-torture/execute')
44 files changed, 0 insertions, 2606 deletions
diff --git a/gcc/testsuite/g77.f-torture/execute/19981119-0.f b/gcc/testsuite/g77.f-torture/execute/19981119-0.f deleted file mode 100644 index 5cfab57a5fc..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19981119-0.f +++ /dev/null @@ -1,40 +0,0 @@ -* X-Delivered: at request of burley on mescaline.gnu.org -* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET) -* From: "B. Yanchitsky" <yan@im.imag.kiev.ua> -* To: fortran@gnu.org -* Subject: Bug report -* MIME-Version: 1.0 -* Content-Type: TEXT/PLAIN; charset=US-ASCII -* -* There is a trouble with g77 on Alpha. -* My configuration: -* Digital Personal Workstation 433au, -* Digital Unix 4.0D, -* GNU Fortran 0.5.23 and GNU C 2.8.1. -* -* The following program treated successfully but crashed when running. -* -* C --- PROGRAM BEGIN ------- -* - subroutine sub(N,u) - integer N - double precision u(-N:N,-N:N) - -C vvvv CRASH HERE vvvvv - u(-N,N)=0d0 - return - end - - - program bug - integer N - double precision a(-10:10,-10:10) - data a/441*1d0/ - N=10 - call sub(N,a) - if (a(-N,N) .ne. 0d0) call abort - end -* -* C --- PROGRAM END ------- -* -* Good luck! diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-0.f b/gcc/testsuite/g77.f-torture/execute/19990313-0.f deleted file mode 100644 index abf898fb793..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-0.f +++ /dev/null @@ -1,33 +0,0 @@ -* To: craig@jcb-sc.com -* Subject: Re: G77 and KIND=2 -* Content-Type: text/plain; charset=us-ascii -* From: Dave Love <d.love@dl.ac.uk> -* Date: 03 Mar 1999 18:20:11 +0000 -* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000" -* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3 -* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0 -* -* ISTM that there is a real problem printing integer*8 (on x86): -* -* $ cat x.f -*[modified for test suite] - integer *8 foo, bar - data r/4e10/ - foo = 4e10 - bar = r - if (foo .ne. bar) call abort - end -* $ g77 x.f && ./a.out -* 1345294336 -* 123 -* $ f2c x.f && g77 x.c && ./a.out -* x.f: -* MAIN: -* 40000000000 -* 123 -* $ -* -* Gdb shows the upper half of the buffer passed to do_lio is zeroed in -* the g77 case. -* -* I've forgotten how the code generation happens. diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-1.f b/gcc/testsuite/g77.f-torture/execute/19990313-1.f deleted file mode 100644 index d99c72f2fde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-1.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double precision r - data r/4d10/ - foo = 4d10 - bar = r - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-2.f b/gcc/testsuite/g77.f-torture/execute/19990313-2.f deleted file mode 100644 index ffb7549d413..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-2.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - complex c - data c/(4e10,0)/ - foo = 4e10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-3.f b/gcc/testsuite/g77.f-torture/execute/19990313-3.f deleted file mode 100644 index 6366dccd890..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-3.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double complex c - data c/(4d10,0)/ - foo = 4d10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-0.f b/gcc/testsuite/g77.f-torture/execute/19990325-0.f deleted file mode 100644 index a230362fdde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-0.f +++ /dev/null @@ -1,313 +0,0 @@ -* test whether complex operators properly handle -* full and partial aliasing. -* (libf2c/libF77 routines used to assume no aliasing, -* then were changed to accommodate full aliasing, while -* the libg2c/libF77 versions were changed to accommodate -* both full and partial aliasing.) -* -* NOTE: this (19990325-0.f) is the single-precision version. -* See 19990325-1.f for the double-precision version. - - program complexalias - implicit none - -* Make sure non-aliased cases work. (Catch roundoff/precision -* problems, etc., here. Modify subroutine check if they occur.) - - call tryfull (1, 3, 5) - -* Now check various combinations of aliasing. - -* Full aliasing. - call tryfull (1, 1, 5) - -* Partial aliasing. - call trypart (2, 3, 5) - call trypart (2, 1, 5) - call trypart (2, 5, 3) - call trypart (2, 5, 1) - - end - - subroutine tryfull (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - complex expect - integer pwr - integer out, in1, in2 - - real array(6) - complex carray(3) - equivalence (carray(1), array(1)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 1) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = (xout + 1) / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carray(out) = + carray(in1) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carray(out) = - carray(in1) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carray(out) = carray(in1) + carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carray(out) = carray(in1) - carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carray(out) = carray(in1) * carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carray(out) = carray(in1) ** 2 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carray(out) = carray(in1) ** 3 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2-1) = abs (carray(in1)) - array(out*2) = 0 - call check (expect, carray(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carray(out) = cos (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carray(out) = exp (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carray(out) = log (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carray(out) = sin (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carray(out) = sqrt (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carray(out) = conjg (carray(in1)) - call check (expect, carray(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carray(out) = carray(in1) ** pwr - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carray(out) = carray(in1) / carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carray(out) = carray(in1) ** carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carray(out) = carray(in1) ** .2 - call check (expect, carray(out)) - - end - - subroutine trypart (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - complex expect - integer pwr - integer out, in1, in2 - - real array(6) - complex carray(3), carrayp(2) - equivalence (carray(1), array(1)) - equivalence (carrayp(1), array(2)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 0) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = xout / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carrayp(out) = + carray(in1) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carrayp(out) = - carray(in1) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carrayp(out) = carray(in1) + carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carrayp(out) = carray(in1) - carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carrayp(out) = carray(in1) * carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carrayp(out) = carray(in1) ** 2 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carrayp(out) = carray(in1) ** 3 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2) = abs (carray(in1)) - array(out*2+1) = 0 - call check (expect, carrayp(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carrayp(out) = cos (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carrayp(out) = exp (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carrayp(out) = log (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carrayp(out) = sin (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carrayp(out) = sqrt (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carrayp(out) = conjg (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carrayp(out) = carray(in1) ** pwr - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carrayp(out) = carray(in1) / carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carrayp(out) = carray(in1) ** carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carrayp(out) = carray(in1) ** .2 - call check (expect, carrayp(out)) - - end - - subroutine prepare1 (in) - implicit none - complex in - - in = (3.2, 4.2) - - end - - subroutine prepare1i (in, i) - implicit none - complex in - integer i - - in = (2.3, 2.5) - i = 4 - - end - - subroutine prepare2 (in1, in2) - implicit none - complex in1, in2 - - in1 = (1.3, 2.4) - in2 = (3.5, 7.1) - - end - - subroutine check (expect, got) - implicit none - complex expect, got - - if (aimag(expect) .ne. aimag(got)) call abort - if (real(expect) .ne. real(got)) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-1.f b/gcc/testsuite/g77.f-torture/execute/19990325-1.f deleted file mode 100644 index 802f375b33d..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-1.f +++ /dev/null @@ -1,313 +0,0 @@ -* test whether complex operators properly handle -* full and partial aliasing. -* (libf2c/libF77 routines used to assume no aliasing, -* then were changed to accommodate full aliasing, while -* the libg2c/libF77 versions were changed to accommodate -* both full and partial aliasing.) -* -* NOTE: this (19990325-1.f) is the double-precision version. -* See 19990325-0.f for the single-precision version. - - program doublecomplexalias - implicit none - -* Make sure non-aliased cases work. (Catch roundoff/precision -* problems, etc., here. Modify subroutine check if they occur.) - - call tryfull (1, 3, 5) - -* Now check various combinations of aliasing. - -* Full aliasing. - call tryfull (1, 1, 5) - -* Partial aliasing. - call trypart (2, 3, 5) - call trypart (2, 1, 5) - call trypart (2, 5, 3) - call trypart (2, 5, 1) - - end - - subroutine tryfull (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - double complex expect - integer pwr - integer out, in1, in2 - - double precision array(6) - double complex carray(3) - equivalence (carray(1), array(1)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 1) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = (xout + 1) / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carray(out) = + carray(in1) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carray(out) = - carray(in1) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carray(out) = carray(in1) + carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carray(out) = carray(in1) - carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carray(out) = carray(in1) * carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carray(out) = carray(in1) ** 2 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carray(out) = carray(in1) ** 3 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2-1) = abs (carray(in1)) - array(out*2) = 0 - call check (expect, carray(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carray(out) = cos (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carray(out) = exp (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carray(out) = log (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carray(out) = sin (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carray(out) = sqrt (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carray(out) = conjg (carray(in1)) - call check (expect, carray(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carray(out) = carray(in1) ** pwr - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carray(out) = carray(in1) / carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carray(out) = carray(in1) ** carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carray(out) = carray(in1) ** .2 - call check (expect, carray(out)) - - end - - subroutine trypart (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - double complex expect - integer pwr - integer out, in1, in2 - - double precision array(6) - double complex carray(3), carrayp(2) - equivalence (carray(1), array(1)) - equivalence (carrayp(1), array(2)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 0) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = xout / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carrayp(out) = + carray(in1) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carrayp(out) = - carray(in1) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carrayp(out) = carray(in1) + carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carrayp(out) = carray(in1) - carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carrayp(out) = carray(in1) * carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carrayp(out) = carray(in1) ** 2 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carrayp(out) = carray(in1) ** 3 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2) = abs (carray(in1)) - array(out*2+1) = 0 - call check (expect, carrayp(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carrayp(out) = cos (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carrayp(out) = exp (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carrayp(out) = log (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carrayp(out) = sin (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carrayp(out) = sqrt (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carrayp(out) = conjg (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carrayp(out) = carray(in1) ** pwr - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carrayp(out) = carray(in1) / carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carrayp(out) = carray(in1) ** carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carrayp(out) = carray(in1) ** .2 - call check (expect, carrayp(out)) - - end - - subroutine prepare1 (in) - implicit none - double complex in - - in = (3.2d0, 4.2d0) - - end - - subroutine prepare1i (in, i) - implicit none - double complex in - integer i - - in = (2.3d0, 2.5d0) - i = 4 - - end - - subroutine prepare2 (in1, in2) - implicit none - double complex in1, in2 - - in1 = (1.3d0, 2.4d0) - in2 = (3.5d0, 7.1d0) - - end - - subroutine check (expect, got) - implicit none - double complex expect, got - - if (dimag(expect) .ne. dimag(got)) call abort - if (dble(expect) .ne. dble(got)) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990419-1.f b/gcc/testsuite/g77.f-torture/execute/19990419-1.f deleted file mode 100644 index 7449bac2b95..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990419-1.f +++ /dev/null @@ -1,21 +0,0 @@ -* Test DO WHILE, to make sure it fully reevaluates its expression. -* Belongs in execute/. - common /x/ ival - j = 0 - do while (i() .eq. 1) - j = j + 1 - if (j .gt. 5) call abort - end do - if (j .ne. 4) call abort - if (ival .ne. 5) call abort - end - function i() - common /x/ ival - ival = ival + 1 - i = 10 - if (ival .lt. 5) i = 1 - end - block data - common /x/ ival - data ival/0/ - end diff --git a/gcc/testsuite/g77.f-torture/execute/970625-2.f b/gcc/testsuite/g77.f-torture/execute/970625-2.f deleted file mode 100644 index 3ef6f46cb79..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970625-2.f +++ /dev/null @@ -1,84 +0,0 @@ -* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST) -* MIME-Version: 1.0 -* From: R.Hooft@EuroMail.com (Rob Hooft) -* To: g77-alpha@gnu.ai.mit.edu -* Subject: Re: testing 970624. -* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu> -* References: <199706251018.MAA21538@nu> -* <199706251027.GAA07892@churchy.gnu.ai.mit.edu> -* X-Mailer: VM 6.30 under Emacs 19.34.1 -* Content-Type: text/plain; charset=US-ASCII -* -* >>>>> "CB" == Craig Burley <burley@gnu.ai.mit.edu> writes: -* -* CB> but OTOH I'd like to see more problems like this on other -* CB> applications, and especially other systems -* -* How about this one: An application that prints "112." on all -* compilers/platforms I have tested, except with the new g77 on ALPHA (I -* don't have the new g77 on any other platform here to test)? -* -* Application Appended. Source code courtesy of my boss..... -* Disclaimer: I do not know the right answer, or even whether there is a -* single right answer..... -* -* Regards, -* -- -* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ == -* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/ -* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ==== -* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! ============= -* -* nu[152]for% cat humor.f - PROGRAM SUBROUTINE - LOGICAL ELSE IF - INTEGER REAL, GO TO PROGRAM, WHILE - REAL FORMAT(2) - DATA IF,REAL,END DO,WHILE,FORMAT(2),I2/2,6,7,1,112.,1/ - DO THEN=1, END DO, WHILE - CALL = END DO - IF - PROGRAM = THEN - IF - ELSE IF = THEN .GT. IF - IF (THEN.GT.REAL) THEN - CALL FUNCTION PROGRAM (ELSE IF, GO TO PROGRAM, THEN) - ELSE IF (ELSE IF) THEN - REAL = THEN + END DO - END IF - END DO - 10 FORMAT(I2/I2) = WHILE*REAL*THEN - IF (FORMAT(I2) .NE. FORMAT(I2+I2)) CALL ABORT - END ! DO - SUBROUTINE FUNCTION PROGRAM (REAL,INTEGER, LOGICAL) - LOGICAL REAL - REAL LOGICAL - INTEGER INTEGER, STOP, RETURN, GO TO - ASSIGN 9 TO STOP - ASSIGN = 9 + LOGICAL - ASSIGN 7 TO RETURN - ASSIGN 9 TO GO TO - GO TO = 5 - STOP = 8 - IF (.NOT.REAL) GOTO STOP - IF (LOGICAL.GT.INTEGER) THEN - IF = LOGICAL +5 - IF (LOGICAL.EQ.5) ASSIGN 5 TO IF - INTEGER=IF - ELSE - IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO - ELSE = GO TO - END IF = ELSE + GO TO - IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN - END IF - 5 CONTINUE - 7 LOGICAL=LOGICAL+STOP - 9 RETURN - END ! IF -* nu[153]for% f77 humor.f -* nu[154]for% ./a.out -* 112.0000 -* nu[155]for% f90 humor.f -* nu[156]for% ./a.out -* 112.0000 -* nu[157]for% g77 humor.f -* nu[158]for% ./a.out -* 40. diff --git a/gcc/testsuite/g77.f-torture/execute/970816-3.f b/gcc/testsuite/g77.f-torture/execute/970816-3.f deleted file mode 100644 index 6398600f059..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970816-3.f +++ /dev/null @@ -1,20 +0,0 @@ -* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) -* From: Claus Denk <denk@cica.es> -* To: g77-alpha@gnu.ai.mit.edu -* Subject: 970811 report - segfault bug on alpha still there -*[...] -* Now, the bug that I reported some weeks ago is still there, I'll post -* the test program again: -* - PROGRAM TEST -C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with -C NSTART=1 on the second write. - PARAMETER (NSTART=1,NADD=NSTART+1) - REAL AB(NSTART:NSTART) - AB(NSTART)=1.0 - I=1 - J=2 - IND=I-J+NADD - write(*,*) AB(IND) - write(*,*) AB(I-J+NADD) - END diff --git a/gcc/testsuite/g77.f-torture/execute/971102-1.f b/gcc/testsuite/g77.f-torture/execute/971102-1.f deleted file mode 100644 index 6b0c2f3b3a9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/971102-1.f +++ /dev/null @@ -1,11 +0,0 @@ - i=3 - j=0 - do i=i,5 - j = j+i - end do - do i=3,i - j = j+i - end do - if (i.ne.7) call abort() - print *, i,j - end diff --git a/gcc/testsuite/g77.f-torture/execute/980520-1.f b/gcc/testsuite/g77.f-torture/execute/980520-1.f deleted file mode 100644 index 6d05c6767fd..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980520-1.f +++ /dev/null @@ -1,6 +0,0 @@ -c Produced a link error through not eliminating the unused statement -c function after 1998-05-15 change to gcc/toplev.c. It's in -c `execute' since it needs to link. -c Fixed by 1998-05-23 change to f/com.c. - values(i,j) = val((i-1)*n+j) - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-0.f b/gcc/testsuite/g77.f-torture/execute/980628-0.f deleted file mode 100644 index c36b1efc052..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-0.f +++ /dev/null @@ -1,61 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1(2), d1) - equivalence (r2(2), d2) - equivalence (r3(2), d3) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-1.f b/gcc/testsuite/g77.f-torture/execute/980628-1.f deleted file mode 100644 index 6ab0a0a81a8..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-1.f +++ /dev/null @@ -1,62 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1(2), d1) - equivalence (r2(2), d2) - equivalence (r3(2), d3) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-10.f b/gcc/testsuite/g77.f-torture/execute/980628-10.f deleted file mode 100644 index 427f635add9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-10.f +++ /dev/null @@ -1,57 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (r1, c1(2)) - equivalence (r2, c2(2)) - equivalence (r3, c3(2)) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-2.f b/gcc/testsuite/g77.f-torture/execute/980628-2.f deleted file mode 100644 index a140e7db611..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-2.f +++ /dev/null @@ -1,55 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (c1(2), r1) - equivalence (c2(2), r2) - equivalence (c3(2), r3) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-3.f b/gcc/testsuite/g77.f-torture/execute/980628-3.f deleted file mode 100644 index 47e6ea57301..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-3.f +++ /dev/null @@ -1,56 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (c1(2), r1) - equivalence (c2(2), r2) - equivalence (c3(2), r3) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-4.f b/gcc/testsuite/g77.f-torture/execute/980628-4.f deleted file mode 100644 index 40bd6e6df51..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-4.f +++ /dev/null @@ -1,27 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - real r - double precision d - common /cmn/ r, d - - if (r .ne. 1.) call abort - if (d .ne. 10.) call abort - - end - - block data init - implicit none - - real r - double precision d - common /cmn/ r, d - - data r/1./, d/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-5.f b/gcc/testsuite/g77.f-torture/execute/980628-5.f deleted file mode 100644 index 14f39e3c51e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-5.f +++ /dev/null @@ -1,27 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - character c - double precision d - common /cmn/ c, d - - if (c .ne. '1') call abort - if (d .ne. 10.) call abort - - end - - block data init - implicit none - - character c - double precision d - common /cmn/ c, d - - data c/'1'/, d/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-6.f b/gcc/testsuite/g77.f-torture/execute/980628-6.f deleted file mode 100644 index c5ade65ed39..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-6.f +++ /dev/null @@ -1,26 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - character c - double precision d(100) - common /cmn/ c, d - - if (d(80) .ne. 10.) call abort - - end - - block data init - implicit none - - character c - double precision d(100) - common /cmn/ c, d - - data d(80)/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-7.f b/gcc/testsuite/g77.f-torture/execute/980628-7.f deleted file mode 100644 index c81ba31fc26..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-7.f +++ /dev/null @@ -1,62 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (d2, r2(2)) - equivalence (d3, r3(2)) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-8.f b/gcc/testsuite/g77.f-torture/execute/980628-8.f deleted file mode 100644 index 8940d009954..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-8.f +++ /dev/null @@ -1,63 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (d2, r2(2)) - equivalence (d3, r3(2)) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-9.f b/gcc/testsuite/g77.f-torture/execute/980628-9.f deleted file mode 100644 index 54e6552d628..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-9.f +++ /dev/null @@ -1,56 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (r1, c1(2)) - equivalence (r2, c2(2)) - equivalence (r3, c3(2)) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980701-0.f b/gcc/testsuite/g77.f-torture/execute/980701-0.f deleted file mode 100644 index a3ddd55473a..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-0.f +++ /dev/null @@ -1,72 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1, s1(2)) - equivalence (d1, r1(2)) - equivalence (r2, s2(2)) - equivalence (d2, r2(2)) - equivalence (r3, s3(2)) - equivalence (d3, r3(2)) - - s1(1) = 1. - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - s2(1) = 2. - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - s3(1) = 3. - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - - end - - subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (s1(1) .ne. 1.) call abort - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (s2(1) .ne. 2.) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (s3(1) .ne. 3.) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980701-1.f b/gcc/testsuite/g77.f-torture/execute/980701-1.f deleted file mode 100644 index fba78564572..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-1.f +++ /dev/null @@ -1,72 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (r1, s1(2)) - equivalence (d2, r2(2)) - equivalence (r2, s2(2)) - equivalence (d3, r3(2)) - equivalence (r3, s3(2)) - - s1(1) = 1. - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - s2(1) = 2. - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - s3(1) = 3. - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - - end - - subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (s1(1) .ne. 1.) call abort - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (s2(1) .ne. 2.) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (s3(1) .ne. 3.) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/alpha2.f b/gcc/testsuite/g77.f-torture/execute/alpha2.f deleted file mode 100644 index d7b9d39da4b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/alpha2.f +++ /dev/null @@ -1,19 +0,0 @@ -c This was originally a compile test. - 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 7./ -C Data values were once mis-compiled on (OSF/1 ?) Alpha with -O2 -c such that, for instance, `7.' appeared as `4.' in the assembler -c output. - call test(a(9), 7) - END - subroutine test(r, i) - double precision r - if (nint(r)/=i) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/auto0.f b/gcc/testsuite/g77.f-torture/execute/auto0.f deleted file mode 100644 index 4b6b2f51a8e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto0.f +++ /dev/null @@ -1,80 +0,0 @@ -* Test automatic arrays. - program auto0 - implicit none - integer i - integer j0(40) - integer j1(40) - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data j0/40*3/ - data j1/40*4/ - - i = 40 - call a1 (j0, j1, i) - - do i = 1, 40 - if (j0(i) .ne. 4) call abort - if (j1(i) .ne. 3) call abort - if (jc0(i) .ne. 6) call abort - if (jc1(i) .ne. 5) call abort - end do - - end - - block data jc - implicit none - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data jc0/40*5/ - data jc1/40*6/ - - end - - subroutine a1 (j0, j1, n) - implicit none - integer j0(40), j1(40), n - integer k0(n), k1(n) - integer i - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - do i = 1, 40 - j0(i) = j1(i) - j0(i) - jc0(i) = jc1(i) - jc0(i) - end do - - n = -1 - - do i = 1, 40 - k0(i) = n - k1(i) = n - end do - - do i = 1, 40 - j1(i) = j1(i) + k0(i) * j0(i) - jc1(i) = jc1(i) + k1(i) * jc0(i) - end do - - n = 500 - - do i = 1, 40 - if (k0(i) .ne. -1) call abort - k0(i) = n - if (k1(i) .ne. -1) call abort - k1(i) = n - end do - - do i = 1, 40 - j0(i) = j1(i) + j0(i) - jc0(i) = jc1(i) + jc0(i) - end do - - end diff --git a/gcc/testsuite/g77.f-torture/execute/auto1.f b/gcc/testsuite/g77.f-torture/execute/auto1.f deleted file mode 100644 index ab9044ceca5..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto1.f +++ /dev/null @@ -1,88 +0,0 @@ -* Test automatic arrays. - program auto1 - implicit none - integer i - integer j0(40) - integer j1(40) - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data j0/40*3/ - data j1/40*4/ - - i = 40 - call a1 (j0, j1, i) - - do i = 1, 40 - if (j0(i) .ne. 4) call abort - if (j1(i) .ne. 3) call abort - if (jc0(i) .ne. 6) call abort - if (jc1(i) .ne. 5) call abort - end do - - end - - block data jc - implicit none - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data jc0/40*5/ - data jc1/40*6/ - - end - - subroutine a1 (j0, j1, n) - implicit none - integer j0(40), j1(40), n - integer k0(n,3,2), k1(n,3,2) - integer i,j,k - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - do i = 1, 40 - j0(i) = j1(i) - j0(i) - jc0(i) = jc1(i) - jc0(i) - end do - - n = -1 - - do k = 1, 2 - do j = 1, 3 - do i = 1, 40 - k0(i, j, k) = n - k1(i, j, k) = n - end do - end do - end do - - do i = 1, 40 - j1(i) = j1(i) + k0(i, 3, 2) * j0(i) - jc1(i) = jc1(i) + k1(i, 1, 1) * jc0(i) - end do - - n = 500 - - do k = 1, 2 - do j = 1, 3 - do i = 1, 40 - if (k0(i, j, k) .ne. -1) call abort - k0(i, j, k) = n - if (k1(i, j, k) .ne. -1) call abort - k1(i, j, k) = n - end do - end do - end do - - do i = 1, 40 - j0(i) = j1(i) + j0(i) - jc0(i) = jc1(i) + jc0(i) - end do - - end diff --git a/gcc/testsuite/g77.f-torture/execute/cabs.f b/gcc/testsuite/g77.f-torture/execute/cabs.f deleted file mode 100644 index 61fd263620b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cabs.f +++ /dev/null @@ -1,14 +0,0 @@ - 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 abort - - z1 = dcmplx(3.d0,4.d0) - r1 = zabs(z1) - if (r1 .ne. 5.d0) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/claus.f b/gcc/testsuite/g77.f-torture/execute/claus.f deleted file mode 100644 index bccef7f4090..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/claus.f +++ /dev/null @@ -1,13 +0,0 @@ - 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 abort - if (ab(ind) /= 1) call abort - if (k-n+2 /= 1) call abort - if (ab(k-n+2) /= 1) call abort - END diff --git a/gcc/testsuite/g77.f-torture/execute/complex_1.f b/gcc/testsuite/g77.f-torture/execute/complex_1.f deleted file mode 100644 index 77da6359f72..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/complex_1.f +++ /dev/null @@ -1,18 +0,0 @@ - program complex_1 - complex z0, z1, z2 - - z0 = cmplx(0.,.5) - z1 = 1./z0 - if (z1 .ne. cmplx(0.,-2)) call abort - - z0 = 10.*z0 - if (z0 .ne. cmplx(0.,5.)) call abort - - z2 = cmplx(1.,2.) - z1 = z0/z2 - if (z1 .ne. cmplx(2.,1.)) call abort - - z1 = z0*z2 - if (z1 .ne. cmplx(-10.,5.)) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/cpp.F b/gcc/testsuite/g77.f-torture/execute/cpp.F deleted file mode 100644 index fc9386b5c92..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cpp.F +++ /dev/null @@ -1,5 +0,0 @@ -! Some versions of cpp will delete "//'World' as a C++ comment. - character*40 title - title = 'Hello '//'World' - if (title .ne. 'Hello World') call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/dcomplex.f b/gcc/testsuite/g77.f-torture/execute/dcomplex.f deleted file mode 100644 index a46f03aabef..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dcomplex.f +++ /dev/null @@ -1,18 +0,0 @@ - program foo - complex*16 z0, z1, z2 - - z0 = dcmplx(0.,.5) - z1 = 1./z0 - if (z1 .ne. dcmplx(0.,-2)) call abort - - z0 = 10.*z0 - if (z0 .ne. dcmplx(0.,5.)) call abort - - z2 = cmplx(1.,2.) - z1 = z0/z2 - if (z1 .ne. dcmplx(2.,1.)) call abort - - z1 = z0*z2 - if (z1 .ne. dcmplx(-10.,5.)) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/dnrm2.f b/gcc/testsuite/g77.f-torture/execute/dnrm2.f deleted file mode 100644 index c69608786b9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dnrm2.f +++ /dev/null @@ -1,74 +0,0 @@ -CCC g77 0.5.21 `Actual Bugs': -CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is -CCC specified compiling, for example, an old version of the `DNRM2' -CCC routine. The x87 coprocessor stack is being somewhat mismanaged -CCC in cases where assigned `GOTO' and `ASSIGN' are involved. -CCC -CCC Version 0.5.21 of `g77' contains an initial effort to fix the -CCC problem, but this effort is incomplete, and a more complete fix is -CCC planned for the next release. - -C Currently this test fails with (at least) `-O2 -funroll-loops' on -C i586-unknown-linux-gnulibc1. - -C (This is actually an obsolete version of dnrm2 -- consult the -c current Netlib BLAS.) - - integer i - double precision a(1:100), dnrm2 - do i=1,100 - a(i)=0.D0 - enddo - if (dnrm2(100,a,1) .ne. 0.0) call abort - end - - double precision function dnrm2 ( n, dx, incx) - integer i, incx, ix, j, n, next - double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one - data zero, one /0.0d0, 1.0d0/ - data cutlo, cuthi / 8.232d-11, 1.304d19 / - j = 0 - if(n .gt. 0 .and. incx.gt.0) go to 10 - dnrm2 = zero - go to 300 - 10 assign 30 to next - sum = zero - i = 1 - ix = 1 - 20 go to next,(30, 50, 70, 110) - 30 if( dabs(dx(i)) .gt. cutlo) go to 85 - assign 50 to next - xmax = zero - 50 if( dx(i) .eq. zero) go to 200 - if( dabs(dx(i)) .gt. cutlo) go to 85 - assign 70 to next - go to 105 - 100 continue - ix = j - assign 110 to next - sum = (sum / dx(i)) / dx(i) - 105 xmax = dabs(dx(i)) - go to 115 - 70 if( dabs(dx(i)) .gt. cutlo ) go to 75 - 110 if( dabs(dx(i)) .le. xmax ) go to 115 - sum = one + sum * (xmax / dx(i))**2 - xmax = dabs(dx(i)) - go to 200 - 115 sum = sum + (dx(i)/xmax)**2 - go to 200 - 75 sum = (sum * xmax) * xmax - 85 hitest = cuthi/float( n ) - do 95 j = ix,n - if(dabs(dx(i)) .ge. hitest) go to 100 - sum = sum + dx(i)**2 - i = i + incx - 95 continue - dnrm2 = dsqrt( sum ) - go to 300 - 200 continue - ix = ix + 1 - i = i + incx - if( ix .le. n ) go to 20 - dnrm2 = xmax * dsqrt(sum) - 300 continue - end diff --git a/gcc/testsuite/g77.f-torture/execute/erfc.f b/gcc/testsuite/g77.f-torture/execute/erfc.f deleted file mode 100644 index e5e0412f587..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/erfc.f +++ /dev/null @@ -1,38 +0,0 @@ -c============================================== test.f - real x, y - real*8 x1, y1 - x=0. - y = erfc(x) - if (y .ne. 1.) call abort - - x=1.1 - y = erfc(x) - if (abs(y - .1197949) .ge. 1.e-6) call abort - -* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas. - x=8 - y = erfc(x) - if (y .gt. 1.2e-28) call abort - - x1=0. - y1 = erfc(x1) - if (y1 .ne. 1.) call abort - - x1=1.1d0 - y1 = erfc(x1) - if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort - - x1=10 - y1 = erfc(x1) - if (y1 .gt. 1.5d-44) call abort - 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 diff --git a/gcc/testsuite/g77.f-torture/execute/execute.exp b/gcc/testsuite/g77.f-torture/execute/execute.exp deleted file mode 100644 index 31608eed4f9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/execute.exp +++ /dev/null @@ -1,55 +0,0 @@ -# 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 -} diff --git a/gcc/testsuite/g77.f-torture/execute/exp.f b/gcc/testsuite/g77.f-torture/execute/exp.f deleted file mode 100644 index de388f181b0..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/exp.f +++ /dev/null @@ -1,3 +0,0 @@ - a = 2**-2*1. - if (a .ne. .25) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/io0.f b/gcc/testsuite/g77.f-torture/execute/io0.f deleted file mode 100644 index c56c9919077..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io0.f +++ /dev/null @@ -1,46 +0,0 @@ -* Preliminary tests for a few things in the i/o library. -* Thrown together by Dave Love not from specific bug reports -- -* other ideas welcome. - - character *(*) fmt - parameter (fmt='(1x,i3,f5.1)') -* Scratch file makes sure we can use one and avoids dealing with -* explicit i/o in the testsuite. - open(90, status='scratch') ! try a biggish unit number - write(90, '()') ! extra record for interest -* Formatted i/o can go wild (endless loop AFAIR) if we're wrongly -* assuming an ANSI sprintf. - write(90, fmt) 123, 123.0 - backspace 90 ! backspace problems reported on DOSish systems - read(90, fmt) i, r - endfile 90 - if (i/=123 .or. nint(r)/=123) call abort - rewind 90 ! make sure we can rewind too - read(90, '()') - read(90, fmt) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) -* Make sure we can do unformatted i/o OK. This might be -* problematic on DOS-like systems if we've done an fopen in text -* mode, not binary. - open(90, status='scratch', access='direct', form='unformatted', - + recl=8) - write(90, rec=1) 123, 123.0 - read(90, rec=1) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) - open(90, status='scratch', form='unformatted') - write(90) 123, 123.0 - backspace 90 - read(90) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) -* Fails at 1998-09-01 on spurious recursive i/o check (fixed by -* 1998-09-06 libI77 change): - open(90, status='scratch', form='formatted', recl=16, - + access='direct') - write(90, '(i8,f8.1)',rec=1) 123, 123.0 - read(90, '(i8,f8.1)', rec=1) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) - end diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f deleted file mode 100644 index c5242446a49..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.f +++ /dev/null @@ -1,10 +0,0 @@ -* Fixed by 1998-09-28 libI77/open.c change. - open(90,status='scratch') - write(90, '(1X, I1 / 1X, I1)') 1, 2 - rewind 90 - write(90, '(1X, I1)') 1 - rewind 90 ! implicit ENDFILE expected - read(90, *) i - read(90, *, end=10) j - call abort() - 10 end diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f deleted file mode 100644 index 032fa41f899..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/labug1.f +++ /dev/null @@ -1,57 +0,0 @@ - PROGRAM LABUG1 - -* This program core dumps on mips-sgi-irix6.2 when compiled -* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots -* with -O2 -* -* Originally derived from LAPACK test suite. -* Almost any change allows it to run. -* -* David Billinghurst, (David.Billinghurst@riotinto.com.au) -* 25 November 1998 -* -* .. Parameters .. - INTEGER LDA, LDE - PARAMETER ( LDA = 2500, LDE = 50 ) - COMPLEX CZERO - PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) - - INTEGER I, J, M, N - REAL V - COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE) - COMPLEX Z - - N=2 - M=1 -* - do i = 1, m - do j = 1, n - e(i,j) = czero - f(i,j) = czero - end do - end do -* - DO J = 1, N - DO I = 1, M - V = ABS( E(I,J) - F(I,J) ) - END DO - END DO - - CALL SUB2(M,Z) - - END - - subroutine SUB2(I,A) - integer i - complex a - end - - - - - - - - - - diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f deleted file mode 100644 index 0af5b1b0b3f..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/large_vec.f +++ /dev/null @@ -1,3 +0,0 @@ - parameter (nmax=165000) - double precision x(nmax) - end diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f deleted file mode 100644 index 74e42750d55..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/le.f +++ /dev/null @@ -1,29 +0,0 @@ - program fool - - real foo - integer n - logical t - - foo = 2.5 - n = 5 - - t = (n > foo) - if (t .neqv. .true.) call abort - t = (n >= foo) - if (t .neqv. .true.) call abort - t = (n < foo) - if (t .neqv. .false.) call abort - t = (n <= 5) - if (t .neqv. .true.) call abort - t = (n >= 5 ) - if (t .neqv. .true.) call abort - t = (n == 5) - if (t .neqv. .true.) call abort - t = (n /= 5) - if (t .neqv. .false.) call abort - t = (n /= foo) - if (t .neqv. .true.) call abort - t = (n == foo) - if (t .neqv. .false.) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f deleted file mode 100644 index 89ae273891c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/short.f +++ /dev/null @@ -1,57 +0,0 @@ - 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 abort - enddo - if (yzin1(0) .ne. -1371.) call abort - if (yzin1(1) .ne. -685.5) call abort - if (yzin1(2) .ne. 0.) call abort - - return - end - diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f deleted file mode 100644 index 198d48b460c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.f +++ /dev/null @@ -1,421 +0,0 @@ -*** Some random stuff for testing libU77. Should be done better. It's -* hard to test things where you can't guarantee the result. Have a -* good squint at what it prints, though detected errors will cause -* starred messages. -* -* Currently not tested: -* ALARM -* CHDIR (func) -* CHMOD (func) -* FGET (func/subr) -* FGETC (func) -* FPUT (func/subr) -* FPUTC (func) -* FSTAT (subr) -* GETCWD (subr) -* HOSTNM (subr) -* IRAND -* KILL -* LINK (func) -* LSTAT (subr) -* RENAME (func/subr) -* SIGNAL (subr) -* SRAND -* STAT (subr) -* SYMLNK (func/subr) -* UMASK (func) -* UNLINK (func) -* -* NOTE! This is the testsuite version, so it should compile and -* execute on all targets, and either run to completion (with -* success status) or fail (by calling abort). The *other* version, -* which is a bit more interactive and tests a couple of things -* this one cannot, should be generally the same, and is in -* libf2c/libU77/u77-test.f. Please keep it up-to-date. - - implicit none - - external hostnm -* intrinsic hostnm - integer hostnm - - integer i, j, k, ltarray (9), idat (3), count, rate, count_max, - + pid, mask - real tarray1(2), tarray2(2), r1, r2 - double precision d1 - integer(kind=2) bigi - logical issum - intrinsic getpid, getuid, getgid, ierrno, gerror, time8, - + fnum, isatty, getarg, access, unlink, fstat, iargc, - + stat, lstat, getcwd, gmtime, etime, chmod, itime, date, - + chdir, fgetc, fputc, system_clock, second, idate, secnds, - + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8, - + cpu_time, dtime, ftell, abort - external lenstr, ctrlc - integer lenstr - logical l - character gerr*80, c*1 - character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8, - + ttime*10, zone*5, ctim2*25 - integer fstatb (13), statb (13) - integer *2 i2zero - integer values(8) - integer(kind=7) sigret - - i = time () - ctim = ctime (i) - WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim)) - write (6,'(A,I3,'', '',I3)') - + ' Logical units 5 and 6 correspond (FNUM) to' - + // ' Unix i/o units ', fnum(5), fnum(6) - if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then - print *, 'LNBLNK or LEN_TRIM failed' - call abort - end if - - bigi = time8 () - - call ctime (i, ctim2) - if (ctim .ne. ctim2) then - write (6, *) '*** CALL CTIME disagrees with CTIME(): ', - + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim)) - call doabort - end if - - j = time () - if (i .gt. bigi .or. bigi .gt. j) then - write (6, *) '*** TIME/TIME8/TIME sequence failures: ', - + i, bigi, j - call doabort - end if - - print *, 'Command-line arguments: ', iargc () - do i = 0, iargc () - call getarg (i, line) - print *, 'Arg ', i, ' is: ', line(:lenstr (line)) - end do - - l= isatty(6) - line2 = ttynam(6) - if (l) then - line = 'and 6 is a tty device (ISATTY) named '//line2 - else - line = 'and 6 isn''t a tty device (ISATTY)' - end if - write (6,'(1X,A)') line(:lenstr(line)) - call ttynam (6, line) - if (line .ne. line2) then - print *, '*** CALL TTYNAM disagrees with TTYNAM: ', - + line(:lenstr (line)) - call doabort - end if - -* regression test for compiler crash fixed by JCB 1998-08-04 com.c - sigret = signal(2, ctrlc) - - pid = getpid() - WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid - WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID () - WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID () - WRITE (6, *) 'If you have the `id'' program, the following call' - write (6, *) 'of SYSTEM should agree with the above:' - call flush(6) - CALL SYSTEM ('echo " " `id`') - call flush - - lognam = 'blahblahblah' - call getlog (lognam) - write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam)) - - wd = 'blahblahblah' - call getenv ('LOGNAME', wd) - write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd)) - - call umask(0, mask) - write(6,*) 'UMASK returns', mask - call umask(mask) - - ctim = fdate() - write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim)) - call fdate (ctim) - write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim)) - - j=time() - call ltime (j, ltarray) - write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray - call gmtime (j, ltarray) - write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray - - call system_clock(count) ! omitting optional args - call system_clock(count, rate, count_max) - write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max - - call date_and_time(ddate) ! omitting optional args - call date_and_time(ddate, ttime, zone, values) - write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ', - + zone, ' ', values - - write (6,*) 'Sleeping for 1 second (SLEEP) ...' - call sleep (1) - -c consistency-check etime vs. dtime for first call - r1 = etime (tarray1) - r2 = dtime (tarray2) - if (abs (r1-r2).gt.1.0) then - write (6,*) - + 'Results of ETIME and DTIME differ by more than a second:', - + r1, r2 - call doabort - end if - if (.not. issum (r1, tarray1(1), tarray1(2))) then - write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) - call doabort - end if - if (.not. issum (r2, tarray2(1), tarray2(2))) then - write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) - call doabort - end if - write (6, '(A,3F10.3)') - + ' Elapsed total, user, system time (ETIME): ', - + r1, tarray1 - -c now try to get times to change enough to see in etime/dtime - write (6,*) 'Looping until clock ticks at least once...' - do i = 1,1000 - do j = 1,1000 - end do - call dtime (tarray2, r2) - if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit - end do - call etime (tarray1, r1) - if (.not. issum (r1, tarray1(1), tarray1(2))) then - write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) - call doabort - end if - if (.not. issum (r2, tarray2(1), tarray2(2))) then - write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) - call doabort - end if - write (6, '(A,3F10.3)') - + ' Differences in total, user, system time (DTIME): ', - + r2, tarray2 - write (6, '(A,3F10.3)') - + ' Elapsed total, user, system time (ETIME): ', - + r1, tarray1 - write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)' - - call idate (i,j,k) - call idate (idat) - write (6,*) 'IDATE (date,month,year): ',idat - print *, '... and the VXT version (month,date,year): ', i,j,k - if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then - print *, '*** VXT and U77 versions don''t agree' - call doabort - end if - - call date (ctim) - write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim)) - - call itime (idat) - write (6,*) 'ITIME (hour,minutes,seconds): ', idat - - call time(line(:8)) - print *, 'TIME: ', line(:8) - - write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) - - write (6,*) 'SECOND returns: ', second() - call dumdum(r1) - call second(r1) - write (6,*) 'CALL SECOND returns: ', r1 - -* compiler crash fixed by 1998-10-01 com.c change - if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then - write (6,*) '*** rand(0) error' - call doabort() - end if - - i = getcwd(wd) - if (i.ne.0) then - call perror ('*** getcwd') - call doabort - else - write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' - end if - call chdir ('.',i) - if (i.ne.0) then - write (6,*) '***CHDIR to ".": ', i - call doabort - end if - - i=hostnm(wd) - if(i.ne.0) then - call perror ('*** hostnm') - call doabort - else - write (6,*) 'Host name is ', wd(:lenstr(wd)) - end if - - i = access('/dev/null ', 'rw') - if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i - write (6,*) 'Creating file "foo" for testing...' - open (3,file='foo',status='UNKNOWN') - rewind 3 - call fputc(3, 'c',i) - call fputc(3, 'd',j) - if (i+j.ne.0) write(6,*) '***FPUTC: ', i -C why is it necessary to reopen? (who wrote this?) -C the better to test with, my dear! (-- burley) - close(3) - open(3,file='foo',status='old') - call fseek(3,0,0,*10) - go to 20 - 10 write(6,*) '***FSEEK failed' - call doabort - 20 call fgetc(3, c,i) - if (i.ne.0) then - write(6,*) '***FGETC: ', i - call doabort - end if - if (c.ne.'c') then - write(6,*) '***FGETC read the wrong thing: ', ichar(c) - call doabort - end if - i= ftell(3) - if (i.ne.1) then - write(6,*) '***FTELL offset: ', i - call doabort - end if - call ftell(3, i) - if (i.ne.1) then - write(6,*) '***CALL FTELL offset: ', i - call doabort - end if - call chmod ('foo', 'a+w',i) - if (i.ne.0) then - write (6,*) '***CHMOD of "foo": ', i - call doabort - end if - i = fstat (3, fstatb) - if (i.ne.0) then - write (6,*) '***FSTAT of "foo": ', i - call doabort - end if - i = stat ('foo', statb) - if (i.ne.0) then - write (6,*) '***STAT of "foo": ', i - call doabort - end if - write (6,*) ' with stat array ', statb - if (statb(6) .ne. getgid ()) then - write (6,*) 'Note: FSTAT gid wrong (happens on some systems).' - end if - if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then - write (6,*) '*** FSTAT uid or nlink is wrong' - call doabort - end if - do i=1,13 - if (fstatb (i) .ne. statb (i)) then - write (6,*) '*** FSTAT and STAT don''t agree on '// ' - + array element ', i, ' value ', fstatb (i), statb (i) - call abort - end if - end do - i = lstat ('foo', fstatb) - do i=1,13 - if (fstatb (i) .ne. statb (i)) then - write (6,*) '*** LSTAT and STAT don''t agree on '// - + 'array element ', i, ' value ', fstatb (i), statb (i) - call abort - end if - end do - -C in case it exists already: - call unlink ('bar',i) - call link ('foo ', 'bar ',i) - if (i.ne.0) then - write (6,*) '***LINK "foo" to "bar" failed: ', i - call doabort - end if - call unlink ('foo',i) - if (i.ne.0) then - write (6,*) '***UNLINK "foo" failed: ', i - call doabort - end if - call unlink ('foo',i) - if (i.eq.0) then - write (6,*) '***UNLINK "foo" again: ', i - call doabort - end if - - call gerror (gerr) - i = ierrno() - write (6,'(A,I3,A/1X,A)') ' The current error number is: ', - + i, - + ' and the corresponding message is:', gerr(:lenstr(gerr)) - write (6,*) 'This is sent to stderr prefixed by the program name' - call getarg (0, line) - call perror (line (:lenstr (line))) - call unlink ('bar') - - print *, 'MCLOCK returns ', mclock () - print *, 'MCLOCK8 returns ', mclock8 () - - call cpu_time (d1) - print *, 'CPU_TIME returns ', d1 - -C WRITE (6,*) 'You should see exit status 1' - CALL EXIT(0) - 99 END - -* Return length of STR not including trailing blanks, but always > 0. - integer function lenstr (str) - character*(*) str - if (str.eq.' ') then - lenstr=1 - else - lenstr = lnblnk (str) - end if - end - -* Just make sure SECOND() doesn't "magically" work the second time. - subroutine dumdum(r) - r = 3.14159 - end - -* Test whether sum is approximately left+right. - logical function issum (sum, left, right) - implicit none - real sum, left, right - real mysum, delta, width - mysum = left + right - delta = abs (mysum - sum) - width = abs (left) + abs (right) - issum = (delta .le. .0001 * width) - end - -* Signal handler - subroutine ctrlc - print *, 'Got ^C' - call doabort - end - -* A problem has been noticed, so maybe abort the test. - subroutine doabort -* For this version, call the ABORT intrinsic. - intrinsic abort - call abort - end - -* Testsuite version only. -* Don't actually reference the HOSTNM intrinsic, because some targets -* need -lsocket, which we don't have a mechanism for supplying. - integer function hostnm(nm) - character*(*) nm - nm = 'not determined by this version of u77-test.f' - hostnm = 0 - end |