+++ /dev/null
-*** 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
projects / msp430-gcc.git / blobdiff