OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

g77.dg: Removed. 

2004-07-17  Toon Moene  <toon@moene.indiv.nluug.nl>

	* g77.dg: Removed.
	* g77.f-torture: Ditto.

From-SVN: r84865
This commit is contained in:
Toon Moene 2004-07-17 13:18:05 +02:00 committed by Toon Moene
parent 320e32f649
commit 649067c362
197 changed files with 5 additions and 11047 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2004-07-17 Toon Moene <toon@moene.indiv.nluug.nl>
* g77.dg: Removed.
* g77.f-torture: Ditto.
2004-07-17 Joseph S. Myers <jsm@polyomino.org.uk>
* gcc.dg/Wparentheses-2.c, gcc.dg/Wparentheses-3.c,

6
gcc/testsuite/g77.dg/12632.f
View File

@ -1,6 +0,0 @@
C { dg-do compile }
C { dg-options "-fbounds-check" }
INTEGER I(1)
I(2) = 0 ! { dg-error "out of defined range" "out of defined range" }
END

51
gcc/testsuite/g77.dg/20010216-1.f
View File

@ -1,51 +0,0 @@
C Test for bug in reg-stack handling conditional moves.
C Reported by Tim Prince <tprince@computer.org>
C
C { dg-do run { target "i[6789]86-*-*" } }
C { dg-options "-ffast-math -march=pentiumpro" }
double precision function foo(x, y)
implicit none
double precision x, y
double precision a, b, c, d
if (x /= y) then
if (x * y >= 0) then
a = abs(x)
b = abs(y)
c = max(a, b)
d = min(a, b)
foo = 1 - d/c
else
foo = 1
end if
else
foo = 0
end if
end
program test
implicit none
integer ntests
parameter (ntests=7)
double precision tolerance
parameter (tolerance=1.0D-6)
C Each column is a pair of values to feed to foo,
C and its expected return value.
double precision a(ntests) /1, -23, -1, 1, 9, 10, -9/
double precision b(ntests) /1, -23, 12, -12, 10, 9, -10/
double precision x(ntests) /0, 0, 1, 1, 0.1, 0.1, 0.1/
double precision foo
double precision result
integer i
do i = 1, ntests
result = foo(a(i), b(i))
if (abs(result - x(i)) > tolerance) then
print *, i, a(i), b(i), x(i), result
call abort
end if
end do
end

12
gcc/testsuite/g77.dg/7388.f
View File

@ -1,12 +0,0 @@
C { dg-do run }
C { dg-options "-fbounds-check" }
character*25 buff(0:10)
character*80 line
integer i, m1, m2
i = 1
m1 = 1
m2 = 7
buff(i) = 'tcase0a'
write(line,*) buff(i)(m1:m2)
if (line .ne. ' tcase0a') call abort
end

59
gcc/testsuite/g77.dg/bprob/bprob.exp
View File

@ -1,59 +0,0 @@
# Copyright (C) 2001, 2002 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Test the functionality of programs compiled with profile-directed block
# ordering using -fprofile-arcs followed by -fbranch-probabilities.
load_lib target-supports.exp
# Some targets don't have any implementation of __bb_init_func or are
# missing other needed machinery.
if { ![check_profiling_available "-fprofile-arcs"] } {
return
}
# The procedures in profopt.exp need these parameters.
set tool g77
set profile_option -fprofile-arcs
set feedback_option -fbranch-probabilities
set prof_ext gcda
set perf_ext tim
# Override the list defined in profopt.exp.
set PROFOPT_OPTIONS [list \
{ -g } \
{ -O0 } \
{ -O1 } \
{ -O2 } \
{ -O3 } \
{ -O3 -g } \
{ -Os } ]
if $tracelevel then {
strace $tracelevel
}
# Load support procs.
load_lib profopt.exp
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
}
profopt-execute $src
}

330
gcc/testsuite/g77.dg/bprob/g77-bprob-1.f
View File

@ -1,330 +0,0 @@
C Test profile-directed block ordering with various Fortran 77 constructs
C to catch basic regressions in the functionality.
program bprob1
implicit none
integer i,j,k,n
integer result
integer lpall, ieall, gtall
integer lpval, ieval, gtval
lpval = lpall()
ieval = ieall()
gtval = gtall()
if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
call abort
end if
end
C Pass a value through a function to thwart optimization.
integer function foo(i)
implicit none
integer i
foo = i
end
C Test various flavors of GOTO and compare results against expected values.
integer function gtall()
implicit none
integer gt1, gt2, gt3, gt4, gt5
integer gtval
gtall = 1
gtval = 0
gtval = gtval + gt1(0)
gtval = gtval + gt1(1)
if (gtval .ne. 3) then
print *,"gtall part 1: ", gtval, 3
gtall = 0
end if
gtval = 0
gtval = gtval + gt2(3)
gtval = gtval + gt2(30)
if (gtval .ne. 12) then
print *,"gtall part 2: ", gtval, 12
gtall = 0
end if
gtval = 0
gtval = gtval + gt3(0)
gtval = gtval + gt3(3)
if (gtval .ne. 48) then
print *,"gtall part 3: ", gtval, 48
gtall = 0
end if
gtval = 0
gtval = gtval + gt4(1)
gtval = gtval + gt4(2)
gtval = gtval + gt4(3)
if (gtval .ne. 14) then
print *,"gtall part 4: ", gtval, 14
gtall = 0
end if
gtval = 0
gtval = gtval + gt5(0)
gtval = gtval + gt5(-1)
gtval = gtval + gt5(5)
if (gtval .ne. 14) then
print *,"gtall part 5: ", gtval, 14
gtall = 0
end if
end
C Test simple GOTO.
integer function gt1(f)
implicit none
integer f
if (f .ne. 0) goto 100
gt1 = 1
goto 101
100 gt1 = 2
101 continue
end
C Test simple GOTO again, this time out of a DO loop.
integer function gt2(f)
implicit none
integer f
integer i
do i=1,10
if (i .eq. f) goto 100
end do
gt2 = 4
goto 101
100 gt2 = 8
101 continue
end
C Test computed GOTO.
integer function gt3(i)
implicit none
integer i
gt3 = 8
goto (101, 102, 103, 104), i
goto 105
101 gt3 = 1024
goto 105
102 gt3 = 2048
goto 105
103 gt3 = 16
goto 105
104 gt3 = 4096
goto 105
105 gt3 = gt3 * 2
end
C Test assigned GOTO.
integer function gt4(i)
implicit none
integer i
integer label
assign 101 to label
if (i .eq. 2) assign 102 to label
if (i .eq. 3) assign 103 to label
goto label, (101, 102, 103)
101 gt4 = 1
goto 104
102 gt4 = 2
goto 104
103 gt4 = 4
104 gt4 = gt4 * 2
end
C Test arithmetic IF (bundled with the GOTO variants).
integer function gt5(i)
implicit none
integer i
gt5 = 1
if (i) 101, 102, 103
101 gt5 = 2
goto 104
102 gt5 = 4
goto 104
103 gt5 = 8
104 continue
end
C Run all of the loop tests and check results against expected values.
integer function lpall()
implicit none
integer loop1, loop2
integer loopval
lpall = 1
loopval = 0
loopval = loopval + loop1(1,0)
loopval = loopval + loop1(1,2)
loopval = loopval + loop1(1,7)
if (loopval .ne. 12) then
print *,"lpall part 1: ", loopval, 12
lpall = 0
end if
loopval = 0
loopval = loopval + loop2(1,0,0,0)
loopval = loopval + loop2(1,1,0,0)
loopval = loopval + loop2(1,1,3,0)
loopval = loopval + loop2(1,1,3,1)
loopval = loopval + loop2(1,3,1,5)
loopval = loopval + loop2(1,3,7,3)
if (loopval .ne. 87) then
print *,"lpall part 2: ", loopval, 87
lpall = 0
end if
end
C Test a simple DO loop.
integer function loop1(r,n)
implicit none
integer r,n,i
loop1 = r
do i=1,n
loop1 = loop1 + 1
end do
end
C Test nested DO loops.
integer function loop2(r, l, m, n)
implicit none
integer r,l,m,n
integer i,j,k
loop2 = r
do i=1,l
do j=1,m
do k=1,n
loop2 = loop2 + 1
end do
end do
end do
end
C Test various combinations of IF-THEN-ELSE and check results against
C expected values.
integer function ieall()
implicit none
integer ie1, ie2, ie3
integer ieval
ieall = 1
ieval = 0
ieval = ieval + ie1(0,2)
ieval = ieval + ie1(0,0)
ieval = ieval + ie1(1,2)
ieval = ieval + ie1(10,2)
ieval = ieval + ie1(11,11)
if (ieval .ne. 31) then
print *,"ieall part 1: ", ieval, 31
ieall = 0
end if
ieval = 0
ieval = ieval + ie2(0)
ieval = ieval + ie2(2)
ieval = ieval + ie2(2)
ieval = ieval + ie2(2)
ieval = ieval + ie2(3)
ieval = ieval + ie2(3)
if (ieval .ne. 23) then
print *,"ieall part 2: ", ieval, 23
ieall = 0
end if
ieval = 0
ieval = ieval + ie3(11,19)
ieval = ieval + ie3(25,27)
ieval = ieval + ie3(11,22)
ieval = ieval + ie3(11,10)
ieval = ieval + ie3(21,32)
ieval = ieval + ie3(21,20)
ieval = ieval + ie3(1,2)
ieval = ieval + ie3(32,31)
ieval = ieval + ie3(3,0)
ieval = ieval + ie3(0,47)
ieval = ieval + ie3(65,65)
if (ieval .ne. 246) then
print *,"ieall part 3: ", ieval, 246
ieall = 0
end if
end
C Test IF-THEN-ELSE.
integer function ie1(i,j)
implicit none
integer i,j
integer foo
ie1 = 0
if (i .ne. 0) then
if (j .ne. 0) then
ie1 = foo(4)
else
ie1 = foo(1024)
end if
else
if (j .ne. 0) then
ie1 = foo(1)
else
ie1 = foo(2)
end if
end if
if (i .gt. j) then
ie1 = foo(ie1*2)
end if
if (i .gt. 10) then
if (j .gt. 10) then
ie1 = foo(ie1*4)
end if
end if
end
C Test a series of simple IF-THEN statements.
integer function ie2(i)
implicit none
integer i
integer foo
ie2 = 0
if (i .eq. 0) then
ie2 = foo(1)
end if
if (i .eq. 1) then
ie2 = foo(1024)
end if
if (i .eq. 2) then
ie2 = foo(2)
end if
if (i .eq. 3) then
ie2 = foo(8)
end if
if (i .eq. 4) then
ie2 = foo(2048)
end if
end
C Test nested IF statements and IF with compound expressions.
integer function ie3(i,j)
implicit none
integer i,j
integer foo
ie3 = 1
if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then
ie3 = foo(16)
end if
if (i .gt. 20) then
if (j .gt. i) then
if (j .lt. 30) then
ie3 = foo(32)
end if
end if
end if
if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then
ie3 = foo(64)
end if
end

36
gcc/testsuite/g77.dg/dg.exp
View File

@ -1,36 +0,0 @@
# Copyright (C) 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# GCC testsuite that uses the `dg.exp' driver.
# Load support procs.
load_lib g77-dg.exp
# If a testcase doesn't have special options, use these.
global DEFAULT_FFLAGS
if ![info exists DEFAULT_FFLAGS] then {
set DEFAULT_FFLAGS " -pedantic-errors"
}
# Initialize `dg'.
dg-init
# Main loop.
g77-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.f]] \
$DEFAULT_FFLAGS
# All done.
dg-finish

21
gcc/testsuite/g77.dg/f77-edit-apostrophe-out.f
View File

