1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         *********************************************************** */
  8 /* File System Interface Module. */
  9 /* ******************************************************
 10    *                                                    *
 11    *                                                    *
 12    * Copyright (c) 1972 by Massachusetts Institute of   *
 13    * Technology and Honeywell Information Systems, Inc. *
 14    *                                                    *
 15    *                                                    *
 16    ****************************************************** */
 17 
 18 file:                                                       /* For multisegment file, read delimiters. */
 19      procedure;
 20 
 21 /* Modified 13 August 1972, M J Grady.  */
 22 /* Modified July 1973 by E. Stone to work for both 64k and 256k MSFs */
 23 /* Modified September 1974 by E. Stone to pass expand_path_ a maximum of 168 char pathname */
 24 /* Modified 750915 by PG and MJG to eliminate incorrect validation of arguments to read */
 25 
 26 /* internal static */
 27 
 28 dcl (reading initial ("0"b),
 29      writing initial ("1"b)) bit (1) aligned internal static;
 30 
 31 /* declarations */
 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,                                     /* Bit offsets and lengths. */
 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,                                               /* Temporaries for pointer manipulation. */
 47      ptrbit3,
 48      offset) fixed binary (35);
 49 dcl (buffer,                                                /* Pointer to workspace. */
 50      p,                                                     /* Pointer to file control block. */
 51      sp,                                                    /* Pointer to status string. */
 52      seg) pointer;                                          /* Pointer to file segment. */
 53 dcl  base fixed binary;                                     /* Base of incremental bit search. */
 54 dcl  byte bit (9) aligned;                                  /* Temporary for element during short delimiter search. */
 55 dcl  mode character (4) aligned;                            /* Copy of mode string. */
 56 dcl  no_delimiter bit (1) aligned;                          /* Flag to show we found a delimiter. */
 57 dcl  pointer_name character (8) aligned;                    /* Copy of pointer names. */
 58 dcl (i, j) fixed bin (24),                                  /* Index. */
 59     (comp,                                                  /* component number for test. */
 60      switch) fixed binary;
 61 dcl  code fixed binary (35);                                /* error code for routines. */
 62 dcl  temp bit (72) aligned;                                 /* Temporary for delimiter search. */
 63 dcl  infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */
 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,                                   /* Ioname already attached. */
 76      error_table_$negative_offset,
 77      error_table_$new_offset_negative,
 78      error_table_$no_room_for_dsb,                          /* Can't allocate file control block. */
 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;                    /* Overlay of segment and workspace (buffer). */
 83 dcl  chars based character (1048576) aligned;               /* Segment overlay for fast delimiter searches. */
 84 dcl  char1 character (1) aligned;                           /* Copy of delimiter table element. */
 85 dcl 1 status based aligned,                                 /* I/O system status string. */
 86     2 code fixed binary (35),                               /* Overall error code. */
 87     2 successful bit (4) unaligned,                         /* Logical/physical initiation/termination. */
 88     2 transaction_terminated bit (1) unaligned,             /* No further status change. */
 89     2 unassigned bit (4) unaligned,
 90     2 end_of_data bit (1) unaligned,                        /* Obvious. */
 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;                 /* IO system transaction index. */
 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;                          /* First file control block, allocated at translation time */
