libf2c/libU77/u77-test.f

   1 ***   Some random stuff for testing libU77.  Should be done better.  It's
   2 *     hard to test things where you can't guarantee the result.  Have a
   3 *     good squint at what it prints, though detected errors will cause
   4 *     starred messages.
   5 *
   6 * NOTE! This is the libU77 version, so it should be a bit more
   7 * "interactive" than the testsuite version, which is in
   8 * gcc/testsuite/g77.f-torture/execute/u77-test.f.
   9 * This version purposely exits with a "failure" status, to test
  10 * returning of non-zero status, and it doesn't call the ABORT
  11 * intrinsic (it substitutes an EXTERNAL stub, so the code can be
  12 * kept nearly the same in both copies).  Also, it goes ahead and
  13 * tests the HOSTNM intrinsic.  Please keep the other copy up-to-date when
  14 * you modify this one.
  15
  16       implicit none
  17
  18 *     external hostnm
  19       intrinsic hostnm
  20       integer hostnm
  21
  22       integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
  23      +     pid, mask
  24       real tarray1(2), tarray2(2), r1, r2
  25       logical issum
  26       intrinsic getpid, getuid, getgid, ierrno, gerror,
  27      +     fnum, isatty, getarg, access, unlink, fstat,
  28      +     stat, lstat, getcwd, gmtime, etime, chmod,
  29      +     chdir, fgetc, fputc, system_clock, second, idate, secnds,
  30      +     time, ctime, fdate, ttynam, date_and_time
  31       external lenstr, ctrlc
  32       integer lenstr
  33       logical l
  34       character gerr*80, c*1
  35       character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8,
  36      +     ttime*10, zone*5
  37       integer fstatb (13), statb (13)
  38       integer *2 i2zero
  39       integer values(8)
  40       integer(kind=7) sigret
  41
  42       ctim = ctime(time())
  43       WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim
  44       write (6,'(A,I3,'', '',I3)')
  45      +     ' Logical units 5 and 6 correspond (FNUM) to'
  46      +     // ' Unix i/o units ', fnum(5), fnum(6)
  47       if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
  48         print *, 'LNBLNK or LEN_TRIM failed'
  49         call abort
  50       end if
  51       l= isatty(6)
  52       line2 = ttynam(6)
  53       if (l) then
  54         line = 'and 6 is a tty device (ISATTY) named '//line2
  55       else
  56         line = 'and 6 isn''t a tty device (ISATTY)'
  57       end if
  58       write (6,'(1X,A)') line(:lenstr(line))
  59
  60 *     regression test for compiler crash fixed by JCB 1998-08-04 com.c
  61       sigret = signal(2, ctrlc)
  62
  63       pid = getpid()
  64       WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
  65       WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
  66       WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
  67       WRITE (6, *) 'If you have the `id'' program, the following call'
  68       write (6, *) 'of SYSTEM should agree with the above:'
  69       call flush(6)
  70       CALL SYSTEM ('echo " " `id`')
  71       call flush
  72       lognam = 'blahblahblah'
  73       call getlog (lognam)
  74       write (6,*) 'Login name (GETLOG): ', lognam
  75       call umask(0, mask)
  76       write(6,*) 'UMASK returns', mask
  77       call umask(mask)
  78
  79       ctim = fdate()
  80       write (6,*) 'FDATE returns: ', ctim
  81       j=time()
  82       call ltime (j, ltarray)
  83       write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
  84       call gmtime (j, ltarray)
  85       write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
  86       call system_clock(count)  ! omitting optional args
  87       call system_clock(count, rate, count_max)
  88       write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
  89       call date_and_time(ddate)  ! omitting optional args
  90       call date_and_time(ddate, ttime, zone, values)
  91       write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
  92      +     zone, ' ', values
  93
  94       write (6,*) 'Sleeping for 1 second (SLEEP) ...'
  95       call sleep (1)
  96
  97 c consistency-check etime vs. dtime for first call
  98       r1 = etime (tarray1)
  99       r2 = dtime (tarray2)
 100       if (abs (r1-r2).gt.1.0) then
 101         write (6,*)
 102      +       'Results of ETIME and DTIME differ by more than a second:',
 103      +       r1, r2
 104         call doabort
 105       end if
 106       if (.not. issum (r1, tarray1(1), tarray1(2))) then
 107         write (6,*) '*** ETIME didn''t return sum of the array: ',
 108      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
 109         call doabort
 110       end if
 111       if (.not. issum (r2, tarray2(1), tarray2(2))) then
 112         write (6,*) '*** DTIME didn''t return sum of the array: ',
 113      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
 114         call doabort
 115       end if
 116       write (6, '(A,3F10.3)')
 117      +     ' Elapsed total, user, system time (ETIME): ',
 118      +     r1, tarray1
 119
 120 c now try to get times to change enough to see in etime/dtime
 121       write (6,*) 'Looping until clock ticks at least once...'
 122       do i = 1,1000
 123       do j = 1,1000
 124       end do
 125       r2 = dtime (tarray2)
 126       if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
 127       end do
 128       r1 = etime (tarray1)
 129       if (.not. issum (r1, tarray1(1), tarray1(2))) then
 130         write (6,*) '*** ETIME didn''t return sum of the array: ',
 131      +       r1, ' /= ', tarray1(1), '+', tarray1(2)
 132         call doabort
 133       end if
 134       if (.not. issum (r2, tarray2(1), tarray2(2))) then
 135         write (6,*) '*** DTIME didn''t return sum of the array: ',
 136      +       r2, ' /= ', tarray2(1), '+', tarray2(2)
 137         call doabort
 138       end if
 139       write (6, '(A,3F10.3)')
 140      +     ' Differences in total, user, system time (DTIME): ',
 141      +     r2, tarray2
 142       write (6, '(A,3F10.3)')
 143      +     ' Elapsed total, user, system time (ETIME): ',
 144      +     r1, tarray1
 145       write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
 146
 147       call idate (i,j,k)
 148       call idate (idat)
 149       write (6,*) 'IDATE (date,month,year): ',idat
 150       print *,  '... and the VXT version (month,date,year): ', i,j,k
 151       if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
 152         print *, '*** VXT and U77 versions don''t agree'
 153         call doabort
 154       end if
 155       call time(line(:8))
 156       print *, 'TIME: ', line(:8)
 157       write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
 158       write (6,*) 'SECOND returns: ', second()
 159       call dumdum(r1)
 160       call second(r1)
 161       write (6,*) 'CALL SECOND returns: ', r1
 162 *     compiler crash fixed by 1998-10-01 com.c change
 163       if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
 164         write (6,*) '*** rand(0) error'
 165         call doabort()
 166       end if
 167       i = getcwd(wd)
 168       if (i.ne.0) then
 169         call perror ('*** getcwd')
 170         call doabort
 171       else
 172         write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
 173       end if
 174       call chdir ('.',i)
 175       if (i.ne.0) then
 176         write (6,*) '***CHDIR to ".": ', i
 177         call doabort
 178       end if
 179       i=hostnm(wd)
 180       if(i.ne.0) then
 181         call perror ('*** hostnm')
 182         call doabort
 183       else
 184         write (6,*) 'Host name is ', wd(:lenstr(wd))
 185       end if
 186       i = access('/dev/null ', 'rw')
 187       if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
 188       write (6,*) 'Creating file "foo" for testing...'
 189       open (3,file='foo',status='UNKNOWN')
 190       rewind 3
 191       call fputc(3, 'c',i)
 192       call fputc(3, 'd',j)
 193       if (i+j.ne.0) write(6,*) '***FPUTC: ', i
 194 C     why is it necessary to reopen?  (who wrote this?)
 195 C     the better to test with, my dear!  (-- burley)
 196       close(3)
 197       open(3,file='foo',status='old')
 198       call fseek(3,0,0,*10)
 199       go to 20
 200  10   write(6,*) '***FSEEK failed'
 201       call doabort
 202  20   call fgetc(3, c,i)
 203       if (i.ne.0) then
 204         write(6,*) '***FGETC: ', i
 205         call doabort
 206       end if
 207       if (c.ne.'c') then
 208         write(6,*) '***FGETC read the wrong thing: ', ichar(c)
 209         call doabort
 210       end if
 211       i= ftell(3)
 212       if (i.ne.1) then
 213         write(6,*) '***FTELL offset: ', i
 214         call doabort
 215       end if
 216       call chmod ('foo', 'a+w',i)
 217       if (i.ne.0) then
 218         write (6,*) '***CHMOD of "foo": ', i
 219         call doabort
 220       end if
 221       i = fstat (3, fstatb)
 222       if (i.ne.0) then
 223         write (6,*) '***FSTAT of "foo": ', i
 224         call doabort
 225       end if
 226       i = stat ('foo', statb)
 227       if (i.ne.0) then
 228         write (6,*) '***STAT of "foo": ', i
 229         call doabort
 230       end if
 231       write (6,*) '  with stat array ', statb
 232       if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4)
 233      +     .ne. 1) then
 234         write (6,*) '*** FSTAT uid, gid or nlink is wrong'
 235         call doabort
 236       end if
 237       do i=1,13
 238         if (fstatb (i) .ne. statb (i)) then
 239           write (6,*) '*** FSTAT and STAT don''t agree on '// '
 240      +         array element ', i, ' value ', fstatb (i), statb (i)
 241           call doabort
 242         end if
 243       end do
 244       i = lstat ('foo', fstatb)
 245       do i=1,13
 246         if (fstatb (i) .ne. statb (i)) then
 247           write (6,*) '*** LSTAT and STAT don''t agree on '//
 248      +         'array element ', i, ' value ', fstatb (i), statb (i)
 249           call doabort
 250         end if
 251       end do
 252
 253 C     in case it exists already:
 254       call unlink ('bar',i)
 255       call link ('foo ', 'bar ',i)
 256       if (i.ne.0) then
 257         write (6,*) '***LINK "foo" to "bar" failed: ', i
 258         call doabort
 259       end if
 260       call unlink ('foo',i)
 261       if (i.ne.0) then
 262         write (6,*) '***UNLINK "foo" failed: ', i
 263         call doabort
 264       end if
 265       call unlink ('foo',i)
 266       if (i.eq.0) then
 267         write (6,*) '***UNLINK "foo" again: ', i
 268         call doabort
 269       end if
 270       call gerror (gerr)
 271       i = ierrno()
 272       write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
 273      +     i,
 274      +     ' and the corresponding message is:', gerr(:lenstr(gerr))
 275       write (6,*) 'This is sent to stderr prefixed by the program name'
 276       call getarg (0, line)
 277       call perror (line (:lenstr (line)))
 278       call unlink ('bar')
 279       WRITE (6,*) 'You should see exit status 1'
 280       CALL EXIT(1)
 281  99   END
 282
 283 * Return length of STR not including trailing blanks, but always > 0.
 284       integer function lenstr (str)
 285       character*(*) str
 286       if (str.eq.' ') then
 287         lenstr=1
 288       else
 289         lenstr = lnblnk (str)
 290       end if
 291       end
 292
 293 * Just make sure SECOND() doesn't "magically" work the second time.
 294       subroutine dumdum(r)
 295       r = 3.14159
 296       end
 297
 298 * Test whether sum is approximately left+right.
 299       logical function issum (sum, left, right)
 300       implicit none
 301       real sum, left, right
 302       real mysum, delta, width
 303       mysum = left + right
 304       delta = abs (mysum - sum)
 305       width = abs (left) + abs (right)
 306       issum = (delta .le. .0001 * width)
 307       end
 308
 309 * Signal handler
 310       subroutine ctrlc
 311       print *, 'Got ^C'
 312       call doabort
 313       end
 314
 315 * A problem has been noticed, so maybe abort the test.
 316       subroutine doabort
 317 * For this version, print out all problems noticed.
 318 *     intrinsic abort
 319 *     call abort
 320       end