@ -1,21 +0,0 @@
C Test Fortran 77 apostrophe edit descriptor
C (ANSI X3.9-1978 Section 13.5.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
10 format('abcde')
20 format('and an apostrophe -''-')
30 format('''a leading apostrophe')
40 format('a trailing apostrophe''')
50 format('''and all of the above -''-''')
write(*,10) ! { dg-output "abcde(\n|\r\n|\r)" }
write(*,20) ! { dg-output "and an apostrophe -'-(\n|\r\n|\r)" }
write(*,30) ! { dg-output "'a leading apostrophe(\n|\r\n|\r)" }
write(*,40) ! { dg-output "a trailing apostrophe'(\n|\r\n|\r)" }
write(*,50) ! { dg-output "'and all of the above -'-'(\n|\r\n|\r)" }
C { dg-output "\$" }
end

9
gcc/testsuite/g77.dg/f77-edit-colon-out.f
View File

@ -1,9 +0,0 @@
C Test Fortran 77 colon edit descriptor
C (ANSI X3.9-1978 Section 13.5.5)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
write(*,'((3(I1:)))') (I,I=1,5)
end

14
gcc/testsuite/g77.dg/f77-edit-h-out.f
View File

@ -1,14 +0,0 @@
C Test Fortran 77 H edit descriptor
C (ANSI X3.9-1978 Section 13.5.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
10 format(1H1)
20 format(6H 6)
write(*,10) ! { dg-output "1(\n|\r\n|\r)" }
write(*,20) ! { dg-output " 6(\n|\r\n|\r)" }
write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\n|\r\n|\r)" }
C { dg-output "\$" }
end

22
gcc/testsuite/g77.dg/f77-edit-i-in.f
View File

@ -1,22 +0,0 @@
C Test Fortran 77 I edit descriptor for input
C (ANSI X3.9-1978 Section 13.5.9.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
integer i,j
character*10 buf
write(buf,'(A)') '1 -1'
read(buf,'(I1)') i
if ( i.ne.1 ) call abort()
read(buf,'(X,I1)') i
if ( i.ne.0 ) call abort()
read(buf,'(X,I1,X,I2)') i,j
if ( i.ne.0 .and. j.ne.-1 ) call abort()
end

26
gcc/testsuite/g77.dg/f77-edit-i-out.f
View File

@ -1,26 +0,0 @@
C Test Fortran 77 I edit descriptor for output
C (ANSI X3.9-1978 Section 13.5.9.1)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^" }
write(*,'(I1)') 1 ! { dg-output "1(\n|\r\n|\r)" }
write(*,'(I1)') -1 ! { dg-output "\\*(\n|\r\n|\r)" }
write(*,'(I2)') 2 ! { dg-output " 2(\n|\r\n|\r)" }
write(*,'(I2)') -2 ! { dg-output "-2(\n|\r\n|\r)" }
write(*,'(I3)') 3 ! { dg-output " 3(\n|\r\n|\r)" }
write(*,'(I3)') -3 ! { dg-output " -3(\n|\r\n|\r)" }
write(*,'(I2.0)') 0 ! { dg-output " (\n|\r\n|\r)" }
write(*,'(I1.1)') 4 ! { dg-output "4(\n|\r\n|\r)" }
write(*,'(I1.1)') -4 ! { dg-output "\\*(\n|\r\n|\r)" }
write(*,'(I2.1)') 5 ! { dg-output " 5(\n|\r\n|\r)" }
write(*,'(I2.1)') -5 ! { dg-output "-5(\n|\r\n|\r)" }
write(*,'(I2.2)') 6 ! { dg-output "06(\n|\r\n|\r)" }
write(*,'(I2.2)') -6 ! { dg-output "\\*\\*(\n|\r\n|\r)" }
write(*,'(I3.2)') 7 ! { dg-output " 07(\n|\r\n|\r)" }
write(*,'(I3.2)') -7 ! { dg-output "-07(\n|\r\n|\r)" }
end

20
gcc/testsuite/g77.dg/f77-edit-s-out.f
View File

@ -1,20 +0,0 @@
C Test Fortran 77 S, SS and SP edit descriptors
C (ANSI X3.9-1978 Section 13.5.6)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
10 format(SP,I3,1X,SS,I3)
20 format(SP,I3,1X,SS,I3,SP,I3)
30 format(SP,I3,1X,SS,I3,S,I3)
40 format(SP,I3)
50 format(SP,I2)
write(*,10) 10, 20 ! { dg-output "\\+10 20(\n|\r\n|\r)" }
write(*,20) 10, 20, 30 ! { dg-output "\\+10 20\\+30(\n|\r\n|\r)" }
write(*,30) 10, 20, 30 ! { dg-output "\\+10 20 30(\n|\r\n|\r)" }
write(*,40) 0 ! { dg-output " \\+0(\n|\r\n|\r)" }
C 15.5.9 - Note 5: When SP editing is in effect, the plus sign is not optional
write(*,50) 11 ! { dg-output "\\*\\*(\n|\r\n|\r)" }
C { dg-output "\$" }
end

9
gcc/testsuite/g77.dg/f77-edit-slash-out.f
View File

@ -1,9 +0,0 @@
C Test Fortran 77 colon slash descriptor
C (ANSI X3.9-1978 Section 13.5.4)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
write(*,'(3(I1)/2(I1))') (I,I=1,5)
end

31
gcc/testsuite/g77.dg/f77-edit-t-in.f
View File

@ -1,31 +0,0 @@
C Test Fortran 77 T edit descriptor for input
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
integer i,j
real a,b,c,d,e
character*32 in
in = '1234 8'
read(in,'(T3,I1)') i
if ( i.ne.3 ) call abort()
read(in,'(5X,TL4,I2)') i
if ( i.ne.23 ) call abort()
read(in,'(3X,I1,TR3,I1)') i,j
if ( i.ne.4 ) call abort()
if ( j.ne.8 ) call abort()
in = ' 1.5 -12.62 348.75 1.0E-6'
100 format(F6.0,TL6,I4,1X,I1,8X,I5,F3.0,T10,F5.0,T17,F6.0,TR2,F6.0)
read(in,100) a,i,j,k,b,c,d,e
if ( abs(a-1.5).gt.1.0e-5 ) call abort()
if ( i.ne.1 ) call abort()
if ( j.ne.5 ) call abort()
if ( k.ne.348 ) call abort()
if ( abs(b-0.75).gt.1.0e-5 ) call abort()
if ( abs(c-12.62).gt.1.0e-5 ) call abort()
if ( abs(d-348.75).gt.1.0e-4 ) call abort()
if ( abs(e-1.0e-6).gt.1.0e-11 ) call abort()
end

12
gcc/testsuite/g77.dg/f77-edit-t-out.f
View File

@ -1,12 +0,0 @@
C Test Fortran 77 T edit descriptor
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
write(*,'(I4,T8,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
write(*,'(I4,TR3,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
write(*,'(I4,5X,TL2,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" }
C ( dg-output "\$" }
end

12
gcc/testsuite/g77.dg/f77-edit-x-out.f
View File

@ -1,12 +0,0 @@
C Test Fortran 77 X descriptor
C (ANSI X3.9-1978 Section 13.5.3.2)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C ( dg-output "^" }
write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
C Section 13.5.3 explains why there are no trailing blanks
write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" }
C { dg-output "\$" }
end

7
gcc/testsuite/g77.dg/fbackslash.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -fbackslash
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fbackslash" }
if ( len('A\nB') .ne. 3 ) call abort
end

9
gcc/testsuite/g77.dg/fcase-preserve.f
View File

@ -1,9 +0,0 @@
C Test compiler flags: -fcase-preserve
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fcase-preserve" }
i = 3
I = 4
if ( i .ne. 3 ) call abort
end

15
gcc/testsuite/g77.dg/ff90-1.f
View File

@ -1,15 +0,0 @@
C Test compiler flags: -ff90
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C Read the g77 manual entry on CMPAMBIG
C
C { dg-do run }
C { dg-options "-ff90" }
double complex z
z = (2.0d0,1.0d0)
call s(real(z))
end
subroutine s(x)
double precision x
if ( abs(x-2.0d0) .gt. 1.0e-5 ) call abort
end

6
gcc/testsuite/g77.dg/ffixed-form-1.f
View File

@ -1,6 +0,0 @@
! Test compiler flags: -ffixed-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffixed-form" }
end

12
gcc/testsuite/g77.dg/ffixed-form-2.f
View File

@ -1,12 +0,0 @@
! PR fortran/10843
! Origin: Brad Davis <bdavis9659@comcast.net>
!
! { dg-do compile }
! { dg-options "-ffixed-form" }
GO TO 3
GOTO 3
3 CONTINUE
GOTO = 55
GO TO = 55
END

7
gcc/testsuite/g77.dg/ffixed-line-length-0.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -ffixed-line-length-0
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-0" }
C The next line has length 257
en d

7
gcc/testsuite/g77.dg/ffixed-line-length-132.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -ffixed-line-length-132
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-132" }
c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012
en d*

8
gcc/testsuite/g77.dg/ffixed-line-length-7.f
View File

@ -1,8 +0,0 @@
C Test compiler flags: -ffixed-line-length-7
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-7" }
e*
$n*
$d*

7
gcc/testsuite/g77.dg/ffixed-line-length-72.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -ffixed-line-length-72
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-72" }
c2345678901234567890123456789012345678901234567890123456789012345678901234567890
en d*

7
gcc/testsuite/g77.dg/ffixed-line-length-none.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -ffixed-line-length-none
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-ffixed-line-length-none" }
C The next line has length 257
en d

6
gcc/testsuite/g77.dg/ffree-form-1.f
View File

@ -1,6 +0,0 @@
! Test compiler flags: -ffree-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
end

11
gcc/testsuite/g77.dg/ffree-form-2.f
View File

@ -1,11 +0,0 @@
! PR fortran/10843
! Origin: Brad Davis <bdavis9659@comcast.net>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
GO TO 3
GOTO 3
3 CONTINUE
GOTO = 55
END

20
gcc/testsuite/g77.dg/ffree-form-3.f
View File

@ -1,20 +0,0 @@
! Test acceptance of keywords in free format
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-ffree-form" }
integer i, j
i = 1
if ( i .eq. 1 ) then
go = 2
endif
if ( i .eq. 3 ) then
i = 4
end if
do i = 1, 3
j = i
end do
do j = 1, 3
i = j
enddo
end

7
gcc/testsuite/g77.dg/fno-backslash.f
View File

@ -1,7 +0,0 @@
C Test compiler flags: -fno-backslash
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-backslash" }
if ( len('A\nB') .ne. 4 ) call abort
end

15
gcc/testsuite/g77.dg/fno-f90-1.f
View File

@ -1,15 +0,0 @@
C Test compiler flags: -fno-f90
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C Read the g77 manual entry on CMPAMBIG
C
C { dg-do run }
C { dg-options "-fno-f90 -fugly-complex" }
double complex z
z = (2.0d0,1.0d0)
call s(real(z))
end
subroutine s(x)
real x
if ( abs(x-2.0) .gt. 1.0e-5 ) call abort
end

6
gcc/testsuite/g77.dg/fno-fixed-form-1.f
View File

@ -1,6 +0,0 @@
! Test compiler flags: -fno-fixed-form
! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
!
! { dg-do compile }
! { dg-options "-fno-fixed-form" }
end

9
gcc/testsuite/g77.dg/fno-onetrip.f
View File

@ -1,9 +0,0 @@
C Test compiler flags: -fno-onetrip
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-onetrip -w" }
do i = 1, 0
call abort
end do
end

10
gcc/testsuite/g77.dg/fno-typeless-boz.f
View File

@ -1,10 +0,0 @@
C Test compiler flags: -fno-typeless-boz
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-typeless-boz" }
equivalence (i,r)
r = Z'ABCD1234'
j = Z'ABCD1234'
if ( j .eq. i ) call abort
end

8
gcc/testsuite/g77.dg/fno-underscoring.f
View File

@ -1,8 +0,0 @@
C Test compiler flags: -fno-underscoring
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-fno-underscoring" }
call aaabbbccc
end
C { dg-final { scan-assembler-not "aaabbbccc_" } }

10
gcc/testsuite/g77.dg/fno-vxt-1.f
View File

@ -1,10 +0,0 @@
C Test compiler flags: -fno-vxt
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fno-vxt" }
i = 0
!1
if ( i .ne. 0 ) call exit
call abort
END

10
gcc/testsuite/g77.dg/fonetrip.f
View File

@ -1,10 +0,0 @@
C Test compiler flags: -fonetrip
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fonetrip -w" }
do i = 1, 0
call exit
end do
call abort
end

10
gcc/testsuite/g77.dg/ftypeless-boz.f
View File

@ -1,10 +0,0 @@
C Test compiler flags: -ftypeless-boz
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-ftypeless-boz" }
equivalence (i,r)
r = Z'ABCD1234'
j = Z'ABCD1234'
if ( j .ne. i ) call abort
end

9
gcc/testsuite/g77.dg/fugly-assumed.f
View File

@ -1,9 +0,0 @@
C Test compiler flags: -fugly-assumed
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-fugly-assumed" }
function f(i)
integer i(1)
f = i(1)+i(2)
end

8
gcc/testsuite/g77.dg/funderscoring.f
View File

@ -1,8 +0,0 @@
C Test compiler flags: -funderscoring
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do compile }
C { dg-options "-funderscoring" }
call aaabbbccc
end
C { dg-final { scan-assembler "aaabbbccc_" } }

10
gcc/testsuite/g77.dg/fvxt-1.f
View File

@ -1,10 +0,0 @@
C Test compiler flags: -fvxt
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-options "-fvxt" }
i = 0
!1
if ( i .eq. 0 ) call exit
call abort
END

419
gcc/testsuite/g77.dg/gcov/gcov-1.f
View File

@ -1,419 +0,0 @@
C { dg-options "-fprofile-arcs -ftest-coverage" }
C { dg-do run { target native } }
C
C Test gcov reports for line counts and branch and call return percentages
C for various Fortran 77 constructs to catch basic regressions in the
C functionality.
program gcov1
implicit none
integer i,j,k,n
integer result
integer lpall, ieall, gtall
integer lpval, ieval, gtval
! returns(100)
lpval = lpall() ! count(1)
! returns(100)
ieval = ieall() ! count(1)
! returns(100)
gtval = gtall() ! count(1)
! returns(end)
if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
call abort
end if
end
C Pass a value through a function to thwart optimization.
integer function foo(i)
implicit none
integer i
foo = i ! count(18)
end
C Test various flavors of GOTO and compare results against expected values.
integer function gtall()
implicit none
integer gt1, gt2, gt3, gt4, gt5
integer gtval
gtall = 1 ! count(1)
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt1(0) ! count(1)
! returns(100)
gtval = gtval + gt1(1) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 3) then ! count(1)
! branch(end)
print *,"gtall part 1: ", gtval, 3
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt2(9) ! count(1)
! returns(100)
gtval = gtval + gt2(20) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 12) then ! count(1)
! branch(end)
print *,"gtall part 2: ", gtval, 12
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt3(0) ! count(1)
! returns(100)
gtval = gtval + gt3(3) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 48) then ! count(1)
! branch(end)
! branch(end)
print *,"gtall part 3: ", gtval, 48
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt4(1) ! count(1)
! returns(100)
gtval = gtval + gt4(2) ! count(1)
! returns(100)
gtval = gtval + gt4(3) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 14) then ! count(1)
! branch(end)
print *,"gtall part 4: ", gtval, 14
gtall = 0
end if
gtval = 0 ! count(1)
! returns(100)
gtval = gtval + gt5(0) ! count(1)
! returns(100)
gtval = gtval + gt5(-1) ! count(1)
! returns(100)
gtval = gtval + gt5(5) ! count(1)
! returns(end)
! branch(0)
if (gtval .ne. 14) then ! count(1)
! branch(end)
print *,"gtall part 5: ", gtval, 14
gtall = 0
end if
end
C Test simple GOTO.
integer function gt1(f)
implicit none
integer f
! branch(50)
if (f .ne. 0) goto 100 ! count(2)
! branch(end)
gt1 = 1 ! count(1)
goto 101 ! count(1)
100 gt1 = 2 ! count(1)
101 continue ! count(2)
end
C Test simple GOTO again, this time out of a DO loop.
integer function gt2(f)
implicit none
integer f
integer i
! branch(95)
do i=1,10
! branch(end)
if (i .eq. f) goto 100 ! count(19)
end do
gt2 = 4 ! count(1)
goto 101 ! count(1)
100 gt2 = 8 ! count(1)
101 continue ! count(2)
end
C Test computed GOTO.
integer function gt3(i)
implicit none
integer i
goto (101, 102, 103, 104), i ! count(2)
gt3 = 8 ! count(1)
goto 105 ! count(1)
101 gt3 = 1024
goto 105
102 gt3 = 2048
goto 105
103 gt3 = 16 ! count(1)
goto 105 ! count(1)
104 gt3 = 4096
goto 105
105 gt3 = gt3 * 2 ! count(2)
end
C Test assigned GOTO.
integer function gt4(i)
implicit none
integer i
integer label
assign 101 to label ! count(3)
if (i .eq. 2) assign 102 to label ! count(3)
if (i .eq. 3) assign 103 to label ! count(3)
goto label, (101, 102, 103) ! count(3)
101 gt4 = 1 ! count(1)
goto 104 ! count(1)
102 gt4 = 2 ! count(1)
goto 104 ! count(1)
103 gt4 = 4 ! count(1)
104 gt4 = gt4 * 2 ! count(3)
end
C Test arithmetic IF (bundled with the GOTO variants).
integer function gt5(i)
implicit none
integer i
gt5 = 1 ! count(3)
! branch(67 50)
if (i) 101, 102, 103 ! count(3)
! branch(end)
101 gt5 = 2 ! count(1)
goto 104 ! count(1)
102 gt5 = 4 ! count(1)
goto 104 ! count(1)
103 gt5 = 8 ! count(1)
104 continue ! count(3)
end
C Run all of the loop tests and check results against expected values.
integer function lpall()
implicit none
integer loop1, loop2
integer loopval
lpall = 1 ! count(1)
loopval = 0 ! count(1)
! returns(100)
loopval = loopval + loop1(1,0) ! count(1)
! returns(100)
loopval = loopval + loop1(1,2) ! count(1)
! returns(100)
loopval = loopval + loop1(1,7) ! count(1)
! returns(end)
if (loopval .ne. 12) then ! count(1)
print *,"lpall part 1: ", loopval, 12
lpall = 0
end if
loopval = 0 ! count(1)
! returns(100)
loopval = loopval + loop2(1,0,0,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,0,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,3,0) ! count(1)
! returns(100)
loopval = loopval + loop2(1,1,3,1) ! count(1)
! returns(100)
loopval = loopval + loop2(1,3,1,5) ! count(1)
! returns(100)
loopval = loopval + loop2(1,3,7,3) ! count(1)
! returns(end)
if (loopval .ne. 87) then ! count(1)
print *,"lpall part 2: ", loopval, 87
lpall = 0
end if
end
C Test a simple DO loop.
integer function loop1(r,n)
implicit none
integer r,n,i
loop1 = r ! count(3)
! branch(75)
do i=1,n
! branch(end)
loop1 = loop1 + 1 ! count(9)
end do
end
C Test nested DO loops.
integer function loop2(r, l, m, n)
implicit none
integer r,l,m,n
integer i,j,k
loop2 = r ! count(6)
! branch(60)
do i=1,l
! branch(77)
do j=1,m
! branch(73)
do k=1,n
! branch(end)
loop2 = loop2 + 1 ! count(81)
end do
end do
end do
end
C Test various combinations of IF-THEN-ELSE and check results against
C expected values.
integer function ieall()
implicit none
integer ie1, ie2, ie3
integer ieval
ieall = 1 ! count(1)
ieval = 0 ! count(1)
ieval = ieval + ie1(0,2) ! count(1)
ieval = ieval + ie1(0,0) ! count(1)
ieval = ieval + ie1(1,2) ! count(1)
ieval = ieval + ie1(10,2) ! count(1)
ieval = ieval + ie1(11,11) ! count(1)
if (ieval .ne. 31) then ! count(1)
print *,"ieall part 1: ", ieval, 31
ieall = 0
end if
ieval = 0
ieval = ieval + ie2(0) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(2) ! count(1)
ieval = ieval + ie2(3) ! count(1)
ieval = ieval + ie2(3) ! count(1)
if (ieval .ne. 23) then ! count(1)
print *,"ieall part 2: ", ieval, 23
ieall = 0
end if
ieval = 0
ieval = ieval + ie3(11,19) ! count(1)
ieval = ieval + ie3(25,27) ! count(1)
ieval = ieval + ie3(11,22) ! count(1)
ieval = ieval + ie3(11,10) ! count(1)
ieval = ieval + ie3(21,32) ! count(1)
ieval = ieval + ie3(21,20) ! count(1)
ieval = ieval + ie3(1,2) ! count(1)
ieval = ieval + ie3(32,31) ! count(1)
ieval = ieval + ie3(3,0) ! count(1)
ieval = ieval + ie3(0,47) ! count(1)
ieval = ieval + ie3(65,65) ! count(1)
if (ieval .ne. 246) then ! count(1)
print *,"ieall part 3: ", ieval, 246
ieall = 0
end if
end
C Test IF-THEN-ELSE.
integer function ie1(i,j)
implicit none
integer i,j
integer foo
ie1 = 0 ! count(5)
! branch(40)
if (i .ne. 0) then ! count(5)
! branch(0)
if (j .ne. 0) then ! count(3)
! branch(end)
ie1 = foo(4) ! count(3)
else
ie1 = foo(1024)
end if
else
! branch(50)
if (j .ne. 0) then ! count(2)
! branch(end)
ie1 = foo(1) ! count(1)
else
ie1 = foo(2) ! count(1)
end if
end if
! branch(80)
if (i .gt. j) then ! count(5)
! branch(end)
ie1 = foo(ie1*2)
end if
! branch(80)
if (i .gt. 10) then ! count(5)
! branch(0)
if (j .gt. 10) then ! count(1)
! branch(end)
ie1 = foo(ie1*4) ! count(1)
end if
end if
end
C Test a series of simple IF-THEN statements.
integer function ie2(i)
implicit none
integer i
integer foo
ie2 = 0 ! count(6)
! branch(83)
if (i .eq. 0) then ! count(6)
! branch(end)
ie2 = foo(1) ! count(1)
end if
! branch(100)
if (i .eq. 1) then ! count(6)
! branch(end)
ie2 = foo(1024)
end if
! branch(50)
if (i .eq. 2) then ! count(6)
! branch(end)
ie2 = foo(2) ! count(3)
end if
! branch(67)
if (i .eq. 3) then ! count(6)
! branch(end)
ie2 = foo(8) ! count(2)
end if
! branch(100)
if (i .eq. 4) then ! count(6)
! branch(end)
ie2 = foo(2048)
end if
end
C Test nested IF statements and IF with compound expressions.
integer function ie3(i,j)
implicit none
integer i,j
integer foo
ie3 = 1 ! count(11)
! branch(27 50 75)
if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then ! count(11)
! branch(end)
ie3 = foo(16) ! count(1)
end if
! branch(55)
if (i .gt. 20) then ! count(11)
! branch(60)
if (j .gt. i) then ! count(5)
! branch(50)
if (j .lt. 30) then ! count(2)
! branch(end)
ie3 = foo(32) ! count(1)
end if
end if
end if
! branch(9 10 11)
if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then ! count(11)
! branch(end)
ie3 = foo(64) ! count(3)
end if
end
C
C { dg-final { run-gcov branches calls { -b gcov-1.f } } }

