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