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