44
gcc/testsuite/g77.dg/gcov/gcov.exp
View File

@ -1,44 +0,0 @@
# Copyright (C) 1997, 2001 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Gcov test driver.
# Load support procs.
load_lib g77-dg.exp
load_lib gcov.exp
global G77_UNDER_TEST
# For now find gcov in the same directory as $G77_UNDER_TEST.
if { ![is_remote host] && [string match "*/*" [lindex $G77_UNDER_TEST 0]] } {
set GCOV [file dirname [lindex $G77_UNDER_TEST 0]]/gcov
} else {
set GCOV gcov
}
# Initialize harness.
dg-init
# Delete old .da files.
set files [glob -nocomplain gcov-*.da];
if { $files != "" } {
eval "remote_file build delete $files";
}
# Main loop.
dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/gcov-*.f]] "" ""
dg-finish

7
gcc/testsuite/g77.dg/pr3743-1.f
View File

@ -1,7 +0,0 @@
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
integer i
i = bit_size(i)
end

8
gcc/testsuite/g77.dg/pr3743-2.f
View File

@ -1,8 +0,0 @@
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
C { dg-options "-fcase-preserve -fintrin-case-upper" }
integer i
i = BIT_SIZE(i)
end

8
gcc/testsuite/g77.dg/pr3743-3.f
View File

@ -1,8 +0,0 @@
c Test case for PR fortran/3743
c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
c
c { dg-do link }
c { dg-options "-fcase-preserve -fintrin-case-lower" }
integer i
i = bit_size(i)
end

8
gcc/testsuite/g77.dg/pr3743-4.f
View File

@ -1,8 +0,0 @@
C Test case for PR fortran/3743
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do link }
C { dg-options "-fcase-preserve -fintrin-case-initcap" }
integer i
i = Bit_Size(i)
end

15
gcc/testsuite/g77.dg/pr5473.f
View File

@ -1,15 +0,0 @@
program pr5473
c Derived from g77.f-torture/execute/intrinsic-unix-bessel.f
c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
c { dg-do compile }
real x, a
double precision dx, da
integer*8 m
x = 2.0
dx = x
m = 2
a = BESJN(m,x) ! { dg-error "incorrect type" "incorrect type" }
a = BESYN(m,x) ! { dg-error "incorrect type" "incorrect type" }
da = DBESJN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
da = DBESYN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
end

18
gcc/testsuite/g77.dg/pr9258.f
View File

@ -1,18 +0,0 @@
C Test case for PR/9258
C Origin: kmccarty@princeton.edu
C
C { dg-do compile }
SUBROUTINE FOO (B)
10 CALL BAR (A)
ASSIGN 20 TO M
IF (100.LT.A) GOTO 10
GOTO 40
C
20 IF (B.LT.ABS(A)) GOTO 10
ASSIGN 30 TO M
GOTO 40
C
30 ASSIGN 10 TO M
40 GOTO M,(10,20,30)
END

95
gcc/testsuite/g77.dg/strlen0.f
View File

@ -1,95 +0,0 @@
C Substring range checking test program, to check behavior with respect
C to X3J3/90.4 paragraph 5.7.1.
C
C Patches relax substring checking for subscript expressions in order to
C simplify coding (elimination of length checks for strings passed as
C parameters) and to avoid contradictory behavior of subscripted substring
C expressions with respect to unsubscripted string expressions.
C
C Key part of 5.7.1 interpretation comes down to statement that in the
C substring expression,
C v ( e1 : e2 )
C 1 <= e1 <= e2 <= len to be valid, yet the expression
C v ( : )
C is equivalent to
C v(1:len(v))
C
C meaning that any statement that reads
C str = v // 'tail'
C (where v is a string passed as a parameter) would require coding as
C if (len(v) .gt. 0) then
C str = v // 'tail'
C else
C str = 'tail'
C endif
C to comply with the standard specification. Under the stricter
C interpretation, functions strcat and strlat would be incorrect as
C written for null values of str1 and/or str2.
C
C This code compiles and runs without error on
C SunOS 4.1.3 f77 (-C option)
C SUNWspro SPARCcompiler 4.2 f77 (-C option)
C (and with proposed patches, gcc-2.9.2 -fbounds-check except for test 6,
C which is a genuine, deliberate error - comment out to make further
C tests)
C
C { dg-do run }
C { dg-options "-fbounds-check" }
C
C G. Helffrich/Tokyo Inst. Technology Jul 24 2001
character str*8,strres*16,strfun*16,strcat*16,strlat*16
str='Hi there'
C Test 1 - (current+patched) two char substring result
strres=strfun(str,1,2)
write(*,*) 'strres is ',strres
C Test 2 - (current+patched) null string result
strres=strfun(str,5,4)
write(*,*) 'strres is ',strres
C Test 3 - (current+patched) null string result
strres=strfun(str,8,7)
write(*,*) 'strres is ',strres
C Test 4 - (current) error; (patched) null string result
strres=strfun(str,9,8)
write(*,*) 'strres is ',strres
C Test 5 - (current) error; (patched) null string result
strres=strfun(str,1,0)
write(*,*) 'strres is ',strres
C Test 6 - (current+patched) error
C strres=strfun(str,20,20)
C write(*,*) 'strres is ',strres
C Test 7 - (current+patched) str result
strres=strcat(str,'')
write(*,*) 'strres is ',strres
C Test 8 - (current) error; (patched) str result
strres=strlat('',str)
write(*,*) 'strres is ',strres
end
character*(*) function strfun(str,i,j)
character str*(*)
strfun = str(i:j)
end
character*(*) function strcat(str1,str2)
character str1*(*), str2*(*)
strcat = str1 // str2
end
character*(*) function strlat(str1,str2)
character str1*(*), str2*(*)
strlat = str1(1:len(str1)) // str2(1:len(str2))
end

5
gcc/testsuite/g77.f-torture/compile/12002.f
View File

@ -1,5 +0,0 @@
C PR middle-end/12002
COMPLEX TE1
TE1=-2.
TE1=TE1+TE1
END

13
gcc/testsuite/g77.f-torture/compile/13060.f
View File

@ -1,13 +0,0 @@
subroutine geo2()
implicit none
integer ms,n,ne(2)
ne(1) = 1
ne(2) = 2
ms = 1
call call_me(ne(1)*ne(1))
n = ne(ms)
end

13
gcc/testsuite/g77.f-torture/compile/19990218-0.f
View File

@ -1,13 +0,0 @@
program test
double precision a,b,c
data a,b/1.0d-46,1.0d0/
c=fun(a,b)
print*,'in main: fun=',c
end
double precision function fun(a,b)
double precision a,b
print*,'in sub: a,b=',a,b
fun=a*b
print*,'in sub: fun=',fun
return
end

55
gcc/testsuite/g77.f-torture/compile/19990305-0.f
View File

@ -1,55 +0,0 @@
* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST)
* From: Denes Molnar <molnard@phys.columbia.edu>
* To: fortran@gnu.org
* Subject: f771 gets fatal signal 6
* Content-Type: TEXT/PLAIN; charset=US-ASCII
* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f
*
* Hi,
*
*
* Comiling object from the source code below WORKS FINE with
* 'g77 -o hwuci2 -c hwuci2.F'
* but FAILS with fatal signal 6
* 'g77 -o hwuci2 -O -c hwuci2.F'
*
* Any explanations?
*
* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1).
*
*
* Denes Molnar
*
* %%%%%%%%%%%%%%%%%%%%%%%%%
* %the source:
* %%%%%%%%%%%%%%%%%%%%%%%%%
*
CDECK ID>, HWUCI2.
*CMZ :- -23/08/94 13.22.29 by Mike Seymour
*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
C-----------------------------------------------------------------------
FUNCTION HWUCI2(A,B,Y0)
C-----------------------------------------------------------------------
C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
C-----------------------------------------------------------------------
IMPLICIT NONE
DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
EXTERNAL HWULI2
COMMON/SMALL/EPSI
PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
IF(B.EQ.ZERO)THEN
HWUCI2=CMPLX(ZERO,ZERO)
ELSE
Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
Y2=ONE-Y1
Z1=Y0/(Y0-Y1)
Z2=(Y0-ONE)/(Y0-Y1)
Z3=Y0/(Y0-Y2)
Z4=(Y0-ONE)/(Y0-Y2)
HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
ENDIF
RETURN
END
*
* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

7
gcc/testsuite/g77.f-torture/compile/19990419-0.f
View File

@ -1,7 +0,0 @@
* Test case Toon submitted, cut down to expose the one bug.
* Belongs in compile/.
SUBROUTINE INIERS1
IMPLICIT LOGICAL(L)
COMMON/COMIOD/ NHIERS1, LERS1
inquire(nhiers1, exist=lers1)
END

66
gcc/testsuite/g77.f-torture/compile/19990502-0.f
View File

