1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 overlay: ov: proc;
 11 
 12 /* OVERLAY - overlay multiple segments.
 13 
 14    THVV */
 15 /* Usage message with no args; reject bad control args 08/14/80 S. Herbst */
 16 /* Change -in to -ind, add clean_up handler, rename variables 02/18/82 L. Baldwin */
 17 /* Change to allow the archive convention.  07/08/84 R. Roach */
 18 
 19 %include prt_conv_info;
 20 %include access_mode_values;
 21 
 22 dcl  BEAD_COUNT fixed bin;
 23 dcl  NL char (1) int static options (constant) init ("
 24 "),
 25      NLVTFF char (3) int static options (constant) init ("
 26 ^K^L"),
 27      SP char (1) int static options (constant) init (" "),
 28      BS char (1) int static options (constant) init ("^H"),
 29      VT char (1) int static options (constant) init ("^K"),
 30      FF char (1) int static options (constant) init ("^L");
 31 
 32 dcl  obuf char (BEAD_COUNT+1) based (obuf_ptr) aligned;
 33 dcl  system_area area (1024) based (area_ptr);
 34 dcl 1 bead (BEAD_COUNT) based (bead_ptr) aligned,
 35     2 loc fixed bin (26) unal,
 36     2 char char (1) unal;
 37 dcl  seg char (curr_seg_len) based (curr_seg_ptr) aligned;
 38 dcl  arg char (arg_len) based (arg_ptr) unaligned;
 39 
 40 dcl  slew char (1);
 41 dcl  cpt char (32);
 42 dcl  en char (32);
 43 dcl  dn char (168);
 44 dcl  obuf_storage char (513);
 45 dcl  output char (4096);
 46 
 47 dcl  eof (10) bit (1);
 48 
 49 dcl (area_ptr, arg_ptr, bead_ptr, obuf_ptr, curr_ptr, curr_seg_ptr) ptr;
 50 dcl  info_ptr (10) ptr;
 51 dcl  seg_ptr (10) ptr init ((10) null);
 52 dcl (temp_ptr, temp1_ptr) ptr init (null);
 53 
 54 dcl (arg_count, arg_no, arg_len) fixed bin;
 55 dcl (i, ii, j, k, m, n) fixed bin;
 56 dcl  nchars fixed bin;
 57 dcl (next_line, curr_line) fixed bin;
 58 dcl  neof fixed bin;
 59 dcl  file_count fixed bin;
 60 dcl  col_no fixed bin;
 61 dcl  nxline (10) fixed bin init ((10)0);
 62 dcl  ocount fixed bin;
 63 dcl  offset (10) fixed bin;
 64 dcl  page_len fixed bin init (60);
 65 dcl  storage (512) fixed bin;
 66 
 67 dcl  io fixed bin (21);
 68 dcl  curr_seg_len fixed bin (21);
 69 dcl  seg_len (10) fixed bin (21);
 70 dcl  line_no (10) fixed bin (21);
 71 dcl  bit_count fixed bin (24);
 72 dcl  code fixed bin (35);
 73 
 74 dcl  error_table_$badopt fixed bin (35) ext;
 75 dcl  iox_$user_output ptr ext;
 76 dcl  print_conv_$print_conv_ ext;
 77 
 78 dcl (com_err_, com_err_$suppress_name) entry options (variable);
 79 dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
 80 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 81 dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
 82 dcl  expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35));
 83 dcl  get_system_free_area_ entry () returns (ptr);
 84 dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
 85 dcl  initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
 86 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
 87 dcl  prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr);
 88 
 89 dcl (addr, divide, hbound, length, min, mod, null, search, string, substr, unspec) builtin;
 90 dcl  cleanup condition;
 91 
 92 /* ======================================================= */
 93 
 94           area_ptr = get_system_free_area_ ();
 95 
 96           file_count = 0;
 97           BEAD_COUNT = hbound (storage, 1);                 /* set the initial values */
 98           bead_ptr = addr (storage);
 99           obuf_ptr = addr (obuf_storage);
