1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18 file:
19 procedure;
20
21
22
23
24
25
26
27
28 dcl (reading initial ("0"b),
29 writing initial ("1"b)) bit (1) aligned internal static;
30
31
32
33 dcl (ioname1, type, ioname3, mode4) character (*);
34 dcl status5 bit (72) aligned;
35 dcl get_system_free_area_ entry returns (ptr);
36 dcl free_area area based (fareap),
37 fareap ptr init (null) int static;
38 dcl pibp6 pointer;
39 dcl (buffer_bit_offset,
40 bits_requested,
41 total_bits,
42 seg_bit_offset,
43 bits_to_move,
44 bits_moved,
45 current_bit) fixed binary (24);
46 dcl (ptrbit2,
47 ptrbit3,
48 offset) fixed binary (35);
49 dcl (buffer,
50 p,
51 sp,
52 seg) pointer;
53 dcl base fixed binary;
54 dcl byte bit (9) aligned;
55 dcl mode character (4) aligned;
56 dcl no_delimiter bit (1) aligned;
57 dcl pointer_name character (8) aligned;
58 dcl (i, j) fixed bin (24),
59 (comp,
60 switch) fixed binary;
61 dcl code fixed binary (35);
62 dcl temp bit (72) aligned;
63 dcl infinity static fixed binary (35) initial (34359738367);
64 dcl bits_per_seg fixed bin (24);
65 dcl (error_table_$badcall,
66 error_table_$boundviol,
67 error_table_$change_first,
68 error_table_$invalid_backspace_read,
69 error_table_$invalid_elsize,
70 error_table_$invalid_read,
71 error_table_$invalid_seek_last_bound,
72 error_table_$invalid_setdelim,
73 error_table_$invalid_write,
74 error_table_$negative_nelem,
75 error_table_$ionmat,
76 error_table_$negative_offset,
77 error_table_$new_offset_negative,
78 error_table_$no_room_for_dsb,
79 error_table_$too_many_read_delimiters,
80 error_table_$undefined_order_request,
81 error_table_$undefined_ptrname) external fixed binary (35);
82 dcl string based bit (9437184) aligned;
83 dcl chars based character (1048576) aligned;
84 dcl char1 character (1) aligned;
85 dcl 1 status based aligned,
86 2 code fixed binary (35),
87 2 successful bit (4) unaligned,
88 2 transaction_terminated bit (1) unaligned,
89 2 unassigned bit (4) unaligned,
90 2 end_of_data bit (1) unaligned,
91 2 pad bit (5) unaligned,
92 2 ioname_detached bit (1) unaligned,
93 2 pad2 bit (2) unaligned,
94 2 transaction_index bit (18) unaligned;
95 dcl file_util$attach_file entry (pointer, fixed binary (35));
96 dcl file_util$detach_file entry (pointer, fixed binary (35));
97 dcl file_util$find_seg_ptr entry (pointer, bit (1) aligned, fixed binary, pointer, fixed binary (35));
98
99 dcl (add, addr, addrel, bit, divide, fixed, index, length, min, mod, multiply, null, rel, substr, unspec) builtin;
100
101 dcl 1 fcb static aligned like pib;
102
103
104 % include file_pib;
105
106
107 dcl (msegp, mbufp) ptr,
108 (msegoff, mbufoff, mmove) fixed bin (24),
109 mchrarray (0:1) char (1) based,
110 mwords (mmove) fixed bin (35) aligned based,
111 mchars char (1000) based aligned;
112
113
114 file_attach:
115 entry (ioname1, type, ioname3, mode4, status5, pibp6);
116 sp = addr (status5);
117 if pibp6 ^= null then
118 do;
119 code = error_table_$ionmat;
120 go to set_detached_bit;
121 end;
122 if fareap = null then
123 fareap = get_system_free_area_ ();
124 if fcb.busy then
125 do;
126 allocate pib in (free_area) set (p);
127 if p = null then
128 do;
129 code = error_table_$no_room_for_dsb;
130 go to set_detached_bit;
131 end;
132 end;
133 else
134 p = addr (fcb);
135
136 p -> pib.device_name.name_size = min (length (ioname3), length (p -> pib.device_name.name_string));
137 p -> pib.device_name.name_string = ioname3;
138 mode = mode4;
139 p -> pib.r, p -> pib.w = ""b;
140 if mode = "r " then
141 p -> pib.r = "1"b;
142 if mode = "w " then
143 p -> pib.w = "1"b;
144 if p -> pib.r | p -> pib.w then go to mode_out;
145
146 if index (mode4, "read") = 0
147 & index (mode4, "write") = 0
148 then do;
149 p -> pib.r, p -> pib.w = "1"b;
150 go to mode_out;
151 end;
152
153 i = index (mode4, "read");
154 if i ^= 0 then do;
155 if i > 1 then
156 if substr (mode4, i-1, 1) ^= "^"
157 then p -> pib.r = "1"b;
158 else;
159 else p -> pib.r = "1"b;
160 end;
161
162 i = index (mode4, "write");
163 if i ^= 0 then do;
164 if i > 1 then
165 if substr (mode4, i-1, 1) ^= "^"
166 then p -> pib.w = "1"b;
167 else;
168 else p -> pib.w = "1"b;
169 end;
170
171 mode_out:
172 call file_util$attach_file (p, code);
173 if code ^= 0 then
174 go to delete_fcb;
175 p -> pib.outer_module_name = type;
176 p -> pib.device_name_list = addr (p -> pib.device_name);
177 p -> pib.device_name.next_device = null;
178 p -> pib.busy = "1"b;
179 pibp6 = p;
180 go to good;
181
182 file_detach:
183 entry (pibp1, ioname2, disposal, status4);
184 dcl pibp1 pointer;
185 dcl (ioname2, disposal) character (*);
186 dcl status4 bit (72) aligned;
187
188 p = pibp1;
189 sp = addr (status4);
190 call file_util$detach_file (p, code);
191 if code = 0 then
192 go to delete_fcb;
193 if disposal ^= "h" then
194 do;
195 delete_fcb: p -> pib.busy = ""b;
196 if p ^= addr (fcb) then
197 free p -> pib in (free_area);
198 sp -> status.ioname_detached = "1"b;
199 end;
200 if code ^= 0 then
201 go to bad;
202 go to good;
203
204 file_order:
205 entry (pibp1, request, argptr, status4);
206 dcl request character (*) aligned;
207 dcl argptr pointer;
208
209 sp = addr (status4);
210 p = pibp1;
211 if request = "backspace_read" then
212 do;
213 if ^ p -> pib.r then
214 do;
215 code = error_table_$invalid_read;
216 go to bad;
217 end;
218 if argptr ^= null then
219 do;
220 code = error_table_$badcall;
221 go to bad;
222 end;
223 if p -> pib.nreads = 0 then
224 do;
225 scan (0): scan_none: code = error_table_$invalid_backspace_read;
226 go to bad;
227 end;
228 p -> pib.readbit = add (p -> pib.readbit, - 2 * p -> pib.elsize, 35, 0);
229 try_scan: if p -> pib.readbit <= 0 then
230 do;
231 p -> pib.readbit = 0;
232 go to good;
233 end;
234 bits_per_seg = p -> pib.bits_per_segment;
235 seg_bit_offset = mod (p -> pib.readbit, bits_per_seg);
236 comp = divide (p -> pib.readbit, bits_per_seg, 17, 0);
237 if comp ^= p -> pib.lastcomp then do;
238 call file_util$find_seg_ptr (p, (reading), comp, seg, code);
239 if code ^= 0 then
240 go to bad;
241 p -> pib.lastcomp = comp;
242 p -> pib.lastseg = seg;
243 end;
244 else seg = p -> pib.lastseg;
245 do current_bit = seg_bit_offset by - p -> pib.elsize to 0;
246 temp = substr (seg -> string, current_bit + 1, p -> pib.elsize);
247 go to scan (p -> pib.search_type);
248
249 scan (2): scan_bit_table: if substr (p -> pib.readlist, fixed (substr (temp, 1, 9), 9) + 1, 1) then
250 go to scan_done;
251 go to scan_loop;
252
253 scan (1): scan_1_char:
254 scan (3): scan_packed: j = 0;
255 do i = 1 to p -> pib.nreads;
256 if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then
257 go to scan_done;
258 j = j + p -> pib.elsize;
259 end;
260 scan_loop: end;
261
262 p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset - p -> pib.elsize, 35, 0);
263 go to try_scan;
264
265
266 scan_done: p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset + current_bit + p -> pib.elsize, 35, 0);
267 go to good;
268 end;
269 if request = "call" then
270 do;
271 argptr -> status.code = p -> pib.call;
272 go to good;
273 end;
274 code = error_table_$undefined_order_request;
275 go to bad;
276
277 file_getsize:
278 entry (pibp1, elsize, status3);
279 dcl elsize fixed binary (24);
280 dcl status3 bit (72) aligned;
281
282 p = pibp1;
283 sp = addr (status3);
284 elsize = p -> pib.elsize;
285 go to good;
286
287 file_setsize:
288 entry (pibp1, elsize, status3);
289
290 p = pibp1;
291 sp = addr (status3);
292 if elsize < 1 then
293 do;
294 code = error_table_$invalid_elsize;
295 go to bad;
296 end;
297 bits_per_seg = p -> pib.bits_per_segment;
298 if elsize > bits_per_seg then
299 do;
300 code = error_table_$invalid_elsize;
301 go to bad;
302 end;
303 p -> pib.elsize = elsize;
304
305 call round (p -> pib.readbit);
306 call round (p -> pib.writebit);
307 call round (p -> pib.lastbit);
308 call round (p -> pib.highbit);
309 call round (p -> pib.boundbit);
310 p -> pib.search_type, p -> pib.nreads = 0;
311 go to good;
312
313 file_read:
314 entry (pibp1, workspace, offset3, nelem, nelemt, status6);
315 dcl workspace pointer;
316 dcl (offset3, nelem, nelemt) fixed binary (24);
317 dcl status6 bit (72) aligned;
318
319 p = pibp1;
320 sp = addr (status6);
321 nelemt, total_bits = 0;
322 if ^ p -> pib.r then
323 do;
324 code = error_table_$invalid_read;
325 go to bad;
326 end;
327 buffer = workspace;
328 buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0);
329 if buffer_bit_offset < 0 then
330 do;
331 code = error_table_$negative_offset;
332 go to bad;
333 end;
334 bits_requested = multiply (nelem, p -> pib.elsize, 24, 0);
335 if bits_requested < 0 then
336 do;
337 code = error_table_$negative_nelem;
338 go to bad;
339 end;
340 bits_per_seg = p -> pib.bits_per_segment;
341 call round (p -> pib.lastbit);
342 no_delimiter = "1"b;
343 try_read: seg_bit_offset = mod (p -> pib.readbit, bits_per_seg);
344 bits_to_move = min (add (p -> pib.lastbit, - p -> pib.readbit, 35, 0), bits_requested);
345 bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move);
346 comp = divide (p -> pib.readbit, bits_per_seg, 17, 0);
347 if comp ^= p -> pib.lastcomp then do;
348 call file_util$find_seg_ptr (p, (reading), comp, seg, code);
349 if code ^= 0 then go to good;
350 p -> pib.lastcomp = comp;
351 p -> pib.lastseg = seg;
352 end;
353 else seg = p -> pib.lastseg;
354 go to read (p -> pib.search_type);
355
356 read (2):
357 current_bit = 0;
358 do while (current_bit < bits_moved);
359
360 byte = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
361 current_bit = current_bit + p -> pib.elsize;
362 if substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) then
363 go to read_delimiter_found;
364 end;
365 go to read_move;
366
367 read (3):
368 current_bit = 0;
369 do while (current_bit < bits_moved);
370
371 temp = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
372 current_bit = current_bit + p -> pib.elsize;
373 j = 0;
374 do i = 1 to p -> pib.nreads;
375 if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then
376 go to read_delimiter_found;
377 j = j + p -> pib.elsize;
378 end;
379 end;
380 go to read_move;
381
382 read (1):
383 i = divide (seg_bit_offset, 9, 17, 0);
384 j = divide (bits_moved, 9, 17, 0);
385 unspec (char1) = substr (p -> pib.readlist, 1, 9);
386 current_bit = 9 * index (substr (seg -> chars, i + 1, j), char1);
387 if current_bit ^= 0 then
388 do;
389 read_delimiter_found:
390 no_delimiter = ""b;
391 bits_moved = current_bit;
392 end;
393 read (0):
394 read_move:
395 if p -> pib.elsize = 36 then do;
396 msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
397 msegp = addrel (seg, msegoff);
398 mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
399 mbufp = addrel (buffer, mbufoff);
400 mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
401 mbufp -> mwords = msegp -> mwords;
402 end;
403 else if p -> pib.elsize = 9 then do;
404 msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
405 mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
406 mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
407 substr (buffer -> mchars, mbufoff+1, mmove) = substr (seg -> mchars, msegoff+1, mmove);
408 end;
409 else do;
410 substr (buffer -> string, buffer_bit_offset + 1, bits_moved) =
411 substr (seg -> string, seg_bit_offset + 1, bits_moved);
412 end;
413 total_bits = total_bits + bits_moved;
414 nelemt = divide (total_bits, p -> pib.elsize, 24, 0);
415 p -> pib.readbit = add (p -> pib.readbit, bits_moved, 35, 0);
416 if no_delimiter then
417 if bits_moved < bits_to_move then
418 do;
419 buffer_bit_offset = buffer_bit_offset + bits_moved;
420 bits_requested = bits_requested - bits_moved;
421 go to try_read;
422 end;
423 go to good;
424
425 file_write:
426 entry (pibp1, workspace, offset3, nelem, nelemt, status6);
427
428 p = pibp1;
429 sp = addr (status6);
430 nelemt, total_bits = 0;
431 if ^ p -> pib.w then
432 do;
433 code = error_table_$invalid_write;
434 go to bad;
435 end;
436 buffer = workspace;
437 buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0);
438 if buffer_bit_offset < 0 then
439 do;
440 code = error_table_$negative_offset;
441 go to bad;
442 end;
443 bits_requested = multiply (nelem, p -> pib.elsize, 24, 0);
444 if bits_requested < 0 then
445 do;
446 code = error_table_$negative_nelem;
447 go to bad;
448 end;
449 bits_per_seg = p -> pib.bits_per_segment;
450
451 if fixed (rel (buffer), 18) * 36 + buffer_bit_offset + bits_requested > bits_per_seg then
452 do;
453 code = error_table_$boundviol;
454 go to bad;
455 end;
456 call round (p -> pib.writebit);
457 try_write:
458 seg_bit_offset = mod (p -> pib.writebit, bits_per_seg);
459 bits_to_move = min (add (p -> pib.boundbit, - p -> pib.writebit, 35, 0), bits_requested);
460 bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move);
461 comp = divide (p -> pib.writebit, bits_per_seg, 17, 0);
462 if comp ^= p -> pib.lastcomp then do;
463 call file_util$find_seg_ptr (p, (writing), comp, seg, code);
464 if code ^= 0 then
465 go to bad;
466 p -> pib.lastcomp = comp;
467 p -> pib.lastseg = seg;
468 end;
469 else seg = p -> pib.lastseg;
470 if p -> pib.elsize = 36 then do;
471 msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
472 msegp = addrel (seg, msegoff);
473 mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
474 mbufp = addrel (buffer, mbufoff);
475 mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
476 msegp -> mwords = mbufp -> mwords;
477 end;
478 else if p -> pib.elsize = 9 then do;
479 msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0);
480 mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0);
481 mmove = divide (bits_moved, p -> pib.elsize, 24, 0);
482 substr (seg -> mchars, msegoff+1, mmove) = substr (buffer -> mchars, mbufoff+1, mmove);
483 end;
484 else do;
485 substr (seg -> string, seg_bit_offset + 1, bits_moved) =
486 substr (buffer -> string, buffer_bit_offset + 1, bits_moved);
487 end;
488 total_bits = total_bits + bits_moved;
489 nelemt = divide (total_bits, p -> pib.elsize, 24, 0);
490 p -> pib.writebit = add (p -> pib.writebit, bits_moved, 35, 0);
491 if p -> pib.writebit > p -> pib.lastbit then
492 do;
493 p -> pib.lastbit = p -> pib.writebit;
494 p -> pib.highbit = p -> pib.lastbit;
495 p -> pib.changed = "1"b;
496 end;
497 if bits_moved < bits_to_move then
498 do;
499 buffer_bit_offset = buffer_bit_offset + bits_moved;
500 bits_requested = bits_requested - bits_moved;
501 go to try_write;
502 end;
503 go to good;
504
505 file_setdelim:
506 entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);
507 dcl nbreaks, nreads;
508 dcl (breaklist, readlist) bit (*) aligned;
509
510 sp = addr (status6);
511 p = pibp1;
512 if p -> pib.elsize > length (temp) then
513 do;
514 code = error_table_$invalid_setdelim;
515 go to bad;
516 end;
517 bits_per_seg = p -> pib.bits_per_segment;
518 if mod (bits_per_seg, p -> pib.elsize) ^= 0 then
519 do;
520 code = error_table_$invalid_setdelim;
521 go to bad;
522 end;
523 if nreads < 0 then
524 do;
525 code = error_table_$badcall;
526 go to bad;
527 end;
528 if p -> pib.elsize > 9 then
529 do;
530 total_bits = nreads * p -> pib.elsize;
531 if total_bits > length (p -> pib.readlist) then
532 do;
533 code = error_table_$too_many_read_delimiters;
534 go to bad;
535 end;
536 end;
537 p -> pib.nreads = nreads;
538 if p -> pib.nreads = 1 then
539 if p -> pib.elsize = 9 then
540 do;
541 p -> pib.search_type = 1;
542 substr (p -> pib.readlist, 1, 9) = substr (readlist, 1, 9);
543 go to good;
544 end;
545 if p -> pib.nreads = 0 then
546 do;
547 p -> pib.search_type = 0;
548 end;
549 else
550 if p -> pib.elsize > 9 then
551 do;
552 p -> pib.search_type = 3;
553 substr (p -> pib.readlist, 1, total_bits) = substr (readlist, 1, total_bits);
554 end;
555 else
556 do;
557 p -> pib.search_type = 2;
558 p -> pib.readlist = ""b;
559 j = 0;
560 do i = 1 to p -> pib.nreads;
561 byte = substr (readlist, j + 1, p -> pib.elsize);
562 substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) = "1"b;
563 j = j + p -> pib.elsize;
564 end;
565 end;
566 go to good;
567
568 file_getdelim:
569 entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);
570
571 sp = addr (status6);
572 p = pibp1;
573 nbreaks = 0;
574 go to get (p -> pib.search_type);
575
576 get (0): get_none:
577 nreads = 0;
578 go to good;
579
580 get (1): get_1_char:
581 nreads = 1;
582 substr (readlist, 1, 9) = substr (p -> pib.readlist, 1, 9);
583 go to good;
584
585 get (2): get_bit_table:
586 base, j = 0;
587 do nreads = 0 by 1;
588 i = index (substr (p -> pib.readlist, base + 1), "1"b);
589 if i = 0 then
590 go to good;
591 substr (readlist, j + 1, p -> pib.elsize) = bit (base + i - 1, 9);
592 j = j + p -> pib.elsize;
593 base = base + i;
594 end;
595 go to good;
596
597 get (3): get_packed:
598 nreads = p -> pib.nreads;
599 total_bits = p -> pib.nreads * p -> pib.elsize;
600 substr (readlist, 1, total_bits) = substr (p -> pib.readlist, 1, total_bits);
601 go to good;
602
603 file_seek:
604 entry (pibp1, ptrname2, ptrname3, offset4, status5);
605 dcl (ptrname2, ptrname3) character (*);
606 dcl offset4 fixed binary (35);
607
608 p = pibp1;
609 sp = addr (status5);
610 pointer_name = ptrname3;
611 call pointerdecode (pointer_name, ptrbit3, switch);
612 if switch = 0 then
613 do;
614 code = error_table_$undefined_ptrname;
615 go to bad;
616 end;
617 offset = add (ptrbit3, multiply (offset4, p -> pib.elsize, 35, 0), 35, 0);
618 if offset < 0 then
619 do;
620 code = error_table_$new_offset_negative;
621 go to bad;
622 end;
623 pointer_name = ptrname2;
624 call pointerdecode (pointer_name, ptrbit2, switch);
625 go to seek (switch);
626
627 seek (0): seek_0:
628 code = error_table_$undefined_ptrname;
629 go to bad;
630
631 seek (1): seek_first:
632 code = error_table_$change_first;
633 go to bad;
634
635 seek (2): seek_read:
636 if ^ p -> pib.r then
637 do;
638 code = error_table_$invalid_read;
639 go to bad;
640 end;
641 p -> pib.readbit = min (offset, p -> pib.lastbit);
642 go to good;
643
644 seek (3): seek_write:
645 if ^ p -> pib.w then
646 do;
647 code = error_table_$invalid_write;
648 go to bad;
649 end;
650 p -> pib.writebit = min (offset, p -> pib.lastbit);
651 go to good;
652
653 seek (4): seek_last:
654 if ^ p -> pib.w then
655 do;
656 if offset > p -> pib.highbit then do;
657 code = error_table_$invalid_seek_last_bound;
658 go to bad;
659 end;
660 p -> pib.lastbit = offset;
661 go to good;
662 end;
663 p -> pib.lastbit = min (offset, p -> pib.boundbit);
664 p -> pib.highbit = p -> pib.lastbit;
665 go to truncate;
666
667 seek (5): seek_bound:
668 if ^ p -> pib.w then
669 do;
670 code = error_table_$invalid_seek_last_bound;
671 go to bad;
672 end;
673 p -> pib.boundbit = offset;
674 if p -> pib.lastbit > offset then
675 do;
676 p -> pib.lastbit = offset;
677 truncate: p -> pib.changed = "1"b;
678 end;
679
680 p -> pib.readbit = min (p -> pib.readbit, p -> pib.lastbit);
681 p -> pib.writebit = min (p -> pib.writebit, p -> pib.lastbit);
682 go to good;
683
684 file_tell:
685 entry (pibp1, ptrname2, ptrname3, offset4, status5);
686
687 p = pibp1;
688 sp = addr (status5);
689 pointer_name = ptrname3;
690 call pointerdecode (pointer_name, ptrbit3, switch);
691 if switch = 0 then
692 do;
693 code = error_table_$undefined_ptrname;
694 go to bad;
695 end;
696 pointer_name = ptrname2;
697 call pointerdecode (pointer_name, ptrbit2, switch);
698 if switch = 0 then
699 do;
700 code = error_table_$undefined_ptrname;
701 go to bad;
702 end;
703 offset4 = divide (add (ptrbit2, - ptrbit3, 35, 0), p -> pib.elsize, 35, 0);
704 go to good;
705
706 set_detached_bit:
707 sp -> status.ioname_detached = "1"b;
708 bad: sp -> status.code = code;
709 go to done;
710
711 good: sp -> status.successful = "1111"b;
712 sp -> status.code = 0;
713 done: sp -> status.transaction_terminated = "1"b;
714 if sp -> status.ioname_detached then
715 return;
716 if p -> pib.readbit >= p -> pib.lastbit then
717 sp -> status.end_of_data = "1"b;
718 return;
719
720 pointerdecode:
721 procedure (pointername, pointerbit, switch);
722 dcl pointername character (8) aligned;
723 dcl pointerbit fixed binary (35);
724 dcl switch fixed binary;
725
726 if pointername = "first " then
727 do;
728 pointerbit = 0;
729 switch = 1;
730 end;
731 else
732 if pointername = "read " then
733 do;
734 pointerbit = p -> pib.readbit;
735 switch = 2;
736 end;
737 else
738 if pointername = "write " then
739 do;
740 call round (p -> pib.writebit);
741 pointerbit = p -> pib.writebit;
742 switch = 3;
743 end;
744 else
745 if pointername = "last " then
746 do;
747 call round (p -> pib.lastbit);
748 pointerbit = p -> pib.lastbit;
749 switch = 4;
750 end;
751 else
752 if pointername = "bound " then
753 do;
754 pointerbit = p -> pib.boundbit;
755 switch = 5;
756 end;
757 else
758 pointerbit, switch = 0;
759 end pointerdecode;
760
761 round: procedure (offset);
762 dcl offset fixed binary (35);
763 dcl (overage, underage) fixed binary (24);
764
765 overage = mod (offset, p -> pib.elsize);
766 if overage ^= 0 then
767 do;
768 underage = p -> pib.elsize - overage;
769 if add (infinity, - offset, 35, 0) >= underage then
770 offset = add (offset, underage, 35, 0);
771 else
772 offset = add (offset, - overage, 35, 0);
773 end;
774 end round;
775 end file;