@ -1,66 +0,0 @@
* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
* Precedence: bulk
* Sender: owner-egcs-bugs@egcs.cygnus.com
* From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de>
* Subject: egcs g77 19990524pre Internal compiler error in `print_operand'
* To: egcs-bugs@egcs.cygnus.com
* Date: Mon, 31 May 1999 11:46:52 +0200 (CET)
* Content-Type: text/plain; charset=US-ASCII
* X-UIDL: 9a00095a5fe4d774b7223de071157374
*
* Hi,
*
* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524
* on an i686-pc-linux-gnu. The program below gives an internal compiler error.
*
*
* Script started on Mon May 31 11:30:01 1999
* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f
* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515)
* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs
* gcc version gcc-2.95 19990524 (prerelease)
* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s
* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease).
* GNU Fortran Front End version 0.5.24-19990515
* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405
* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'.
* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for details.
* lx{g010}:/tmp>cat e3.f
SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 )
DOUBLE PRECISION SMALL2, TOL2
DOUBLE PRECISION EE( * ), QQ( * )
INTEGER ICONV, N, OFF
DOUBLE PRECISION QEMAX, XINF
EXTERNAL DLASQ3
INTRINSIC MAX, SQRT
XINF = 0.0D0
ICONV = 0
IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
END IF
IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
$ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN
QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
END IF
IF( N.EQ.0 ) THEN
IF( OFF.EQ.0 ) THEN
RETURN
ELSE
XINF =0.0D0
END IF
ELSE IF( N.EQ.2 ) THEN
END IF
CALL DLASQ3(ICONV)
END
* lx{g010}:/tmp>exit
*
* Script done on Mon May 31 11:30:23 1999
*
* Best regards,
*
* Norbert.
* --
* Norbert Conrad phone: ++49 641 9913021
* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de
* Heinrich-Buff-Ring 44
* 35392 Giessen
* Germany

6
gcc/testsuite/g77.f-torture/compile/19990502-1.f
View File

@ -1,6 +0,0 @@
SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY)
INTEGER*2 IGAMS(2,NADC)
in = 1
do while (in.le.nadc.and.IGAMS(2,in).le.in)
enddo
END

50
gcc/testsuite/g77.f-torture/compile/19990525-0.f
View File

@ -1,50 +0,0 @@
* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
* Precedence: bulk
* Sender: owner-egcs-bugs@egcs.cygnus.com
* From: "Bjorn R. Bjornsson" <brb@halo.hi.is>
* Subject: g77 char expr. as arg to subroutine bug
* To: egcs-bugs@egcs.cygnus.com
* Date: Tue, 25 May 1999 14:45:56 +0000 (GMT)
* Content-Type: text/plain; charset=US-ASCII
* X-UIDL: 06000c94269ed6dfe826493e52a818b9
*
* The following bug is in all snapshots starting
* from April 18. I have only tested this on Alpha linux,
* and with FFECOM_FASTER_ARRAY_REFS set to 1.
*
* Run the following through g77:
*
subroutine a
character*2 string1
character*2 string2
character*4 string3
string1 = 's1'
string2 = 's2'
c
c the next 2 lines are ok.
string3 = (string1 // string2)
call b(string1//string2)
c
c this line gives gcc/f/com.c:10660: failed assertion `hook'
call b((string1//string2))
end
*
* the output from:
*
* /usr/local/egcs-19990418/bin/g77 --verbose -c D.f
*
* is:
*
* on egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (from FSF-g77 version 0.5.24-19990418)
* Reading specs from /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/specs
* gcc version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental)
* /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/f771 D.f -quiet -dumpbase D.f -version -fversion -o /tmp/ccNpaaaa.s
* GNU F77 version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (alphaev56-unknown-linux-gnu) compiled by GNU C version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental).
* GNU Fortran Front End version 0.5.24-19990418
* ../../../egcs-19990418/gcc/f/com.c:10351: failed assertion `hook'
* g77: Internal compiler error: program f771 got fatal signal 6
*
* Yours,
*
* Bjorn R. Bjornsson
* brb@halo.hi.is

286
gcc/testsuite/g77.f-torture/compile/19990826-1.f
View File

@ -1,286 +0,0 @@
* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST)
* From: Jonathan Ravens <ravens@whio.gns.cri.nz>
* To: gcc-bugs@gcc.gnu.org
* Subject: g77 bug report
* X-UIDL: a0bf5ecc21487cde48d9104983ab04d6
! This fortran source will not compile - if the penultimate elseif block is 0
! included then the message appears :
!
! /usr/src/egcs//gcc-2.95.1/gcc/f/stw.c:308: failed assertion `b->uses_ > 0'
! g77: Internal compiler error: program f771 got fatal signal 6
!
! The command was : g77 -c <prog.f>
!
! The OS is Red Hat 6, and the output from uname -a is
! Linux grfw1452.gns.cri.nz 2.2.5-15 #1 Mon Apr 19 23:00:46 EDT 1999 i686 unknown
!
! The configure script I used was
! /usr/src/egcs/gcc/gcc-2.95.1/configure --enable-languages=f77 i585-unknown-linux
!
! I was installing 2.95 because under EGCS 2.1.1 none of my code was working
! with optimisation turned on, and there were still bugs with no optimisation
! (all of which code works fine under g77 0.5.21 and Sun/IBM/Dec/HP fortrans).
!
! The version of g77 is :
!
!g77 version 2.95.1 19990816 (release) (from FSF-g77 version 0.5.25 19990816 (release))
program main
if (i.eq.1) then
call abc(1)
else if (i.eq. 1) then
call abc( 1)
else if (i.eq. 2) then
call abc( 2)
else if (i.eq. 3) then
call abc( 3)
else if (i.eq. 4) then
call abc( 4)
else if (i.eq. 5) then
call abc( 5)
else if (i.eq. 6) then
call abc( 6)
else if (i.eq. 7) then
call abc( 7)
else if (i.eq. 8) then
call abc( 8)
else if (i.eq. 9) then
call abc( 9)
else if (i.eq. 10) then
call abc( 10)
else if (i.eq. 11) then
call abc( 11)
else if (i.eq. 12) then
call abc( 12)
else if (i.eq. 13) then
call abc( 13)
else if (i.eq. 14) then
call abc( 14)
else if (i.eq. 15) then
call abc( 15)
else if (i.eq. 16) then
call abc( 16)
else if (i.eq. 17) then
call abc( 17)
else if (i.eq. 18) then
call abc( 18)
else if (i.eq. 19) then
call abc( 19)
else if (i.eq. 20) then
call abc( 20)
else if (i.eq. 21) then
call abc( 21)
else if (i.eq. 22) then
call abc( 22)
else if (i.eq. 23) then
call abc( 23)
else if (i.eq. 24) then
call abc( 24)
else if (i.eq. 25) then
call abc( 25)
else if (i.eq. 26) then
call abc( 26)
else if (i.eq. 27) then
call abc( 27)
else if (i.eq. 28) then
call abc( 28)
else if (i.eq. 29) then
call abc( 29)
else if (i.eq. 30) then
call abc( 30)
else if (i.eq. 31) then
call abc( 31)
else if (i.eq. 32) then
call abc( 32)
else if (i.eq. 33) then
call abc( 33)
else if (i.eq. 34) then
call abc( 34)
else if (i.eq. 35) then
call abc( 35)
else if (i.eq. 36) then
call abc( 36)
else if (i.eq. 37) then
call abc( 37)
else if (i.eq. 38) then
call abc( 38)
else if (i.eq. 39) then
call abc( 39)
else if (i.eq. 40) then
call abc( 40)
else if (i.eq. 41) then
call abc( 41)
else if (i.eq. 42) then
call abc( 42)
else if (i.eq. 43) then
call abc( 43)
else if (i.eq. 44) then
call abc( 44)
else if (i.eq. 45) then
call abc( 45)
else if (i.eq. 46) then
call abc( 46)
else if (i.eq. 47) then
call abc( 47)
else if (i.eq. 48) then
call abc( 48)
else if (i.eq. 49) then
call abc( 49)
else if (i.eq. 50) then
call abc( 50)
else if (i.eq. 51) then
call abc( 51)
else if (i.eq. 52) then
call abc( 52)
else if (i.eq. 53) then
call abc( 53)
else if (i.eq. 54) then
call abc( 54)
else if (i.eq. 55) then
call abc( 55)
else if (i.eq. 56) then
call abc( 56)
else if (i.eq. 57) then
call abc( 57)
else if (i.eq. 58) then
call abc( 58)
else if (i.eq. 59) then
call abc( 59)
else if (i.eq. 60) then
call abc( 60)
else if (i.eq. 61) then
call abc( 61)
else if (i.eq. 62) then
call abc( 62)
else if (i.eq. 63) then
call abc( 63)
else if (i.eq. 64) then
call abc( 64)
else if (i.eq. 65) then
call abc( 65)
else if (i.eq. 66) then
call abc( 66)
else if (i.eq. 67) then
call abc( 67)
else if (i.eq. 68) then
call abc( 68)
else if (i.eq. 69) then
call abc( 69)
else if (i.eq. 70) then
call abc( 70)
else if (i.eq. 71) then
call abc( 71)
else if (i.eq. 72) then
call abc( 72)
else if (i.eq. 73) then
call abc( 73)
else if (i.eq. 74) then
call abc( 74)
else if (i.eq. 75) then
call abc( 75)
else if (i.eq. 76) then
call abc( 76)
else if (i.eq. 77) then
call abc( 77)
else if (i.eq. 78) then
call abc( 78)
else if (i.eq. 79) then
call abc( 79)
else if (i.eq. 80) then
call abc( 80)
else if (i.eq. 81) then
call abc( 81)
else if (i.eq. 82) then
call abc( 82)
else if (i.eq. 83) then
call abc( 83)
else if (i.eq. 84) then
call abc( 84)
else if (i.eq. 85) then
call abc( 85)
else if (i.eq. 86) then
call abc( 86)
else if (i.eq. 87) then
call abc( 87)
else if (i.eq. 88) then
call abc( 88)
else if (i.eq. 89) then
call abc( 89)
else if (i.eq. 90) then
call abc( 90)
else if (i.eq. 91) then
call abc( 91)
else if (i.eq. 92) then
call abc( 92)
else if (i.eq. 93) then
call abc( 93)
else if (i.eq. 94) then
call abc( 94)
else if (i.eq. 95) then
call abc( 95)
else if (i.eq. 96) then
call abc( 96)
else if (i.eq. 97) then
call abc( 97)
else if (i.eq. 98) then
call abc( 98)
else if (i.eq. 99) then
call abc( 99)
else if (i.eq. 100) then
call abc( 100)
else if (i.eq. 101) then
call abc( 101)
else if (i.eq. 102) then
call abc( 102)
else if (i.eq. 103) then
call abc( 103)
else if (i.eq. 104) then
call abc( 104)
else if (i.eq. 105) then
call abc( 105)
else if (i.eq. 106) then
call abc( 106)
else if (i.eq. 107) then
call abc( 107)
else if (i.eq. 108) then
call abc( 108)
else if (i.eq. 109) then
call abc( 109)
else if (i.eq. 110) then
call abc( 110)
else if (i.eq. 111) then
call abc( 111)
else if (i.eq. 112) then
call abc( 112)
else if (i.eq. 113) then
call abc( 113)
else if (i.eq. 114) then
call abc( 114)
else if (i.eq. 115) then
call abc( 115)
else if (i.eq. 116) then
call abc( 116)
else if (i.eq. 117) then
call abc( 117)
else if (i.eq. 118) then
call abc( 118)
else if (i.eq. 119) then
call abc( 119)
else if (i.eq. 120) then
call abc( 120)
else if (i.eq. 121) then
call abc( 121)
else if (i.eq. 122) then
call abc( 122)
else if (i.eq. 123) then
call abc( 123)
else if (i.eq. 124) then
call abc( 124)
else if (i.eq. 125) then !< Miscompiles if present
call abc( 125) !<
c else if (i.eq. 126) then
c call abc( 126)
endif
end

320
gcc/testsuite/g77.f-torture/compile/19990826-3.f
View File

