freebsd-nq/contrib/libf2c/libU77/u77-test.f

***   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