| *** 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 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 |
| 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 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') |
| |
| print *, 'MCLOCK returns ', mclock () |
| print *, 'MCLOCK8 returns ', mclock8 () |
| |
| call cpu_time (d1) |
| print *, 'CPU_TIME returns ', d1 |
| |
| 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 |