@ -1,320 +0,0 @@
* Date: Thu, 19 Aug 1999 10:02:32 +0200
* From: Frederic Devernay <devernay@istar.fr>
* Organization: ISTAR
* X-Accept-Language: French, fr, en
* To: gcc-bugs@gcc.gnu.org
* Subject: g77 2.95 bug (Internal compiler error in `final_scan_insn')
* X-UIDL: 08443f5c374ffa382a05573281482f4f
* Here's a bug that happens only when I compile with -O (disappears with
* -O2)
* > g77 -v --save-temps -O -c pcapop.f
* g77 version 2.95 19990728 (release) (from FSF-g77 version 0.5.25
* 19990728 (release))
* Reading specs from
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/specs
* gcc version 2.95 19990728 (release)
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/f771 pcapop.f -quiet
* -dumpbase pcapop.f -O -version -fversion -o pcapop.s
* GNU F77 version 2.95 19990728 (release) (sparc-sun-solaris2.6) compiled
* by GNU C version 2.95 19990728 (release).
* GNU Fortran Front End version 0.5.25 19990728 (release)
* pcapop.f: In subroutine `pcapop':
* pcapop.f:291: Internal compiler error in `final_scan_insn', at
* final.c:2920
* Please submit a full bug report.
* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for instructions.
C* PCAPOP
SUBROUTINE PCAPOP(M1,M2,L1,L2,NMEM,N1,N2,IB,IBB,K3,TF,TS,TC,TTO)
DIMENSION NVA(6),C(6),I(6)
C
C CALCUL DES PARAMETRES OPTIMAUX N1 N2 IB IBB
C
TACC=.035
TTRANS=.000004
RAD=.000001
RMI=.000001
RMU=.0000015
RDI=.000003
RTE=.000003
REQ=.000005
VY1=3*RTE+RDI+8*REQ+3*(RAD+RMI+RMU)
VY2=REQ+2*RAD
AR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ))
C VARIATION DE L1,L2,
C
TTOTOP=1.E+10
N1CO=0
N2CO=0
IBCO=0
IBBCO=0
K3CO=0
TESOP=0.
TCOP=0.
TFOP=0.
INUN=7
INDE=7
IF(M1.LT.128)INUN=6
IF(M1.LT.64)INUN=5
IF(M1.LT.32)INUN=4
IF(M2.LT.128)INDE=6
IF(M2.LT.64)INDE=5
IF(M2.LT.32)INDE=4
DO 3 NUN =3,INUN
DO 3 NDE=3,INDE
N10=2**NUN
N20=2**NDE
NDIF=(N10-N20)
NDIF=IABS(NDIF)
C POUR AVOIR CES RESULTATS FAIRE TOURNER LE PROGRAMME VEFFT1
TCFFTU=0.
IF(N10.EQ.128.AND.N20.EQ.128)TCFFTU=3.35
IF(N10.EQ.64.AND.N20.EQ.64)TCFFTU=.70
IF(N10.EQ.32.AND.N20.EQ.32)TCFFTU=.138
IF(N10.EQ.16.AND.N20.EQ.16)TCFFTU=.0332
IF(N10.EQ.8.AND.N20.EQ.8)TCFFTU=.00688
IF(NDIF.EQ.64)TCFFTU=1.566
IF(NDIF.EQ.96)TCFFTU=.709
IF(NDIF.EQ.112)TCFFTU=.349
IF(NDIF.EQ.120)TCFFTU=.160
IF(NDIF.EQ.32)TCFFTU=.315
IF(NDIF.EQ.48)TCFFTU=.154
IF(NDIF.EQ.56)TCFFTU=.07
IF(NDIF.EQ.16)TCFFTU=.067
IF(NDIF.EQ.24)TCFFTU=.030
IF(NDIF.EQ.8)TCFFTU=.016
N30=N10-L1+1
N40=N20-L2+1
WW=VY1+N30*VY2
NDOU=2*N10*N20
IF((N10.LT.L1).OR.(N20.LT.L2)) GOTO 3
NB=NMEM-NDOU-N20*(L1-1)
NVC=2*N10*(N20-1)+M1
IF(NB.LT.(NVC)) GOTO 3
CALL VALENT(M1,N30,K1)
CALL VALENT(M2,N40,K2)
IS=K1/2
IF((2*IS).NE.K1)K1=K1+1
TFF=TCFFTU*K1*K2
CALL VALENT(M2,N40,JOFI)
IF(NB.GE.(K1*N20*N30+2*N20*(L1-1))) GOTO 4
TIOOP=1.E+10
IC=1
18 IB1=2*IC
MAX=(NB-2*N20*(L1-1))/(N20*N30)
IN=MAX/2
IF(MAX.NE.2*IN) MAX=MAX-1
K3=K1/IB1
IBB1=K1-K3*IB1
IOFI=M1/(IB1*N30)
IRZ=0
IF(IOFI*IB1*N30.EQ.M1) GOTO1234
IRZ=1
IOFI=IOFI+1
IF(IBB1.EQ.0) GOTO 1234
IF(M1.EQ.((IOFI-1)*IB1*N30+IBB1*N30)) GOTO 1233
IRZ=2
GOTO 1234
1233 IRZ=3
1234 IBX1=IBB1
IF(IBX1.EQ.0)IBX1=IB1
AR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1-(IOFI-1)*IB1*N30)*2*(REQ+RAD))
%+M2*(3*(REQ+RMU+RAD)+4*RMI+(M1-(IOFI-1)*IB1*N30)*(2*RAD+REQ)
%+(IOFI-1)*IB1*N30*(2*RMI+REQ+RAD))
AR5=(JOFI-1)*(N20-L2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU)+REQ)
%*IOFI+(M2-(JOFI-1)*N40+L2-2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU
%)+REQ)*IOFI
WQ=((IOFI-1)*IB1+IBX1)*JOFI*WW
AT1=N20*WQ
AT2=N40*WQ
QW=JOFI*(VY1+VY2*IB1*N30)
AT3=IOFI*N40*QW
AT4=(IOFI-1)*N40*QW
AT5=JOFI*((IOFI-1)*N40*(IB1/IBX1)*(VY1+IBX1*N30*VY2)
%+N40*((IB1/IBX1)*(IOFI-1)+1)*(VY1+IBX1*N30*VY2))
AT6=JOFI*((IOFI-1)*N40*(IB1/2)*(VY1+2*N30*VY2)+N40*(
%IB1*(IOFI-1)/2+IBX1/2)*(VY1+2*N30*VY2))
T1=JOFI*N20*(L1-1)*REQ
T2=M1*(L2-1)*REQ
T3=JOFI*N20*IBX1*N30*(RAD+REQ)
T4=JOFI*((IOFI-1)*IB1*N30*N20*(2*RMI+REQ)+IBX1*N30*N20*(2*RMI+R
%EQ))
T5=JOFI*((IOFI-1)*IB1/2+IBX1/2)*N20*N30*(2*RAD+REQ)
T6=2*JOFI*(((IOFI-1)*IB1+IBX1)*N20)*((5*(RMI+RMU)+4*RAD
%)+(L1-1)*(2*RAD+REQ)+N30*(2*RAD+REQ))
T7=JOFI*2*((IOFI-1)*IB1+IBX1)*(L1-1)*(2*RAD+REQ)
T8=JOFI*N10*N20*((IOFI-1)*IB1/2+IBX1/2)*(3*REQ+9*RAD+4*RMU+RMI)
T9=N10*N20*JOFI*((IOFI-1)*IB1/2+IBX1/2)*(REQ+RMI)+M1*M2*(REQ+R
%DI+2*RAD)
T10=JOFI*((IOFI-1)*IB1/2+IBX1/2)*2*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
POI=JOFI
IF(POI.LE.2)POI=2
TNRAN=(N40+(POI-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMI+RMU+RAD
%+REQ+N30*(2*RAD+2*REQ)*(IB1*(IOFI-1)+IBX1))
IF(TNRAN.LT.0.)TNRAN=0.
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10+TNRAN
NVA(1)=N40
NVA(2)=N40
NVA(3)=N20
NVA(4)=N20
NVA(5)=M2-(JOFI-1)*N40
NVA(6)=NVA(5)
C(1)=FLOAT(IB1*N30)/FLOAT(M1)
C(2)=FLOAT(M1-(IOFI-1)*IB1*N30)/FLOAT(M1)
C(3)=C(1)
C(4)=C(2)
C(5)=C(1)
C(6)=C(2)
K=1
P1=FLOAT(NB)/FLOAT(M1)
10 IP1=P1
I(K)=1
IF(IP1.GE.NVA(K)) GOTO 7
P2=P1
IP2=P2
8 P2=P2-FLOAT(IP2)*C(K)
IP2=P2
IF(IP2.EQ.0) GOTO 3
IP1=IP1+IP2
I(K)=I(K)+1
IF(IP1.GE.NVA(K))GOTO 7
GOTO 8
7 IF(K.EQ.6) GOTO 11
K=K+1
GOTO 10
11 IP1=0
IP2=0
IP3=0
POFI=JOFI
IF(POFI.LE.2)POFI=2
TIOL=(I(2)+(IOFI-1)*I(1)+(POFI-2)*(IOFI-1)*I(3)+(POFI-
%2)*I(4)+(IOFI-1)*I(5)+I(6))*TACC+(IOFI*M1*N40+(POFI-2)*IOFI*
%M1*N20+(M2-(JOFI-1)*N40+L2-1)*M1*IOFI)*TTRANS
IF(IBB1.EQ.0) GOTO 33
IF(IB1.EQ.IBB1) GOTO 33
IF(IBB1.EQ.2)GOTO 34
IP3=1
INL=NMEM/((IOFI-1)*IB1*N30+IBB1*N30)
55 IF(INL.GT.N40)INL=N40
GOTO 35
33 IF(IB1.GT.2) GOTO 36
IF((M1-(IOFI-1)*IB1*N30).GE.N30) GOTO 36
34 IP1=1
INL=NMEM/(2*M1-(IOFI-1)*IB1*N30)
GOTO 55
36 IP2=1
INL=NMEM/(IOFI*IB1*N30)
IF(INL.GT.N40)INL=N40
35 CALL VALENT(N40,INL,KN1)
CALL VALENT(M2-(JOFI-1)*N40,INL,KN2)
CALL VALENT(INL*IBB1,IB1,KN3)
CALL VALENT((N40-(KN1-1)*INL)*IBB1,IB1,KN4)
IF((IP1+IP2+IP3).NE.1) CALL ERMESF(14)
TIO1=0.
IF(IP3.EQ.1)TIO1=N30*M2*TTRANS*(IB1*(IOFI-1)+IBB1)
IF(IP1.EQ.1)TIO1=M1*M2*TTRANS
IF(IP2.EQ.1) TIO1=(IB1*N30*M2*IOFI*TTRANS)
TTIO=2.*TIO1+(KN1*IOFI*(JOFI-1)+KN2*IOFI+(KN1-1)*(
%JOFI-1)+IOFI*(JOFI-1)+KN2-1.+IOFI+(KN1*(JOFI-1)+KN2))*TACC
%+M1*M2*TTRANS+TIOL
IF((IP1.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
IF((IP1.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT4+AR1
IF((IP2.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3
IF((IP2.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT3+AR2
IFOIS=IB1/IBX1
IF((IP3.EQ.1).AND.(IFOIS*IBX1.EQ.IB1))TCPU=TCPU+AT1+AT2+AT5+AR2
IF((IP3.EQ.1).AND.(IFOIS*IBX1.NE.IB1))TCPU=TCPU+AT1+AT2+AT6+AR2
IF((IP1.EQ.1).AND.(IRZ.EQ.1))TCPU=TCPU+AR5
IF((IP1.EQ.1).AND.(IRZ.EQ.2))TCPU=TCPU+AR5
TTIOG=TTIO+TCPU
IF(TTIOG.LE.0.) GOTO 99
IF(TTIOG.GE.TIOOP) GOTO 99
IBOP=IB1
IBBOP=IBB1
K3OP=K3
TIOOP=TTIOG
TIOOP1=TTIO
TIOOP2=TCPU
99 IF(IB1.GE.MAX)GOTO17
IC=IC+1
GOTO 18
4 T1=JOFI*N20*(L1-1)*REQ
T2=M1*(L2-1)*REQ
T3=JOFI*N20*N30*(RAD+REQ)*K1
T4=JOFI*(K1*N30*N20*(2*RMI+REQ))
T5=JOFI*N20*N30*(2*RAD+REQ)*K1/2
T6=2*JOFI*(K1*N20)*((5*RMI+RMU)+4*RAD+(L1-1)*(2*RAD+REQ)+N30*2*
%RAD+REQ)
T7=JOFI*2*K1*(L1-1)*(2*RAD+REQ)
T9=JOFI*N10*N20*K1*(REQ+RMI)/2+M1*M2*(REQ+RDI+2*RAD)
T8=JOFI*N10*N20*K1*(3*REQ+9*RAD+4*RMU+RMI)/2
T10=JOFI*K1*(3*RMU+2*(RMI+RAD)+N40*(3*RMI
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ)))
PIO=JOFI
IF(PIO.LE.2)PIO=2
TNR=(N40+(PIO-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMU+RMI+RAD+REQ+
%N30*(2*RAD+2*REQ)*K1)
IF(TNR.LE.0.)TNR=0.
BT1=JOFI*N20*WW*K1
BT2=JOFI*N40*WW*K1
BT3=JOFI*N40*(VY1+K1*N30*VY2)
BR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1*2*(REQ+RAD)))+M2*(3*(
$REQ+RAD+RMU)+4*(RMI)+M1*(2*(RAD)+REQ))
BR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ))
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10
TCPU=TCPU+TNR+BT1+BT2
LIOF=M1/(N30)
IRZ=0
IF(LIOF*N30.EQ.M1) GOTO 2344
IRZ=1
2344 IF(IRZ.EQ.0)TCPU=TCPU+BT3
IF(IRZ.NE.0)TCPU=TCPU+BT3+BR2
TIOOP=2.*FLOAT(M1)*FLOAT(M2)*TTRANS+2.*FLOAT(K2)*TACC+TCPU
IBOP=1
IBBOP=0
K3OP=1
TIOOP2=TCPU
TIOOP1=TIOOP-TCPU
17 TTOT=TIOOP+TFF
IF(TTOT.LE.0.) GOTO 3
IF(TTOT.GE.TTOTOP)GOTO3
N1CO=N10
N2CO=N20
IBCO=IBOP
IBBCO=IBBOP
K3CO=K3OP
TTOTOP=TTOT
TESOP=TIOOP1
TCOP=TIOOP2
TFOP=TFF
3 CONTINUE
C
N1=N1CO
N2=N2CO
TTO=TTOTOP
IB=IBCO
IBB=IBBCO
K3=K3CO
TC=TCOP
TS=TESOP
TF=TFOP
TT=TCOP+TFOP
TWER=TTO-TT
IF(N1.EQ.0.OR.N2.EQ.0) CALL OUTSTR(0,'PAS DE PLACE MEMOIRE SUFFISA
$NTE POUR UNE MISE EN OEUVRE PAR BLOCS$')
IF(IB.NE.1)RETURN
IHJ=(M1/(N1-L1+1))
IF(IHJ*(N1-L1+1).NE.M1)IHJ=IHJ+1
IHJ1=IHJ/2
IF(IHJ1*2.NE.IHJ)GOTO7778
IB=IHJ
IBB=0
RETURN
7778 IB=IHJ+1
IBB=0
RETURN
END

7
gcc/testsuite/g77.f-torture/compile/19990905-0.f
View File

@ -1,7 +0,0 @@
* =foo0.f in Burley's g77 test suite.
subroutine sub(a)
common /info/ iarray(1000)
equivalence (m,iarray(100)), (n,iarray(200))
real a(m,n)
a(1,1) = a(2,2)
end

22
gcc/testsuite/g77.f-torture/compile/19990905-2.f
View File

@ -1,22 +0,0 @@
* =watson11.f in Burley's g77 test suite.
* Probably originally submitted by Ian Watson.
* Too small to worry about copyright issues, IMO, since it
* doesn't do anything substantive.
SUBROUTINE OUTDNS(A,B,LCONV)
IMPLICIT REAL*8(A-H,O-Z),INTEGER*4(I-N)
COMMON/ARRAYS/Z(64,8),AB(30,30),PAIRS(9,9),T(9,9),TEMP(9,9),C1(3),
> C2(3),AA(30),BB(30)
EQUIVALENCE (X1,C1(1)),(Y1,C1(2)),(Z1,C1(3))
EQUIVALENCE (X2,C2(1)),(Y2,C2(2)),(Z2,C2(3))
COMMON /CONTRL/
> SHIFT,CONV,SCION,DIVERG,
> IOPT,KCNDO,KINDO,KMINDO,I2EINT,KOHNO,KSLATE,
> N,NG,NUMAT,NSEK,NELECS,NIT,OCCA,OCCB,NOLDAT,NOLDFN
INTEGER*4 OCCA,OCCB
DIMENSION W(N),A(N,N),B(N,N)
DIMENSION BUF(100)
occb=5
ENTRY INDNS (A,B)
40 READ(IREAD) BUF
STOP
END

5
gcc/testsuite/g77.f-torture/compile/20000412-1.f
View File

@ -1,5 +0,0 @@
subroutine aap(k)
equivalence (i,r)
i = k
print*,r
end

21
gcc/testsuite/g77.f-torture/compile/20000511-1.f
View File

@ -1,21 +0,0 @@
subroutine saxpy(n,sa,sx,incx,sy,incy)
C
C constant times a vector plus a vector.
C uses unrolled loop for increments equal to one.
C jack dongarra, linpack, 3/11/78.
C modified 12/3/93, array(1) declarations changed to array(*)
C
real sx(*),sy(*),sa
integer i,incx,incy,ix,iy,m,mp1,n
C
C -ffast-math ICE provoked by this conditional
if(sa /= 0.0)then
C
C code for both increments equal to 1
C
do i= 1,n
sy(i)= sy(i)+sa*sx(i)
enddo
endif
return
end

61
gcc/testsuite/g77.f-torture/compile/20000511-2.f
View File

@ -1,61 +0,0 @@
subroutine sgbcon(norm,n,kl,ku,ab,ldab,ipiv,anorm,rcond,work,iwork
&,info)
C
C -- LAPACK routine (version 3.0) --
C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C Courant Institute, Argonne National Lab, and Rice University
C September 30, 1994
C
C .. Scalar Arguments ..
character norm
integer info,kl,ku,ldab,n
real anorm,rcond
C ..
C .. Array Arguments ..
integer ipiv(n),iwork(n)
real ab(ldab,n),work(n)
C ..
C
C Purpose
C =======
C demonstrate g77 bug at -O -funroll-loops
C =====================================================================
C
C .. Parameters ..
real one,zero
parameter(one= 1.0e+0,zero= 0.0e+0)
C ..
C .. Local Scalars ..
logical lnoti,onenrm
character normin
integer ix,j,jp,kase,kase1,kd,lm
real ainvnm,scale,smlnum,t
C ..
C .. External Functions ..
logical lsame
integer isamax
real sdot,slamch
externallsame,isamax,sdot,slamch
C ..
C .. External Subroutines ..
externalsaxpy,slacon,slatbs,srscl,xerbla
C ..
C .. Executable Statements ..
C
C Multiply by inv(L).
C
do j= 1,n-1
C the following min() intrinsic provokes this bug
lm= min(kl,n-j)
jp= ipiv(j)
t= work(jp)
if(jp.ne.j)then
C but only when combined with this if block
work(jp)= work(j)
work(j)= t
endif
C and this subroutine call
call saxpy(lm,-t,ab(kd+1,j),1,work(j+1),1)
enddo
return
end

16
gcc/testsuite/g77.f-torture/compile/20000518.f
View File

@ -1,16 +0,0 @@
SUBROUTINE SORG2R( K, A, N, LDA )
* ICE in `verify_wide_reg_1', at flow.c:2605 at -O2
* g77 version 2.96 20000515 (experimental) on i686-pc-linux-gnu
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 18 May 2000
INTEGER I, K, LDA, N
REAL A( LDA, * )
DO I = K, 1, -1
IF( I.LT.N ) A( I, I ) = 1.0
A( I, I ) = 1.0
END DO
RETURN
END

28
gcc/testsuite/g77.f-torture/compile/20000601-1.f
View File

@ -1,28 +0,0 @@
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB )
* PR fortran/275
* ICE in `change_address', at emit-rtl.c:1589 with -O1 and above
* g77 version 2.96 20000530 (experimental) on mips-sgi-irix6.5/-mabi=64
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 1 June 2000
INTEGER KL, KU, LDAB, M
REAL AB( LDAB, * )
INTEGER J, JB, JJ, JP, KV, KM
REAL WORK13(65,64), WORK31(65,64)
KV = KU + KL
DO J = 1, M
JB = MIN( 1, M-J+1 )
DO JJ = J, J + JB - 1
KM = MIN( KL, M-JJ )
JP = KM+1
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
END DO
END DO
RETURN
END

27
gcc/testsuite/g77.f-torture/compile/20000601-2.f
View File

@ -1,27 +0,0 @@
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB )
* Slightly modified version of 20000601-1.f that still ICES with
* CVS 20010118 g77 on mips-sgi-irix6.5/-mabi=64.
*
* Originally derived from LAPACK 3.0 test suite failure.
*
* David Billinghurst, (David.Billinghurst@riotinto.com.au)
* 18 January 2001
INTEGER KL, KU, LDAB, M
REAL AB( LDAB, * )
INTEGER J, JB, JJ, JP, KV, KM, F
REAL WORK13(65,64), WORK31(65,64)
KV = KU + KL
DO J = 1, M
JB = MIN( 1, M-J+1 )
DO JJ = J, J + JB - 1
KM = MIN( KL, M-JJ )
JP = F( KM+1, AB( KV+1, JJ ) )
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
$ AB( KV+JP+JJ-J, J ), LDAB-1 )
END DO
END DO
RETURN
END

11
gcc/testsuite/g77.f-torture/compile/20000629-1.f
View File

@ -1,11 +0,0 @@
SUBROUTINE MIST(N, BETA)
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER IA, IQ, M1
DIMENSION BETA(N)
DO 80 IQ=1,M1
IF (BETA(IQ).EQ.0.0D0) GO TO 120
80 CONTINUE
120 IF (IQ.NE.1) GO TO 160
160 M1 = IA(IQ)
RETURN
END

9
gcc/testsuite/g77.f-torture/compile/20000630-2.f
View File

@ -1,9 +0,0 @@
SUBROUTINE CHOUT(CHR,ICNT)
C ICE: failed assertion `expr != NULL'
C Reduced version of GNATS PR fortran/329 from trond.bo@dnmi.no
INTEGER CHR(ICNT)
CHARACTER*255 BUF
BUF(1:1)=CHAR(CHR(1))
CALL FPUTC(1,BUF(1:1))
RETURN
END

