diff options
Diffstat (limited to 'gcc/f/runtime/libU77/u77-test.f')
| -rw-r--r-- | gcc/f/runtime/libU77/u77-test.f | 178 |
1 files changed, 0 insertions, 178 deletions
diff --git a/gcc/f/runtime/libU77/u77-test.f b/gcc/f/runtime/libU77/u77-test.f deleted file mode 100644 index 11c5ecae449..00000000000 --- a/gcc/f/runtime/libU77/u77-test.f +++ /dev/null @@ -1,178 +0,0 @@ -*** 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. - - integer i, j, k, ltarray (9), idat (3), count, rate, count_max, - + pid - real tarray1(2), tarray2(2), r1, r2, etime - intrinsic getpid, getuid, getgid, ierrno, gerror, - + fnum, isatty, getarg, access, unlink, fstat, - + stat, lstat, getcwd, gmtime, hostnm, etime, chmod, - + chdir, fgetc, fputc, system_clock, second, idate, secnds, - + time, ctime, fdate, ttynam - external lenstr - logical l - character gerr*80, c*1 - character ctim*25, line*80, lognam*20, wd*100, line2*80 - integer fstatb (13), statb (13) - integer *2 i2zero - - 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 exit(1) - 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)) - 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 of' - + // ' SYSTEM should agree with the above' - call flush(6) - CALL SYSTEM ('echo " " `id`') - call flush - 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, rate, count_max) - write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max - write (6,*) 'Sleeping for 1 second (SLEEP) ...' - call sleep (1) - write (6,*) 'Looping 10,000,000 times ...' - do i=1,10*1000*1000 - end do - r1= etime (tarray1) - if (r1.ne.tarray1(1)+tarray1(2)) - + write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1 - r2= dtime (tarray2) - if (abs (r1-r2).gt.1.0) write (6,*) - + 'Results of ETIME and DTIME differ by more than a second:', - + i, j - write (6,'(A,3F10.3)') - + ' Elapsed total, user, system time (ETIME): ', - + r1, tarray1 - call idate(i,j,k) - call idate (idat) - write (6,*) 'IDATE d,m,y: ',idat - print *, '... and the VXT version: ', i,j,k - call time(line(:8)) - print *, 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 - i = getcwd(wd) - if (i.ne.0) then - call perror ('*** getcwd') - else - write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' - end if - call chdir ('.',i) - if (i.ne.0) write (6,*) '***CHDIR to ".": ', i - i=hostnm(wd) - if(i.ne.0) then - call perror ('*** hostnm') - 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? - close(3) - open(3,file='foo',status='old') - call fseek(3,0,0,*10) - go to 20 - 10 write(6,*) '***FSEEK failed' - 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) - i= ftell(3) - if (i.ne.1) write(6,*) '***FTELL offset: ', i - call chmod ('foo', 'a+w',i) - if (i.ne.0) write (6,*) '***CHMOD of "foo": ', i - i = fstat (3, fstatb) - if (i.ne.0) write (6,*) '***FSTAT of "foo": ', i - i = stat ('foo', statb) - if (i.ne.0) write (6,*) '***STAT of "foo": ', i - 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' - 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) - 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) - 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 - call unlink ('foo',i) - if (i.ne.0) write (6,*) '***UNLINK "foo" failed: ', i - call unlink ('foo',i) - if (i.eq.0) write (6,*) '***UNLINK "foo" again: ', i - 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 - - integer function lenstr (str) -C return length of STR not including trailing blanks, but always -C return >0 - 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 |