*** 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. * * 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 logical issum intrinsic getpid, getuid, getgid, ierrno, gerror, + fnum, isatty, getarg, access, unlink, fstat, + stat, lstat, getcwd, gmtime, etime, chmod, + chdir, fgetc, fputc, system_clock, second, idate, secnds, + time, ctime, fdate, ttynam, date_and_time external lenstr, ctrlc integer lenstr logical l character gerr*80, c*1 character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8, + ttime*10, zone*5 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 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 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)) * 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 call umask(0, mask) write(6,*) 'UMASK returns', mask call umask(mask) ctim = fdate() write (6,*) 'FDATE returns: ', 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 r2 = dtime (tarray2) if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit end do r1 = etime (tarray1) 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 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 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(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4) + .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)) 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)) 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) 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') WRITE (6,*) 'You should see exit status 1' CALL EXIT(1) 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, print out all problems noticed. * intrinsic abort * call abort end