9
gcc/testsuite/g77.f-torture/compile/20010115.f
View File

@ -1,9 +0,0 @@
* GNATS PR Fortran/1636
PRINT 42, 'HELLO'
42 FORMAT(A)
CALL WORLD
END
SUBROUTINE WORLD
PRINT 42, 'WORLD'
42 FORMAT(A)
END

8
gcc/testsuite/g77.f-torture/compile/20010321-1.f
View File

@ -1,8 +0,0 @@
# 1 "20010321-1.f"
SUBROUTINE TWOEXP
# 1 "include/implicit.h" 1 3
IMPLICIT DOUBLE PRECISION (A-H)
# 3 "20010321-1.f" 2 3
LOGICAL ANTI
ANTI = .FALSE.
END

6
gcc/testsuite/g77.f-torture/compile/20010426.f
View File

@ -1,6 +0,0 @@
function f(c)
implicit none
real*8 c, f
f = sqrt(c)
return
end

1326
gcc/testsuite/g77.f-torture/compile/20010519-1.f
View File

File diff suppressed because it is too large Load Diff

21
gcc/testsuite/g77.f-torture/compile/20020307-1.f
View File

@ -1,21 +0,0 @@
SUBROUTINE SWEEP
PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20)
REAL*8 B,W1,W2,BNORM,BINV,WT,W0,C1,C2,R1,R2
DIMENSION B(MAXVEC,0:3),W1(MAXVEC,0:3),W2(MAXVEC,0:3)
DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC)
DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC)
DO 200 ILAT=1,2**IDIM
DO 200 I1=1,IDIM
DO 220 I2=1,IDIM
CALL INTACT(ILAT,I1,I1,W1)
220 CONTINUE
DO 310 IATT=1,IDIM
DO 311 I=1,100
WT(I)=ONE + C1(I)*LOG(EPS+R1(I))
IF( R2(I)**2 .LE. (ONE-WT(I)**2) )THEN
W0(I)=WT(I)
ENDIF
311 CONTINUE
310 CONTINUE
200 CONTINUE
END

14
gcc/testsuite/g77.f-torture/compile/20030115-1.c
View File

@ -1,14 +0,0 @@
SUBROUTINE FOO (B)
10 CALL BAR(A)
ASSIGN 20 TO M
IF(100.LT.A) GOTO 10
GOTO 40
C
20 IF(B.LT.ABS(A)) GOTO 10
ASSIGN 30 TO M
GOTO 40
C
30 ASSIGN 10 TO M
40 GOTO M,(10,20,30)
END

14
gcc/testsuite/g77.f-torture/compile/20030326-1.f
View File

@ -1,14 +0,0 @@
C PR fortran/9793
C larson@w6yx.stanford.edu
C
integer a, b, c
c = -2147483648 / -1
a = 1
b = 0
c = a / b
print *, c
end

8
gcc/testsuite/g77.f-torture/compile/8485.f
View File

@ -1,8 +0,0 @@
C Extracted from PR fortran/8485
PARAMETER (PPMULT = 1.0E5)
INTEGER*8 NWRONG
PARAMETER (NWRONG = 8)
PARAMETER (DDMULT = PPMULT * NWRONG)
PRINT 10, DDMULT
10 FORMAT (F10.3)
END

103
gcc/testsuite/g77.f-torture/compile/960317-1.f
View File

@ -1,103 +0,0 @@
* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST)
* From: Kate Hedstrom <kate@ahab.Rutgers.EDU>
* To: burley@gnu.ai.mit.edu
* Subject: g77 bug in assign
*
* I found some files in the NCAR graphics source code which used to
* compile with g77 and now don't. All contain the following combination
* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a
* Sun running SunOS 5.5 (slightly older g77), but compiles on an
* IBM/RS6000:
*
C
SUBROUTINE QUICK
SAVE
C
ASSIGN 101 TO JUMP
101 Continue
C
RETURN
END
*
* Everything else in the NCAR distribution compiled, including quite a
* few C routines.
*
* Kate
*
*
* nemo% g77 -v -c quick.f
* gcc -v -c -xf77 quick.f
* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/specs
* gcc version 2.7.2
* /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/f771 quick.f -fset-g77-defaults -quiet -dumpbase quick.f -version -fversion -o /usr/tmp/cca24166.s
* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.1.
* GNU Fortran Front End version 0.5.18-960314 compiled: Mar 16 1996 14:28:11
* gcc: Internal compiler error: program f771 got fatal signal 11
*
*
* nemo% gdb /usr/local/lib/gcc-lib/*/*/f771 core
* GDB is free software and you are welcome to distribute copies of it
* under certain conditions; type "show copying" to see the conditions.
* There is absolutely no warranty for GDB; type "show warranty" for details.
* GDB 4.14 (sparc-sun-sunos4.1.3),
* Copyright 1995 Free Software Foundation, Inc...
* Core was generated by `f771'.
* Program terminated with signal 11, Segmentation fault.
* Couldn't read input and local registers from core file
* find_solib: Can't read pathname for load map: I/O error
*
* Couldn't read input and local registers from core file
* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
* 7881 if ((ffesymbol_save (s) || ffe_is_saveall ())
* (gdb) where
* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
* Error accessing memory address 0xefffefcc: Invalid argument.
* (gdb)
*
*
* ahab% g77 -v -c quick.f
* gcc -v -c -xf77 quick.f
* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/specs
* gcc version 2.7.2
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase quick.f -version -fversion -o /var/tmp/cca003D2.s
* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.2.
* GNU Fortran Front End version 0.5.18-960304 compiled: Mar 5 1996 16:12:46
* gcc: Internal compiler error: program f771 got fatal signal 11
*
*
* ahab% !gdb
* gdb /usr/local/lib/gcc-lib/*/*/f771 core
* GDB is free software and you are welcome to distribute copies of it
* under certain conditions; type "show copying" to see the conditions.
* There is absolutely no warranty for GDB; type "show warranty" for details.
* GDB 4.15.1 (sparc-sun-solaris2.4),
* Copyright 1995 Free Software Foundation, Inc...
* Core was generated by
* `/usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase'.
* Program terminated with signal 11, Segmentation fault.
* Reading symbols from /usr/lib/libc.so.1...done.
* Reading symbols from /usr/lib/libdl.so.1...done.
* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
* Source file is more recent than executable.
* 7963 assert (st != NULL);
* (gdb) where
* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
* #1 0x38044 in ffecom_expr_ (expr=0x3a23c0, dest_tree=0x0, dest=0x0, dest_used=0x0, assignp=true) at f/com.c:2100
* #2 0x489c8 in ffecom_expr_assign_w (expr=0x3a23c0) at f/com.c:10238
* #3 0xe9228 in ffeste_R838 (label=0x3a1ba8, target=0x3a23c0) at f/ste.c:2769
* #4 0xdae60 in ffestd_stmt_pass_ () at f/std.c:840
* #5 0xdc090 in ffestd_exec_end () at f/std.c:1405
* #6 0xcb534 in ffestc_shriek_subroutine_ (ok=true) at f/stc.c:4849
* #7 0xd8f00 in ffestc_R1225 (name=0x0) at f/stc.c:12307
* #8 0xcc808 in ffestc_end () at f/stc.c:5572
* #9 0x9fa84 in ffestb_end3_ (t=0x3a19c8) at f/stb.c:3216
* #10 0x9f30c in ffestb_end (t=0x3a19c8) at f/stb.c:2995
* #11 0x98414 in ffesta_save_ (t=0x3a19c8) at f/sta.c:453
* #12 0x997ec in ffesta_second_ (t=0x3a19c8) at f/sta.c:1178
* #13 0x8ed84 in ffelex_send_token_ () at f/lex.c:1614
* #14 0x8cab8 in ffelex_finish_statement_ () at f/lex.c:946
* #15 0x91684 in ffelex_file_fixed (wf=0x397780, f=0x37a560) at f/lex.c:2946
* #16 0x107a94 in ffe_file (wf=0x397780, f=0x37a560) at f/top.c:456
* #17 0x96218 in yyparse () at f/parse.c:77
* #18 0x10beac in compile_file (name=0xdffffaf7 "quick.f") at toplev.c:2239
* #19 0x110dc0 in main (argc=9, argv=0xdffff994, envp=0xdffff9bc) at toplev.c:3927

40
gcc/testsuite/g77.f-torture/compile/970125-0.f
View File

