1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41 indent: ind: proc;
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72 dcl suffixes (3) char (4) init (".pl1", ".cds", ".rd"),
73 suffix_lengths (3) fixed bin init (4, 4, 3),
74 suffix_len fixed bin;
75
76 dcl rd_source_sw bit (1),
77 copy_this_comment_unchanged bit (1);
78
79 dcl (n1, n2) char (168) aligned,
80 dn char (168) aligned,
81 en char (32) aligned,
82 temp_en char (32) aligned,
83 ap ptr,
84 al fixed bin,
85 an fixed bin,
86 nargs fixed bin,
87 expecting fixed bin init (0),
88 bchr char (al) based (ap) unaligned,
89 (linno, indent, ntab) fixed bin,
90 ec fixed bin (35) init (0),
91 offset fixed bin (24),
92 (string_offset, line_offset) fixed bin (24),
93 string_len fixed bin,
94 (p, p1) ptr,
95 (icb, ice, icol) fixed bin,
96 (chars, temchars) char (400),
97 char char (1),
98 n fixed bin,
99 lth fixed bin (24),
100 (lth1, lth2) fixed bin,
101 end_count fixed bin,
102 if_count fixed bin,
103 old_if_count fixed bin,
104 (scolsw,
105 dclfnd,
106 dclsw,
107 condsw,
108 ifsw,
109 begin_ok,
110 else_ok,
111 strut,
112 sixty,
113 bos,
114 blsw,
115 comment,
116 newpage,
117 string,
118 pstring) bit (1) aligned,
119 bfsw bit (1) aligned init ("0"b),
120 string_error bit (1) aligned init ("0"b),
121 (false init ("0"b), true init ("1"b)) int static options (constant) bit (1) aligned,
122 (in, dent, dclind) fixed bin,
123 LMARGIN fixed bin init (11),
124 IN fixed bin init (5),
125 CMC fixed bin init (61),
126 TABCOL fixed bin init (60),
127 NTAB fixed bin init (6),
128 nout fixed bin (24),
129 colpos fixed bin,
130 parct fixed bin init (0),
131 pdlx fixed bin,
132 ifdent fixed bin,
133 suffix char (4),
134 suffix_assumed bit (1) init ("0"b),
135 (i, j, k, kk, m) fixed bin (24);
136
137 dcl 1 pdl (1024) aligned,
138 2 nif fixed bin (33) unal,
139 2 swc bit (1) unal,
140 2 sw bit (1) unal;
141
142 dcl NP_NL_SP char (3) init static init ("^L
143 ");
144 dcl SP char (1) int static init (" ");
145 dcl SP_TAB char (2) int static init (" ");
146 dcl SP_LP_NOT char (3) int static init (" (^");
147 dcl NOT_LES_GRT char (3) int static init ("^<>");
148 dcl SP_TAB_COM_SEMI char (4) int static init (" ,; ");
149 dcl SP_TAB_SEMI_NL char (4) int static init (" ;
150 ");
151 dcl SP_TAB_SEMI_LP_NL char (5) int static init (" ; (
152 ");
153 dcl NL char (1) int static init ("
154 ");
155 dcl TABS char (40) int static init ((40)" ");
156
157 dcl bcs char (lth) based (p) aligned;
158 dcl bcso char (1048576) based (p1) aligned;
159
160 dcl cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin),
161 ioa_ entry options (variable),
162 com_err_ entry options (variable),
163 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
164 cu_$arg_count entry (fixed bin),
165 expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
166 hcs_$delentry_seg entry (ptr, fixed bin (35)),
167 hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)),
168 hcs_$terminate_noname entry (ptr, fixed bin (35)),
169 hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5),
170 ptr, fixed bin (35)),
171 hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
172 fixed bin (2), ptr, fixed bin (35)),
173 get_pdir_ entry () returns (char (168) aligned),
174 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
175
176 dcl (output_path_given, error_occurred) bit (1) aligned init ("0"b);
177
178
179
180 dcl moveseg char (nout) based aligned;
181
182 dcl err_msg char (100) varying;
183
184 dcl error_table_$bad_arg fixed bin (35) ext;
185 dcl error_table_$badopt fixed bin (35) ext;
186 dcl error_table_$noarg fixed bin (35) ext;
187 dcl error_table_$noentry fixed bin (35) ext;
188
189 dcl (addr, divide, fixed, length, mod, min, null, substr, index, reverse,
190 search, verify, unspec) builtin;
191 ^L
192
193
194
195 call cu_$arg_count (nargs);
196 if nargs = 0 then do;
197 call com_err_ (0, "indent", "Usage: indent n1 -n2- -lm nn -in mm -cm kk -brief");
198 return;
199 end;
200
201 lth1, lth2 = 0;
202 arg_loop: do an = 1 to nargs;
203 call cu_$arg_ptr (an, ap, al, ec);
204
205 if ec ^= 0 then do;
206 print_bad_arg: err_msg = "^a";
207 arg_error: call com_err_ (ec, "indent", err_msg, bchr);
208 return;
209 end;
210
211 if expecting ^= 0 then do;
212
213 en = bchr;
214 i = cv_dec_check_ (en, ec);
215
216 if expecting = 1 then do;
217 expecting = 0;
218 if ec ^= 0 then do;
219 blm: err_msg = "illegal left margin arg ^a";
220 cv_dec_error: ec = 0;
221 goto arg_error;
222 end;
223 if i < 1 then goto blm;
224 if i > 100 then goto blm;
225 LMARGIN = i;
226 end;
227
228 else if expecting = 2 then do;
229 expecting = 0;
230 if ec ^= 0 then do;
231 bint: err_msg = "illegal indent arg ^a";
232 goto cv_dec_error;
233 end;
234 if i < 0 then goto bint;
235 if i > 100 then goto bint;
236 IN = i;
237 end;
238
239 else do;
240 expecting = 0;
241 if ec ^= 0 then do;
242 bcmc: err_msg = "illegal comment column arg ^a";
243 goto cv_dec_error;
244 end;
245 if i < 1 then goto bcmc;
246 if i > 350 then goto bcmc;
247 CMC = i;
248 TABCOL = 10 * divide (CMC-1, 10, 17, 0);
249 NTAB = divide (TABCOL, 10, 17, 0);
250 end;
251
252 end;
253
254 else do;
255
256 if substr (bchr, 1, 1) = "-" then do;
257 if bchr = "-brief" then bfsw = true;
258 else if bchr = "-bf" then bfsw = true;
259 else if bchr = "-lmargin" then expecting = 1;
260 else if bchr = "-lm" then expecting = 1;
261 else if bchr = "-indent" then expecting = 2;
262 else if bchr = "-ind" then expecting = 2;
263 else if bchr = "-in" then expecting = 2;
264 else if bchr = "-comment" then expecting = 3;
265 else if bchr = "-cm" then expecting = 3;
266 else do;
267 ec = error_table_$badopt;
268 goto print_bad_arg;
269 end;
270 end;
271
272 else do;
273 if lth1 = 0 then do;
274 n1 = bchr;
275 lth1 = al;
276 end;
277 else if lth2 = 0 then do;
278 n2 = bchr;
279 lth2 = al;
280 output_path_given = "1"b;
281 end;
282 else do;
283 ec = error_table_$bad_arg;
284 goto print_bad_arg;
285 end;
286 end;
287 end;
288 end arg_loop;
289
290 if lth1 = 0 then do;
291 err_msg = "pathname of input file";
292 noarg_err: ec = error_table_$noarg;
293 goto arg_error;
294 end;
295
296 if expecting ^= 0 then do;
297 err_msg = "after ^a";
298 goto noarg_err;
299 end;
300
301 if lth2 = 0 then do;
302 n2 = n1;
303 lth2 = lth1;
304 end;
305
306
307
308
309
310
311 rd_source_sw, copy_this_comment_unchanged = false;
312
313 in, ifdent, if_count, old_if_count = 0;
314 strut, dclsw, condsw, ifsw, begin_ok, else_ok, comment, sixty, string, pstring = false;
315 bos, blsw = true;
316 pdlx = 1;
317 linno = 1;
318 offset, nout = 1;
319
320 i = index (reverse (substr (n1, 1, lth1)), ".");
321 if i = 0 | i > 4 then go to in_suffix;
322 suffix = substr (n1, lth1 - i + 1, i);
323 do j = 1 to 3;
324 if suffix = suffixes (j)
325 then do;
326 suffix_len = suffix_lengths (j);
327 go to good_suffix;
328 end;
329 end;
330
331
332
333 in_suffix: suffix = ".pl1";
334 suffix_len = 4;
335 substr (n1, lth1+1, suffix_len) = suffix;
336 lth1 = lth1+suffix_len;
337 suffix_assumed = "1"b;
338
339 good_suffix:
340 if suffix = ".rd" then rd_source_sw = "1"b;
341
342 call expand_path_ (addr (n1), lth1, addr (dn), addr (en), ec);
343 if ec ^= 0 then go to error;
344 call hcs_$initiate_count (dn, en, "", lth, 0, p, ec);
345 if p = null then do;
346 if ^suffix_assumed then go to error;
347 if ec ^= error_table_$noentry then go to error;
348 i = 34 - suffix_len - verify (reverse (en), " ");
349 suffix = ".cds";
350 suffix_len = 4;
351 substr (en, i, suffix_len) = substr (suffix, 1, suffix_len);
352 call hcs_$initiate_count (dn, en, "", lth, 0, p, ec);
353 if p = null then do;
354 if ec = error_table_$noentry then
355 go to error;
356 substr (n1, lth1 - (suffix_len-1), suffix_len) = substr (suffix, 1, suffix_len);
357
358 go to error;
359 end;
360 end;
361 if lth2 < 4 then go to out_suffix;
362 else if substr (n2, lth2 - (suffix_len-1), suffix_len) ^= substr (suffix, 1, suffix_len)
363 then do;
364 out_suffix: substr (n2, lth2+1, suffix_len) = substr (suffix, 1, suffix_len);
365 lth2 = lth2+suffix_len;
366 end;
367 lth = divide (lth+8, 9, 17, 0);
368
369 temp_en = en;
370 i = 34 -suffix_len - verify (reverse (temp_en), " ");
371 substr (temp_en, i, 4) = ".ind";
372 call hcs_$make_seg ((get_pdir_ ()), temp_en, "", 1010b, p1, ec);
373 if p1 = null then go to error;
374 call expand_path_ (addr (n2), lth2, addr (dn), addr (en), ec);
375 if ec ^= 0 then go to error;
376
377
378
379
380 loop: pstring = string;
381 if offset > lth then go to eof;
382 i = index (substr (bcs, offset), NL);
383 if i = 0 then i = lth - offset + 1;
384 else if i = 1 then do;
385 substr (bcso, nout, 1) = NL;
386 nout = nout + 1;
387 linno = linno + 1;
388 offset = offset + 1;
389 blsw = true;
390 go to loop;
391 end;
392 k = i - 1;
393 if k > 385 then do;
394 k, i = 385;
395 call ioa_ ("indent: line ^d of ""^a"" was too long & has been split.", linno, en);
396 error_occurred = "1"b;
397 end;
398 chars = substr (bcs, offset, k);
399 substr (chars, k+1, 1) = NL;
400 line_offset = offset;
401 offset = offset + i;
402 n = k + 1;
403 if n = 1 then go to lemp;
404 if ^pstring then
405 if substr (chars, 1, 1) = "%" then do;
406 lemp: blsw = true;
407 go to cpy;
408 end;
409
410 icb, ice, icol, dent, end_count = 0;
411 scolsw, dclfnd, newpage = false;
412
413
414
415
416 if pstring then do;
417 kk = index (substr (chars, 1, n-1), """");
418 if kk = 0 then go to cpy;
419 else i = kk;
420 end;
421 else i = 1;
422 l2s: char = substr (chars, i, 1);
423 if string then do;
424 if char = """" then do;
425 string = false;
426
427
428
429
430
431 string_len = line_offset+i-string_offset-1;
432 if string_len > 254 then
433
434 if ^bfsw then
435 if ^string_error then do;
436
437 call ioa_
438 ("indent: possible syntax error in line ^d of ^a: string length (^d) > pl1 max.",
439 linno, en, string_len);
440 string_error = "1"b;
441 error_occurred = "1"b;
442 end;
443 end;
444 go to l2e;
445 end;
446 if comment then do;
447 if substr (chars, i, 2) = "*/" then do;
448 comment = false;
449 if copy_this_comment_unchanged then
450
451 copy_this_comment_unchanged = false;
452 else do;
453 if i > 1 then if index (SP_TAB, substr (chars, i-1, 1)) = 0
454
455 then call inb (i);
456 if i < n-2 then
457 if index (SP_TAB_COM_SEMI, substr (chars, i+2, 1)) = 0 then
458 call inb (i+2);
459 end;
460 ice = i;
461 i = i + 1;
462 go to l2e;
463 end;
464 if i = 1 then do;
465 k = verify (substr (chars, 1, n-1), SP_TAB) - 1;
466 if k = -1 then do;
467 chars = "";
468 substr (chars, 1, 1) = NL;
469 n = 1;
470 go to cpy;
471 end;
472 if ^copy_this_comment_unchanged
473 then do;
474 substr (temchars, 1, n-k) = substr (chars, k+1, n-k);
475 substr (chars, 1, 3) = "";
476 substr (chars, 4, n-k) = substr (temchars, 1, n-k);
477 i = 4;
478 n = n - k + 3;
479 end;
480 end;
481 kk = index (substr (chars, i, n-i), "*/");
482 if kk = 0 then i = n-1;
483 else i = i + kk - 2;
484 go to l2e;
485 end;
486 k = fixed (unspec (char), 9);
487 if k < 0 then go to ilchr;
488 if k > 126 then go to ilchr;
489 go to case (k);
490
491
492
493
494
495 case (009):
496 substr (chars, i, 1) = SP;
497 case (032):
498 if i = 1 then go to squidge;
499 if substr (chars, i-1, 1) = SP then do;
500 squidge: k = verify (substr (chars, i, n-i), SP_TAB) - 1;
501 if k > 0 then call outb (i, k);
502 end;
503 go to l2e;
504 case (034):
505 string = true;
506 string_offset = line_offset+i;
507 kk = index (substr (chars, i+1, n-i), """");
508 if kk > 0 then i = i + kk - 1;
509 else i = n-1;
510 go to cbs;
511 case (040):
512 parct = parct + 1;
513 if i > 1 then if index (SP_LP_NOT, substr (chars, i-1, 1)) = 0 then call inb (i);
514 if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) ^= 0 then call outb (i+1, 1);
515 go to nxchr;
516 case (041):
517 if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1);
518 parct = parct - 1;
519 if parct < 0 then do;
520 call ioa_ ("indent: line ^d of ""^a"" has an extra "")"".", linno, en);
521 error_occurred = "1"b;
522 parct = 0;
523 end;
524 go to cbs;
525 case (044):
526 if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1);
527 if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1);
528 go to cbs;
529 case (045):
530 if substr (chars, i+1, 1) = ">" then do;
531 if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i);
532 if i < n-2 then if substr (chars, i+2, 1) ^= SP then call inb (i+2);
533 end;
534 go to cbs;
535 case (047):
536 if substr (chars, i+1, 1) = "*" then do;
537 comment = true;
538 if i - length ("/") + length ("
539
540
541 if ^copy_this_comment_unchanged then do;
542 if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i);
543 if i < n - length ("/") - length (NL)
544 then if index (SP_TAB, substr (chars, i+2, 1)) = 0
545 then if ^rd_source_sw
546 then call inb (i+2);
547 else if substr (chars, i+2, 2) = "++"
548
549 then copy_this_comment_unchanged = true;
550
551 else call inb (i+2);
552 end;
553 icb = i;
554 kk = index (substr (chars, i+2, n-i-2), "*/");
555 if kk = 0 then i = n-1;
556 else i = i + kk;
557 go to l2e;
558 end;
559 go to cbs;
560 case (058):
561 if parct > 0 then go to nxchr;
562 if bos then go to cbs;
563 bos = true;
564 icol = i + 1;
565 if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) = 0 then call inb (i+1);
566 go to l2e;
567 case (059):
568 scolsw, bos = true;
569 begin_ok = false;
570 if condsw then do;
571 old_if_count = if_count;
572 if pdlx = 1 then if_count = 0;
573 else if_count = pdl (pdlx-1).nif;
574 condsw = false;
575 else_ok = true;
576 end;
577 else old_if_count = 0;
578 ifsw = false;
579 if parct > 0 then do;
580 call ioa_ ("indent: ^d extra ""(""s at line ^d of ""^a"".",
581 parct, linno, en);
582 error_occurred = "1"b;
583 parct = 0;
584 end;
585 go to l2e;
586 case (061):
587 if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1);
588 m = 1;
589 if i > 1 then if index (NOT_LES_GRT, substr (chars, i-1, 1)) ^= 0 then m = 2;
590 if i > m then if substr (chars, i-m, 1) ^= SP then call inb (i-m+1);
591 go to cbs;
592
593
594
595 case (098):
596 if ^bos then if ^begin_ok then go to nxchr;
597 if parct > 0 then go to nxchr;
598 if i <= n-5 then if substr (chars, i, 5) = "begin" then
599 if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 6 then do;
600 i = i + 4;
601 in_found: if ifsw then if_count = if_count - 1;
602 pdl (pdlx).sw = ifsw;
603 pdl (pdlx).swc = condsw;
604 pdl (pdlx).nif = if_count;
605 pdlx = pdlx + 1;
606 if pdlx = 1024 then do;
607 call com_err_ (0, "indent", "FATAL ERROR. Line ^d of ""^a"" nesting depth > 1024",
608 linno, en);
609 return;
610 end;
611 condsw = false;
612 ifsw = false;
613 dent = dent + 1;
614 end;
615 go to nxchr;
616 case (100):
617 if parct > 0 then go to nxchr;
618 if ^bos then go to nxchr;
619 kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL);
620 if kk = 3 then if substr (chars, i, 2) = "do" then do;
621 i = i + 1;
622 go to in_found;
623 end;
624 if condsw then go to nxchr;
625 if i = 1 then do;
626 if kk = 4 then if substr (chars, i, 3) = "dcl" then do;
627 dclfnd = true;
628 i = i + 2;
629 dclind = 4;
630 go to nxchr;
631 end;
632 if kk = 8 then if substr (chars, i, 7) = "declare" then do;
633 dclfnd = true;
634 i = i + 6;
635 dclind = 8;
636 go to nxchr;
637 end;
638 end;
639 go to nxchr;
640 case (101):
641 if parct > 0 then go to nxchr;
642 if ^bos then go to nxchr;
643 kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL);
644 if else_ok then if kk = 5 then if substr (chars, i, 4) = "else" then do;
645 if_count = old_if_count - 1;
646 ifdent = old_if_count - 1;
647 else_ok = false;
648 if if_count > 0 then condsw = true;
649 bos = true;
650 i = i + 3;
651 go to l2e;
652 end;
653 if condsw then go to nxchr;
654 if kk = 4 then if substr (chars, i, 3) = "end" then do;
655 end_count = end_count + 1;
656 if pdlx > 1 then do;
657 pdlx = pdlx - 1;
658 ifsw = pdl (pdlx).sw;
659 condsw = pdl (pdlx).swc;
660 if_count = pdl (pdlx).nif;
661 if ifsw then if_count = if_count + 1;
662 end;
663 if (in - end_count + dent) < 0 then do;
664 call ioa_ ("indent: line ^d of ""^a"" has an extra ""end"".", linno, en);
665 dent, in, end_count = 0;
666 error_occurred = "1"b;
667 end;
668 i = i + 2;
669 end;
670 go to nxchr;
671 case (105):
672 if parct > 0 then go to nxchr;
673 if ^bos then go to nxchr;
674 if i <= n-2 then if substr (chars, i, 2) = "if" then
675 if search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL) = 3 then do;
676 condsw = true;
677 ifsw = true;
678 i = i + 1;
679 end;
680 go to nxchr;
681 case (116):
682 if parct > 0 then go to nxchr;
683 if bos then go to nxchr;
684 if ^ifsw then go to nxchr;
685 if i ^= 1 then if substr (chars, i-1, 1) ^= SP then go to nxchr;
686 if i <= n-4 then if substr (chars, i, 4) = "then" then
687 if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 5 then do;
688 bos = true;
689 i = i + 3;
690 if_count = if_count + 1;
691 go to l2e;
692 end;
693 go to nxchr;
694 case (111):
695 if ^bos then go to nxchr;
696 if parct > 0 then go to nxchr;
697 if i <= n-2 then if substr (chars, i, 2) = "on" then
698 if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 3 then do;
699 begin_ok = true;
700 i = i + 1;
701 end;
702 go to nxchr;
703 case (112):
704 if parct > 0 then go to nxchr;
705 if ^bos then go to nxchr;
706 if condsw then go to nxchr;
707 k = 3;
708 kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL);
709 if kk = 5 then if substr (chars, i, 4) = "proc" then go to procfnd;
710 k = 8;
711 if kk = 10 then if substr (chars, i, 9) = "procedure" then do;
712 procfnd: i = i + k;
713 go to in_found;
714 end;
715 go to nxchr;
716
717
718
719 case (000):
720 case (001):
721 case (002):
722 case (003):
723 case (004):
724 case (005):
725 case (006):
726 case (007):
727 case (008):
728 case (013):
729 case (014):
730 case (015):
731 case (016):
732 case (017):
733 case (018):
734 case (019):
735 case (020):
736 case (021):
737 case (022):
738 case (023):
739 case (024):
740 case (025):
741 case (026):
742 case (027):
743 case (028):
744 case (029):
745 case (030):
746 case (031):
747 ilchr: call ioa_ ("indent: warning: illegal character (octal ^3.3b) in line ^d of ""^a""",
748 unspec (substr (chars, i, 1)), linno, en);
749 error_occurred = "1"b;
750 go to l2e;
751
752 case (033):
753 case (035):
754 case (039):
755 case (063):
756 case (064):
757 case (091):
758 case (092):
759 case (093):
760 case (096):
761 case (123):
762 case (125):
763 case (126):
764 if ^bfsw then do;
765 call ioa_ ("indent: warning: non-pl1 char ""^a"" outside string in line ^d of ""^a""",
766 substr (chars, i, 1), linno, en);
767 error_occurred = "1"b;
768 end;
769 go to l2e;
770
771
772
773 case (036):
774 case (038):
775 case (042):
776 case (043):
777 case (046):
778 case (048):
779 case (049):
780 case (050):
781 case (051):
782 case (052):
783 case (053):
784 case (054):
785 case (055):
786 case (056):
787 case (057):
788 case (060):
789 case (062):
790 case (094):
791 case (095):
792 case (124):
793 cbs: if bos then if ^bfsw then do;
794 call ioa_ ("indent: possible syntax error in line ^d of ^a detected at char ""^a""",
795 linno, en, substr (chars, i, 1));
796 error_occurred = "1"b;
797 end;
798
799
800
801 case (037):
802 case (065):
803 case (066):
804 case (067):
805 case (068):
806 case (069):
807 case (070):
808 case (071):
809 case (072):
810 case (073):
811 case (074):
812 case (075):
813 case (076):
814 case (077):
815 case (078):
816 case (079):
817 case (080):
818 case (081):
819 case (082):
820 case (083):
821 case (084):
822 case (085):
823 case (086):
824 case (087):
825 case (088):
826 case (089):
827 case (090):
828 case (097):
829 case (099):
830 case (102):
831 case (103):
832 case (104):
833 case (106):
834 case (107):
835 case (108):
836 case (109):
837 case (110):
838 case (113):
839 case (114):
840 case (115):
841 case (117):
842 case (118):
843 case (119):
844 case (120):
845 case (121):
846 case (122):
847 nxchr: bos = false;
848 else_ok = false;
849 go to l2e;
850
851
852
853 case (012):
854 newpage = "1"b;
855 case (010):
856 case (011):
857 l2e: i = i + 1;
858 if i < n then go to l2s;
859
860
861
862 i = 1;
863 if newpage then do;
864 if verify (substr (chars, 1, n), NP_NL_SP) = 0 then do;
865 n = 2;
866 chars = substr (NP_NL_SP, 1, 2);
867 blsw = true;
868 go to cpy;
869 end;
870 end;
871 if icb = 1 then do;
872 if blsw then do;
873 sixty = false;
874 go to cpy;
875 end;
876 push: sixty = true;
877 ntab = NTAB;
878 i = 1;
879 go to nimcom;
880 end;
881 if icb = 0 then if (comment | ice > 0) then do;
882 if sixty then go to push;
883 cpy: substr (bcso, nout, n) = substr (chars, 1, n);
884 nout = nout + n;
885 go to finish_line;
886 end;
887
888
889
890 blsw = false;
891 if pstring then do;
892 indent = 0;
893 icol = 0;
894 end;
895 else if dclfnd then do;
896 dclfnd = false;
897 dclsw = true;
898 if index ("0123456789", substr (chars, dclind+1, 1)) ^= 0 then strut = true; else strut = false;
899 icol = dclind;
900 if strut then indent = dclind+1;
901 else if substr (chars, dclind+1, 1) = "(" then indent = dclind+1;
902
903 else indent = dclind+2;
904 end;
905 else if dclsw then do;
906 icol = 0;
907 kk = index ("0123456789", substr (chars, 1, 1)) - 1;
908 if strut & kk >= 0 then do;
909 k = kk;
910 kk = index ("0123456789", substr (chars, 2, 1)) - 1;
911 if kk >= 0 then k = k*10 + kk;
912 indent = dclind + k + k - 3;
913 end;
914
915
916
917
918
919 else if substr (chars, 1, 1) = "("
920 then do;
921 if strut
922 then do;
923 k = index ("0123456789", substr (chars, 2, 1)) - 1;
924 if k > 0
925 then do;
926 kk = index ("0123456789", substr (chars, 3, 1)) - 1;
927 if kk > 0 then k = 10 * k + kk;
928 indent = dclind + k + k - 4;
929 end;
930
931
932
933 end;
934 else indent = dclind + 1;
935 end;
936
937 else indent = dclind+2;
938 end;
939 else do;
940 k = min (end_count, dent);
941 end_count = end_count - k;
942 dent = dent - k;
943 indent = (in + ifdent - end_count - 1) * IN + LMARGIN;
944 if indent < 0 then indent = 0;
945 end;
946
947
948
949 if icol >= n then go to cpy;
950 colpos = 0;
951 if icol ^= 0 then do;
952 substr (bcso, nout, icol) = substr (chars, 1, icol);
953 nout = nout + icol;
954 colpos = colpos + icol;
955 end;
956 i = icol + 1;
957 if i ^= icb then
958 if indent > icol then do;
959 if substr (chars, icol, 1) = SP then do;
960 icol = icol - 1;
961 colpos = colpos - 1;
962 nout = nout - 1;
963 end;
964 k = indent - icol - 1;
965 colpos = colpos + k;
966 if colpos >= 10 then do;
967 kk = divide (colpos, 10, 17, 0) - divide (icol, 10, 17, 0);
968 if kk > 0 then do;
969 substr (bcso, nout, kk) = substr (TABS, 1, kk);
970 nout = nout + kk;
971 k = mod (colpos, 10);
972 end;
973 end;
974 if k ^= 0 then do;
975 substr (bcso, nout, k) = "";
976 nout = nout + k;
977 end;
978 end;
979 if ice ^= 0 then if ice = n-2 then go to havcom;
980 if ice ^= 0 then if ice = n-3 then if substr (chars, n-1, 1) = ";" then go to havcom;
981
982 if ice = 0 then if icb > 0 then do;
983 havcom: sixty = true;
984 k = icb-i;
985 if k ^= 0 then do;
986 substr (bcso, nout, k) = substr (chars, i, k);
987 nout = nout + k;
988 colpos = colpos + k;
989 i = i + k;
990 end;
991 if colpos < TABCOL then do;
992 if substr (bcso, nout-1, 1) = SP then do;
993 nout = nout - 1;
994 colpos = colpos - 1;
995 end;
996 if substr (chars, i, 1) = SP then i = i + 1;
997 ntab = divide (TABCOL-colpos-1, 10, 17, 0) + 1;
998 nimcom: if ntab ^= 0 then do;
999 substr (bcso, nout, ntab) = substr (TABS, 1, ntab);
1000 nout = nout + ntab;
1001 end;
1002 colpos = TABCOL;
1003 end;
1004 k = CMC - colpos - 1;
1005 if k > 0 then do;
1006 substr (bcso, nout, k) = "";
1007 nout = nout + k;
1008 end;
1009 end;
1010 k = n - i + 1;
1011 if k ^= 0 then do;
1012 substr (bcso, nout, k) = substr (chars, i, k);
1013 nout = nout + k;
1014 end;
1015
1016 in = in - end_count + dent;
1017 ifdent = if_count;
1018 if ^bos then if ^ifsw then ifdent = ifdent + 1;
1019 dclsw = dclsw & ^ scolsw;
1020
1021
1022
1023 finish_line:
1024 linno = linno + 1;
1025 if nout ^> 2 then go to loop;
1026 i = verify (reverse (substr (bcso, 1, nout-2)), SP_TAB);
1027 if i = 1 then go to loop;
1028 if i = 0 then i = nout - 2;
1029 else i = i - 1;
1030 if string then do;
1031 if ^bfsw then call ioa_
1032 ("indent: Line ^d of ""^a"" contains trailing white space that is part of a string.",
1033 linno - 1, en);
1034 go to loop;
1035 end;
1036 nout = nout - i;
1037 substr (bcso, nout-1, 1) = NL;
1038 unspec (substr (bcso, nout, i)) = "0"b;
1039 go to loop;
1040
1041
1042
1043 eof: if in > 0
1044 then if ^(rd_source_sw & in = 1)
1045 then do;
1046 call ioa_ ("indent: ""^a"" has ^d too few ""end""s.", en, in);
1047 error_occurred = "1"b;
1048 end;
1049 else;
1050 else if rd_source_sw
1051 then do;
1052 call ioa_ ("indent: The reduction_compiler source ""^a"" has one too many ""end""s.", en);
1053 error_occurred = "1"b;
1054 end;
1055 if string then do;
1056 call ioa_ ("indent: ""^a"" ends in a string.", en);
1057 error_occurred = "1"b;
1058 end;
1059 if comment then do;
1060 call ioa_ ("indent: ""^a"" ends in a comment.", en);
1061 error_occurred = "1"b;
1062 end;
1063 if parct > 0 then do;
1064 call ioa_ ("indent: ""^a"" has ^d extra ""(""s.", en, parct);
1065 error_occurred = "1"b;
1066 end;
1067
1068 call hcs_$terminate_noname (p, ec);
1069
1070 lth = 9 * (nout-1);
1071 call hcs_$set_bc_seg (p1, lth, ec);
1072
1073 if error_occurred then
1074 if ^output_path_given then do;
1075 call com_err_ (0, "indent", "Input segment not replaced. Indented copy is in [pd]>^a", temp_en);
1076 return;
1077 end;
1078
1079 call hcs_$make_seg (dn, en, "", 1011b, p, ec);
1080 if p = null then go to error1;
1081 call hcs_$truncate_seg (p, 0, ec);
1082 if ec ^= 0 then do;
1083 error1: call com_err_ (ec, "indent", "Cannot copy ^a from [pd]>^a", en, temp_en);
1084 return;
1085 end;
1086 p -> moveseg = p1 -> moveseg;
1087 call hcs_$set_bc_seg (p, lth, ec);
1088 call hcs_$terminate_noname (p, ec);
1089 call hcs_$delentry_seg (p1, ec);
1090 return;
1091
1092 error: call com_err_ (ec, "indent", n1);
1093 return;
1094
1095
1096
1097
1098
1099 inb: proc (ix);
1100 dcl ix fixed bin (24);
1101 substr (temchars, 1, n-ix+1) = substr (chars, ix, n-ix+1);
1102 substr (chars, ix+1, n-ix+1) = substr (temchars, 1, n-ix+1);
1103 substr (chars, ix, 1) = SP;
1104 n = n + 1;
1105 if ix <= i then i = i + 1;
1106 end inb;
1107
1108
1109
1110 outb: proc (ix, nn);
1111 dcl ix fixed bin (24);
1112 dcl nn fixed bin (24);
1113
1114 substr (temchars, 1, n-ix-nn+1) = substr (chars, ix+nn, n-ix-nn+1);
1115 substr (chars, ix, n-ix-nn+1) = substr (temchars, 1, n-ix-nn+1);
1116 n = n - nn;
1117 if ix = i then i = i - 1;
1118 else if ix < i then i = i - nn;
1119 end outb;
1120
1121 end indent;