1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    *********************************************************** */
   6 
   7 
   8 /****^  HISTORY COMMENTS:
   9   1) change(69-06-01,VanVleck), approve(), audit(), install():
  10      created from a
  11      MAD (Michigan Algorithmic Decode) Stan Dutton's CTSS program.
  12   2) change(73-06-01,Morris), approve(), audit(), install():
  13      modified to know
  14      about IF statements.
  15   3) change(73-12-01,VanVleck), approve(), audit(), install():
  16      heavily
  17      modified to take advantage of EIS instruction set.
  18   4) change(74-08-01,Casey), approve(), audit(), install():
  19      modified to -
  20      check for missing quotes and other errors that are really caused by
  21      missing quotes; and - refuse to replace the original segment when such
  22      errors are detected; - rewrite argument processing to use less code and
  23      allow control arguments anywhere on the line.
  24   5) change(76-03-01,LJohnson), approve(), audit(), install():
  25      modified to fix
  26      bugs in indenting multiple line strings, to improve <NP> character
  27      handling, and to support .cds suffix.
  28   6) change(77-06-14,May), approve(), audit(), install():
  29      modified to add
  30      processing of source for the reduction_compiler, to generalize somewhat
  31      for other possible dialects, and to fix a bug indenting factored structure
  32      entries.
  33   7) change(85-08-02,GDixon), approve(85-09-27,MCR7261), audit(85-09-27,GWMay),
  34      install(85-12-16,MR12.0-1001):
  35      support format_pl1's unchangeable comment syntax, which is a comment
  36      beginning with /****^.  This is needed to prevent indent from messing up
  37      history comments.
  38                                                    END HISTORY COMMENTS */
  39 
  40 
  41 indent: ind: proc;
  42 
  43 /* The INDENT command indents PL1 programs to make them more readable.
  44 
  45    Each DO, BEGIN, or PROCEDURE statement causes an additional level of indentation
  46    until a corresponding END is encountered. (Multiple closure is not permitted.)
  47    An IF statement or ELSE statement which is continued over multiple lines will also
  48    indent its subsequent lines.
  49 
  50    Comments are lined up in a standard column. A comment will be placed in column 1 if
  51    it is the first thing on the line and if the preceding line was blank or another such comment.
  52 
  53    Declaration statements are indented in a standard form, so that factoring and
  54    structure nesting are exhibited.
  55 
  56    Multiple spaces or tabs are replaced by a single space, except for the content of strings
  57    and for non-leading spaces and tabs in comments.
  58    Spaces are inserted around the operators = -> ^= >= and <=, after commas,
  59    and before left parentheses and after right parentheses.
  60    Spaces are removed if found before a comma or right paren, or after a left paren.
  61    Tabs are used wherever possible to conserve space in the segment.
  62 
  63    Parentheses are counted, and must balance at every semicolon. A warning will be printed.
  64    Lines longer than 350 characters will be split with a warning message.
  65    Illegal characters or non-pl1 characters not contained in a string will be commented upon.
  66 
  67    Some uses of the identifiers begin, end, proc, procedure, do, if, then, and else
  68    as variable names may cause the command to become confused. This is bad programming anyway.
  69    The command knows when a new statement may begin and can complain about some obvious syntax errors.
  70    */
  71 
  72 dcl  suffixes (3) char (4) init (".pl1", ".cds", ".rd"),    /* all the known dialects */
  73      suffix_lengths (3) fixed bin init (4, 4, 3),           /* and their lengths */
  74      suffix_len fixed bin;                                  /* one of the preceding */
  75 
  76 dcl  rd_source_sw bit (1),                                  /* flag for source to the reduction_compiler */
  77      copy_this_comment_unchanged bit (1);                   /* flag to copy current comment without change */
  78 
  79 dcl (n1, n2) char (168) aligned,                            /* input and output segment pathnames */
  80      dn char (168) aligned,                                 /* directory name */
  81      en char (32) aligned,                                  /* entry name */
  82      temp_en char (32) aligned,                             /* entry name of temp seg. */
  83      ap ptr,                                                /* ptr to argument */
  84      al fixed bin,                                          /* lth of argument */
  85      an fixed bin,                                          /* current arg number */
  86      nargs fixed bin,                                       /* number of arguments */
  87      expecting fixed bin init (0),                          /* ^=0 if expecting a numeric arg following a control arg */
  88      bchr char (al) based (ap) unaligned,                   /* based char string */
  89     (linno, indent, ntab) fixed bin,                        /* misc counters */
  90      ec fixed bin (35) init (0),                            /* error code */
  91      offset fixed bin (24),                                 /* char offset in input */
  92     (string_offset, line_offset) fixed bin (24),            /* offsets where current string and line started */
  93      string_len fixed bin,                                  /* length of current string, for error checking */
  94     (p, p1) ptr,                                            /* pointers to input, output */
  95     (icb, ice, icol) fixed bin,                             /* indices in line */
  96     (chars, temchars) char (400),                           /* Working storage */
  97      char char (1),                                         /* temp */
  98      n fixed bin,                                           /* length of working line */
  99      lth fixed bin (24),                                    /* number of chars in input */
 100     (lth1, lth2) fixed bin,                                 /* length of args */
 101      end_count fixed bin,                                   /* number of END on this line */
 102      if_count fixed bin,                                    /* count of IF's encountered */
 103      old_if_count fixed bin,                                /* previous value. */
 104     (scolsw,                                                /* TRUE if semicolon on line */
 105      dclfnd,                                                /* TRUE if DECLARE statement on line. */
 106      dclsw,                                                 /* TRUE if in a declaration */
 107      condsw,                                                /* TRUE if now in if statement. */
 108      ifsw,                                                  /* TRUE for if but not for else. */
 109      begin_ok,                                              /* TRUE if in an ON statement. */
 110      else_ok,                                               /* TRUE if else is now permitted. */
 111      strut,                                                 /* TRUE if in structure */
 112      sixty,                                                 /* TRUE if comment is to be pushed to col. 60 */
 113      bos,                                                   /* TRUE if current char could be beginning of stmnt */
 114      blsw,                                                  /* TRUE if preceding line blank */
 115      comment,                                               /* TRUE if currently in comment. */
 116      newpage,                                               /* TRUE if line contains newpage character */
 117      string,                                                /* TRUE if currently in string */
 118      pstring) bit (1) aligned,                              /* TRUE if previous line ended in string */
 119      bfsw bit (1) aligned init ("0"b),                      /* Brief mode switch */
 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, /* named bit values */
 122     (in, dent, dclind) fixed bin,                           /* indentation */
 123      LMARGIN fixed bin init (11),                           /* left margin */
 124      IN fixed bin init (5),                                 /* subsequent indent */
 125      CMC fixed bin init (61),                               /* comment column */
 126      TABCOL fixed bin init (60),                            /* nearest mult of 10 < CMC */
 127      NTAB fixed bin init (6),                               /* number of tabs to get to TABCOL */
 128      nout fixed bin (24),                                   /* number of chars in output */
 129      colpos fixed bin,                                      /* Column pointer in output line. (last filled col) */
 130      parct fixed bin init (0),                              /* paren count. must be 0 at semicolon */
 131      pdlx fixed bin,
 132      ifdent fixed bin,
 133      suffix char (4),
 134      suffix_assumed bit (1) init ("0"b),                    /* set if indent is assuming the suffix */
 135     (i, j, k, kk, m) fixed bin (24);
 136 
 137 dcl 1 pdl (1024) aligned,                                   /* Pushdown list. */
 138     2 nif fixed bin (33) unal,                              /* IF count. */
 139     2 swc bit (1) unal,                                     /* Conditional switch. IF and ELSE */
 140     2 sw bit (1) unal;                                      /* IF switch. */
 141 
 142 dcl  NP_NL_SP char (3) init static init ("^L
 143  ");
 144 dcl  SP char (1) int static init (" ");                     /* Single space. */
 145 dcl  SP_TAB char (2) int static init ("  ");                /* Tab and space, for verify etc. */
 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;                     /* For copy of whole segment. */
 181 
 182 dcl  err_msg char (100) varying;
 183 
 184 dcl  error_table_$bad_arg fixed bin (35) ext;               /* Illegal command argument */
 185 dcl  error_table_$badopt fixed bin (35) ext;                /* Specified control arg not implemented by this command */
 186 dcl  error_table_$noarg fixed bin (35) ext;                 /* Expected argument missing */
 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);                       /* get number of args */
 196           if nargs = 0 then do;                             /* gripe if no args */
 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;                                   /* so we can tell if we have the pathnames yet */
 202 arg_loop: do an = 1 to nargs;
 203                call cu_$arg_ptr (an, ap, al, ec);           /* pick off next arg */
 204 
 205                if ec ^= 0 then do;
 206 print_bad_arg:      err_msg = "^a";                         /* control string to just print argument */
 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;                              /* cv_dec_check_ needs aligned arg */
 214                     i = cv_dec_check_ (en, ec);
 215 
 216                     if expecting = 1 then do;               /* expecting left margin */
 217                          expecting = 0;
 218                          if ec ^= 0 then do;
 219 blm:                          err_msg = "illegal left margin arg ^a";
 220 cv_dec_error:                 ec = 0;                       /* cv_dec_check_ does not return an error_table_ code */
 221                               goto arg_error;               /* go call com_err_ */
 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;          /* expecting indent spaces */
 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;                                /* must be expecting comment column */
 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;                                         /* end of expecting argument do group */
 253 
 254                else do;                                     /* not-expected-argument */
 255 
 256                     if substr (bchr, 1, 1) = "-" then do;   /* Control argument? */
 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;                                /* Not control arg, must be filename */
 273                          if lth1 = 0 then do;               /* if we don't have input filename then this is it */
 274                               n1 = bchr;                    /* Pick up arg 1, input name */
 275                               lth1 = al;                    /* Remember length for expand path */
 276                          end;
 277                          else if lth2 = 0 then do;          /* if we don't have output filename, this is it */
 278                               n2 = bchr;                    /* User gave second name. Set it up. */
 279                               lth2 = al;                    /* Set length of second arg. */
 280                               output_path_given = "1"b;
 281                          end;
 282                          else do;
 283                               ec = error_table_$bad_arg;    /* "Illegal command argument" */
 284                               goto print_bad_arg;           /* go call com_err_ to print the bad arg */
 285                          end;
 286                     end;
 287                end;                                         /* end of not-expected-argument do group */
 288           end arg_loop;                                     /* end of argument processing do group */
 289 
 290           if lth1 = 0 then do;                              /* if input filename not given */
 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;                              /* if output path not given, use input path */
 302                n2 = n1;
 303                lth2 = lth1;
 304           end;
 305 
 306 
 307 /* END OF ARGUMENT PROCESSING */
 308 
 309 /* Initialization */
 310 
 311           rd_source_sw, copy_this_comment_unchanged = false; /* flags for source to reduction_compiler */
 312                                                             /* and for unchangable comments. */
 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;                                 /* Pretend line zero was empty. */
 316           pdlx = 1;                                         /* Set pushdown list to empty. */
 317           linno = 1;                                        /* This is line 1. */
 318           offset, nout = 1;                                 /* read and write pointers */
 319 
 320           i = index (reverse (substr (n1, 1, lth1)), ".");  /* get last component */
 321           if i = 0 | i > 4 then go to in_suffix;            /* wrong size, don't bother */
 322           suffix = substr (n1, lth1 - i + 1, i);            /* includes "." */
 323           do j = 1 to 3;                                    /* .pl1, .cds, .rd */
 324                if suffix = suffixes (j)
 325                then do;
 326                     suffix_len = suffix_lengths (j);        /* for later suffix processing */
 327                     go to good_suffix;
 328                end;
 329           end;
 330 
 331 /* Didn't match list of good suffices */
 332 
 333 in_suffix: suffix = ".pl1";                                 /* a good guess */
 334           suffix_len = 4;
 335           substr (n1, lth1+1, suffix_len) = suffix;         /* add to name */
 336           lth1 = lth1+suffix_len;                           /* adjust length */
 337           suffix_assumed = "1"b;                            /* remember, this was only a guess */
 338 
 339 good_suffix:
 340           if suffix = ".rd" then rd_source_sw = "1"b;       /* remember to check for rd parse in comments */
 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;                              /* didn't find input seg */
 346                if ^suffix_assumed then go to error;         /* user gave suffix. Nothing more to try */
 347                if ec ^= error_table_$noentry then go to error; /* foo.pl1 not found is the only reason to continue */
 348                i = 34 - suffix_len - verify (reverse (en), " "); /* find suffix in entry name */
 349                suffix = ".cds";                             /* try new suffix */
 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;                         /* trouble with foo.cds too */
 354                     if ec = error_table_$noentry then
 355                          go to error;                       /* if foo.cds not found, print error about foo.pl1 */
 356                     substr (n1, lth1 - (suffix_len-1), suffix_len) = substr (suffix, 1, suffix_len);
 357                                                             /* for other errors, print message aboout foo.cds */
 358                     go to error;
 359                end;
 360           end;
 361           if lth2 < 4 then go to out_suffix;                /* out name shorter than x.rd, need suffix */
 362           else if substr (n2, lth2 - (suffix_len-1), suffix_len) ^= substr (suffix, 1, suffix_len)
 363           then do;                                          /* output suffix must match input */
 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);                   /* compute bit count of input seg */
 368 
 369           temp_en = en;                                     /* Generate name of temp file. */
 370           i = 34 -suffix_len - verify (reverse (temp_en), " "); /* Locate end. */
 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 /* This is the loop for each line in the input segment. Starting at "offset" a line of "n" chars
 378    is moved to the temporary buffer "chars". Trailing tabs and blanks are trimmed. */
 379 
 380 loop:     pstring = string;                                 /* remember if previous line ended inside quotes */
 381           if offset > lth then go to eof;
 382           i = index (substr (bcs, offset), NL);             /* Find length of line. */
 383           if i = 0 then i = lth - offset + 1;               /* .. in case did not end in NL */
 384           else if i = 1 then do;                            /* Check for empty line. */
 385                substr (bcso, nout, 1) = NL;                 /* insert in output */
 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;                               /* Line too big? */
 394                k, i = 385;                                  /* Take first 385 chars. */
 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);                  /* Pick up line. */
 399           substr (chars, k+1, 1) = NL;                      /* Put in NL */
 400           line_offset = offset;                             /* remember where line started */
 401           offset = offset + i;                              /* Increase index. */
 402           n = k + 1;                                        /* Set up length of line. */
 403           if n = 1 then go to lemp;                         /* Empty line? */
 404           if ^pstring then                                  /* if not in string */
 405                if substr (chars, 1, 1) = "%" then do;       /* Is this an "include" line? */
 406 lemp:               blsw = true;                            /* Yes, set switch. */
 407                     go to cpy;                              /* And just copy line. */
 408                end;
 409 
 410           icb, ice, icol, dent, end_count = 0;              /* Set up for loop. */
 411           scolsw, dclfnd, newpage = false;
 412 
 413 /* The following section examines each character in the current line in "chars".
 414    In this section, "i" is the character index which may be from 1 to "n". */
 415 
 416           if pstring then do;                               /* If we are now in a string, */
 417                kk = index (substr (chars, 1, n-1), """");   /* .. See if it ends on this line. */
 418                if kk = 0 then go to cpy;                    /* Nope. Can't touch line at all. */
 419                else i = kk;                                 /* Yes. Skip string content. */
 420           end;
 421           else i = 1;                                       /* Examine each character in line. */
 422 l2s:      char = substr (chars, i, 1);                      /* Pick up a character. */
 423           if string then do;                                /* Now in a string ? */
 424                if char = """" then do;                      /* Watch for end */
 425                     string = false;                         /* not any more */
 426                                                             /* While this ignoring of possible double quotes within a
 427                                                                string works ok for indenting, it throws off string
 428                                                                length checking. However, since this checking is to
 429                                                                help locate missing quotes, it is not really necessary
 430                                                                to check for double quotes here. */
 431                     string_len = line_offset+i-string_offset-1; /* compute length, excluding the quotes */
 432                     if string_len > 254 then                /* if string is too long, report line number
 433                                                                to aid user in finding missing quote */
 434                          if ^bfsw then                      /* but only if user wants to be warned */
 435                               if ^string_error then do;     /* report only the first one - if there is a missing quote,
 436                                                                there are probably a lot more long strings */
 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;     /* remember not to report any more of these */
 441                                    error_occurred = "1"b;
 442                               end;
 443                end;
 444                go to l2e;                                   /* ... leaving all other chars */
 445           end;
 446           if comment then do;                               /* are we now in a comment? */
 447                if substr (chars, i, 2) = "*/" then do;      /* Comment ends? */
 448                     comment = false;                        /* Turn off switch. */
 449                     if copy_this_comment_unchanged then     /* Are we in rd reductions or in unchangable      */
 450                                                             /* comment?  Then we are done with the comment.   */
 451                          copy_this_comment_unchanged = false;
 452                     else do;                                /* Not in unchangable comment?                    */
 453                          if i > 1 then if index (SP_TAB, substr (chars, i-1, 1)) = 0
 454                                                             /* chars on line prior to comment end delimiter?  */
 455                               then call inb (i);            /* insert blank prior to comment end delimiter    */
 456                          if i < n-2 then                    /* Chars on line after comment end delimiter?     */
 457                               if index (SP_TAB_COM_SEMI, substr (chars, i+2, 1)) = 0 then
 458                                    call inb (i+2);          /* Nice blank after comment */
 459                     end;
 460                     ice = i;                                /* save index of end of comment. */
 461                     i = i + 1;                              /* Don't scan slash again. */
 462                     go to l2e;                              /* Comment leaves state unchanged. */
 463                end;
 464                if i = 1 then do;                            /* Continue comment. Trim leading blanks and tabs. */
 465                     k = verify (substr (chars, 1, n-1), SP_TAB) - 1;
 466                     if k = -1 then do;                      /* if line of just white space inside comment */
 467                          chars = "";                        /* replace it wich just a newline */
 468                          substr (chars, 1, 1) = NL;
 469                          n = 1;
 470                          go to cpy;
 471                     end;
 472                     if ^copy_this_comment_unchanged         /* don't disturb rd parse controls */
 473                     then do;
 474                          substr (temchars, 1, n-k) = substr (chars, k+1, n-k);
 475                          substr (chars, 1, 3) = "";         /* Stick in three blanks. */
 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), "*/");   /* Character inside comment. Skip out to end. */
 482                if kk = 0 then i = n-1;
 483                else i = i + kk - 2;                         /* Set so we scan the comment end next. */
 484                go to l2e;
 485           end;
 486           k = fixed (unspec (char), 9);                     /* See if char is ASCII */
 487           if k < 0 then go to ilchr;
 488           if k > 126 then go to ilchr;
 489           go to case (k);                                   /* Dispatch on character. */
 490 
 491 /* Handlers for each character. */
 492 
 493 /* Punctuation. */
 494 
 495 case (009):                                                 /* HT, octal 011 */
 496           substr (chars, i, 1) = SP;
 497 case (032):                                                 /* blank, octal 040 */
 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);              /* Remove multiple blanks and tabs. */
 502           end;
 503           go to l2e;                                        /* Ignore blank */
 504 case (034):                                                 /* quote, octal 042 */
 505           string = true;                                    /* now in string */
 506           string_offset = line_offset+i;                    /* remember where it started, for length checking */
 507           kk = index (substr (chars, i+1, n-i), """");      /* Does string end on this line? */
 508           if kk > 0 then i = i + kk - 1;                    /* Yes. Skip string contents. */
 509           else i = n-1;                                     /* No. Skip rest of line. */
 510           go to cbs;
 511 case (040):                                                 /* "(", octal 050 */
 512           parct = parct + 1;                                /* Increase count. */
 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;                                      /* Condition prefix begins with paren. */
 516 case (041):                                                 /* ")", octal 051 */
 517           if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1);
 518           parct = parct - 1;                                /* decrease parenthesis count. */
 519           if parct < 0 then do;                             /* Check for more closes than opens. */
 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):                                                 /* ",", octal 054 */
 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):                                                 /* "-", octal 055 */
 530           if substr (chars, i+1, 1) = ">" then do;          /* Is this a pointer digraph? */
 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):                                                 /* "/", octal 057 */
 536           if substr (chars, i+1, 1) = "*" then do;          /* Comment begins? */
 537                comment = true;                              /* Now in comment. */
 538                if i - length ("/") + length ("/****^") + length (NL) <= n
 539                then if substr (chars, i, length ("/****^")) = "/****^" then
 540                          copy_this_comment_unchanged = true; /* check for comments which cannot be changed. */
 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 /* need a blank? */
 545                          then if ^rd_source_sw              /* check first for rd parse control */
 546                               then call inb (i+2);
 547                               else if substr (chars, i+2, 2) = "++"
 548                                                             /* beginning of rd parse specification? */
 549                               then copy_this_comment_unchanged = true;
 550                                                             /* yes. remember, and don't insert blank */
 551                               else call inb (i+2);          /* just a normal comment */
 552                end;
 553                icb = i;                                     /* Remember where comment began. */
 554                kk = index (substr (chars, i+2, n-i-2), "*/"); /* Search for end of comment. */
 555                if kk = 0 then i = n-1;                      /* Not scanning content of comment. */
 556                else i = i + kk;                             /* ... */
 557                go to l2e;                                   /* Leave "bos" as it was when comment began. */
 558           end;
 559           go to cbs;                                        /* Statement don't begin with slash */
 560 case (058):                                                 /* ":", octal 072 */
 561           if parct > 0 then go to nxchr;                    /* Label can't be in parentheses. */
 562           if bos then go to cbs;                            /* Null label ? */
 563           bos = true;                                       /* This is label. keyword ok */
 564           icol = i + 1;                                     /* Save index. */
 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):                                                 /* ";", octal 073 */
 568           scolsw, bos = true;                               /* Semicolon. End of statement. */
 569           begin_ok = false;
 570           if condsw then do;                                /* Does this end an IF? */
 571                old_if_count = if_count;                     /* Save proper indent level for ELSE */
 572                if pdlx = 1 then if_count = 0;               /* Reset if_count */
 573                else if_count = pdl (pdlx-1).nif;            /* Set back to base for this level. */
 574                condsw = false;                              /* Not now in conditional */
 575                else_ok = true;
 576           end;
 577           else old_if_count = 0;                            /* End of some other statement. */
 578           ifsw = false;                                     /* Not in IF now. */
 579           if parct > 0 then do;                             /* Parenthesis count should be zero. */
 580                call ioa_ ("indent: ^d extra ""(""s at line ^d of ""^a"".",
 581                     parct, linno, en);                      /* Complain. */
 582                error_occurred = "1"b;
 583                parct = 0;                                   /* Start over on count. */
 584           end;
 585           go to l2e;
 586 case (061):                                                 /* "=", octal 075 */
 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 /* This section checks for reserved words by looking at the first letter. */
 594 
 595 case (098):                                                 /* letter "b", octal 142 */
 596           if ^bos then if ^begin_ok then go to nxchr;       /* Must be at begin of statement or in ON */
 597           if parct > 0 then go to nxchr;                    /* ignore begins in parens */
 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;                         /* Skip over rest of word. */
 601 in_found:                if ifsw then if_count = if_count - 1; /* Don't do extra indent. */
 602                          pdl (pdlx).sw = ifsw;              /* Push down current if switch. */
 603                          pdl (pdlx).swc = condsw;           /* .. and conditional switch. */
 604                          pdl (pdlx).nif = if_count;         /* .. and if indentation. */
 605                          pdlx = pdlx + 1;                   /* .. */
 606                          if pdlx = 1024 then do;            /* If nesting depth too great, die. */
 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;                    /* Now not in IF */
 612                          ifsw = false;
 613                          dent = dent + 1;                   /* Increase indentation level. */
 614                     end;
 615           go to nxchr;
 616 case (100):                                                 /* letter "d", octal 144 */
 617           if parct > 0 then go to nxchr;                    /* reserved word not in parens */
 618           if ^bos then go to nxchr;                         /* Must be at beginning of statement. */
 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;                              /* Found DO statement. */
 622                     go to in_found;
 623                end;
 624           if condsw then go to nxchr;                       /* Declaration cannot be inside an IF */
 625           if i = 1 then do;                                 /* declare stm must start in col 1 ... */
 626                if kk = 4 then if substr (chars, i, 3) = "dcl" then do;
 627                          dclfnd = true;                     /* Found DCL statement. */
 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;                     /* Found DECLARE statement. */
 634                          i = i + 6;
 635                          dclind = 8;
 636                          go to nxchr;
 637                     end;
 638           end;
 639           go to nxchr;
 640 case (101):                                                 /* letter "e", octal 145 */
 641           if parct > 0 then go to nxchr;                    /* keyword not appear in parens. */
 642           if ^bos then go to nxchr;                         /* Must be in beginning-of-statment state. */
 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;       /* Restore old IF indentation. */
 646                          ifdent = old_if_count - 1;         /* Outdent the ELSE to the corresponding IF */
 647                          else_ok = false;                   /* ELSE may not follow ELSE. */
 648                          if if_count > 0 then condsw = true; /* But may follow after semi. */
 649                          bos = true;                        /* Statement may follow ELSE. */
 650                          i = i + 3;
 651                          go to l2e;
 652                     end;
 653           if condsw then go to nxchr;                       /* Cannot say "then end" */
 654           if kk = 4 then if substr (chars, i, 3) = "end" then do;
 655                     end_count = end_count + 1;              /* Found END statement. */
 656                     if pdlx > 1 then do;                    /* Unstack IF state. */
 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; /* Too many END's? */
 664                          call ioa_ ("indent: line ^d of ""^a"" has an extra ""end"".", linno, en);
 665                          dent, in, end_count = 0;           /* Start over on indents */
 666                          error_occurred = "1"b;
 667                     end;
 668                     i = i + 2;
 669                end;
 670           go to nxchr;
 671 case (105):                                                 /* letter "i", octal 151 */
 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;                     /* Set IF encountered flag. */
 677                          ifsw = true;
 678                          i = i + 1;
 679                     end;
 680           go to nxchr;
 681 case (116):                                                 /* letter "t", octal 164 */
 682           if parct > 0 then go to nxchr;                    /* Look for THEN keyword. */
 683           if bos then go to nxchr;                          /* THEN cannot begin a statement. */
 684           if ^ifsw then go to nxchr;                        /* and some IF must have come up. */
 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;                        /* Found THEN. Statement may follow. */
 689                          i = i + 3;
 690                          if_count = if_count + 1;
 691                          go to l2e;
 692                     end;
 693           go to nxchr;
 694 case (111):                                                 /* letter "o", octal 157 */
 695           if ^bos then go to nxchr;                         /* Check for ON statement. */
 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;                   /* ON statement may contain BEGIN */
 700                          i = i + 1;
 701                     end;
 702           go to nxchr;
 703 case (112):                                                 /* letter "p", octal 160 */
 704           if parct > 0 then go to nxchr;
 705           if ^bos then go to nxchr;
 706           if condsw then go to nxchr;                       /* Cannot say "then proc" */
 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;                              /* Skip scan of keyword. */
 713                     go to in_found;                         /* Increase indentation level */
 714                end;
 715           go to nxchr;
 716 
 717 /* Illegal characters. Squawk and continue. */
 718 
 719 case (000):                                                 /* NUL, octal 000 */
 720 case (001):                                                 /* undefined, octal 001 */
 721 case (002):                                                 /* undefined, octal 002 */
 722 case (003):                                                 /* undefined, octal 003 */
 723 case (004):                                                 /* undefined, octal 004 */
 724 case (005):                                                 /* undefined, octal 005 */
 725 case (006):                                                 /* undefined, octal 006 */
 726 case (007):                                                 /* BEL, octal 007 */
 727 case (008):                                                 /* BS, octal 010 */
 728 case (013):                                                 /* CR, octal 015 */
 729 case (014):                                                 /* RRS, octal 016 */
 730 case (015):                                                 /* BRS, octal 017 */
 731 case (016):                                                 /* undefined, octal 020 */
 732 case (017):                                                 /* undefined, octal 021 */
 733 case (018):                                                 /* undefined, octal 022 */
 734 case (019):                                                 /* undefined, octal 023 */
 735 case (020):                                                 /* undefined, octal 024 */
 736 case (021):                                                 /* undefined, octal 025 */
 737 case (022):                                                 /* undefined, octal 026 */
 738 case (023):                                                 /* undefined, octal 027 */
 739 case (024):                                                 /* undefined, octal 030 */
 740 case (025):                                                 /* undefined, octal 031 */
 741 case (026):                                                 /* undefined, octal 032 */
 742 case (027):                                                 /* undefined, octal 033 */
 743 case (028):                                                 /* undefined, octal 034 */
 744 case (029):                                                 /* undefined, octal 035 */
 745 case (030):                                                 /* undefined, octal 036 */
 746 case (031):                                                 /* EGM, octal 037 */
 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):                                                 /* "!", octal 041 */
 753 case (035):                                                 /* sharp, octal 043 */
 754 case (039):                                                 /* "'", octal 047 */
 755 case (063):                                                 /* "?", octal 077 */
 756 case (064):                                                 /* at-sign, octal 100 */
 757 case (091):                                                 /* "[", octal 133 */
 758 case (092):                                                 /* escape (backslash), octal 134 */
 759 case (093):                                                 /* "]", octal 135 */
 760 case (096):                                                 /* "`", octal 140 */
 761 case (123):                                                 /* "{", octal 173 */
 762 case (125):                                                 /* "}", octal 175 */
 763 case (126):                                                 /* tilde, octal 176 */
 764           if ^bfsw then do;                                 /* Unless brief mode, gripe */
 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 /* Chars which are legal but cannot begin a statement. */
 772 
 773 case (036):                                                 /* "$", octal 044 */
 774 case (038):                                                 /* "&", octal 046 */
 775 case (042):                                                 /* "*", octal 052 */
 776 case (043):                                                 /* "+", octal 053 */
 777 case (046):                                                 /* ".", octal 056 */
 778 case (048):                                                 /* digit "0", octal 060 */
 779 case (049):                                                 /* digit "1", octal 061 */
 780 case (050):                                                 /* digit "2", octal 062 */
 781 case (051):                                                 /* digit "3", octal 063 */
 782 case (052):                                                 /* digit "4", octal 064 */
 783 case (053):                                                 /* digit "5", octal 065 */
 784 case (054):                                                 /* digit "6", octal 066 */
 785 case (055):                                                 /* digit "7", octal 067 */
 786 case (056):                                                 /* digit "8", octal 070 */
 787 case (057):                                                 /* digit "9", octal 071 */
 788 case (060):                                                 /* "<", octal 074 */
 789 case (062):                                                 /* ">", octal 076 */
 790 case (094):                                                 /* circumflex, octal 136 */
 791 case (095):                                                 /* underscore, octal 137 */
 792 case (124):                                                 /* "|", octal 174 */
 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 /* Chars which are legal beginnings of statement. */
 800 
 801 case (037):                                                 /* "%", octal 045 */
 802 case (065):                                                 /* letter "A", octal 101 */
 803 case (066):                                                 /* letter "B", octal 102 */
 804 case (067):                                                 /* letter "C", octal 103 */
 805 case (068):                                                 /* letter "D", octal 104 */
 806 case (069):                                                 /* letter "E", octal 105 */
 807 case (070):                                                 /* letter "F", octal 106 */
 808 case (071):                                                 /* letter "G", octal 107 */
 809 case (072):                                                 /* letter "H", octal 110 */
 810 case (073):                                                 /* letter "I", octal 111 */
 811 case (074):                                                 /* letter "J", octal 112 */
 812 case (075):                                                 /* letter "K", octal 113 */
 813 case (076):                                                 /* letter "L", octal 114 */
 814 case (077):                                                 /* letter "M", octal 115 */
 815 case (078):                                                 /* letter "N", octal 116 */
 816 case (079):                                                 /* letter "O", octal 117 */
 817 case (080):                                                 /* letter "P", octal 120 */
 818 case (081):                                                 /* letter "Q", octal 121 */
 819 case (082):                                                 /* letter "R", octal 122 */
 820 case (083):                                                 /* letter "S", octal 123 */
 821 case (084):                                                 /* letter "T", octal 124 */
 822 case (085):                                                 /* letter "U", octal 125 */
 823 case (086):                                                 /* letter "V", octal 126 */
 824 case (087):                                                 /* letter "W", octal 127 */
 825 case (088):                                                 /* letter "X", octal 130 */
 826 case (089):                                                 /* letter "Y", octal 131 */
 827 case (090):                                                 /* letter "Z", octal 132 */
 828 case (097):                                                 /* letter "a", octal 141 */
 829 case (099):                                                 /* letter "c", octal 143 */
 830 case (102):                                                 /* letter "f", octal 146 */
 831 case (103):                                                 /* letter "g", octal 147 */
 832 case (104):                                                 /* letter "h", octal 150 */
 833 case (106):                                                 /* letter "j", octal 152 */
 834 case (107):                                                 /* letter "k", octal 153 */
 835 case (108):                                                 /* letter "l", octal 154 */
 836 case (109):                                                 /* letter "m", octal 155 */
 837 case (110):                                                 /* letter "n", octal 156 */
 838 case (113):                                                 /* letter "q", octal 161 */
 839 case (114):                                                 /* letter "r", octal 162 */
 840 case (115):                                                 /* letter "s", octal 163 */
 841 case (117):                                                 /* letter "u", octal 165 */
 842 case (118):                                                 /* letter "v", octal 166 */
 843 case (119):                                                 /* letter "w", octal 167 */
 844 case (120):                                                 /* letter "x", octal 170 */
 845 case (121):                                                 /* letter "y", octal 171 */
 846 case (122):                                                 /* letter "z", octal 172 */
 847 nxchr:    bos = false;                                      /* No longer at beginning of statement. */
 848           else_ok = false;                                  /* ELSE no longer legal. */
 849           go to l2e;
 850 
 851 /* Chars which do not preclude beginning of statement. */
 852 
 853 case (012):                                                 /* NP, octal 014 */
 854           newpage = "1"b;                                   /* remember line contained NP */
 855 case (010):                                                 /* NL, octal 012 */
 856 case (011):                                                 /* VT, octal 013 */
 857 l2e:      i = i + 1;                                        /* Increase index in working array. */
 858           if i < n then go to l2s;                          /* If any chars left, go thru again. */
 859 
 860 /* come here when all characters in line examined */
 861 
 862           i = 1;                                            /* "i" will be the index in the "chars" buffer. */
 863           if newpage then do;                               /* special test if newpage encountered */
 864                if verify (substr (chars, 1, n), NP_NL_SP) = 0 then do; /* if line is all spaces, newpages, and newlines */
 865                     n = 2;                                  /* make new short line */
 866                     chars = substr (NP_NL_SP, 1, 2);        /* of newpage and newline */
 867                     blsw = true;                            /* this is a blank line */
 868                     go to cpy;
 869                end;
 870           end;
 871           if icb = 1 then do;                               /* Does line start with comment? */
 872                if blsw then do;                             /* Yes. Previous line empty? */
 873                     sixty = false;                          /* Yes, start in column 1. */
 874                     go to cpy;                              /* Just copy line. */
 875                end;
 876 push:          sixty = true;                                /* Comment goes in column 60. */
 877                ntab = NTAB;
 878                i = 1;
 879                go to nimcom;
 880           end;
 881           if icb = 0 then if (comment | ice > 0) then do;   /* Continuation of comment? */
 882                     if sixty then go to push;               /* Do we indent it? */
 883 cpy:                substr (bcso, nout, n) = substr (chars, 1, n); /* Copy whole line. */
 884                     nout = nout + n;
 885                     go to finish_line;
 886                end;
 887 
 888 /* This section computes the left margin for each line. */
 889 
 890           blsw = false;                                     /* Not empty line. */
 891           if pstring then do;
 892                indent = 0;                                  /* don't indent inside quoted string */
 893                icol = 0;
 894           end;
 895           else if dclfnd then do;                           /* Does line begin with DCL? */
 896                dclfnd = false;                              /* Yes. */
 897                dclsw = true;                                /* We are in a declaration now. */
 898                if index ("0123456789", substr (chars, dclind+1, 1)) ^= 0 then strut = true; else strut = false;
 899                icol = dclind;                               /* Copy first dclind chars without indent. */
 900                if strut then indent = dclind+1;             /* Indent dclind+1 in structure */
 901                else if substr (chars, dclind+1, 1) = "(" then indent = dclind+1;
 902                                                             /* ... or in factored dcl, */
 903                else indent = dclind+2;                      /* ... otherwise dclind+2. */
 904           end;
 905           else if dclsw then do;                            /* Are we in old declaration? */
 906                icol = 0;                                    /* Yes. */
 907                kk = index ("0123456789", substr (chars, 1, 1)) - 1;
 908                if strut & kk >= 0 then do;                  /* If structure, use level number. */
 909                     k = kk;                                 /* Convert to number. */
 910                     kk = index ("0123456789", substr (chars, 2, 1)) - 1;
 911                     if kk >= 0 then k = k*10 + kk;
 912                     indent = dclind + k + k - 3;            /* calculate proper indentation */
 913                end;                                         /* typically, this yields
 914                                                                .      dcl 1 s,
 915                                                                .          2 l1,
 916                                                                .          2 l2,
 917                                                                .            3 l3; etc.     */
 918 
 919                else if substr (chars, 1, 1) = "("
 920                then do;
 921                     if strut
 922                     then do;                                /* we have factored level declarations */
 923                          k = index ("0123456789", substr (chars, 2, 1)) - 1;
 924                          if k > 0                           /* better be */
 925                          then do;
 926                               kk = index ("0123456789", substr (chars, 3, 1)) - 1; /* look for level > 9 */
 927                               if kk > 0 then k = 10 * k + kk;
 928                               indent = dclind + k + k - 4;  /* subtract 1 more to allow for paren */
 929                          end;
 930 
 931 /* should report the following, but can't tell the difference between missing level number and just initialize...
 932    else call ioa_ ("indent: No level number follows ""("" in structure. Line ^d in ""^a"". Continuing.", linno, en); */
 933                     end;
 934                     else indent = dclind + 1;               /* no structure */
 935                end;
 936 
 937                else indent = dclind+2;                      /* No. */
 938           end;
 939           else do;                                          /* Normal statement. */
 940                k = min (end_count, dent);                   /* May be both do and end on same line. */
 941                end_count = end_count - k;                   /* If so, do not "outdent" */
 942                dent = dent - k;                             /* ... */
 943                indent = (in + ifdent - end_count - 1) * IN + LMARGIN; /* Compute indentation. */
 944                if indent < 0 then indent = 0;               /* No negative indent. */
 945           end;
 946 
 947 /* This section copies the line into the output seg, inserting blanks and tabs. */
 948 
 949           if icol >= n then go to cpy;                      /* If line is just a label, do it the easy way. */
 950           colpos = 0;                                       /* Remember where started. */
 951           if icol ^= 0 then do;
 952                substr (bcso, nout, icol) = substr (chars, 1, icol); /* Copy label section if any. */
 953                nout = nout + icol;                          /* Increase offset. */
 954                colpos = colpos + icol;                      /* and column. */
 955           end;
 956           i = icol + 1;
 957           if i ^= icb then                                  /* Handle case of just label and comment. */
 958                if indent > icol then do;                    /* Must insert blanks. */
 959                     if substr (chars, icol, 1) = SP then do; /* a blank was included in icol for labels */
 960                          icol = icol - 1;                   /* Back up by one char, to prevent space-tab. */
 961                          colpos = colpos - 1;
 962                          nout = nout - 1;
 963                     end;
 964                     k = indent - icol - 1;                  /* Calculate number of blanks required. */
 965                     colpos = colpos + k;                    /* Calculate new column position in output. */
 966                     if colpos >= 10 then do;                /* Replace blanks by tabs if possible. */
 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);         /* Tab column might not be multiple of 10 */
 972                          end;
 973                     end;
 974                     if k ^= 0 then do;
 975                          substr (bcso, nout, k) = "";       /* Run in blanks. */
 976                          nout = nout + k;
 977                     end;
 978                end;
 979           if ice ^= 0 then if ice = n-2 then go to havcom;  /* If comment is last thing on line, */
 980           if ice ^= 0 then if ice = n-3 then if substr (chars, n-1, 1) = ";" then go to havcom;
 981                                                             /* or if comment is last on line except end of statement, */
 982           if ice = 0 then if icb > 0 then do;               /* or if comment starts on this line and doesn't end.. */
 983 havcom:             sixty = true;                           /* Yes, move comment to column 60. */
 984                     k = icb-i;                              /* Copy statement part. */
 985                     if k ^= 0 then do;
 986                          substr (bcso, nout, k) = substr (chars, i, k);
 987                          nout = nout + k;
 988                          colpos = colpos + k;               /* Keep track of column. */
 989                          i = i + k;
 990                     end;
 991                     if colpos < TABCOL then do;             /* If statement does not reach to col. 60, */
 992                          if substr (bcso, nout-1, 1) = SP then do; /* Avoid space-tab sequence. */
 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; /* Compute number of tabs to get there. */
 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;                   /* In case tab column not 10 * x + 1 */
1005                     if k > 0 then do;
1006                          substr (bcso, nout, k) = "";       /* Run in blanks */
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); /* Copy remainder of line. */
1013                nout = nout + k;
1014           end;
1015 
1016           in = in - end_count + dent;                       /* Adjust indentation base for next line. */
1017           ifdent = if_count;                                /* Set IF's to indent. */
1018           if ^bos then if ^ifsw then ifdent = ifdent + 1;   /* .. if statement is continued, indent 5 more. */
1019           dclsw = dclsw & ^ scolsw;                         /* In declaration if were in and no semicolon. */
1020 
1021 /* Finished with the line. Go get another. */
1022 
1023 finish_line:
1024           linno = linno + 1;                                /* Count line. */
1025           if nout ^> 2 then go to loop;                     /* too short to check */
1026           i = verify (reverse (substr (bcso, 1, nout-2)), SP_TAB); /* check for trailing white space in line copied */
1027           if i = 1 then go to loop;                         /* there was none */
1028           if i = 0 then i = nout - 2;                       /* there was a lot */
1029           else i = i - 1;                                   /* there was some */
1030           if string then do;                                /* if in a string, bad news because its invisible */
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;                                  /* Don't change */
1035           end;
1036           nout = nout - i;                                  /* back up end over white space */
1037           substr (bcso, nout-1, 1) = NL;                    /* put in a new newline */
1038           unspec (substr (bcso, nout, i)) = "0"b;           /* clean out the extra stuff that was moved in */
1039           go to loop;
1040 
1041 /* Control comes here when the input segment is exhausted. */
1042 
1043 eof:      if in > 0
1044           then if ^(rd_source_sw & in = 1)                  /* rd source should be missing one "end" */
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);               /* Terminate input segment. */
1069 
1070           lth = 9 * (nout-1);                               /* Compute bit count. */
1071           call hcs_$set_bc_seg (p1, lth, ec);               /* Set bit count on temp, in case of error. */
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);    /* Get ptr to final output. Make if necessary */
1080           if p = null then go to error1;
1081           call hcs_$truncate_seg (p, 0, ec);                /* Truncate target. */
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;                     /* Zap. */
1087           call hcs_$set_bc_seg (p, lth, ec);                /* Set bit count. */
1088           call hcs_$terminate_noname (p, ec);               /* Terminate output. */
1089           call hcs_$delentry_seg (p1, ec);                  /* Delete scratch segment. */
1090           return;                                           /* Happy return. */
1091 
1092 error:    call com_err_ (ec, "indent", n1);                 /* Here to gripe to user */
1093           return;                                           /* And give up */
1094 
1095 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * */
1096 
1097 /* Insert a blank at "ix" */
1098 
1099 inb:      proc (ix);
1100 dcl  ix fixed bin (24);                                     /* Index in work array where blank goes. */
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;                  /* Insert blank. */
1104                n = n + 1;                                   /* Up the line length. */
1105                if ix <= i then i = i + 1;                   /* did we change the character looked at? */
1106           end inb;
1107 
1108 /* This procedure removes "nn" blanks starting at "ix" */
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;                    /* Back up one if now looking at new char. */
1118                else if ix < i then i = i - nn;
1119           end outb;
1120 
1121      end indent;