@ -1,40 +0,0 @@
C JCB comments:
C g77 doesn't accept the added line "integer(kind=7) ..." --
C it crashes!
C
C It's questionable that g77 DTRT with regarding to passing
C %LOC() as an argument (thus by reference) and the new global
C analysis. I need to look into that further; my feeling is that
C passing %LOC() as an argument should be treated like passing an
C INTEGER(KIND=7) by reference, and no more specially than that
C (and that INTEGER(KIND=7) should be permitted as equivalent to
C INTEGER(KIND=1), INTEGER(KIND=2), or whatever, depending on the
C system's pointer size).
C
C The back end *still* has a bug here, which should be fixed,
C because, currently, what g77 is passing to it is, IMO, correct.
C No options:
C ../../egcs/gcc/f/info.c:259: failed assertion `ffeinfo_types_[basictype][kindtype] != NULL'
C -fno-globals -O:
C ../../egcs/gcc/expr.c:7291: Internal compiler error in function expand_expr
c Frontend bug fixed by JCB 1998-06-01 com.c &c changes.
integer*4 i4
integer*8 i8
integer*8 max4
data max4/2147483647/
i4 = %loc(i4)
i8 = %loc(i8)
print *, max4
print *, i4, %loc(i4)
print *, i8, %loc(i8)
call foo(i4, %loc(i4), i8, %loc(i8))
end
subroutine foo(i4, i4a, i8, i8a)
integer(kind=7) i4a, i8a
integer*8 i8
print *, i4, i4a
print *, i8, i8a
end

20
gcc/testsuite/g77.f-torture/compile/970915-0.f
View File

@ -1,20 +0,0 @@
* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR
* node twice in a given top-level call to it.
* (JCB com.c patch of 1998-06-04.)
SUBROUTINE TSTSIG11
IMPLICIT COMPLEX (A-Z)
EXTERNAL gzi1,gzi2
branch3 = sw2 / cw
. * ( rdw * (epsh*gzi1(A,B)-gzi2(A,B))
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
. + (-1./2. + 2.*sw2/3.) / (sw*cw)
. * rdw * (epsh*gzi1(A,B)-gzi2(A,B)
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B))
. + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
. * rup * (epsh*gzi1(A,B)-gzi2(A,B)
. + rup * (epsh*gzi1(A,B)-gzi2(A,B)) )
. * 4.*(3.-tw**2) * gzi2(A,B)
. + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B)
RETURN
END

28
gcc/testsuite/g77.f-torture/compile/980310-1.f
View File

@ -1,28 +0,0 @@
C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4
C To: egcs-bugs@cygnus.com
C Subject: backend case range problem/fix
C From: Dave Love <d.love@dl.ac.uk>
C Date: 02 Dec 1997 18:11:35 +0000
C Message-ID: <rzqpvnfboo8.fsf@djlvig.dl.ac.uk>
C
C The following Fortran test case aborts the compiler because
C tree_int_cst_lt dereferences a null tree; this is a regression from
C gcc 2.7.
INTEGER N
READ(*,*) N
SELECT CASE (N)
CASE (1:)
WRITE(*,*) 'case 1'
CASE (0)
WRITE(*,*) 'case 0'
END SELECT
END
C The relevant change to cure this is:
C
C Thu Dec 4 06:34:40 1997 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
C
C * stmt.c (pushcase_range): Clean up handling of "infinite" values.
C

43
gcc/testsuite/g77.f-torture/compile/980310-2.f
View File

@ -1,43 +0,0 @@
C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl
C
C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT)
C From: David Bristow <dbristow@lynx.dac.neu.edu>
C To: egcs-bugs@cygnus.com
C Subject: g77 crashes compiling Dungeon
C Message-ID: <Pine.OSF.3.91.970823003521.11281A-100000@lynx.dac.neu.edu>
C
C The following small segment of Dungeon (the adventure that became the
C commercial hit Zork) causes an internal error in f771. The platform is
C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran
C 0.5.21-19970811)
C
C --cut here--cut here--cut here--cut here--cut here--cut here--
C g77 --verbose -fugly -fvxt -c subr_.f
C g77 version 0.5.21-19970811
C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm
C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs
C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental)
C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s
C f771: warning: -fugly is overloaded with meanings and likely to be removed;
C f771: warning: use only the specific -fugly-* options you need
C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental).
C GNU Fortran Front End version 0.5.21-19970811
C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))'
C gcc: Internal compiler error: program f771 got fatal signal 6
C --cut here--cut here--cut here--cut here--cut here--cut here--
C
C Here's the FORTRAN code, it's basically a single subroutine from subr.f
C in the Dungeon source, slightly altered (the original calls RAN(), which
C doesn't exist in the g77 runtime)
C
C RND - Return a random integer mod n
C
INTEGER FUNCTION RND (N)
IMPLICIT INTEGER (A-Z)
REAL RAND
COMMON /SEED/ RNSEED
RND = RAND(RNSEED)*FLOAT(N)
RETURN
END

259
gcc/testsuite/g77.f-torture/compile/980310-3.f
View File

@ -1,259 +0,0 @@
c
c This demonstrates a problem with g77 and pic on x86 where
c egcs 1.0.1 and earlier will generate bogus assembler output.
c unfortunately, gas accepts the bogus acssembler output and
c generates code that almost works.
c
C Date: Wed, 17 Dec 1997 23:20:29 +0000
C From: Joao Cardoso <jcardoso@inescn.pt>
C To: egcs-bugs@cygnus.com
C Subject: egcs-1.0 f77 bug on OSR5
C When trying to compile the Fortran file that I enclose bellow,
C I got an assembler error:
C
C ./g77 -B./ -fpic -O -c scaleg.f
C /usr/tmp/cca002D8.s:123:syntax error at (
C
C ./g77 -B./ -fpic -O0 -c scaleg.f
C /usr/tmp/cca002EW.s:246:invalid operand combination: leal
C
C Compiling without the -fpic flag runs OK.
subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
c
c *****parameters:
integer igh,low,ma,mb,n
double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
c
c *****local variables:
integer i,ir,it,j,jc,kount,nr,nrp2
double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor,
* ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc
c
c *****fortran functions:
double precision dabs, dlog10, dsign
c float
c
c *****subroutines called:
c none
c
c ---------------------------------------------------------------
c
c *****purpose:
c scales the matrices a and b in the generalized eigenvalue
c problem a*x = (lambda)*b*x such that the magnitudes of the
c elements of the submatrices of a and b (as specified by low
c and igh) are close to unity in the least squares sense.
c ref.: ward, r. c., balancing the generalized eigenvalue
c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
c 141-152.
c
c *****parameter description:
c
c on input:
c
c ma,mb integer
c row dimensions of the arrays containing matrices
c a and b respectively, as declared in the main calling
c program dimension statement;
c
c n integer
c order of the matrices a and b;
c
c a real(ma,n)
c contains the a matrix of the generalized eigenproblem
c defined above;
c
c b real(mb,n)
c contains the b matrix of the generalized eigenproblem
c defined above;
c
c low integer
c specifies the beginning -1 for the rows and
c columns of a and b to be scaled;
c
c igh integer
c specifies the ending -1 for the rows and columns
c of a and b to be scaled;
c
c cperm real(n)
c work array. only locations low through igh are
c referenced and altered by this subroutine;
c
c wk real(n,6)
c work array that must contain at least 6*n locations.
c only locations low through igh, n+low through n+igh,
c ..., 5*n+low through 5*n+igh are referenced and
c altered by this subroutine.
c
c on output:
c
c a,b contain the scaled a and b matrices;
c
c cscale real(n)
c contains in its low through igh locations the integer
c exponents of 2 used for the column scaling factors.
c the other locations are not referenced;
c
c wk contains in its low through igh locations the integer
c exponents of 2 used for the row scaling factors.
c
c *****algorithm notes:
c none.
c
c *****history:
c written by r. c. ward.......
c modified 8/86 by bobby bodenheimer so that if
c sum = 0 (corresponding to the case where the matrix
c doesn't need to be scaled) the routine returns.
c
c ---------------------------------------------------------------
c
if (low .eq. igh) go to 410
do 210 i = low,igh
wk(i,1) = 0.0d0
wk(i,2) = 0.0d0
wk(i,3) = 0.0d0
wk(i,4) = 0.0d0
wk(i,5) = 0.0d0
wk(i,6) = 0.0d0
cscale(i) = 0.0d0
cperm(i) = 0.0d0
210 continue
c
c compute right side vector in resulting linear equations
c
basl = dlog10(2.0d0)
do 240 i = low,igh
do 240 j = low,igh
tb = b(i,j)
ta = a(i,j)
if (ta .eq. 0.0d0) go to 220
ta = dlog10(dabs(ta)) / basl
220 continue
if (tb .eq. 0.0d0) go to 230
tb = dlog10(dabs(tb)) / basl
230 continue
wk(i,5) = wk(i,5) - ta - tb
wk(j,6) = wk(j,6) - ta - tb
240 continue
nr = igh-low+1
coef = 1.0d0/float(2*nr)
coef2 = coef*coef
coef5 = 0.5d0*coef2
nrp2 = nr+2
beta = 0.0d0
it = 1
c
c start generalized conjugate gradient iteration
c
250 continue
ew = 0.0d0
ewc = 0.0d0
gamma = 0.0d0
do 260 i = low,igh
gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
ew = ew + wk(i,5)
ewc = ewc + wk(i,6)
260 continue
gamma = coef*gamma - coef2*(ew**2 + ewc**2)
+ - coef5*(ew - ewc)**2
if (it .ne. 1) beta = gamma / pgamma
t = coef5*(ewc - 3.0d0*ew)
tc = coef5*(ew - 3.0d0*ewc)
do 270 i = low,igh
wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
270 continue
c
c apply matrix to vector
c
do 300 i = low,igh
kount = 0
sum = 0.0d0
do 290 j = low,igh
if (a(i,j) .eq. 0.0d0) go to 280
kount = kount+1
sum = sum + cperm(j)
280 continue
if (b(i,j) .eq. 0.0d0) go to 290
kount = kount+1
sum = sum + cperm(j)
290 continue
wk(i,3) = float(kount)*wk(i,2) + sum
300 continue
do 330 j = low,igh
kount = 0
sum = 0.0d0
do 320 i = low,igh
if (a(i,j) .eq. 0.0d0) go to 310
kount = kount+1
sum = sum + wk(i,2)
310 continue
if (b(i,j) .eq. 0.0d0) go to 320
kount = kount+1
sum = sum + wk(i,2)
320 continue
wk(j,4) = float(kount)*cperm(j) + sum
330 continue
sum = 0.0d0
do 340 i = low,igh
sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
340 continue
if(sum.eq.0.0d0) return
alpha = gamma / sum
c
c determine correction to current iterate
c
cmax = 0.0d0
do 350 i = low,igh
cor = alpha * wk(i,2)
if (dabs(cor) .gt. cmax) cmax = dabs(cor)
wk(i,1) = wk(i,1) + cor
cor = alpha * cperm(i)
if (dabs(cor) .gt. cmax) cmax = dabs(cor)
cscale(i) = cscale(i) + cor
350 continue
if (cmax .lt. 0.5d0) go to 370
do 360 i = low,igh
wk(i,5) = wk(i,5) - alpha*wk(i,3)
wk(i,6) = wk(i,6) - alpha*wk(i,4)
360 continue
pgamma = gamma
it = it+1
if (it .le. nrp2) go to 250
c
c end generalized conjugate gradient iteration
c
370 continue
do 380 i = low,igh
ir = wk(i,1) + dsign(0.5d0,wk(i,1))
wk(i,1) = ir
jc = cscale(i) + dsign(0.5d0,cscale(i))
cscale(i) = jc
380 continue
c
c scale a and b
c
do 400 i = 1,igh
ir = wk(i,1)
fi = 2.0d0**ir
if (i .lt. low) fi = 1.0d0
do 400 j =low,n
jc = cscale(j)
fj = 2.0d0**jc
if (j .le. igh) go to 390
if (i .lt. low) go to 400
fj = 1.0d0
390 continue
a(i,j) = a(i,j)*fi*fj
b(i,j) = b(i,j)*fi*fj
400 continue
410 continue
return
c
c last line of scaleg
c
end

348
gcc/testsuite/g77.f-torture/compile/980310-4.f
View File

@ -1,348 +0,0 @@
C To: egcs-bugs@cygnus.com
C Subject: -fPIC problem showing up with fortran on x86
C From: Dave Love <d.love@dl.ac.uk>
C Date: 19 Dec 1997 19:31:41 +0000
C
C
C This illustrates a long-standing problem noted at the end of the g77
C `Actual Bugs' info node and thought to be in the back end. Although
C the report is against gcc 2.7 I can reproduce it (specifically on
C redhat 4.2) with the 971216 egcs snapshot.
C
C g77 version 0.5.21
C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone
C -lf2c -lm
C
C ------------
subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr,
* neval,ier,alist,blist,rlist,elist,iord,last)
C --------------------------------------------------
C
C Modified Feb 1989 by Barry W. Brown to eliminate key
C as argument (use key=1) and to eliminate all Fortran
C output.
C
C Purpose: to make this routine usable from within S.
C
C --------------------------------------------------
c***begin prologue dqage
c***date written 800101 (yymmdd)
c***revision date 830518 (yymmdd)
c***category no. h2a1a1
c***keywords automatic integrator, general-purpose,
c integrand examinator, globally adaptive,
c gauss-kronrod
c***author piessens,robert,appl. math. & progr. div. - k.u.leuven
c de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose the routine calculates an approximation result to a given
c definite integral i = integral of f over (a,b),
c hopefully satisfying following claim for accuracy
c abs(i-reslt).le.max(epsabs,epsrel*abs(i)).
c***description
c
c computation of a definite integral
c standard fortran subroutine
c double precision version
c
c parameters
c on entry
c f - double precision
c function subprogram defining the integrand
c function f(x). the actual name for f needs to be
c declared e x t e r n a l in the driver program.
c
c a - double precision
c lower limit of integration
c
c b - double precision
c upper limit of integration
c
c epsabs - double precision
c absolute accuracy requested
c epsrel - double precision
c relative accuracy requested
c if epsabs.le.0
c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c the routine will end with ier = 6.
c
c key - integer
c key for choice of local integration rule
c a gauss-kronrod pair is used with
c 7 - 15 points if key.lt.2,
c 10 - 21 points if key = 2,
c 15 - 31 points if key = 3,
c 20 - 41 points if key = 4,
c 25 - 51 points if key = 5,
c 30 - 61 points if key.gt.5.
c
c limit - integer
c gives an upperbound on the number of subintervals
c in the partition of (a,b), limit.ge.1.
c
c on return
c result - double precision
c approximation to the integral
c
c abserr - double precision
c estimate of the modulus of the absolute error,
c which should equal or exceed abs(i-result)
c
c neval - integer
c number of integrand evaluations
c
c ier - integer
c ier = 0 normal and reliable termination of the
c routine. it is assumed that the requested
c accuracy has been achieved.
c ier.gt.0 abnormal termination of the routine
c the estimates for result and error are
c less reliable. it is assumed that the
c requested accuracy has not been achieved.
c error messages
c ier = 1 maximum number of subdivisions allowed
c has been achieved. one can allow more
c subdivisions by increasing the value
c of limit.
c however, if this yields no improvement it
c is rather advised to analyze the integrand
c in order to determine the integration
c difficulties. if the position of a local
c difficulty can be determined(e.g.
c singularity, discontinuity within the
c interval) one will probably gain from
c splitting up the interval at this point
c and calling the integrator on the
c subranges. if possible, an appropriate
c special-purpose integrator should be used
c which is designed for handling the type of
c difficulty involved.
c = 2 the occurrence of roundoff error is
c detected, which prevents the requested
c tolerance from being achieved.
c = 3 extremely bad integrand behavior occurs
c at some points of the integration
c interval.
c = 6 the input is invalid, because
c (epsabs.le.0 and
c epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c result, abserr, neval, last, rlist(1) ,
c elist(1) and iord(1) are set to zero.
c alist(1) and blist(1) are set to a and b
c respectively.
c
c alist - double precision
c vector of dimension at least limit, the first
c last elements of which are the left
c end points of the subintervals in the partition
c of the given integration range (a,b)
c
c blist - double precision
c vector of dimension at least limit, the first
c last elements of which are the right
c end points of the subintervals in the partition
c of the given integration range (a,b)
c
c rlist - double precision
c vector of dimension at least limit, the first
c last elements of which are the
c integral approximations on the subintervals
c
c elist - double precision
c vector of dimension at least limit, the first
c last elements of which are the moduli of the
c absolute error estimates on the subintervals
c
c iord - integer
c vector of dimension at least limit, the first k
c elements of which are pointers to the
c error estimates over the subintervals,
c such that elist(iord(1)), ...,
c elist(iord(k)) form a decreasing sequence,
c with k = last if last.le.(limit/2+2), and
c k = limit+1-last otherwise
c
c last - integer
c number of subintervals actually produced in the
c subdivision process
c
c***references (none)
c***routines called d1mach,dqk15,dqk21,dqk31,
c dqk41,dqk51,dqk61,dqpsrt
c***end prologue dqage
c
double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b,
* blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach,
* epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f,
* resabs,result,rlist,uflow
integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval,
* nrmax
c
dimension alist(limit),blist(limit),elist(limit),iord(limit),
* rlist(limit)
c
external f
c
c list of major variables
c -----------------------
c
c alist - list of left end points of all subintervals
c considered up to now
c blist - list of right end points of all subintervals
c considered up to now
c rlist(i) - approximation to the integral over
c (alist(i),blist(i))
c elist(i) - error estimate applying to rlist(i)
c maxerr - pointer to the interval with largest
c error estimate
c errmax - elist(maxerr)
c area - sum of the integrals over the subintervals
c errsum - sum of the errors over the subintervals
c errbnd - requested accuracy max(epsabs,epsrel*
c abs(result))
c *****1 - variable for the left subinterval
c *****2 - variable for the right subinterval
c last - index for subdivision
c
c
c machine dependent constants
c ---------------------------
c
c epmach is the largest relative spacing.
c uflow is the smallest positive magnitude.
c
c***first executable statement dqage
epmach = d1mach(4)
uflow = d1mach(1)
c
c test on validity of parameters
c ------------------------------
c
ier = 0
neval = 0
last = 0
result = 0.0d+00
abserr = 0.0d+00
alist(1) = a
blist(1) = b
rlist(1) = 0.0d+00
elist(1) = 0.0d+00
iord(1) = 0
if(epsabs.le.0.0d+00.and.
* epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6
if(ier.eq.6) go to 999
c
c first approximation to the integral
c -----------------------------------
c
neval = 0
call dqk15(f,a,b,result,abserr,defabs,resabs)
last = 1
rlist(1) = result
elist(1) = abserr
iord(1) = 1
c
c test on accuracy.
c
errbnd = dmax1(epsabs,epsrel*dabs(result))
if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2
if(limit.eq.1) ier = 1
if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs)
* .or.abserr.eq.0.0d+00) go to 60
c
c initialization
c --------------
c
c
errmax = abserr
maxerr = 1
area = result
errsum = abserr
nrmax = 1
iroff1 = 0
iroff2 = 0
c
c main do-loop
c ------------
c
do 30 last = 2,limit
c
c bisect the subinterval with the largest error estimate.
c
a1 = alist(maxerr)
b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
a2 = b1
b2 = blist(maxerr)
call dqk15(f,a1,b1,area1,error1,resabs,defab1)
call dqk15(f,a2,b2,area2,error2,resabs,defab2)
c
c improve previous approximations to integral
c and error and test for accuracy.
c
neval = neval+1
area12 = area1+area2
erro12 = error1+error2
errsum = errsum+erro12-errmax
area = area+area12-rlist(maxerr)
if(defab1.eq.error1.or.defab2.eq.error2) go to 5
if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12)
* .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1
if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1
5 rlist(maxerr) = area1
rlist(last) = area2
errbnd = dmax1(epsabs,epsrel*dabs(area))
if(errsum.le.errbnd) go to 8
c
c test for roundoff error and eventually set error flag.
c
if(iroff1.ge.6.or.iroff2.ge.20) ier = 2
c
c set error flag in the case that the number of subintervals
c equals limit.
c
if(last.eq.limit) ier = 1
c
c set error flag in the case of bad integrand behavior
c at a point of the integration range.
c
if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*
* epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3
c
c append the newly-created intervals to the list.
c
8 if(error2.gt.error1) go to 10
alist(last) = a2
blist(maxerr) = b1
blist(last) = b2
elist(maxerr) = error1
elist(last) = error2
go to 20
10 alist(maxerr) = a2
alist(last) = a1
blist(last) = b1
rlist(maxerr) = area2
rlist(last) = area1
elist(maxerr) = error2
elist(last) = error1
c
c call subroutine dqpsrt to maintain the descending ordering
c in the list of error estimates and select the subinterval
c with the largest error estimate (to be bisected next).
c
20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
if(ier.ne.0.or.errsum.le.errbnd) go to 40
30 continue
c
c compute final result.
c ---------------------
c
40 result = 0.0d+00
do 50 k=1,last
result = result+rlist(k)
50 continue
abserr = errsum
60 neval = 30*neval+15
999 return
end