102 
103 /* Additional file control blocks, allocated as needed. */
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 /* ^L */
114 file_attach:                                                /* entry to attach file. */
115           entry (ioname1, type, ioname3, mode4, status5, pibp6);
116           sp = addr (status5);                              /* Set up pointer to status string. */
117           if pibp6 ^= null then                             /* Is this name already attached? */
118                do;                                          /* Yes. */
119                code = error_table_$ionmat;                  /* Set error code. */
120                go to set_detached_bit;                      /* Give up. */
121           end;
122           if fareap = null then
123                fareap = get_system_free_area_ ();           /* get area to alloc in */
124           if fcb.busy then                                  /* Is the first block in use? */
125                do;                                          /* Yes. */
126                allocate pib in (free_area) set (p);         /* Get another. */
127                if p = null then                             /* Successful? */
128                     do;                                     /* No. */
129                     code = error_table_$no_room_for_dsb;    /* Set error code. */
130                     go to set_detached_bit;                 /* Give up. */
131                end;
132           end;
133           else
134           p = addr (fcb);                                   /* Use internal block. */
135                                                             /* Insert path name of file into control block. */
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;                                     /* Copy mode string. */
139           p -> pib.r, p -> pib.w = ""b;                     /* Clear both permission flags. */
140           if mode = "r   " then                             /* Read only? */
141                p -> pib.r = "1"b;                           /* Yes, set read permission flag. */
142           if mode = "w   " then                             /* Write only? */
143                p -> pib.w = "1"b;                           /* Yes, set write permission flag. */
144           if p -> pib.r | p -> pib.w then go to mode_out;   /* If any set now jump 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;                 /* set read on */
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;                 /* set write on */
167                     else;
168                else p -> pib.w = "1"b;                      /* also set write */
169           end;
170 
171 mode_out:
172           call file_util$attach_file (p, code);             /* Initialize data block. */
173           if code ^= 0 then                                 /* Successful? */
174                go to delete_fcb;                            /* No, deallocate the control block. */
175           p -> pib.outer_module_name = type;                /* Insert our name. */
176           p -> pib.device_name_list = addr (p -> pib.device_name); /* Insert pointer for IOS. */
177           p -> pib.device_name.next_device = null;          /* Clear pointer to next list bead. */
178           p -> pib.busy = "1"b;                             /* Mark block as in use. */
179           pibp6 = p;                                        /* Give pointer to block to IOS. */
180           go to good;                                       /* Attach successfully completed. */
181                                                             /* ^L */
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);             /* Clean up and free data block. */
191           if code = 0 then                                  /* Successful? */
192                go to delete_fcb;                            /* Yes, deallocate control block. */
193           if disposal ^= "h" then                           /* No, are we requested to hold the control block? */
194                do;                                          /* No. */
195 delete_fcb:    p -> pib.busy = ""b;                         /* Clear the use flag. */
196                if p ^= addr (fcb) then                      /* Is it the original block? */
197                     free p -> pib in (free_area);           /* No, return it to free storage. */
198                sp -> status.ioname_detached = "1"b;         /* Set detached bit. */
199           end;
200           if code ^= 0 then                                 /* Which exit should we take? */
201                go to bad;                                   /* Erroneous operation, report code. */
202           go to good;
203                                                             /* ^L */
204 file_order:
205           entry (pibp1, request, argptr, status4);
206 dcl  request character (*) aligned;                         /* The name of the request. */
207 dcl  argptr pointer;                                        /* Pointer to arguments. */
208 
209           sp = addr (status4);                              /* Get pointer to status string. */
210           p = pibp1;                                        /* Copy pointer to control block. */
211           if request = "backspace_read" then                /* Examine request name. */
212                do;                                          /* This is it. */
213                if ^ p -> pib.r then                         /* Is file readable? */
214                     do;                                     /* No. */
215                     code = error_table_$invalid_read;       /* Set error code. */
216                     go to bad;                              /* Give error return. */
217                end;
218                if argptr ^= null then                       /* No arguments. */
219                     do;                                     /* But some supplied. */
220                     code = error_table_$badcall;            /* Set error code. */
221                     go to bad;                              /* Give error return. */
222                end;
223                if p -> pib.nreads = 0 then                  /* Are there any delimiters? */
224                     do;                                     /* No. */
225 scan (0): scan_none: code = error_table_$invalid_backspace_read; /* No, set error code. */
226                     go to bad;                              /* Return to caller. */
227                end;
228                p -> pib.readbit = add (p -> pib.readbit, - 2 * p -> pib.elsize, 35, 0); /* Back up two bytes. */
229 try_scan:      if p -> pib.readbit <= 0 then                /* At beginning of file? */
230                     do;                                     /* Yes. */
231                     p -> pib.readbit = 0;                   /* Make sure nonnegative. */
232                     go to good;                             /* Give normal return. */
233                end;
234                bits_per_seg = p -> pib.bits_per_segment;
235                seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get offset in current segment. */
236                comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */
237                if comp ^= p -> pib.lastcomp then do;        /* check to see if same as last time. */
238                     call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */
239                     if code ^= 0 then                       /* Successful? */
240                          go to bad;                         /* Give error return. */
241                     p -> pib.lastcomp = comp;               /* set new component number. */
242                     p -> pib.lastseg = seg;                 /* save new seg number */
243                end;
244                else seg = p -> pib.lastseg;                 /* else set seg to be same as last time. */
245                do current_bit = seg_bit_offset by - p -> pib.elsize to 0; /* Scan backwards. */
246                     temp = substr (seg -> string, current_bit + 1, p -> pib.elsize); /* Extract one byte. */
247                     go to scan (p -> pib.search_type);      /* Dispatch to proper scan. */
248 
249 scan (2): scan_bit_table: if substr (p -> pib.readlist, fixed (substr (temp, 1, 9), 9) + 1, 1) then /* Is this a break? */
250                          go to scan_done;                   /* Yes, terminate the scan. */
251                     go to scan_loop;                        /* No, get next. */
252 
253 scan (1): scan_1_char:                                      /* Can't handle special case; treat as packed. */
254 scan (3): scan_packed: j = 0;                               /* Reset array index. */
255                     do i = 1 to p -> pib.nreads;            /* Compare with each delimiter. */
256                          if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Does this match? */
257                               go to scan_done;              /* Yes, stop. */
258                          j = j + p -> pib.elsize;           /* Bump array index. */
259                     end;
260 scan_loop:     end;
261                                                             /* Adjust read pointer to end of previous segment. */
262                p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset - p -> pib.elsize, 35, 0);
263                go to try_scan;                              /* Go check for file beginning, get next segment. */
264 
265 /* Adjust read pointer to place we found. */
266 scan_done:     p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset + current_bit + p -> pib.elsize, 35, 0);
267                go to good;                                  /* Give normal return. */
268           end;
269           if request = "call" then                          /* Is request for file system call? */
270                do;                                          /* Yes. */
271                argptr -> status.code = p -> pib.call;       /* Give it to caller. */
272                go to good;                                  /* Return to caller. */
273           end;
274           code = error_table_$undefined_order_request;      /* Unrecognized request. */
275           go to bad;                                        /* Give error return. */
276                                                             /* ^L */
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                     /* Is it too big? */
299                do;                                          /* Yes. */
300                code = error_table_$invalid_elsize;          /* Set code. */
301                go to bad;                                   /* Give error return. */
302           end;
303           p -> pib.elsize = elsize;
304                                                             /* Round pointers to integral element. */
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;        /* Flush any read delimiters. */
311           go to good;
312                                                             /* ^L */
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;                           /* Nothing transmitted yet. */
322           if ^ p -> pib.r then
323                do;                                          /* Improper mode. */
324                code = error_table_$invalid_read;            /* Give error return. */
325                go to bad;
326           end;
327           buffer = workspace;                               /* Copy workspace pointer. */
328           buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0); /* Copy workspace offset. */
329           if buffer_bit_offset < 0 then                     /* It must be non-negative. */
330                do;                                          /* Bad offset. */
331                code = error_table_$negative_offset;         /* Give error return. */
332                go to bad;
333           end;
334           bits_requested = multiply (nelem, p -> pib.elsize, 24, 0); /* Copy number of elements desired. */
335           if bits_requested < 0 then                        /* It, too must be non-negative. */
336                do;                                          /* Bad buffer size. */
337                code = error_table_$negative_nelem;          /* Give error return. */
338                go to bad;
339           end;
340           bits_per_seg = p -> pib.bits_per_segment;
341           call round (p -> pib.lastbit);                    /* Round last pointer to element boundary. */
342           no_delimiter = "1"b;                              /* Set flag for retry. */
343 try_read: seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get bit offset in current segment. */
344           bits_to_move = min (add (p -> pib.lastbit, - p -> pib.readbit, 35, 0), bits_requested); /* Get bits to move. */
345           bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move); /* Get bits we can move out of cur seg. */
346           comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */
347           if comp ^= p -> pib.lastcomp then do;             /* check to see if same as last time. */
348                call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */
349                if code ^= 0 then go to good;                /* Not an error...this is an EOF condition */
350                p -> pib.lastcomp = comp;                    /* set new component number. */
351                p -> pib.lastseg = seg;                      /* save new seg number */
352           end;
353           else seg = p -> pib.lastseg;                      /* else set seg to be same as last time. */
354           go to read (p -> pib.search_type);                /* Dispatch to proper delimiter search. */
355 
356 read (2):                                                   /* READ BIT TABLE */
357           current_bit = 0;                                  /* Reset bit count. */
358           do while (current_bit < bits_moved);              /* Fill buffer if possible. */
359                                                             /* Move one byte for comparison. */
360                byte = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
361                current_bit = current_bit + p -> pib.elsize; /* Count the element. */
362                if substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) then /* Is this it? */
363                     go to read_delimiter_found;             /* Yes. */
364           end;
365           go to read_move;                                  /* Go move the entire string. */
366 
367 read (3):                                                   /* READ PACKED */
368           current_bit = 0;                                  /* Reset bit count. */
369           do while (current_bit < bits_moved);              /* Fill buffer if possible. */
370                                                             /* Move one byte for comparison. */
371                temp = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize);
372                current_bit = current_bit + p -> pib.elsize; /* Count the element. */
373                j = 0;                                       /* Reset array index. */
374                do i = 1 to p -> pib.nreads;                 /* Search the delimiter list. */
375                     if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Is this it? */
376                          go to read_delimiter_found;        /* Yes. */
377                     j = j + p -> pib.elsize;                /* Update array index. */
378                end;
379           end;
380           go to read_move;                                  /* Go move the entire string. */
381 
382 read (1):                                                   /* READ 1 CHAR */
383           i = divide (seg_bit_offset, 9, 17, 0);            /* Compute index of first character in file segment. */
384           j = divide (bits_moved, 9, 17, 0);                /* Compute length of rest of segment in characters. */
385           unspec (char1) = substr (p -> pib.readlist, 1, 9); /* Copy the delimiter. */
386           current_bit = 9 * index (substr (seg -> chars, i + 1, j), char1); /* Look for the break. */
387           if current_bit ^= 0 then                          /* Any found? */
388                do;                                          /* Yes. */
389 read_delimiter_found:
390                no_delimiter = ""b;                          /* Clear flag. */
391                bits_moved = current_bit;                    /* Correct size of move. */
392           end;
393 read (0):                                                   /* Case of no read delimiters. */
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;             /* Count total bits transmitted. */
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                              /* Was the delimiter found? */
417                if bits_moved < bits_to_move then            /* No, is more data in other segment? */
418                     do;                                     /* Yes. */
419                     buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */
420                     bits_requested = bits_requested - bits_moved; /* Decrease "demand". */
421                     go to try_read;                         /* Go try again. */
422                end;
423           go to good;
424                                                             /* ^L */
425 file_write:
426           entry (pibp1, workspace, offset3, nelem, nelemt, status6);
427 
428           p = pibp1;
429           sp = addr (status6);
430           nelemt, total_bits = 0;                           /* Clear for accumulation of bits transmitted. */
431           if ^ p -> pib.w then
432                do;                                          /* Improper mode. */
433                code = error_table_$invalid_write;           /* Give error return. */
434                go to bad;
435           end;
436           buffer = workspace;                               /* Copy pointer to caller's buffer. */
437           buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0);
438           if buffer_bit_offset < 0 then                     /* Check range. */
439                do;                                          /* Bad. */
440                code = error_table_$negative_offset;         /* Set up code. */
441                go to bad;                                   /* Give error return. */
442           end;
443           bits_requested = multiply (nelem, p -> pib.elsize, 24, 0);
444           if bits_requested < 0 then                        /* Check range. */
445                do;                                          /* Bad. */
446                code = error_table_$negative_nelem;          /* Set up code. */
447                go to bad;                                   /* Give error return. */
448           end;
449           bits_per_seg = p -> pib.bits_per_segment;
450                                                             /* Might we get bounds fault accessing buffer? */
451           if fixed (rel (buffer), 18) * 36 + buffer_bit_offset + bits_requested > bits_per_seg then
452                do;                                          /* Yes. */
453                code = error_table_$boundviol;               /* Off end of buffer. */
454                go to bad;                                   /* Give error return. */
455           end;
456           call round (p -> pib.writebit);                   /* Round write pointer to element boundary. */
457 try_write:
458           seg_bit_offset = mod (p -> pib.writebit, bits_per_seg); /* Get offset in current segment. */
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); /* Get bits we can move. */
461           comp = divide (p -> pib.writebit, bits_per_seg, 17, 0); /* get component number */
462           if comp ^= p -> pib.lastcomp then do;             /* check to see if same as last time. */
463                call file_util$find_seg_ptr (p, (writing), comp, seg, code); /* Get segment. */
464                if code ^= 0 then                            /* Successful? */
465                     go to bad;                              /* Give error return. */
466                p -> pib.lastcomp = comp;                    /* set new component number. */
467                p -> pib.lastseg = seg;                      /* save new seg number */
468           end;
469           else seg = p -> pib.lastseg;                      /* else set seg to be same as last time. */
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;             /* Count this batch. */
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      /* Was file size increased? */
492                do;                                          /* Yes. */
493                p -> pib.lastbit = p -> pib.writebit;        /* Increase pointer to indicate it. */
494                p -> pib.highbit = p -> pib.lastbit;         /* set high water mark */
495                p -> pib.changed = "1"b;                     /* Mark it for setting bit count. */
496           end;
497           if bits_moved < bits_to_move then                 /* Is more data in other segment? */
498                do;                                          /* Yes. */
499                buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */
500                bits_requested = bits_requested - bits_moved; /* Decrease "demand". */
501                go to try_write;                             /* Go try again. */
502           end;
503           go to good;
504                                                             /* ^L */
505 file_setdelim:
506           entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);
507 dcl  nbreaks, nreads;                                       /* Numbers of elements. */
508 dcl (breaklist, readlist) bit (*) aligned;
509 
510           sp = addr (status6);                              /* Get pointer to status string. */
511           p = pibp1;                                        /* Copy pointer to control data. */
512           if p -> pib.elsize > length (temp) then           /* Will delimiter search work? */
513                do;                                          /* No. */
514                code = error_table_$invalid_setdelim;        /* Refuse call. */
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  /* Will elements span segment boundaries? */
519                do;                                          /* Yes, delimiter search will not always work. */
520                code = error_table_$invalid_setdelim;        /* Give error code. */
521                go to bad;                                   /* Refuse call. */
522           end;
523           if nreads < 0 then                                /* Check validity. */
524                do;                                          /* Bad. */
525                code = error_table_$badcall;                 /* Refuse call. */
526                go to bad;
527           end;
528           if p -> pib.elsize > 9 then                       /* Will we have to store the bytes? */
529                do;                                          /* Yes. */
530                total_bits = nreads * p -> pib.elsize;       /* Compute number of bits required. */
531                if total_bits > length (p -> pib.readlist) then /* Make sure not too many. */
532                     do;                                     /* Bad. */
533                     code = error_table_$too_many_read_delimiters; /* Refuse call. */
534                     go to bad;
535                end;
536           end;
537           p -> pib.nreads = nreads;                         /* Save the total number of delimiters. */
538           if p -> pib.nreads = 1 then                       /* Is there only one? */
539                if p -> pib.elsize = 9 then                  /* Is it a character? */
540                     do;                                     /* Yes, special case. */
541                     p -> pib.search_type = 1;               /* Set dispatch code. */
542                     substr (p -> pib.readlist, 1, 9) = substr (readlist, 1, 9); /* Copy the character. */
543                     go to good;                             /* Return to caller. */
544                end;
545           if p -> pib.nreads = 0 then                       /* Are there no delimiters specified? */
546                do;                                          /* Yes. */
547                p -> pib.search_type = 0;                    /* Set up dispatch code. */
548           end;
549           else
550           if p -> pib.elsize > 9 then                       /* Must we use packed array? */
551                do;                                          /* Yes. */
552                p -> pib.search_type = 3;                    /* Remember dispatch code. */
553                substr (p -> pib.readlist, 1, total_bits) = substr (readlist, 1, total_bits); /* Copy the string. */
554           end;
555           else                                              /* Element size less than 9 bits. */
556           do;                                               /* We may use bit table. */
557                p -> pib.search_type = 2;                    /* Set dispatch code. */
558                p -> pib.readlist = ""b;                     /* Clear the table. */
559                j = 0;                                       /* Set up index of first delimiter. */
560                do i = 1 to p -> pib.nreads;                 /* Start copy loop. */
561                     byte = substr (readlist, j + 1, p -> pib.elsize); /* Extract the byte. */
562                     substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) = "1"b; /* Mark the table entry. */
563                     j = j + p -> pib.elsize;                /* Move index to next delimiter. */
564                end;
565           end;
566           go to good;                                       /* Give happy return. */
567                                                             /* ^L */
568 file_getdelim:
569           entry (pibp1, nbreaks, breaklist, nreads, readlist, status6);
570 
571           sp = addr (status6);                              /* Get pointer to status string. */
572           p = pibp1;                                        /* Copy pointer to control data. */
573           nbreaks = 0;                                      /* We have no break characters. */
574           go to get (p -> pib.search_type);                 /* Dispatch on delimiter code. */
575 
576 get (0): get_none:                                          /* Case of no delimiters. */
577           nreads = 0;                                       /* Set caller's count. */
578           go to good;                                       /* Return to caller. */
579 
580 get (1): get_1_char:                                        /* Special case. */
581           nreads = 1;                                       /* Give caller number of delimiters. */
582           substr (readlist, 1, 9) = substr (p -> pib.readlist, 1, 9); /* Give caller the character. */
583           go to good;                                       /* Return to caller. */
584 
585 get (2): get_bit_table:                                     /* Case of 256-entry bit table. */
586           base, j = 0;                                      /* Reset bit and byte indices. */
587           do nreads = 0 by 1;                               /* Count bytes returned. */
588                i = index (substr (p -> pib.readlist, base + 1), "1"b); /* Find next marked entry. */
589                if i = 0 then                                /* No more? */
590                     go to good;                             /* Return to caller. */
591                substr (readlist, j + 1, p -> pib.elsize) = bit (base + i - 1, 9); /* Form matching code. */
592                j = j + p -> pib.elsize;                     /* Update output array index. */
593                base = base + i;                             /* Update search base. */
594           end;
595           go to good;                                       /* Return to caller. */
596 
597 get (3): get_packed:                                        /* Case of packed array of bytes. */
598           nreads = p -> pib.nreads;                         /* Give caller the number of read delimiters. */
599           total_bits = p -> pib.nreads * p -> pib.elsize;   /* Compute number of bits required. */
600           substr (readlist, 1, total_bits) = substr (p -> pib.readlist, 1, total_bits); /* Give them to caller. */
601           go to good;                                       /* Give happy return. */
602                                                             /* ^L */
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;                          /* Copy name of reference pointer. */
611           call pointerdecode (pointer_name, ptrbit3, switch);
612           if switch = 0 then                                /* Was name recognizable? */
613                do;
614                code = error_table_$undefined_ptrname;       /* Unrecognizable ptrname3. */
615                go to bad;
616           end;
617           offset = add (ptrbit3, multiply (offset4, p -> pib.elsize, 35, 0), 35, 0); /* Compute new pointer value. */
618           if offset < 0 then
619                do;
620                code = error_table_$new_offset_negative;     /* Resultant offset improper. */
621                go to bad;
622           end;
623           pointer_name = ptrname2;                          /* Copy name of pointer to be set. */
624           call pointerdecode (pointer_name, ptrbit2, switch);
625           go to seek (switch);                              /* Dispatch on pointer name. */
626 
627 seek (0): seek_0:
628           code = error_table_$undefined_ptrname;            /* Improper ptrname2. */
629           go to bad;
630 
631 seek (1): seek_first:
632           code = error_table_$change_first;                 /* Attempt to change value of first pointer. */
633           go to bad;                                        /* Give error return. */
634 
635 seek (2): seek_read:
636           if ^ p -> pib.r then                              /* Do we have read permission? */
637                do;                                          /* No. */
638                code = error_table_$invalid_read;            /* Set Error code. */
639                go to bad;                                   /* Give error return. */
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                              /* Do we have write permission? */
646                do;                                          /* No. */
647                code = error_table_$invalid_write;           /* Set error code. */
648                go to bad;                                   /* Give error return. */
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                              /* May we write on this file? */
655                do;                                          /* No. */
656                if offset > p -> pib.highbit then do;
657                     code = error_table_$invalid_seek_last_bound; /* Give error return. */
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                              /* Do we have write permission? */
669                do;                                          /* No. */
670                code = error_table_$invalid_seek_last_bound; /* Give error return. */
671                go to bad;
672           end;
673           p -> pib.boundbit = offset;
674           if p -> pib.lastbit > offset then                 /* Does change to bound necessitate change to last? */
675                do;                                          /* Yes. */
676                p -> pib.lastbit = offset;                   /* Perform necessary truncation. */
677 truncate:      p -> pib.changed = "1"b;                     /* Mark for later setting bit count. */
678           end;
679                                                             /* Truncate read, write pointers if necessary. */
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                                                             /* ^L */
684 file_tell:
685           entry (pibp1, ptrname2, ptrname3, offset4, status5);
686 
687           p = pibp1;
688           sp = addr (status5);
689           pointer_name = ptrname3;                          /* Copy name of reference pointer. */
690           call pointerdecode (pointer_name, ptrbit3, switch);
691           if switch = 0 then                                /* Was name recognizable? */
692                do;
693                code = error_table_$undefined_ptrname;       /* Unrecognizable ptrname3. */
694                go to bad;                                   /* Give error return. */
695           end;
696           pointer_name = ptrname2;                          /* Copy name of pointer whose value is wanted. */
697           call pointerdecode (pointer_name, ptrbit2, switch);
698           if switch = 0 then                                /* Was name recognizable? */
699                do;
700                code = error_table_$undefined_ptrname;       /* Unrecognizable ptrname2. */
701                go to bad;                                   /* Give error return. */
702           end;
703           offset4 = divide (add (ptrbit2, - ptrbit3, 35, 0), p -> pib.elsize, 35, 0);
704           go to good;
705                                                             /* ^L */
706 set_detached_bit:
707           sp -> status.ioname_detached = "1"b;              /* Indicate detachment. */
708 bad:      sp -> status.code = code;
709           go to done;
710 
711 good:     sp -> status.successful = "1111"b;                /* Indicate initiation/termination. */
712           sp -> status.code = 0;                            /* set return code to zero */
713 done:     sp -> status.transaction_terminated = "1"b;       /* Indicate we are done. */
714           if sp -> status.ioname_detached then              /* Was this a detach call? */
715                return;
716           if p -> pib.readbit >= p -> pib.lastbit then
717                sp -> status.end_of_data = "1"b;             /* Set EOF indicator. */
718           return;                                           /* Return to caller. */
719                                                             /* ^L */
720 pointerdecode:                                              /* Procedure to decode pointer name. */
721           procedure (pointername, pointerbit, switch);      /* Returns pointer value and dispatch index. */
722 dcl  pointername character (8) aligned;                     /* Symbolic pointer name. */
723 dcl  pointerbit fixed binary (35);                          /* Returned value of the pointer. */
724 dcl  switch fixed binary;                                   /* Label index. */
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);         /* Round write pointer to integral element. */
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);          /* Round last pointer to integral elements. */
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;                                /* Return to caller. */
760                                                             /* ^L */
761 round:    procedure (offset);                               /* Procedure to round subject to upper limit. */
762 dcl  offset fixed binary (35);                              /* Bit offset in file. */
763 dcl (overage, underage) fixed binary (24);                  /* Element size and errors. */
764 
765                overage = mod (offset, p -> pib.elsize);     /* Calculate amount of offset over integral elements. */
766                if overage ^= 0 then                         /* If zero, we are OK. */
767                     do;
768                     underage = p -> pib.elsize - overage;   /* Get amount of increase necessary. */
769                     if add (infinity, - offset, 35, 0) >= underage then /* Is there room for increase? */
770                          offset = add (offset, underage, 35, 0); /* Yes, round up. */
771                     else
772                     offset = add (offset, - overage, 35, 0); /* No, truncate down. */
773                end;
774           end round;
775      end file;