From 0bfc6dd22fb6e5fca8558563da146b5fe738f48a Mon Sep 17 00:00:00 2001 From: Craig Burley Date: Sat, 1 May 1999 22:29:28 +0000 Subject: [PATCH] clean up both u77-test.f versions From-SVN: r26717 --- gcc/testsuite/ChangeLog | 6 + .../g77.f-torture/execute/u77-test.f | 93 ++++++---- libf2c/ChangeLog | 6 + libf2c/libU77/u77-test.f | 170 +++++++++++++----- 4 files changed, 199 insertions(+), 76 deletions(-) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0025ed7bb3f1..b4633b758169 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +1999-05-01 Craig Burley + + * g77.f-torture/execute/u77-test.f: Modify to be more like + libf2c/libU77 version, bringing patches to that version here. + Add suitable commentary. + Sun Apr 25 12:28:59 1999 Richard Henderson * gcc.dg/990424-1.c: New test. diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f index 8baa8f97d31c..25647191ddf3 100644 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.f +++ b/gcc/testsuite/g77.f-torture/execute/u77-test.f @@ -2,8 +2,20 @@ * 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. +* +* 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, sum @@ -40,7 +52,7 @@ line = 'and 6 isn''t a tty device (ISATTY)' end if write (6,'(1X,A)') line(:lenstr(line)) - + * regression test for compiler crash fixed by JCB 1998-08-04 com.c sigret = signal(2, ctrlc) @@ -85,19 +97,19 @@ c consistency-check etime vs. dtime for first call write (6,*) + 'Results of ETIME and DTIME differ by more than a second:', + r1, r2 - call abort + call doabort end if call sgladd (sum, tarray1(1), tarray1(2)) if (r1 .ne. sum) then write (6,*) '*** ETIME didn''t return sum of the array: ', + r1, ' /= ', tarray1(1), '+', tarray1(2) - call abort + call doabort end if call sgladd (sum, tarray2(1), tarray2(2)) if (r2 .ne. sum) then write (6,*) '*** DTIME didn''t return sum of the array: ', + r2, ' /= ', tarray2(1), '+', tarray2(2) - call abort + call doabort end if write (6, '(A,3F10.3)') + ' Elapsed total, user, system time (ETIME): ', @@ -116,13 +128,13 @@ c now try to get times to change enough to see in etime/dtime if (r1 .ne. sum) then write (6,*) '*** ETIME didn''t return sum of the array: ', + r1, ' /= ', tarray1(1), '+', tarray1(2) - call abort + call doabort end if call sgladd (sum, tarray2(1), tarray2(2)) if (r2 .ne. sum) then write (6,*) '*** DTIME didn''t return sum of the array: ', + r2, ' /= ', tarray2(1), '+', tarray2(2) - call abort + call doabort end if write (6, '(A,3F10.3)') + ' Differences in total, user, system time (DTIME): ', @@ -134,11 +146,11 @@ c now try to get times to change enough to see in etime/dtime call idate (i,j,k) call idate (idat) - write (6,*) 'IDATE d,m,y: ',idat - print *, '... and the VXT version: ', i,j,k + 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 abort + print *, '*** VXT and U77 versions don''t agree' + call doabort end if call time(line(:8)) print *, 'TIME: ', line(:8) @@ -150,29 +162,27 @@ c now try to get times to change enough to see in etime/dtime * 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 abort() + call doabort() end if i = getcwd(wd) if (i.ne.0) then call perror ('*** getcwd') - call abort + 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 abort + 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 -CCC Don't do this, beacuse some targets need -lsocket, which we don't -CCC have a mechanism for supplying. -CCC i=hostnm(wd) -CCC if(i.ne.0) then -CCC call perror ('*** hostnm') -CCC call abort -CCC else -CCC write (6,*) 'Host name is ', wd(:lenstr(wd)) -CCC 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...' @@ -188,41 +198,41 @@ C the better to test with, my dear! (-- burley) call fseek(3,0,0,*10) go to 20 10 write(6,*) '***FSEEK failed' - call abort + call doabort 20 call fgetc(3, c,i) if (i.ne.0) then write(6,*) '***FGETC: ', i - call abort + call doabort end if if (c.ne.'c') then write(6,*) '***FGETC read the wrong thing: ', ichar(c) - call abort + call doabort end if i= ftell(3) if (i.ne.1) then write(6,*) '***FTELL offset: ', i - call abort + call doabort end if call chmod ('foo', 'a+w',i) if (i.ne.0) then write (6,*) '***CHMOD of "foo": ', i - call abort + call doabort end if i = fstat (3, fstatb) if (i.ne.0) then write (6,*) '***FSTAT of "foo": ', i - call abort + call doabort end if i = stat ('foo', statb) if (i.ne.0) then write (6,*) '***STAT of "foo": ', i - call abort + call doabort end if write (6,*) ' with stat array ', statb if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4) + .ne. 1) then write (6,*) '*** FSTAT uid, gid or nlink is wrong' - call abort + call doabort end if do i=1,13 if (fstatb (i) .ne. statb (i)) then @@ -245,17 +255,17 @@ C in case it exists already: call link ('foo ', 'bar ',i) if (i.ne.0) then write (6,*) '***LINK "foo" to "bar" failed: ', i - call abort + call doabort end if call unlink ('foo',i) if (i.ne.0) then write (6,*) '***UNLINK "foo" failed: ', i - call abort + call doabort end if call unlink ('foo',i) if (i.eq.0) then write (6,*) '***UNLINK "foo" again: ', i - call abort + call doabort end if call gerror (gerr) i = ierrno() @@ -266,7 +276,7 @@ C in case it exists already: call getarg (0, line) call perror (line (:lenstr (line))) call unlink ('bar') -C WRITE (6,*) 'You should see exit status 1' +C WRITE (6,*) 'You should see exit status 1' CALL EXIT(0) 99 END @@ -294,5 +304,20 @@ C return >0 * signal handler subroutine ctrlc print *, 'Got ^C' + call doabort + end + + 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/libf2c/ChangeLog b/libf2c/ChangeLog index a7b0a4fe4e75..9d3403a84b21 100644 --- a/libf2c/ChangeLog +++ b/libf2c/ChangeLog @@ -1,3 +1,9 @@ +Sat May 1 23:35:18 1999 Craig Burley + + * libU77/u77-test.f: Modify to be more like testsuite + version, bringing patches to that version here. + Add suitable commentary. + Sat Apr 24 11:02:48 1999 Craig Burley * Makefile.in (s-libi77, s-libf77, s-libu77): Revert diff --git a/libf2c/libU77/u77-test.f b/libf2c/libU77/u77-test.f index 07963c97e75a..e45132ad95aa 100644 --- a/libf2c/libU77/u77-test.f +++ b/libf2c/libU77/u77-test.f @@ -2,17 +2,32 @@ * 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. +* +* NOTE! This is the libU77 version, so it should be a bit more +* "interactive" than the testsuite version, which is in +* gcc/testsuite/g77.f-torture/execute/u77-test.f. +* This version purposely exits with a "failure" status, to test +* returning of non-zero status, and it doesn't call the ABORT +* intrinsic (it substitutes an EXTERNAL stub, so the code can be +* kept nearly the same in both copies). Also, it goes ahead and +* tests the HOSTNM intrinsic. Please keep the other copy up-to-date when +* you modify this one. 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, sum intrinsic getpid, getuid, getgid, ierrno, gerror, + fnum, isatty, getarg, access, unlink, fstat, - + stat, lstat, getcwd, gmtime, hostnm, etime, chmod, + + stat, lstat, getcwd, gmtime, etime, chmod, + chdir, fgetc, fputc, system_clock, second, idate, secnds, + time, ctime, fdate, ttynam, date_and_time - external lenstr + external lenstr, ctrlc integer lenstr logical l character gerr*80, c*1 @@ -21,6 +36,7 @@ integer fstatb (13), statb (13) integer *2 i2zero integer values(8) + integer(kind=7) sigret ctim = ctime(time()) WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim @@ -29,7 +45,7 @@ + // ' 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 exit(1) + call abort end if l= isatty(6) line2 = ttynam(6) @@ -40,6 +56,9 @@ end if write (6,'(1X,A)') line(:lenstr(line)) +* 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 () @@ -76,21 +95,25 @@ c consistency-check etime vs. dtime for first call r1 = etime (tarray1) - if (r1.ne.tarray1(1)+tarray1(2)) - + write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) r2 = dtime (tarray2) - if (abs (r1-r2).gt.1.0) write (6,*) - + 'Results of ETIME and DTIME differ by more than a second:', - + r1, r2 + 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 call sgladd (sum, tarray1(1), tarray1(2)) - if (r1 .ne. sum) - + write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) + if (r1 .ne. sum) then + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1(1), '+', tarray1(2) + call doabort + end if call sgladd (sum, tarray2(1), tarray2(2)) - if (r2 .ne. sum) - + write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) + if (r2 .ne. sum) 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 @@ -105,13 +128,17 @@ c now try to get times to change enough to see in etime/dtime end do r1 = etime (tarray1) call sgladd (sum, tarray1(1), tarray1(2)) - if (r1 .ne. sum) - + write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) + if (r1 .ne. sum) then + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1(1), '+', tarray1(2) + call doabort + end if call sgladd (sum, tarray2(1), tarray2(2)) - if (r2 .ne. sum) - + write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) + if (r2 .ne. sum) 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 @@ -122,8 +149,12 @@ c now try to get times to change enough to see in etime/dtime call idate (i,j,k) call idate (idat) - write (6,*) 'IDATE d,m,y: ',idat - print *, '... and the VXT version: ', i,j,k + 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 time(line(:8)) print *, 'TIME: ', line(:8) write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) @@ -131,17 +162,27 @@ c now try to get times to change enough to see in etime/dtime 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) write (6,*) '***CHDIR to ".": ', 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 @@ -160,42 +201,75 @@ C the better to test with, my dear! (-- burley) 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) write(6,*) '***FGETC: ', i - if (c.ne.'c') write(6,*) '***FGETC read the wrong thing: ', - + ichar(c) + 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) write(6,*) '***FTELL offset: ', i + if (i.ne.1) then + write(6,*) '***FTELL offset: ', i + call doabort + end if call chmod ('foo', 'a+w',i) - if (i.ne.0) write (6,*) '***CHMOD of "foo": ', i + if (i.ne.0) then + write (6,*) '***CHMOD of "foo": ', i + call doabort + end if i = fstat (3, fstatb) - if (i.ne.0) write (6,*) '***FSTAT of "foo": ', i + if (i.ne.0) then + write (6,*) '***FSTAT of "foo": ', i + call doabort + end if i = stat ('foo', statb) - if (i.ne.0) write (6,*) '***STAT of "foo": ', i + if (i.ne.0) then + write (6,*) '***STAT of "foo": ', i + call doabort + end if write (6,*) ' with stat array ', statb if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4) - + .ne. 1) write (6,*) '*** FSTAT uid, gid or nlink is wrong' + + .ne. 1) then + write (6,*) '*** FSTAT uid, gid or nlink is wrong' + call doabort + end if do i=1,13 - if (fstatb (i) .ne. statb (i)) - + write (6,*) '*** FSTAT and STAT don''t agree on '// ' - + array element ', i, ' value ', fstatb (i), statb (i) + 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 doabort + end if end do i = lstat ('foo', fstatb) do i=1,13 - if (fstatb (i) .ne. statb (i)) - + write (6,*) '*** LSTAT and STAT don''t agree on '// ' - + array element ', i, ' value ', fstatb (i), statb (i) + 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 doabort + end if end do C in case it exists already: call unlink ('bar',i) call link ('foo ', 'bar ',i) - if (i.ne.0) - + write (6,*) '***LINK "foo" to "bar" failed: ', 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) write (6,*) '***UNLINK "foo" failed: ', i + if (i.ne.0) then + write (6,*) '***UNLINK "foo" failed: ', i + call doabort + end if call unlink ('foo',i) - if (i.eq.0) write (6,*) '***UNLINK "foo" again: ', 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: ', @@ -229,3 +303,15 @@ C return >0 real sum,left,right sum = left+right end + +* signal handler + subroutine ctrlc + print *, 'Got ^C' + call doabort + end + + subroutine doabort +* For this version, print out all problems noticed. +* intrinsic abort +* call abort + end -- 2.47.2