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