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
6 * Currently not tested:
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.
42 integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
44 real tarray1(2), tarray2(2), r1, r2
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
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)
63 integer(kind=7) sigret
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'
79 if (ctim .ne. ctim2) then
80 write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
81 + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
86 if (i .gt. bigi .or. bigi .gt. j) then
87 write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
92 print *, 'Command-line arguments: ', iargc ()
95 print *, 'Arg ', i, ' is: ', line(:lenstr (line))
101 line = 'and 6 is a tty device (ISATTY) named '//line2
103 line = 'and 6 isn''t a tty device (ISATTY)'
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))
113 * regression test for compiler crash fixed by JCB 1998-08-04 com.c
114 sigret = signal(2, ctrlc)
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:'
123 CALL SYSTEM ('echo " " `id`')
126 lognam = 'blahblahblah'
128 write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
131 call getenv ('LOGNAME', wd)
132 write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
135 write(6,*) 'UMASK returns', mask
139 write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
141 write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
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
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
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, ' ',
158 write (6,*) 'Sleeping for 1 second (SLEEP) ...'
161 c consistency-check etime vs. dtime for first call
164 if (abs (r1-r2).gt.1.0) then
166 + 'Results of ETIME and DTIME differ by more than a second:',
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)
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)
180 write (6, '(A,3F10.3)')
181 + ' Elapsed total, user, system time (ETIME): ',
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...'
189 call dtime (tarray2, r2)
190 if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
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)
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)
203 write (6, '(A,3F10.3)')
204 + ' Differences in total, user, system time (DTIME): ',
206 write (6, '(A,3F10.3)')
207 + ' Elapsed total, user, system time (ETIME): ',
209 write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
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'
221 write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
224 write (6,*) 'ITIME (hour,minutes,seconds): ', idat
227 print *, 'TIME: ', line(:8)
229 write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
231 write (6,*) 'SECOND returns: ', second()
234 write (6,*) 'CALL SECOND returns: ', r1
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'
244 call perror ('*** getcwd')
247 write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
251 write (6,*) '***CHDIR to ".": ', i
257 call perror ('*** hostnm')
260 write (6,*) 'Host name is ', wd(:lenstr(wd))
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')
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)
274 open(3,file='foo',status='old')
275 call fseek(3,0,0,*10)
277 10 write(6,*) '***FSEEK failed'
279 20 call fgetc(3, c,i)
281 write(6,*) '***FGETC: ', i
285 write(6,*) '***FGETC read the wrong thing: ', ichar(c)
290 write(6,*) '***FTELL offset: ', i
295 write(6,*) '***CALL FTELL offset: ', i
298 call chmod ('foo', 'a+w',i)
300 write (6,*) '***CHMOD of "foo": ', i
303 i = fstat (3, fstatb)
305 write (6,*) '***FSTAT of "foo": ', i
308 i = stat ('foo', statb)
310 write (6,*) '***STAT of "foo": ', i
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).'
317 if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
318 write (6,*) '*** FSTAT uid or nlink is wrong'
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)
328 i = lstat ('foo', fstatb)
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)
337 C in case it exists already:
338 call unlink ('bar',i)
339 call link ('foo ', 'bar ',i)
341 write (6,*) '***LINK "foo" to "bar" failed: ', i
344 call unlink ('foo',i)
346 write (6,*) '***UNLINK "foo" failed: ', i
349 call unlink ('foo',i)
351 write (6,*) '***UNLINK "foo" again: ', i
357 write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
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)))
365 print *, 'MCLOCK returns ', mclock ()
366 print *, 'MCLOCK8 returns ', mclock8 ()
369 print *, 'CPU_TIME returns ', d1
371 C WRITE (6,*) 'You should see exit status 1'
375 * Return length of STR not including trailing blanks, but always > 0.
376 integer function lenstr (str)
381 lenstr = lnblnk (str)
385 * Just make sure SECOND() doesn't "magically" work the second time.
390 * Test whether sum is approximately left+right.
391 logical function issum (sum, left, right)
393 real sum, left, right
394 real mysum, delta, width
396 delta = abs (mysum - sum)
397 width = abs (left) + abs (right)
398 issum = (delta .le. .0001 * width)
407 * A problem has been noticed, so maybe abort the test.
409 * For this version, call the ABORT intrinsic.
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)
419 nm = 'not determined by this version of u77-test.f'