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 iocall: proc;
40
41 dcl whoami char(8) static aligned init("iocall");
42
43
44
45 dcl (l1,l2,l3,l4,l5) fixed bin(17),
46 (p1,p2,p3,p4,p5) ptr,
47 statusp ptr,
48 call_name char(l1) based(p1),
49 command_name char(32) init(whoami),
50 ioname char(l2) based(p2),
51 arg3 char(l3) based(p3),
52 arg4 char(l4) based(p4),
53 arg5 char(l5) based(p5),
54 count fixed bin(17),
55 mode char(128),
56 pos fixed bin,
57 old_mode char(128),
58 old_status bit(72) aligned,
59 limit fixed bin,
60 status bit(72) aligned,
61 ioname2 char(32),
62 path char(168),
63 dir char(168),
64 entry char(32),
65 code fixed bin(35),
66 segptr ptr,
67 offset fixed bin(17),
68 nelem fixed bin(17),
69 bit_count fixed bin(24),
70 nelemt fixed bin(17),
71 ptrname2 char(32),
72 element_size fixed bin(17),
73 name char(32);
74
75 dcl 1 s based(statusp) aligned,
76 2 code fixed bin(17),
77 2 comp bit(5) unaligned,
78 2 p1 bit(4) unaligned,
79 2 eof bit(1) unaligned,
80 2 p2 bit(4) unaligned,
81 2 abs bit(1) unaligned,
82 2 det bit(1) unaligned,
83 2 quit bit(1) unaligned,
84 2 abort bit(1) unaligned,
85 2 p3 bit(18) unaligned;
86
87
88
89 dcl (error_table_$noarg fixed bin(35),
90 sys_info$max_seg_size fixed bin) ext;
91
92
93
94 dcl cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(35)),
95 expand_path_ ext entry(ptr,fixed bin(17),ptr,ptr,fixed bin(35)),
96 hcs_$make_seg entry(char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
97 hcs_$initiate_count entry(char(*), char(*), char(*), fixed bin(24), fixed bin, ptr, fixed bin(35)),
98 hcs_$set_bc entry(char(*), char(*), fixed bin(24), fixed bin(35)),
99 cv_dec_check_ entry(char(*), fixed bin(35), fixed bin),
100 (com_err_, ioa_) entry options(variable);
101
102 dcl ios_$attach entry(char(*), char(*), char(*), char(*), bit(72) aligned),
103 ios_$detach entry(char(*), char(*), char(*), bit(72) aligned),
104 ios_$read entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
105 ios_$write entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
106 ios_$seek entry(char(*), char(*), char(*), fixed bin, bit(72) aligned),
107 ios_$tell entry(char(*), char(*), char(*), fixed bin, bit(72) aligned),
108 ios_$setsize entry(char(*), fixed bin, bit(72) aligned),
109 ios_$getsize entry(char(*), fixed bin, bit(72) aligned),
110 ios_$order entry(char(*), char(*), ptr, bit(72) aligned),
111 ios_$changemode entry(char(*), char(*), char(*), bit(72) aligned),
112 ios_$resetread entry(char(*), bit(72) aligned),
113 ios_$resetwrite entry(char(*), bit(72) aligned),
114 ios_$abort entry(char(*), bit(72) aligned, bit(72) aligned),
115 ios_$readsync entry(char(*), char(*), fixed bin, bit(72) aligned),
116 ios_$writesync entry(char(*), char(*), fixed bin, bit(72) aligned),
117 ios_$worksync entry(char(*), char(*), char(*), bit(72) aligned);
118
119 dcl (addr, bin, divide, length, null, substr) builtin;
120
121
122
123 statusp = addr(status);
124 call cu_$arg_ptr(1,p1,l1,code);
125 if code ^= 0 then go to bad_args;
126 call cu_$arg_ptr(2,p2,l2,code);
127 if code ^= 0 then go to bad_args;
128 call cu_$arg_ptr(3,p3,l3,code);
129 if code ^= 0 then count = 2;
130 else do;
131 call cu_$arg_ptr(4,p4,l4,code);
132 if code ^= 0 then count = 3;
133 else do;
134 call cu_$arg_ptr(5,p5,l5,code);
135 if code ^= 0 then count = 4;
136 else count = 5;
137 end;
138 end;
139 if call_name = "attach" then do;
140 if count < 4 then go to bad_args;
141 mode = "";
142 pos = 1;
143 do count = 6 by 1 while(code = 0);
144 substr(mode,pos,l5) = arg5;
145 pos = pos + l5 + 1;
146 call cu_$arg_ptr(count,p5,l5,code);
147 if code = 0 then substr(mode,pos-1,1) = ",";
148 end;
149 call ios_$attach(ioname,arg3,arg4,mode,status);
150 end;
151 else if call_name = "detach" then do;
152 if count = 2 then ioname2,mode = "";
153 else if count = 3 then do;
154 ioname2 = arg3;
155 mode = "";
156 end;
157 else if count = 4 then do;
158 ioname2 = arg3;
159 mode = arg4;
160 end;
161 else go to bad_args;
162 call ios_$detach(ioname,ioname2,mode,status);
163 end;
164 else if call_name = "read" then do;
165 if count < 3 | count > 5 then go to bad_args;
166 path = arg3;
167 call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
168
169 if code ^= 0 then go to path_err;
170 call hcs_$make_seg(dir,entry,"",01011b,segptr,code);
171
172 if segptr = null then go to path_err;
173 call ios_$getsize(ioname,element_size,status);
174 if substr(status,1,36) ^= "0"b then element_size = 9;
175 if count = 3 then do;
176 offset = 0;
177 nelem = divide(sys_info$max_seg_size * 36, element_size, 17, 0);
178 end;
179 else if count = 4 then do;
180 offset = 0;
181 call cv_dec_check_(arg4, code, nelem);
182 if code ^= 0
183 then
184 nelem_4: call num_err(arg4, "nelem");
185 end;
186 else if count = 5 then do;
187 call cv_dec_check_(arg4, code, offset);
188 if code ^= 0
189 then
190 offset_4: call num_err(arg4, "offset");
191 call cv_dec_check_(arg5, code, nelem);
192 if code ^= 0
193 then
194 nelem_5: call num_err(arg5, "nelem");
195 end;
196 call ios_$read(ioname,segptr,offset,nelem,nelemt,status);
197 if s.code = 0 then do;
198 call hcs_$set_bc(dir,entry,nelemt*element_size,code);
199 if code ^= 0 then
200 call ioa_("iocall: Unable to set bit count for segment. ^a",path);
201 call ioa_("The number of elements read is ^d.",nelemt);
202 end;
203 end;
204 else if call_name = "write" then do;
205 if count < 3 | count > 5 then go to bad_args;
206 path = arg3;
207 call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
208
209 if code ^= 0 then go to path_err;
210 call hcs_$initiate_count(dir,entry,"",bit_count,1,segptr,code);
211
212 if segptr = null then go to path_err;
213 call ios_$getsize(ioname,element_size,status);
214 if substr(status,1,36) then element_size = 9;
215 if count = 3 then do;
216 offset = 0;
217 nelem = divide(bit_count,element_size,17,0);
218 nelemt = nelem * element_size;
219 bit_count = bit_count - nelemt;
220 if bit_count ^= 0
221 then call ioa_("^d bits at bit-offset ^d not transmitted to device ^a",
222 bit_count, nelemt, ioname);
223 end;
224 else if count = 4 then do;
225 offset = 0;
226 call cv_dec_check_(arg4, code, nelem);
227 if code ^= 0
228 then go to nelem_4;
229 end;
230 else if count = 5 then do;
231 call cv_dec_check_(arg4, code, offset);
232 if code ^= 0
233 then go to offset_4;
234 call cv_dec_check_(arg5, code, nelem);
235 if code ^= 0
236 then go to nelem_5;
237 end;
238 call ios_$write(ioname,segptr,offset,nelem,nelemt,status);
239 if s.code = 0 then call ioa_("The number of elements written is ^d.",nelemt);
240 end;
241 else if call_name = "seek" then do;
242 if count = 3 then do;
243 ptrname2 = "first";
244 offset = 0;
245 end;
246 else if count = 4 then do;
247 ptrname2 = arg4;
248 offset = 0;
249 end;
250 else if count = 5 then do;
251 ptrname2 = arg4;
252 call cv_dec_check_(arg5, code, offset);
253 if code ^= 0
254 then call num_err(arg5, "offset");
255 end;
256 else go to bad_args;
257 call ios_$seek(ioname,arg3,ptrname2,offset,status);
258 end;
259 else if call_name = "tell" then do;
260 if count = 3 then ptrname2 = "first";
261 else if count = 4 then ptrname2 = arg4;
262 else go to bad_args;
263 call ios_$tell(ioname,arg3,ptrname2,offset,status);
264 if s.code = 0 then call ioa_("Offset is ^d.",offset);
265 end;
266 else if call_name = "setsize" then do;
267 if count ^= 3 then go to bad_args;
268 call cv_dec_check_(arg3, code, element_size);
269 if code ^= 0
270 then call num_err(arg3, "element_size");
271 call ios_$setsize(ioname,element_size,status);
272 end;
273 else if call_name = "getsize" then do;
274 if count ^= 2 then go to bad_args;
275 call ios_$getsize(ioname,element_size,status);
276 if s.code = 0 then call ioa_("Element size is ^d.",element_size);
277 end;
278 else if call_name = "order" then do;
279 if count ^= 3 then go to bad_args;
280 call ios_$order(ioname,arg3,null,status);
281 end;
282 else if call_name = "changemode" then do;
283 mode = "";
284 if count >= 3 then code = 0;
285 pos = 1;
286 do count = 4 by 1 while(code = 0);
287 substr(mode,pos,l3) = arg3;
288 pos = pos + l3 + 1;
289 call cu_$arg_ptr(count,p3,l3,code);
290 if code = 0 then substr(mode,pos-1,1) = ",";
291 end;
292 call ios_$changemode(ioname,mode,old_mode,status);
293 if s.code = 0 then call ioa_("Mode changed from ^a",old_mode);
294 end;
295 else if call_name = "resetread" then do;
296 if count ^= 2 then go to bad_args;
297 call ios_$resetread(ioname,status);
298 end;
299 else if call_name = "resetwrite" then do;
300 if count ^= 2 then go to bad_args;
301 call ios_$resetwrite(ioname,status);
302 end;
303 else if call_name = "abort" then do;
304 if count ^= 2 then go to bad_args;
305 old_status = ""b;
306 call ios_$abort(ioname,old_status,status);
307 end;
308 else if call_name = "readsync" then do;
309 if count = 3 then limit = bin(131071, 17);
310 else if count = 4 then do;
311 call cv_dec_check_(arg4, code, limit);
312 if code ^= 0
313 then
314 limit_4: call num_err(arg4, "limit");
315 end;
316 else go to bad_args;
317 call ios_$readsync(ioname,arg3,limit,status);
318 end;
319 else if call_name = "writesync" then do;
320 if count = 3 then limit = bin(131071, 17);
321 else if count = 4 then do;
322 call cv_dec_check_(arg4, code, limit);
323 if code ^= 0
324 then go to limit_4;
325 end;
326 else go to bad_args;
327 call ios_$writesync(ioname,arg3,limit,status);
328 end;
329 else if call_name = "worksync" then do;
330 if count ^= 3 then go to bad_args;
331 call ios_$worksync(ioname,arg3,"",status);
332 end;
333 else do;
334 call ioa_("iocall: The ^a call to the I/O system is not permitted by iocall.",call_name);
335 return;
336 end;
337 name = ioname;
338 go to status_check;
339
340 path_err: call com_err_(code,whoami,path);
341 return;
342
343
344 bad_args: call com_err_(error_table_$noarg,whoami,"");
345 return;
346
347
348
349 checkstatus: entry(input_status);
350
351 dcl input_status bit(72) aligned;
352
353 name = "";
354 statusp = addr(status);
355 status = input_status;
356 command_name = "I/O Error";
357 status_check:
358
359 if s.code ^= 0 then call com_err_(s.code,command_name,name);
360 if s.eof then call ioa_("^a at end of file.",name);
361 if s.abs then call ioa_("^a device absent.",name);
362 if s.det then call ioa_("^a device detached.",name);
363 if s.quit then call ioa_("^a quit detected.",name);
364 if s.abort then call ioa_("^a transaction aborted.",name);
365
366 num_err: proc(str, id);
367
368 dcl (str, id) char(*);
369
370 call com_err_(0, whoami, "Non-numeric digits in ^a argument to ^a request: ^a", id, call_name, str);
371
372 go to end_iocall;
373
374 end;
375
376 end_iocall:
377 end iocall;