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
164c 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
187c 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
274C     why is it necessary to reopen?  (who wrote this?)
275C     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
340C     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
416