21
gcc/testsuite/g77.f-torture/compile/980310-6.f
View File

@ -1,21 +0,0 @@
C From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de>
C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de>
C Subject: 971105 g77 bug
C To: egcs-bugs@cygnus.com
C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET)
C I found a bug in g77 in snapshot 971105
subroutine ai (a)
dimension a(-1:*)
return
end
C ai.f: In subroutine `ai':
C ai.f:1:
C subroutine ai (a)
C ^
C Array `a' at (^) is too large to handle
C
C This happens whenever the lower index boundary is negative and the upper index
C boundary is '*'.

50
gcc/testsuite/g77.f-torture/compile/980310-7.f
View File

@ -1,50 +0,0 @@
C From: "David C. Doherty" <doherty@networkcs.com>
C Message-Id: <199711171846.MAA27947@uh.msc.edu>
C Subject: g77: auto arrays + goto = no go
C To: egcs-bugs@cygnus.com
C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST)
C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love
C replied that he was able to reproduce it on rs6000-aix; not on
C others. He suggested that I send it to egcs-bugs.
C Hi - I've observed the following behavior regarding
C automatic arrays and gotos. Seems similar to what I found
C in the docs about computed gotos (but not exactly the same).
C
C I suspect from the nature of the error msg that it's in the GBE.
C
C I'm using egcs-971105, under linux-ppc.
C
C I also observed the same in g77-0.5.19 (and gcc 2.7.2?).
C
C I'd appreciate any advice on this. thanks for the great work.
C --
C >cat testg77.f
subroutine testg77(n, a)
c
implicit none
c
integer n
real a(n)
real b(n)
integer i
c
do i = 1, 10
if (i .gt. 4) goto 100
write(0, '(i2)')i
enddo
c
goto 200
100 continue
200 continue
c
return
end
C >g77 -c testg77.f
C testg77.f: In subroutine `testg77':
C testg77.f:19: label `200' used before containing binding contour
C testg77.f:18: label `100' used before containing binding contour
C --
C If I comment out the b(n) line or replace it with, e.g., b(10),
C it compiles fine.

39
gcc/testsuite/g77.f-torture/compile/980310-8.f
View File

@ -1,39 +0,0 @@
C To: egcs-bugs@cygnus.com
C Subject: egcs-g77 and array indexing
C Reply-To: etseidl@jutland.ca.sandia.gov
C Date: Wed, 26 Nov 1997 10:38:27 -0800
C From: Edward Seidl <etseidl@jutland.ca.sandia.gov>
C
C I have some horrible spaghetti code I'm trying compile with egcs-g77,
C but it's puking on code like the example below. I have no idea if it's
C legal fortran or not, and I'm in no position to change it. All I do know
C is it compiles with a number of other compilers, including f2c and
C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122
C I get the following (on both i686-pc-linux-gnu and alphaev56-unknown-linux-gnu):
C
C foo.f: In subroutine `foobar':
C foo.f:11:
C subroutine foobar(norb,nnorb)
C ^
C Array `norb' at (^) is too large to handle
program foo
implicit integer(A-Z)
dimension norb(6)
nnorb=6
call foobar(norb,nnorb)
stop
end
subroutine foobar(norb,nnorb)
implicit integer(A-Z)
dimension norb(-1:*)
do 10 i=-1,nnorb-2
norb(i) = i+999
10 continue
return
end

48
gcc/testsuite/g77.f-torture/compile/980419-2.f
View File

@ -1,48 +0,0 @@
c SEGVs in loop.c with -O2.
character*80 function nxtlin(lun,ierr,itok)
character onechr*1,twochr*2,thrchr*3
itok=0
do while (.true.)
read (lun,'(a)',iostat=ierr) nxtlin
if (nxtlin(1:1).ne.'#') then
ito=0
do 10 it=1,79
if (nxtlin(it:it).ne.' ' .and. nxtlin(it+1:it+1).eq.' ')
$ then
itast=0
itstrt=0
do itt=ito+1,it
if (nxtlin(itt:itt).eq.'*') itast=itt
enddo
itstrt=ito+1
do while (nxtlin(itstrt:itstrt).eq.' ')
itstrt=itstrt+1
enddo
if (itast.gt.0) then
nchrs=itast-itstrt
if (nchrs.eq.1) then
onechr=nxtlin(itstrt:itstrt)
read (onechr,*) itokn
elseif (nchrs.eq.2) then
twochr=nxtlin(itstrt:itstrt+1)
read (twochr,*) itokn
elseif (nchrs.eq.3) then
thrchr=nxtlin(itstrt:itstrt+2)
read (thrchr,*) itokn
elseif (nchrs.eq.4) then
thrchr=nxtlin(itstrt:itstrt+3)
read (thrchr,*) itokn
endif
itok=itok+itokn
else
itok=itok+1
endif
ito=it+1
endif
10 continue
return
endif
enddo
return
end

6
gcc/testsuite/g77.f-torture/compile/980424-0.f
View File

@ -1,6 +0,0 @@
C crashes in subst_stack_regs_pat on x86-linux, in the "abort();"
C within the switch statement.
SUBROUTINE C(A)
COMPLEX A
WRITE(*,*) A.NE.CMPLX(0.0D0)
END

8
gcc/testsuite/g77.f-torture/compile/980427-0.f
View File

@ -1,8 +0,0 @@
c ../../egcs/gcc/f/com.c:938: failed assertion `TREE_CODE (TREE_TYPE (e)) == REAL_TYPE'
c Fixed by 28-04-1998 global.c (ffeglobal_ref_progunit_) change.
external b
call y(b)
end
subroutine x
a = b()
end

47
gcc/testsuite/g77.f-torture/compile/980519-2.f
View File

@ -1,47 +0,0 @@
* Date: Fri, 17 Apr 1998 14:12:51 +0200
* From: Jean-Paul Jeannot <jeannot@gx-tech.fr>
* Organization: GX Technology France
* To: egcs-bugs@cygnus.com
* Subject: identified bug in g77 on Alpha
*
* Dear Sir,
*
* You will find below the assembly code of a simple Fortran routine which
* crashes with segmentation fault when storing the first element
* in( jT_f-hd_T ) = Xsp
* whereas everything is fine when commenting this line.
*
* The assembly code (generated with
* -ffast-math -fexpensive-optimizations -fomit-frame-pointer -fno-inline
* or with -O5)
* uses a zapnot instruction to copy an address.
* BUT the zapnot parameter is 15 (copuing 4 bytes) instead of 255 (to copy
* 8 bytes).
*
* I guess this is typically a 64 bit issue. As, from my understanding,
* zapnots are used a lot to copy registers, this may create problems
* elsewhere.
*
* Thanks for your help
*
* Jean-Paul Jeannot
*
subroutine simul_trace( in, Xsp, Ysp, Xrcv, Yrcv )
common /Idim/ jT_f, jT_l, nT, nT_dim
common /Idim/ jZ_f, jZ_l, nZ, nZ_dim
common /Idim/ jZ2_f, jZ2_l, nZ2, nZ2_dim
common /Idim/ jzs_f, jzs_l, nzs, nzs_dim, l_amp
common /Idim/ hd_S, hd_Z, hd_T
common /Idim/ nlay, nlayz
common /Idim/ n_work
common /Idim/ nb_calls
real Xsp, Ysp, Xrcv, Yrcv
real in( jT_f-hd_T : jT_l )
in( jT_f-hd_T ) = Xsp
in( jT_f-hd_T + 1 ) = Ysp
in( jT_f-hd_T + 2 ) = Xrcv
in( jT_f-hd_T + 3 ) = Yrcv
end

5
gcc/testsuite/g77.f-torture/compile/980729-0.f
View File

@ -1,5 +0,0 @@
c Got ICE on Alpha only with -mieee (currently not tested).
c Fixed by rth 1998-07-30 alpha.md change.
subroutine a(b,c)
b = max(b,c)
end

23
gcc/testsuite/g77.f-torture/compile/981117-1.f
View File

@ -1,23 +0,0 @@
* egcs-bugs:
* From: Martin Kahlert <martin.kahlert@mchp.siemens.de>
* Subject: ICE in g77 from egcs-19981109
* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de>
* As of 1998-11-17, fails -O2 -fomit-frame-pointer with
* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints:
* (insn 31 83 32 (set (reg:SF 8 %st(0))
* (mult:SF (reg:SF 8 %st(0))
* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil)
* (nil))
* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn
* Fixed sometime before 1998-11-21 -- don't know by which change.
SUBROUTINE SSPTRD
PARAMETER (HALF = 0.5 )
DO I = 1, N
CALL SSPMV(TAUI)
ALPHA = -HALF*TAUI
CALL SAXPY(ALPHA)
ENDDO
END

8
gcc/testsuite/g77.f-torture/compile/990115-1.f
View File

@ -1,8 +0,0 @@
C Derived from lapack
SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
$ WORK, RWORK, INFO )
COMPLEX*16 WORK( * )
DO 20 I = 1, RANK
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
20 CONTINUE
END

10
gcc/testsuite/g77.f-torture/compile/alpha1.f
View File

@ -1,10 +0,0 @@
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

11
gcc/testsuite/g77.f-torture/compile/alpha1.x
View File

@ -1,11 +0,0 @@
# This test fails compilation in cross-endian environments, for example as
# below, with a "sorry" message.
if { [ishost "i\[34567\]86-*-*"] } {
if { [istarget "mmix-knuth-mmixware"]
|| [istarget "powerpc-*-*"] } {
set torture_compile_xfail [istarget]
}
}
return 0

44
gcc/testsuite/g77.f-torture/compile/compile.exp
View File

@ -1,44 +0,0 @@
# 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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
}

9
gcc/testsuite/g77.f-torture/compile/cpp.F
View File

@ -1,9 +0,0 @@
C When run through the C preprocessor, the indentation of the
C CONTINUE line must not be mangled.
subroutine aap(a, n)
dimension a(n)
do 10 i = 1, n
a(i) = i
10 continue
print *, a(1)
end

Some files were not shown because too many files have changed in this diff Show More