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 161c 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 184c 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 271C why is it necessary to reopen? (who wrote this?) 272C 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 337C 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 371C 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 422