100 
101           call cu_$arg_count (arg_count, code);
102           if code ^= 0 then do;
103                call com_err_ (code, "overlay");
104                return;
105           end;
106           if arg_count = 0 then do;
107                call com_err_$suppress_name (0, "overlay", "Usage:  overlay paths {-control_args}");
108                return;
109           end;
110 
111           do arg_no = 1 to arg_count;
112                call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
113                if arg = "-page_length" | arg = "-pl" then do;
114                     arg_no = arg_no + 1;
115                     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
116                     if code ^= 0 then do;
117 ERROR:                   call com_err_ (code, "overlay", "^a", arg);
118                          return;
119                     end;
120                     page_len = cv_dec_check_ (arg, code);
121                     if code ^= 0 then do;
122                          call com_err_ (0, "overlay", "Invalid integer argument ^a for -page_length", arg);
123                          return;
124                     end;
125                end;
126                else if arg = "-indent" | arg = "-ind" | arg = "-in" then do;
127                     arg_no = arg_no + 1;
128                     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
129                     if code ^= 0 then go to ERROR;
130                     offset (file_count) = cv_dec_check_ (arg, code);
131                     if code ^= 0 then do;
132                          call com_err_ (0, "overlay", "Invalid integer argument ^a for -indent", arg);
133                          return;
134                     end;
135                end;
136                else if substr (arg, 1, 1) = "-" then do;
137                     code = error_table_$badopt;
138                     go to ERROR;
139                end;
140                else do;
141                     file_count = file_count + 1;
142                     if file_count > hbound (seg_ptr, 1) then do;
143                          call com_err_ (0, "overlay", "Number of files exceeds implementation maximum of ^d", hbound (seg_ptr, 1));
144                          return;
145                     end;
146 
147                     call expand_pathname_$component (arg, dn, en, cpt, code);
148                     if code ^= 0 then go to ERROR;
149 
150                     allocate pci set (info_ptr (file_count)) in (system_area);
151                     call init_pci (info_ptr (file_count));
152 
153                     offset (file_count) = 0;
154                     line_no (file_count) = 1;
155                     seg_ptr (file_count) = null;
156 
157                     call initiate_file_$component (dn, en, cpt, R_ACCESS, seg_ptr (file_count), bit_count, code);
158                     if code ^= 0 then go to ERROR;
159                     seg_len (file_count) = divide (bit_count, 9, 17, 0);
160                end;
161           end;
162 
163           if file_count = 0 then do;
164                call com_err_$suppress_name (0, "overlay", "Usage:  overlay paths {-control_args}");
165                return;
166           end;
167 
168           on cleanup call clean_up;
169 
170           do i = 1 to file_count;
171                info_ptr (i) -> pci.page_length = page_len;
172                info_ptr (i) -> pci.phys_page_length = page_len;
173                info_ptr (i) -> pci.overflow_off = "0"b;
174           end;
175 
176           neof = 0;                                         /* Initialize counters */
177           curr_line = 1;
178           eof (*) = "0"b;
179 
180           do while (neof < file_count);                     /* Stop when end of all input */
181 
182                nchars = 0;                                  /* number of chars in this line */
183                next_line = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0);
184 
185                do i = 1 to file_count;                      /* Take input from all segs */
186                     if eof (i) then go to SKIP;
187                     if curr_line < nxline (i) then go to SKIP;
188 
189                     curr_seg_len = seg_len (i);             /* Get input seg length */
190                     curr_seg_ptr = seg_ptr (i);             /* .. ptr */
191                     curr_ptr = addr (substr (seg, line_no (i), 1)); /* .. ptr to current loc */
192                     n = search (substr (seg, line_no (i)), NLVTFF); /* .. loc of end of input line */
193                     if n = 0 then n = seg_len (i) - line_no (i);
194                     line_no (i) = line_no (i) + n;
195                     if line_no (i) >= seg_len (i) then do;
196                          eof (i) = "1"b;                    /* ignore this seg from now on */
197                          neof = neof + 1;
198                     end;
199 
200                     do while (n > 0);                       /* Normalize line */
201                          call prt_conv_ (curr_ptr, n, addr (obuf), ocount, info_ptr (i));
202                          do j = 1 to ocount-1;
203                               if substr (obuf, j, 1) ^= " " then do;
204                                    nchars = nchars + 1;     /* Save each character */
205                                    if nchars > BEAD_COUNT then call MORE_ROOM;
206                                    bead (nchars).char = substr (obuf, j, 1);
207                                    bead (nchars).loc = j + offset (i);
208                               end;
209                          end;
210                     end;
211 
212                     slew = substr (obuf, ocount, 1);        /* Deal with slew */
213                     if slew = FF then do;
214                          nxline (i) = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0);
215                     end;
216                     else if slew = VT then do;
217                          nxline (i) = 1 + 10 * divide (curr_line+9, 10, 17, 0);
218                     end;
219                     else if slew = NL then do;              /* Can reach vertical tabstop via NL's */
220                          nxline (i) = curr_line+1;
221                     end;
222                     next_line = min (next_line, nxline (i));
223 SKIP:          end;                                         /* End loop on input files. one line assembled */
224                call sort;                                   /* Order chars on line */
225                io = 0;                                      /* output counter */
226                col_no = 1;                                  /* column */
227                do k = 1 to nchars;                          /* put out all chars */
228                     m = bead (k).loc - col_no;              /* compute white space */
229                     if m > 0 then do ii = 1 to m;           /* if going right */
230                          io = io + 1;
231                          substr (output, io, 1) = SP;
232                     end;
233                     if m < 0 then do;                       /* if going left (should be only one) */
234                          io = io + 1;
235                          substr (output, io, 1) = BS;
236                     end;
237                     io = io + 1;                            /* Now put out char */
238                     substr (output, io, 1) = bead (k).char;
239                     col_no = bead (k).loc + 1;              /* remember last used column */
240                end;
241                io = io + 1;                                 /* output slew char */
242                if next_line = curr_line+1 then substr (output, io, 1) = NL;
243                else if mod (next_line-1, page_len) = 0 then substr (output, io, 1) = FF;
244                else substr (output, io, 1) = VT;
245                call iox_$put_chars (iox_$user_output, addr (output), io, (0));
246                curr_line = next_line;
247 
248           end;
249 
250           call clean_up;
251           return;
252 
253 /* ------------------------------------------------------- */
254 
255 sort:     proc;
256 
257 dcl  temp fixed bin;
258 dcl  swaps fixed bin;
259 dcl  d fixed bin;
260 dcl  i fixed bin;
261 
262 dcl  vec (BEAD_COUNT) fixed bin based (bead_ptr);
263 
264                d = nchars;
265 PASS:          swaps = 0;
266                d = divide (d + 1, 2, 17, 0);
267                do i = 1 to nchars - d;
268                     if vec (i) > vec (i+d) then do;
269                          swaps = swaps + 1;
270                          temp = vec (i);
271                          vec (i) = vec (i+d);
272                          vec (i+d) = temp;
273                     end;
274                end;
275                if d > 1 then go to PASS;
276                if swaps > 0 then go to PASS;
277 
278           end sort;
279 
280 init_pci: proc (p);
281 
282 dcl  p ptr;
283 
284                unspec (p -> pci) = "0"b;                    /* clear everything */
285                p -> pci.cv_proc = addr (print_conv_$print_conv_);
286                p -> pci.level = 0;
287                p -> pci.pos = 0;
288                p -> pci.lmarg = 0;
289                p -> pci.rmarg = length (obuf) - 1;
290                p -> pci.phys_line_length = length (obuf) - 1;
291                p -> pci.page_length = 60;
292                p -> pci.phys_page_length = 66;
293                p -> pci.lpi = 6;
294                p -> pci.sheets_per_page = 1;
295                p -> pci.line_count = 0;
296                p -> pci.page_count = 0;
297                string (p -> pci.modes) = ""b;
298                p -> pci.top_label_line = "";
299                p -> pci.bot_label_line = "";
300                p -> pci.top_label_length = 0;
301                p -> pci.bot_label_length = 0;
302                p -> pci.line = 1;
303                p -> pci.slew_residue = 0;
304                p -> pci.label_nelem = 0;
305                p -> pci.sav_pos = 0;
306                p -> pci.func = 0;
307                p -> pci.temp = "0"b;
308                p -> pci.overflow_off = "1"b;
309 
310           end init_pci;
311 
312 MORE_ROOM: proc;
313 
314 dcl  k fixed bin;
315 
316                k = BEAD_COUNT;
317                BEAD_COUNT = 2*BEAD_COUNT;
318                allocate bead set (temp_ptr) in (system_area);
319                allocate obuf set (temp1_ptr) in (system_area);
320                BEAD_COUNT = k;
321                temp_ptr -> bead = bead;
322                temp1_ptr -> obuf = obuf;
323                if bead_ptr ^= addr (storage) then free bead;
324                if obuf_ptr ^= addr (obuf_storage) then free obuf;
325                BEAD_COUNT = 2*BEAD_COUNT;
326                bead_ptr = temp_ptr;
327                obuf_ptr = temp1_ptr;
328 
329           end MORE_ROOM;
330 
331 clean_up: proc;
332 
333                do i = 1 to file_count;
334                     if seg_ptr (i) ^= null then call hcs_$terminate_noname (seg_ptr (i), code);
335                     free info_ptr (i) -> pci;
336                end;
337                if temp_ptr ^= null then free bead;
338                if temp1_ptr ^= null then free obuf;
339 
340           end clean_up;
341 
342      end overlay;