1
2
3
4
5
6
7
8
9
10 overlay: ov: proc;
11
12
13
14
15
16
17
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);
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;
177 curr_line = 1;
178 eof (*) = "0"b;
179
180 do while (neof < file_count);
181
182 nchars = 0;
183 next_line = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0);
184
185 do i = 1 to file_count;
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);
190 curr_seg_ptr = seg_ptr (i);
191 curr_ptr = addr (substr (seg, line_no (i), 1));
192 n = search (substr (seg, line_no (i)), NLVTFF);
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;
197 neof = neof + 1;
198 end;
199
200 do while (n > 0);
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;
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);
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;
220 nxline (i) = curr_line+1;
221 end;
222 next_line = min (next_line, nxline (i));
223 SKIP: end;
224 call sort;
225 io = 0;
226 col_no = 1;
227 do k = 1 to nchars;
228 m = bead (k).loc - col_no;
229 if m > 0 then do ii = 1 to m;
230 io = io + 1;
231 substr (output, io, 1) = SP;
232 end;
233 if m < 0 then do;
234 io = io + 1;
235 substr (output, io, 1) = BS;
236 end;
237 io = io + 1;
238 substr (output, io, 1) = bead (k).char;
239 col_no = bead (k).loc + 1;
240 end;
241 io = io + 1;
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;
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;