diff options
Diffstat (limited to 'gcc/testsuite/g77.f-torture')
20 files changed, 1619 insertions, 0 deletions
diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f new file mode 100644 index 00000000000..c5242446a49 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/io1.f @@ -0,0 +1,10 @@ +* Fixed by 1998-09-28 libI77/open.c change. + open(90,status='scratch') + write(90, '(1X, I1 / 1X, I1)') 1, 2 + rewind 90 + write(90, '(1X, I1)') 1 + rewind 90 ! implicit ENDFILE expected + read(90, *) i + read(90, *, end=10) j + call abort() + 10 end diff --git a/gcc/testsuite/g77.f-torture/execute/io1.x b/gcc/testsuite/g77.f-torture/execute/io1.x new file mode 100644 index 00000000000..6a69a3aadab --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/io1.x @@ -0,0 +1,13 @@ +# Scratch files aren't implemented for mmixware +# (_stat is a stub and files can't be deleted). +# Similar restrictions exist for most simulators. + +if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] + || [istarget "cris-*-elf"] } { + set torture_execute_xfail [istarget] +} + +return 0 diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f new file mode 100644 index 00000000000..032fa41f899 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/labug1.f @@ -0,0 +1,57 @@ + PROGRAM LABUG1 + +* This program core dumps on mips-sgi-irix6.2 when compiled +* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots +* with -O2 +* +* Originally derived from LAPACK test suite. +* Almost any change allows it to run. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 25 November 1998 +* +* .. Parameters .. + INTEGER LDA, LDE + PARAMETER ( LDA = 2500, LDE = 50 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + + INTEGER I, J, M, N + REAL V + COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE) + COMPLEX Z + + N=2 + M=1 +* + do i = 1, m + do j = 1, n + e(i,j) = czero + f(i,j) = czero + end do + end do +* + DO J = 1, N + DO I = 1, M + V = ABS( E(I,J) - F(I,J) ) + END DO + END DO + + CALL SUB2(M,Z) + + END + + subroutine SUB2(I,A) + integer i + complex a + end + + + + + + + + + + diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f new file mode 100644 index 00000000000..0af5b1b0b3f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/large_vec.f @@ -0,0 +1,3 @@ + parameter (nmax=165000) + double precision x(nmax) + end diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f new file mode 100644 index 00000000000..74e42750d55 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/le.f @@ -0,0 +1,29 @@ + program fool + + real foo + integer n + logical t + + foo = 2.5 + n = 5 + + t = (n > foo) + if (t .neqv. .true.) call abort + t = (n >= foo) + if (t .neqv. .true.) call abort + t = (n < foo) + if (t .neqv. .false.) call abort + t = (n <= 5) + if (t .neqv. .true.) call abort + t = (n >= 5 ) + if (t .neqv. .true.) call abort + t = (n == 5) + if (t .neqv. .true.) call abort + t = (n /= 5) + if (t .neqv. .false.) call abort + t = (n /= foo) + if (t .neqv. .true.) call abort + t = (n == foo) + if (t .neqv. .false.) call abort + + end diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f new file mode 100644 index 00000000000..f1024330a71 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/select.f @@ -0,0 +1,173 @@ +C integer byte case with integer byte parameters as case(s) + subroutine ib + integer *1 a /1/ + integer *1 one,two,three + parameter (one=1,two=2,three=3) + select case (a) + case (one) + case (two) + call abort + case (three) + call abort + case default + call abort + end select + print*,'normal ib' + end +C integer halfword case with integer halfword parameters + subroutine ih + integer *2 a /1/ + integer *2 one,two,three + parameter (one=1,two=2,three=3) + select case (a) + case (one) + case (two) + call abort + case (three) + call abort + case default + call abort + end select + print*,'normal ih' + end +C integer case with integer parameters + subroutine iw + integer *4 a /1/ + integer *4 one,two,three + parameter (one=1,two=2,three=3) + select case (a) + case (one) + case (two) + call abort + case (three) + call abort + case default + call abort + end select + print*,'normal iw' + end +C integer double case with integer double parameters + subroutine id + integer *8 a /1/ + integer *8 one,two,three + parameter (one=1,two=2,three=3) + select case (a) + case (one) + case (two) + call abort + case (three) + call abort + case default + call abort + end select + print*,'normal id' + end +C integer byte select with integer case + subroutine ib_mixed + integer*1 s /1/ + select case (s) + case (1) + case (2) + call abort + end select + print*,'ib ok' + end +C integer halfword with integer case + subroutine ih_mixed + integer*2 s /1/ + select case (s) + case (1) + case default + call abort + end select + print*,'ih ok' + end +C integer word with integer case + subroutine iw_mixed + integer s /5/ + select case (s) + case (1) + call abort + case (2) + call abort + case (3) + call abort + case (4) + call abort + case (5) +C + case (6) + call abort + case default + call abort + end select + print*,'iw ok' + end +C integer doubleword with integer case + subroutine id_mixed + integer *8 s /1024/ + select case (s) + case (1) + call abort + case (1023) + call abort + case (1025) + call abort + case (1024) +C + end select + print*,'i8 ok' + end + subroutine l1_mixed + logical*1 s /.TRUE./ + select case (s) + case (.TRUE.) + case (.FALSE.) + call abort + end select + print*,'l1 ok' + end + subroutine l2_mixed + logical*2 s /.FALSE./ + select case (s) + case (.TRUE.) + call abort + case (.FALSE.) + end select + print*,'lh ok' + end + subroutine l4_mixed + logical*4 s /.TRUE./ + select case (s) + case (.FALSE.) + call abort + case (.TRUE.) + end select + print*,'lw ok' + end + subroutine l8_mixed + logical*8 s /.TRUE./ + select case (s) + case (.TRUE.) + case (.FALSE.) + call abort + end select + print*,'ld ok' + end +C main +C -- regression cases + call ib + call ih + call iw + call id +C -- new functionality + call ib_mixed + call ih_mixed + call iw_mixed + call id_mixed + end + + + + + diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f new file mode 100644 index 00000000000..89ae273891c --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/short.f @@ -0,0 +1,57 @@ + program short + + parameter ( N=2 ) + common /chb/ pi,sig(0:N) + common /parm/ h(2,2) + +c initialize some variables + h(2,2) = 1117 + h(2,1) = 1178 + h(1,2) = 1568 + h(1,1) = 1621 + sig(0) = -1. + sig(1) = 0. + sig(2) = 1. + + call printout + stop + end + +c ****************************************************************** + + subroutine printout + parameter ( N=2 ) + common /chb/ pi,sig(0:N) + common /parm/ h(2,2) + dimension yzin1(0:N), yzin2(0:N) + +c function subprograms + z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.) + +c a four-way average of rhobar + do 260 k=0,N + yzin1(k) = 0.25 * + & ( z(2,2,k) + z(1,2,k) + + & z(2,1,k) + z(1,1,k) ) + 260 continue + +c another four-way average of rhobar + do 270 k=0,N + rtmp1 = z(2,2,k) + rtmp2 = z(1,2,k) + rtmp3 = z(2,1,k) + rtmp4 = z(1,1,k) + yzin2(k) = 0.25 * + & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 ) + 270 continue + + do k=0,N + if (yzin1(k) .ne. yzin2(k)) call abort + enddo + if (yzin1(0) .ne. -1371.) call abort + if (yzin1(1) .ne. -685.5) call abort + if (yzin1(2) .ne. 0.) call abort + + return + end + diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f new file mode 100644 index 00000000000..f502bc72833 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/u77-test.f @@ -0,0 +1,421 @@ +*** Some random stuff for testing libU77. Should be done better. It's +* hard to test things where you can't guarantee the result. Have a +* good squint at what it prints, though detected errors will cause +* starred messages. +* +* Currently not tested: +* ALARM +* CHDIR (func) +* CHMOD (func) +* FGET (func/subr) +* FGETC (func) +* FPUT (func/subr) +* FPUTC (func) +* FSTAT (subr) +* GETCWD (subr) +* HOSTNM (subr) +* IRAND +* KILL +* LINK (func) +* LSTAT (subr) +* RENAME (func/subr) +* SIGNAL (subr) +* SRAND +* STAT (subr) +* SYMLNK (func/subr) +* UMASK (func) +* UNLINK (func) +* +* NOTE! This is the testsuite version, so it should compile and +* execute on all targets, and either run to completion (with +* success status) or fail (by calling abort). The *other* version, +* which is a bit more interactive and tests a couple of things +* this one cannot, should be generally the same, and is in +* libf2c/libU77/u77-test.f. Please keep it up-to-date. + + implicit none + + external hostnm +* intrinsic hostnm + integer hostnm + + integer i, j, k, ltarray (9), idat (3), count, rate, count_max, + + pid, mask + real tarray1(2), tarray2(2), r1, r2 + double precision d1 + integer(kind=2) bigi + logical issum + intrinsic getpid, getuid, getgid, ierrno, gerror, time8, + + fnum, isatty, getarg, access, unlink, fstat, iargc, + + stat, lstat, getcwd, gmtime, etime, chmod, itime, date, + + chdir, fgetc, fputc, system_clock, second, idate, secnds, + + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8, + + cpu_time, dtime, ftell, abort + external lenstr, ctrlc + integer lenstr + logical l + character gerr*80, c*1 + character ctim*25, line*80, lognam*20, wd*1000, line2*80, + + ddate*8, ttime*10, zone*5, ctim2*25 + integer fstatb (13), statb (13) + integer *2 i2zero + integer values(8) + integer(kind=7) sigret + + i = time () + ctim = ctime (i) + WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim)) + write (6,'(A,I3,'', '',I3)') + + ' Logical units 5 and 6 correspond (FNUM) to' + + // ' Unix i/o units ', fnum(5), fnum(6) + if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then + print *, 'LNBLNK or LEN_TRIM failed' + call abort + end if + + bigi = time8 () + + call ctime (i, ctim2) + if (ctim .ne. ctim2) then + write (6, *) '*** CALL CTIME disagrees with CTIME(): ', + + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim)) + call doabort + end if + + j = time () + if (i .gt. bigi .or. bigi .gt. j) then + write (6, *) '*** TIME/TIME8/TIME sequence failures: ', + + i, bigi, j + call doabort + end if + + print *, 'Command-line arguments: ', iargc () + do i = 0, iargc () + call getarg (i, line) + print *, 'Arg ', i, ' is: ', line(:lenstr (line)) + end do + + l= isatty(6) + line2 = ttynam(6) + if (l) then + line = 'and 6 is a tty device (ISATTY) named '//line2 + else + line = 'and 6 isn''t a tty device (ISATTY)' + end if + write (6,'(1X,A)') line(:lenstr(line)) + call ttynam (6, line) + if (line .ne. line2) then + print *, '*** CALL TTYNAM disagrees with TTYNAM: ', + + line(:lenstr (line)) + call doabort + end if + +* regression test for compiler crash fixed by JCB 1998-08-04 com.c + sigret = signal(2, ctrlc) + + pid = getpid() + WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid + WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID () + WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID () + WRITE (6, *) 'If you have the `id'' program, the following call' + write (6, *) 'of SYSTEM should agree with the above:' + call flush(6) + CALL SYSTEM ('echo " " `id`') + call flush + + lognam = 'blahblahblah' + call getlog (lognam) + write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam)) + + wd = 'blahblahblah' + call getenv ('LOGNAME', wd) + write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd)) + + call umask(0, mask) + write(6,*) 'UMASK returns', mask + call umask(mask) + + ctim = fdate() + write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim)) + call fdate (ctim) + write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim)) + + j=time() + call ltime (j, ltarray) + write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray + call gmtime (j, ltarray) + write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray + + call system_clock(count) ! omitting optional args + call system_clock(count, rate, count_max) + write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max + + call date_and_time(ddate) ! omitting optional args + call date_and_time(ddate, ttime, zone, values) + write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ', + + zone, ' ', values + + write (6,*) 'Sleeping for 1 second (SLEEP) ...' + call sleep (1) + +c consistency-check etime vs. dtime for first call + r1 = etime (tarray1) + r2 = dtime (tarray2) + if (abs (r1-r2).gt.1.0) then + write (6,*) + + 'Results of ETIME and DTIME differ by more than a second:', + + r1, r2 + call doabort + end if + if (.not. issum (r1, tarray1(1), tarray1(2))) then + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1(1), '+', tarray1(2) + call doabort + end if + if (.not. issum (r2, tarray2(1), tarray2(2))) then + write (6,*) '*** DTIME didn''t return sum of the array: ', + + r2, ' /= ', tarray2(1), '+', tarray2(2) + call doabort + end if + write (6, '(A,3F10.3)') + + ' Elapsed total, user, system time (ETIME): ', + + r1, tarray1 + +c now try to get times to change enough to see in etime/dtime + write (6,*) 'Looping until clock ticks at least once...' + do i = 1,1000 + do j = 1,1000 + end do + call dtime (tarray2, r2) + if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit + end do + call etime (tarray1, r1) + if (.not. issum (r1, tarray1(1), tarray1(2))) then + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1(1), '+', tarray1(2) + call doabort + end if + if (.not. issum (r2, tarray2(1), tarray2(2))) then + write (6,*) '*** DTIME didn''t return sum of the array: ', + + r2, ' /= ', tarray2(1), '+', tarray2(2) + call doabort + end if + write (6, '(A,3F10.3)') + + ' Differences in total, user, system time (DTIME): ', + + r2, tarray2 + write (6, '(A,3F10.3)') + + ' Elapsed total, user, system time (ETIME): ', + + r1, tarray1 + write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)' + + call idate (i,j,k) + call idate (idat) + write (6,*) 'IDATE (date,month,year): ',idat + print *, '... and the VXT version (month,date,year): ', i,j,k + if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then + print *, '*** VXT and U77 versions don''t agree' + call doabort + end if + + call date (ctim) + write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim)) + + call itime (idat) + write (6,*) 'ITIME (hour,minutes,seconds): ', idat + + call time(line(:8)) + print *, 'TIME: ', line(:8) + + write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) + + write (6,*) 'SECOND returns: ', second() + call dumdum(r1) + call second(r1) + write (6,*) 'CALL SECOND returns: ', r1 + +* compiler crash fixed by 1998-10-01 com.c change + if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then + write (6,*) '*** rand(0) error' + call doabort() + end if + + i = getcwd(wd) + if (i.ne.0) then + call perror ('*** getcwd') + call doabort + else + write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' + end if + call chdir ('.',i) + if (i.ne.0) then + write (6,*) '***CHDIR to ".": ', i + call doabort + end if + + i=hostnm(wd) + if(i.ne.0) then + call perror ('*** hostnm') + call doabort + else + write (6,*) 'Host name is ', wd(:lenstr(wd)) + end if + + i = access('/dev/null ', 'rw') + if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i + write (6,*) 'Creating file "foo" for testing...' + open (3,file='foo',status='UNKNOWN') + rewind 3 + call fputc(3, 'c',i) + call fputc(3, 'd',j) + if (i+j.ne.0) write(6,*) '***FPUTC: ', i +C why is it necessary to reopen? (who wrote this?) +C the better to test with, my dear! (-- burley) + close(3) + open(3,file='foo',status='old') + call fseek(3,0,0,*10) + go to 20 + 10 write(6,*) '***FSEEK failed' + call doabort + 20 call fgetc(3, c,i) + if (i.ne.0) then + write(6,*) '***FGETC: ', i + call doabort + end if + if (c.ne.'c') then + write(6,*) '***FGETC read the wrong thing: ', ichar(c) + call doabort + end if + i= ftell(3) + if (i.ne.1) then + write(6,*) '***FTELL offset: ', i + call doabort + end if + call ftell(3, i) + if (i.ne.1) then + write(6,*) '***CALL FTELL offset: ', i + call doabort + end if + call chmod ('foo', 'a+w',i) + if (i.ne.0) then + write (6,*) '***CHMOD of "foo": ', i + call doabort + end if + i = fstat (3, fstatb) + if (i.ne.0) then + write (6,*) '***FSTAT of "foo": ', i + call doabort + end if + i = stat ('foo', statb) + if (i.ne.0) then + write (6,*) '***STAT of "foo": ', i + call doabort + end if + write (6,*) ' with stat array ', statb + if (statb(6) .ne. getgid ()) then + write (6,*) 'Note: FSTAT gid wrong (happens on some systems).' + end if + if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then + write (6,*) '*** FSTAT uid or nlink is wrong' + call doabort + end if + do i=1,13 + if (fstatb (i) .ne. statb (i)) then + write (6,*) '*** FSTAT and STAT don''t agree on '// ' + + array element ', i, ' value ', fstatb (i), statb (i) + call abort + end if + end do + i = lstat ('foo', fstatb) + do i=1,13 + if (fstatb (i) .ne. statb (i)) then + write (6,*) '*** LSTAT and STAT don''t agree on '// + + 'array element ', i, ' value ', fstatb (i), statb (i) + call abort + end if + end do + +C in case it exists already: + call unlink ('bar',i) + call link ('foo ', 'bar ',i) + if (i.ne.0) then + write (6,*) '***LINK "foo" to "bar" failed: ', i + call doabort + end if + call unlink ('foo',i) + if (i.ne.0) then + write (6,*) '***UNLINK "foo" failed: ', i + call doabort + end if + call unlink ('foo',i) + if (i.eq.0) then + write (6,*) '***UNLINK "foo" again: ', i + call doabort + end if + + call gerror (gerr) + i = ierrno() + write (6,'(A,I3,A/1X,A)') ' The current error number is: ', + + i, + + ' and the corresponding message is:', gerr(:lenstr(gerr)) + write (6,*) 'This is sent to stderr prefixed by the program name' + call getarg (0, line) + call perror (line (:lenstr (line))) + call unlink ('bar') + + print *, 'MCLOCK returns ', mclock () + print *, 'MCLOCK8 returns ', mclock8 () + + call cpu_time (d1) + print *, 'CPU_TIME returns ', d1 + +C WRITE (6,*) 'You should see exit status 1' + CALL EXIT(0) + 99 END + +* Return length of STR not including trailing blanks, but always > 0. + integer function lenstr (str) + character*(*) str + if (str.eq.' ') then + lenstr=1 + else + lenstr = lnblnk (str) + end if + end + +* Just make sure SECOND() doesn't "magically" work the second time. + subroutine dumdum(r) + r = 3.14159 + end + +* Test whether sum is approximately left+right. + logical function issum (sum, left, right) + implicit none + real sum, left, right + real mysum, delta, width + mysum = left + right + delta = abs (mysum - sum) + width = abs (left) + abs (right) + issum = (delta .le. .0001 * width) + end + +* Signal handler + subroutine ctrlc + print *, 'Got ^C' + call doabort + end + +* A problem has been noticed, so maybe abort the test. + subroutine doabort +* For this version, call the ABORT intrinsic. + intrinsic abort + call abort + end + +* Testsuite version only. +* Don't actually reference the HOSTNM intrinsic, because some targets +* need -lsocket, which we don't have a mechanism for supplying. + integer function hostnm(nm) + character*(*) nm + nm = 'not determined by this version of u77-test.f' + hostnm = 0 + end diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.x b/gcc/testsuite/g77.f-torture/execute/u77-test.x new file mode 100644 index 00000000000..e4b89008c25 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/execute/u77-test.x @@ -0,0 +1,12 @@ +# Various intrinsics not implemented and not implementable; will fail at +# link time. + +if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] + || [istarget "cris-*-elf"] } { + set torture_compile_xfail [istarget] +} + +return 0 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f new file mode 100644 index 00000000000..0cc9087d6cb --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f @@ -0,0 +1,89 @@ +* Resent-From: Craig Burley <burley@gnu.org> +* Resent-To: craig@jcb-sc.com +* X-Delivered: at request of burley on mescaline.gnu.org +* Date: Wed, 16 Dec 1998 18:31:24 +0100 +* From: Dieter Stueken <stueken@conterra.de> +* Organization: con terra GmbH +* To: fortran@gnu.org +* Subject: possible bug +* Content-Type: text/plain; charset=iso-8859-1 +* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085 +* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2 +* +* Hi, +* +* I'm about to compile a very old, very ugly Fortran program. +* For one part I got: +* +* f77: Internal compiler error: program f771 got fatal signal 6 +* +* instead of any detailed error message. I was able to break down the +* problem to the following source fragment: +* +* ------------------------------------------- + PROGRAM WAP + + integer*2 ios + character*80 name + + name = 'blah' + open(unit=8,status='unknown',file=name,form='formatted', + F iostat=ios) + + END +* ------------------------------------------- +* +* The problem seems to be caused by the "integer*2 ios" declaration. +* So far I solved it by simply using a plain integer instead. +* +* I'm running gcc on a Linux system compiled/installed +* with no special options: +* +* -> g77 -v +* g77 version 0.5.23 +* Driving: g77 -v -c -xf77-version /dev/null -xnone +* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs +* gcc version 2.8.1 +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef +* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__ +* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional +* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__ +* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null +* /dev/null +* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF) +* #include "..." search starts here: +* #include <...> search starts here: +* /usr/local/include +* /usr/i686-pc-linux-gnulibc1/include +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include +* /usr/include +* End of search list. +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version +* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s +* /dev/null +* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version +* 2.8.1. +* GNU Fortran Front End version 0.5.23 +* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s +* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1 +* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911 +* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o +* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc +* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o +* /usr/lib/crtn.o +* /tmp/cca24911 +* __G77_LIBF77_VERSION__: 0.5.23 +* @(#)LIBF77 VERSION 19970919 +* __G77_LIBI77_VERSION__: 0.5.23 +* @(#) LIBI77 VERSION pjw,dmg-mods 19980405 +* __G77_LIBU77_VERSION__: 0.5.23 +* @(#) LIBU77 VERSION 19970919 +* +* +* Regards, Dieter. +* -- +* Dieter Stüken, con terra GmbH, Münster +* stueken@conterra.de stueken@qgp.uni-muenster.de +* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken +* (0)251-980-2027 (0)251-83-334974 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f new file mode 100644 index 00000000000..25b7c5b2b52 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f @@ -0,0 +1,13 @@ + 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 + 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 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f new file mode 100644 index 00000000000..86d2a939064 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990826-4.f @@ -0,0 +1,648 @@ +* Culled from 970528-1.f in Burley's g77 test suite. Copyright +* status not clear. Feel free to chop down if the bug is still +* reproducible (see end of test case for how bug shows up in gdb +* run of f771). No particular reason it should be a noncompile +* case, other than that I didn't want to spend time "fixing" it +* to compile cleanly (with -O0, which works) while making sure the +* ICE remained reproducible. -- burley 1999-08-26 + +* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200) +* From: "D. O'Donoghue" <dod@da.saao.ac.za> +* To: Craig Burley <burley@gnu.ai.mit.edu> +* Cc: fortran@gnu.ai.mit.edu +* Subject: Re: g77 problems + + program dophot + parameter (napple = 4) + common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50) + common/io/luout,ludebg + common/search/nstot,thresh + common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1, + + mfit2,ind(npmax) + common /starlist/ starpar(npmax,nsmax), imtype(nsmax), + 1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax) + common /aperlist/ apple(napple ,nsmax) + common /parpred / ava(npmax) + common /unitize / ufactor + common /undergnd/ nfast, nslow + common/bzero/ scale,zero + common /ctimes / chiimp, apertime, filltime, addtime + common / drfake / needit + common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim + common /vers/ version + logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy + logical fixed,piped,debug,ex,clinfo + character header*5760,rhead*2880 + character yn*1,version*40,ccd*4,infile*20 + character*30 numf,odir,record*80 + integer*2 instr(8) + character*800 line + external pseud0d, pseud2d, pseud4d, pseudmd, shape +C +C Initialization + data burn, fixedxy,fixed, piped + + /.false.,.false.,.false.,.false./ + data needit,screen,comd,isub + + /.true.,.false.,.true.,.false. / + data acc / .01, -.03, -.03, .01, .03, .1, .03 / + data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 / +C + version = 'DoPHOT Version 1.0 LINUX May 97 ' + debug=.false. + clinfo=.false. + line(1:800) = ' ' + odir = ' ' +C +C +C Read default tuneable parameters + call tuneup ( nccd, ccd, piped, debug ) + version(33:36) = ccd(1:4) +C + + ludebg=6 + if(piped)then + yn='n' + else + write(*,'(''****************************************'')') + write(*,1000) version + write(*,'(''****************************************''//)') +C + write(*,'(''Screen output (y/[n])? '',$)') + read(*,1000) yn + end if + if(yn.eq.'y'.or.yn.eq.'Y') then + screen=.true. + luout=6 + else + luout=2 + end if +C + if(piped)then + yn='y' + else + write(*,'(''Batch mode ([y]/n)? '',$)') + read(*,1000) yn + end if + if(yn.eq.'n'.or.yn.eq.'N') comd = .false. +C + if(.not.comd) then + write(*, + * '(''Do you want windowing ([y]/n)? '',$)') + read(*,1000)yn + iwindo=1 + if(yn.eq.'n'.or.yn.eq.'N')then + nwindo=0 + iwindo=0 + end if +C + write(*, + * '(''Star classification info (y/[n]) ?'',$)') + read(*,1000)yn + clinfo=.false. + if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true. +C + write(*, + * '(''Create a star-subtracted frame (y/[n])? '',$)') + read(*,1000) yn + if(yn.eq.'y'.or.yn.eq.'Y') isub = .true. +C + write(*,'(''Apply after-burner (y/[n])? '',$)') + read(*,1000) yn + if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true. + wrtres = burn +C + write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)') + read(*,1000) yn + if ( yn.eq.'y'.or.yn.eq.'Y' ) then + fixedxy = .true. + fixed = .true. + burn = .true. + wrtres = .true. + endif + endif + iopen=0 +C +C This is the start of the loop over the input files +c + iframe=0 + open(10,file='timing',status='unknown',access='append') + +1 ifit = 0 + iapr = 0 + itmn = 0 + model = 1 + xc = 0.0 + yc = 0.0 + rc = 0.0 + ibr = 0 + ixy = 0 +C + iframe=iframe+1 + tgetpar=0.0 + tsearch=0.0 + tshape=0.0 + timprove=0.0 +C +C Batch mode ... + + if ( comd ) then + if(iopen.eq.0)then + iopen=1 + open(11,file='dophot.bat',status='old',err=995) + end if + read(11,1000,end=999)infile +c now read in the parameter instructions. these are: +c instr(1) : if 1, specifies uncrowded field, otherwise crowded +c instr(2) : if 1, specifies sequential frames of same field +c with a window around the stars of interest - +c all other objects are ignored +c instr(3) : if 0, takes cmin from dophot.inp (via tuneup) +c if>0, sets cmin=instr(3) +c instr(4) : if 0, does nothing +c if 1, then opens a file called classifications +c sets clinfo to .true. and writes out the star +c typing info to this file +c instr(5) : Delete the shd.nnnnnnn file +c instr(6) : Delete the out.nnnnnnn file +c instr(7) : Delete the input frame +c instr(8) : Create a star-subtracted frame + read(11,*)instr + read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy + nocrwd = instr(1) + iwindo=instr(2) + if(iwindo.eq.0)nwindo=0 + itmn=tmn + if ( instr(3).gt.0 ) cmin=instr(3) + clinfo=.false. + if ( instr(4).gt.0 )then + clinfo=.true. + open(12,file='classifications',status='unknown') + ludebg=12 + end if + if ( instr(8).ne.0 ) then + isub = .true. + else + isub = .false. + endif +C + if(ibr.ne.0) burn = .true. + if(ixy.ne.0) then + fixedxy = .true. + fixed = .true. + burn = .true. + goto 20 + endif + if(iwindo.eq.0)then + write(6,10)iframe,infile(1:15) + 10 format(' ***** DoPHOT-ing frame ',i4,': ',a) + if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15) + 11 format(////' ',62('*')/ + * ' * DoPHOT-ing frame ',i4,': ',a, + * ' *'/' ',62('*')) + end if + if(iwindo.eq.1)then + write(6,12)iframe,infile(1:15) + 12 format(' ***** DoPHOT-ing frame ',i4,': ',a, + * ' - Windowed *****') + if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15) + 13 format(////' ',62('*')/ + * ' * DoPHOT-ing frame ',i4,': ',a, + * ' - Windowed *'/2x,62('*')) + end if +C +C Interactive... + else + write(*,'(''Image name: '',$)') + read(*,1000) infile + if(infile(1:1).eq.' ') goto 999 +1000 format(a) + write(*,'(''Crowded field mode ([y]/n) ? '',$)') + read(*,1000)yn + nocrwd=0 + if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1 + if(.not.fixed) then + write(*,1001) +1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$) + read(*,1000)record + if(record.ne.' ')then + read(record,*) model + else + model=1 + end if + else + burn=.true. + goto 20 + endif + endif +C +C if windowing, open the file and read the window + if(iwindo.eq.1)then + inquire(file='windows',exist=ex) + if(.not.ex)go to 997 + if(iframe.eq.1)open(9,file='windows',status='old') + nwindo=0 + 2 read(9,*,end=3)intype,inx,iny,inbox + nwindo=nwindo+1 + if(nwindo.gt.50)then + print *,'too many windows - max = 50' + stop + end if + ixwin(nwindo)=inx + iywin(nwindo)=iny + iboxwin(nwindo)=inbox + itype(nwindo)=intype + go to 2 + + 3 rewind 9 + if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j), + * j=1,nwindo) + 4 format(' Windows: Type X Y Size'/ + * (I13,i6,i5,i5)) + end if + + t1 = cputime(0.0) +C +C Read FITS frame. + call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd) +C +C Ignore frame if not the correct chip + if(nc.lt.0) goto 900 +C +C Estimate starting PSF parameters. + 15 call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax, + * iframe) + tgetpar = cputime(t1) + tgetpar + if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax + 16 format(' Getparams on frame ',i4,' sky ',f6.1,' gxwid ',f5.1, + * ' gywid ',f5.1,' tmin ',f5.1,' tmax ',f5.1) +C +C Initialize + do j=1,nsmax + imtype(j) = 0 + do i=1,npmax + shadow(i,j)=0. + shaderr(i,j)=0. + enddo + enddo +C + skyguess=skyval + tfac = 1.0 +C Use 4.5 X SD as fitting width + fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5 + i=fitr + irect(1)=i + irect(2)=fitr/asprat +C Use 4/3 X FitFac X SD as aperture width + gmax = asprat*gywid + if(gxwid.gt.gmax) gmax=gxwid + aprw = 1.33*fitfac*sqrt(gmax) + 0.5 + i = aprw + arect(1) = i + i = aprw/asprat + 0.1 + arect(2) = i +C + if(irect(1).gt.50) irect(1)=50 + if(irect(2).gt.50) irect(2)=50 + if(arect(1).gt.45.) arect(1)=45. + if(arect(2).gt.45.) arect(2)=45. +C + if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon) +C +C Prompt for further information + if ( .not.comd ) then + write(*,1002) + 1002 format(/'The above are the inital parameters DoPHOT'/ + * 'has found. You can change them now or accept'/ + * 'the values in [ ] by pressing enter'/) + + write(*,1004)tmin + 1004 format('Enter Tmin: threshold for star detection', + * ' [',f5.1,'] ',$) + read(*,1000)record + if(record.ne.' ')read(record,*)tmin + + write(*,1005)cmin + 1005 format('Enter Cmin: threshold for PSF stars', + * ' [',f5.1,'] ',$) + read(*,1000)record + if(record.ne.' ')read(record,*)cmin + + write(*,1006) + 1006 format('Do you want to fix the aperture mag size ?', + * ' (y/[n]) ') + read(*,1000)record + if(record.eq.'y'.or.record.eq.'Y')then + write(*,1007) + 1007 format('Enter the size in pixels: ',$) + read(*,*)iapr + if(iapr.gt.0) then + arect(1)=iapr + i = iapr/asprat + 0.1 + arect(2)=i + end if + endif +C + write(*,1008) + 1008 format('Satisfied with other input parameters ? ([y]/n)?',$) + read(*,1000) yn + if(yn.eq.'n'.or.yn.eq.'N')then + yn='n' + else + yn='y' + end if + if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input + else + if ( ifit.ne.0 ) then + irect(1)=ifit + irect(2)=(ifit/asprat + 0.1) + endif + if ( iapr.ne.0 ) then + arect(1)=iapr + i = iapr/asprat + 0.1 + arect(2)=i + endif + if ( itmn.ne.0 ) tmin = itmn + if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then + xcen = xc + ycen = yc + endif + endif +C +C-------------------------------- +C +C + call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon, + +nfast, nslow ) +C +C if the uncrowded field option has been chosen, jump +C straight to the minimum threshold +C + if(nocrwd.eq.1)tmax=tmin +C +C Adjust tfac so that thresh ends precisely on Tmin. + if(tmin/tmax .gt. 0.999) then + thresh = tmin + tfac = 1. + else + thresh = tmax + xnum = alog10(tmax/tmin)/alog10(2.**tfac) + if(xnum.gt.1.5) then + xnum = float(nint(xnum)) + else if(xnum.ge.1) then + xnum = 2.0 + else + xnum = 1.0 + endif + tfac = alog10(tmax/tmin)/alog10(2.)/xnum + endif +C +C------------------------------------------------------------------------ +C +C This is the BIG LOOP which searches the frame for stars +C with intensities > thresh. +C +C----------------------------------------------------------------------- +C + loop = .true. + nstot = 0 + do while ( loop ) + loop = thresh/tmin .ge. 1.01 + write(luout,1050) thresh +1050 format(/20('-')/'THRESHOLD: ', f10.3) + if(ludebg.eq.12)write(ludebg,1050) thresh +C +C Fit given model to sky values. +C + call varipar(nstot, nfast, nslow ) + t1 = cputime(0.0) +C +C Identifies potential objects in cleaned array IMG + nstar = isearch( pseud2d, nfast, nslow , clinfo) + tsearch = cputime(t1) + tsearch +C + if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then +C +C Performs 7-parameter PSF fit and determines nature of object. + t1 = cputime(0.0) + call shape(pseud2d,pseud4d,nfast,nslow,clinfo) + tshape = cputime(t1) + tshape +C +C Computes average sky values etc from star list + call paravg + t1 = cputime(0.0) +C +C Computes 4-parameter fits for all stellar objects using +C new average shape parameters. + call improve(pseud2d,nfast,nslow,clinfo) + timprove = cputime(t1) + timprove + end if +C +C Calculate aperture photometry on last pass. + if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow ) +C + totaltime = (tgetpar+tsearch+tshape+timprove) + write(3,1060) totaltime + write(4,1060) totaltime + write(luout,1060) totaltime +1060 format('Total CPU time consumed:',F10.2,' seconds.') + write(10,1070)infile,tgetpar,tsearch,tshape,timprove, + * totaltime +1070 format(a20,' T(getp/f)',f5.1,' T(search)',f5.1, + * ' T(shape)',f5.1,' T(improve)',f5.1, + * ' Total',f6.1) + call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums) + rewind(2) + rewind(3) + rewind(4) +C + call output ( line ) +C +C Now reduce the threshold and loop back +C + thresh = thresh/2.**tfac + end do +C +C--------- END OF BIG LOOP --------------------------------------- +C +C If after-burner required, residuals from analytic PSF are computed +C and stored in RES. +C +20 if ( burn ) then +C +C If using a fixed (X,Y) coordinate list, read it. + if (fixed) then +C Read the image frame + call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line) +C +C Initialize arrays, open files etc. + call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon, + +nfast, nslow ) +C +C Read the XY list + write(luout,'(''Reading XY list ...'')') + call xylist(numf, nc, ios ) + if(ios.ne.0) then + fixed = .false. + write(luout,'(''SXY file absent or incorrect...'')') + goto 15 + endif +C + call htype(line,skyval,.false.,fitr,ngr,ncon) +C +C Remove good stars + write(luout,'(''Cleaning frame of stars: '',i8)') nstot + call clean ( pseud2d, nstot, nfast, nslow, -1) +C +C Calculate aperture photometry +C call aper ( pseud2d, nstot, nfast, nslow ) + else + rewind(3) + rewind(4) + endif +C +C----------------------- +C Flag all stars close together in groups. Keep making the distance +C criterion FITR smaller until the maximum number in a group is less +C than NFMAX +C + fitr = amax1(arect(1),arect(2)) + fitr = fitr + 2.0 + nmax = 10000 + write(*,'(''Regrouping ...'')') +C + do while ( nmax.gt.nfmax ) + fitr = fitr - 1.0 + write(luout,'(''Min distance ='',f8.1)') fitr + call regroup( fitr, ngr, nmax ) + enddo +C + xlim = irect(1)/2 + ylim = irect(2)/2 +C +C Calculate normalized PSF residual from PSEUD2D + call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect, + +arect,ztot,nums) + if(nums.eq.0) then + write(luout,'(''No suitable PSF stars!'')') + goto 30 + endif +C + write(luout,'(/''AFTERBURNER tuned ON!'')') +C +C Fit multiple stars in a group with enhanced PSF using box size IRECT. + call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect ) +C +C Re-calculate aperture photometry + call aperm ( pseudmd, nstot, nfast, nslow ) +C + call skyadj ( nstot ) +C + call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums) + call output ( line ) + endif +C--------------------- +C +C----- This section skipped if PSF residual not written out ------ +C +30 if( isub ) then +C +C Write final Cleaned array. + infile = 'x'//numf(1:nc)//'.fits' + call putfits(2,infile,header,nhead,nfast,nslow) + close(2) +C +C If afterburner used, then residual array also written out. +C Find suitable scale for writing residual PSF to FITS "R" file. +C + if ( wrtres ) then + scale=20000.0/(rmx-rmn) + zero=-scale*rmn + do j=-nres,nres + jj=nres+j+1 + do i=-nres,nres + ii=nres+i+1 + big(ii,jj)=scale*res(i,j)+zero + enddo + enddo + nx=2*nres+1 +C + infile = 'r'//numf(1:nc)//'.fits' + zer=-zero/scale + scl=1.0/scale +C +C Create a FITS header for the normalized PSF residual image + call sethead(rhead,numf,nx,nx,zer,scl) + scale=1.0 + zero=0.0 +C Write the normalized PSF residual image + call putfits(2,infile,rhead,1,nx,nx) + close(2) + endif +C + end if +C +C +900 close(1) + close(3) + close(4) + if ( .not.screen ) close(luout) + if(comd) then + if(instr(5).eq.1)call system('rm shd.'//numf(1:nc)) + if(instr(6).eq.1)call system('rm out.'//numf(1:nc)) + n=1 + do while(infile(n:n).ne.' ') + n=n+1 + end do + if(instr(7).eq.1)call system('rm '//infile(1:n-1)) + end if + fixed = fixedxy + goto 1 +C +995 print 996 +996 format(/'*** Fatal error ***'/ + * 'You asked for batch processing but'/ + * 'I cant open the "dophot.bat" file.'/ + * 'Please make one (using batchdophot)'/ + * 'and restart DoPHOT'/) + go to 999 + +C +997 print 998 +998 format(/'*** Fatal error ***'/ + * 'You asked for "windowed" processing'/ + * 'but I cant open the "windows" file.'/ + * 'Please make one and restart DoPHOT'/) + +999 call exit(0) + end + +* (gdb) r +* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O +* [...] +* Breakpoint 2, fancy_abort ( +* file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399, +* function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010 +* (gdb) up +* #1 0x8222fab in output_fp_cc0_set (insn=0x8382324) +* at ../../g77-e/gcc/config/i386/i386.c:4399 +* (gdb) p insn +* $1 = 0x3a +* (gdb) up +* #2 0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60) +* at ../../g77-e/gcc/config/i386/i386.c:4205 +* (gdb) p insn +* $2 = 0x8382324 +* (gdb) whatis insn +* type = rtx +* (gdb) pr +* (insn 2181 2180 2191 (parallel[ +* (set (cc0) +* (compare (reg:SF 8 %st(0)) +* (mem:SF (plus:SI (reg:SI 6 %ebp) +* (const_int -9948 [0xffffd924])) 0))) +* (clobber (reg:HI 0 %ax)) +* ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil))) +* (expr_list:REG_DEAD (reg:DF 8 %st(0)) +* (expr_list:REG_UNUSED (reg:HI 0 %ax) +* (nil)))) +* (gdb) diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f new file mode 100644 index 00000000000..026d05e4b3c --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/19990905-1.f @@ -0,0 +1,8 @@ +* =foo7.f in Burley's g77 test suite. + subroutine x + real a(n) + common /foo/n + continue + entry y(a) + call foo(a(1)) + end diff --git a/gcc/testsuite/g77.f-torture/noncompile/9263.f b/gcc/testsuite/g77.f-torture/noncompile/9263.f new file mode 100644 index 00000000000..e68b3e0a65f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/9263.f @@ -0,0 +1,7 @@ + PARAMETER (Q=1) + PARAMETER (P=10) + INTEGER C(10),D(10),E(10),F(10) + DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER + DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER + DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER + END diff --git a/gcc/testsuite/g77.f-torture/noncompile/970626-2.f b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f new file mode 100644 index 00000000000..c1e2348646f --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/970626-2.f @@ -0,0 +1,4 @@ + SUBROUTINE A(A,ALPHA,IA) + COMPLEX A(IA,*), ALPHA(*) + ALPHA(I)=A(I,I).ZERO) + END diff --git a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f new file mode 100644 index 00000000000..316969f6aa8 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f @@ -0,0 +1,10 @@ +* Fixed by JCB 1998-07-25 change to stc.c. + +* Date: Thu, 11 Jun 1998 22:35:20 -0500 +* From: Ian A Watson <WATSON_IAN_A@lilly.com> +* Subject: crash +* + CaLL foo(W) + END + SUBROUTINE foo(W) + yy(I)=A(I)Q(X) diff --git a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f new file mode 100644 index 00000000000..bd5e74022a3 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f @@ -0,0 +1,8 @@ +* Fixed by 1998-07-11 equiv.c change. +* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER' + +* Date: Mon, 15 Jun 1998 21:54:32 -0500 +* From: Ian A Watson <WATSON_IAN_A@lilly.com> +* Subject: Mangler Crash + EQUIVALENCE(I,glerf(P)) + COMMON /foo/ glerf(3) diff --git a/gcc/testsuite/g77.f-torture/noncompile/check0.f b/gcc/testsuite/g77.f-torture/noncompile/check0.f new file mode 100644 index 00000000000..fc3c6ca730e --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/check0.f @@ -0,0 +1,11 @@ +CCC Abort fixed by: +CCC1998-04-21 Jim Wilson <wilson@cygnus.com> +CCC +CCC * stmt.c (check_seenlabel): When search for line number note for +CCC warning, handle case where there is no such note. + logical l(10) + integer i(10) + goto (10,20),l + goto (10,20),i + 10 stop + 20 end diff --git a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp new file mode 100644 index 00000000000..fadd1fbbe5a --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp @@ -0,0 +1,36 @@ +# Copyright (C) 1988, 90, 91, 92, 97, 1998 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. + +# This file was written by Jeff Law. (law@cs.utah.edu) + +# +# These tests come from Torbjorn Granlund (tege@cygnus.com) +# C torture test suite. +# + +load_lib mike-g77.exp + +# Test check0.f +prebase + +set src_code check0.f +# Not really sure what the error should be here... +set compiler_output ".*:8.*:9" + +set groups {passed gcc-noncompile} + +postbase $src_code $run $groups + diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f new file mode 100644 index 00000000000..f7dad339a81 --- /dev/null +++ b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f @@ -0,0 +1,10 @@ + integer*1 one + integer*2 two + parameter (one=1) + parameter (two=2) + select case (I) + case (one) + case (two) + end select + end + |