1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
|
*** 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.
implicit none
integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
+ pid, mask
real tarray1(2), tarray2(2), r1, r2, sum
intrinsic getpid, getuid, getgid, ierrno, gerror,
+ fnum, isatty, getarg, access, unlink, fstat,
+ stat, lstat, getcwd, gmtime, etime, chmod,
+ chdir, fgetc, fputc, system_clock, second, idate, secnds,
+ time, ctime, fdate, ttynam, date_and_time
external lenstr, ctrlc
integer lenstr
logical l
character gerr*80, c*1
character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8,
+ ttime*10, zone*5
integer fstatb (13), statb (13)
integer *2 i2zero
integer values(8)
integer(kind=7) sigret
ctim = ctime(time())
WRITE (6,'(A/)') '1 GNU libU77 test at: ' // 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
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))
* 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
call umask(0, mask)
write(6,*) 'UMASK returns', mask
call umask(mask)
ctim = fdate()
write (6,*) 'FDATE returns: ', 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 abort
end if
call sgladd (sum, tarray1(1), tarray1(2))
if (r1 .ne. sum) then
write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call abort
end if
call sgladd (sum, tarray2(1), tarray2(2))
if (r2 .ne. sum) then
write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
call abort
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
r2 = dtime (tarray2)
if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
end do
r1 = etime (tarray1)
call sgladd (sum, tarray1(1), tarray1(2))
if (r1 .ne. sum) then
write (6,*) '*** ETIME didn''t return sum of the array: ',
+ r1, ' /= ', tarray1(1), '+', tarray1(2)
call abort
end if
call sgladd (sum, tarray2(1), tarray2(2))
if (r2 .ne. sum) then
write (6,*) '*** DTIME didn''t return sum of the array: ',
+ r2, ' /= ', tarray2(1), '+', tarray2(2)
call abort
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 d,m,y: ',idat
print *, '... and the VXT version: ', 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 abort
end if
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 abort()
end if
i = getcwd(wd)
if (i.ne.0) then
call perror ('*** getcwd')
call abort
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 abort
end if
CCC Don't do this, beacuse some targets need -lsocket, which we don't
CCC have a mechanism for supplying.
CCC i=hostnm(wd)
CCC if(i.ne.0) then
CCC call perror ('*** hostnm')
CCC call abort
CCC else
CCC write (6,*) 'Host name is ', wd(:lenstr(wd))
CCC 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 abort
20 call fgetc(3, c,i)
if (i.ne.0) then
write(6,*) '***FGETC: ', i
call abort
end if
if (c.ne.'c') then
write(6,*) '***FGETC read the wrong thing: ', ichar(c)
call abort
end if
i= ftell(3)
if (i.ne.1) then
write(6,*) '***FTELL offset: ', i
call abort
end if
call chmod ('foo', 'a+w',i)
if (i.ne.0) then
write (6,*) '***CHMOD of "foo": ', i
call abort
end if
i = fstat (3, fstatb)
if (i.ne.0) then
write (6,*) '***FSTAT of "foo": ', i
call abort
end if
i = stat ('foo', statb)
if (i.ne.0) then
write (6,*) '***STAT of "foo": ', i
call abort
end if
write (6,*) ' with stat array ', statb
if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4)
+ .ne. 1) then
write (6,*) '*** FSTAT uid, gid or nlink is wrong'
call abort
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 abort
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 abort
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 abort
end if
call unlink ('foo',i)
if (i.ne.0) then
write (6,*) '***UNLINK "foo" failed: ', i
call abort
end if
call unlink ('foo',i)
if (i.eq.0) then
write (6,*) '***UNLINK "foo" again: ', i
call abort
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')
C WRITE (6,*) 'You should see exit status 1'
CALL EXIT(0)
99 END
integer function lenstr (str)
C return length of STR not including trailing blanks, but always
C return >0
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
* do an add that is most likely to be done in single precision.
subroutine sgladd(sum,left,right)
implicit none
real sum,left,right
sum = left+right
end
* signal handler
subroutine ctrlc
print *, 'Got ^C'
call abort
end
|
