1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4         *                                                         *
   5         * Copyright (c) 1972 by Massachusetts Institute of        *
   6         * Technology and Honeywell Information Systems, Inc.      *
   7         *                                                         *
   8         *********************************************************** */
   9 
  10 
  11 /* This program peruses a cross-reference output file, as generated by the
  12    online crossreference program. It is used to print out entries from the
  13    crossref in a relatively readable format.
  14 
  15    Modification history:
  16    08/13/80 W. Olin Sibert
  17    03/04/81 E. N. Kittlitz - divers alterations.
  18    04/22/81 E. N. Kittlitz - handle cref* error messages in CREF MSF.
  19    Fix assumes that all messages are at end of MSF.
  20    12/31/81 J. Spencer Love - fix search bug, fix long include file names
  21    bug, minor improvements.
  22    2/82 BIM for default cref path.
  23    4 Apr 82, WOS: Modified for active function usage.
  24    1984-08-26 BIM -brief_errors
  25    1985-01-03, BIM: fixed leading _ names to work for include files.
  26 */
  27 
  28 
  29 /****^  HISTORY COMMENTS:
  30   1) change(86-08-16,JSLove), approve(86-08-16,MCR7430),
  31      audit(86-09-12,GDixon), install(86-09-15,MR12.0-1153):
  32      Added support for synonyms in input file.  Added undocumented -debug
  33      control argument.
  34                                                    END HISTORY COMMENTS */
  35 
  36 
  37 /* format: style2 */
  38 
  39 pcref:
  40 peruse_crossref:
  41      procedure () options (variable);
  42 
  43           dcl     alp                    pointer;
  44           dcl     code                   fixed bin (35);
  45           dcl     debug                  bit (3) aligned;
  46           dcl     nargs                  fixed bin;
  47           dcl     rs_ptr                 pointer;
  48           dcl     rs_lth                 fixed bin (21);
  49           dcl     return_string          char (rs_lth) based (rs_ptr) varying;
  50           dcl     complain               variable entry options (variable);
  51           dcl     active_function        bit (1) aligned;
  52           dcl     brief_sw               bit (1) aligned;
  53           dcl     brief_error_sw         bit (1) aligned;
  54           dcl     questionable_module    bit (1) aligned;   /* GLOBAL for communication between process_entry and process_entrypoint. */
  55 
  56           dcl     dname                  char (168);
  57           dcl     ename                  char (32);
  58           dcl     bitcount               fixed bin (24);
  59           dcl     fs_type                fixed bin (2);
  60           dcl     fcb_ptr                pointer;
  61 
  62           dcl     system_area_ptr        pointer;
  63           dcl     system_area            area based (system_area_ptr);
  64 
  65           dcl     first_entry            fixed bin;
  66           dcl     n_entries              fixed bin;
  67           dcl     entry_ptr              pointer;
  68           dcl     1 entry                (n_entries) based (entry_ptr),
  69                     2 argno              fixed bin,
  70                     2 name               char (36) varying,
  71                     2 ep                 char (36) varying,
  72                     2 non_star_lth       fixed bin,
  73                     2 include            bit (1) aligned;
  74 
  75           dcl     n_parts                fixed bin;
  76           dcl     1 part                 (64) aligned,      /* "parts" of the cref. Segments and last/first lines */
  77                     2 ptr                pointer,           /* pointer to beginning of this part */
  78                     2 lth                fixed bin (21),    /* length in characters */
  79                     2 first              fixed bin (30),    /* index (from char 1 of part 1) of first char in this part */
  80                     2 last               fixed bin (30),    /* index of last char in this part */
  81                     2 allocated          bit (1) aligned;   /* whether this part was allocated, and hence must be freed */
  82 
  83           dcl     active_fnc_err_        entry options (variable);
  84           dcl     check_star_name_$entry entry (char (*), fixed bin (35));
  85           dcl     com_err_               entry options (variable);
  86           dcl     cu_$af_return_arg      entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
  87           dcl     cu_$arg_list_ptr       entry (pointer);
  88           dcl     cu_$arg_ptr_rel        entry (fixed bin, pointer, fixed bin (21), fixed bin (35), pointer);
  89           dcl     expand_pathname_$add_suffix
  90                                          entry (character (*), character (*), character (*), character (*),
  91                                          fixed binary (35));
  92           dcl     get_system_free_area_  entry () returns (pointer);
  93           dcl     hcs_$status_minf       entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
  94                                          fixed bin (35));
  95           dcl     initiate_file_         entry (character (*), character (*), bit (*), pointer, fixed binary (24),
  96                                          fixed binary (35));
  97           dcl     terminate_file_        entry (pointer, fixed binary (24), bit (*), fixed binary (35));
  98           dcl     pathname_              entry (character (*), character (*)) returns (character (168));
  99           dcl     ioa_                   entry options (variable);
 100           dcl     ioa_$nnl               entry options (variable);
 101           dcl     match_star_name_       entry (char (*), char (*), fixed bin (35));
 102           dcl     msf_manager_$close     entry (pointer);
 103           dcl     msf_manager_$get_ptr   entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24),
 104                                          fixed bin (35));
 105           dcl     msf_manager_$open      entry (char (*), char (*), pointer, fixed bin (35));
 106 
 107           dcl     (
 108                   error_table_$badopt,
 109                   error_table_$dirseg,
 110                   error_table_$noarg,
 111                   error_table_$not_act_fnc,
 112                   error_table_$too_many_args
 113                   )                      fixed bin (35) external static;
 114 
 115           dcl     WHOAMI                 char (32) internal static options (constant) init ("peruse_crossref");
 116           dcl     DEFAULT_CREF_PATH      char (168) init (">library_dir_dir>crossref>total.crossref") internal
 117                                          static options (constant);
 118           dcl     SUFFIX                 char (8) init ("crossref") internal static options (constant);
 119           dcl     FIRST_CH               char (63) aligned internal static options (constant)
 120                                          init ("_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789");
 121           dcl     DASH                   char (1) aligned internal static options (constant) init ("-");
 122           dcl     SPACE                  char (1) aligned internal static options (constant) init (" ");
 123           dcl     TWO_SPACES             char (2) aligned internal static options (constant) init ("  ");
 124           dcl     TAB                    char (1) aligned internal static options (constant) init ("          ");
 125           dcl     TWO_TABS               char (2) aligned internal static options (constant)
 126                                          init ("            ");
 127           dcl     NEWLINE                char (1) aligned internal static options (constant) init ("
 128 ");
 129           dcl     WHITESPACE             char (3) aligned internal static options (constant) init ("
 130            ");                                              /* NEWLINE, TAB, SPACE */
 131 
 132           dcl     (
 133                   LESS                   init (1),
 134                   EQUAL                  init (2),
 135                   GREATER                init (3)
 136                   )                      fixed bin internal static options (constant);
 137 
 138           dcl     (
 139                   EXACT                  init (1),
 140                   PARTIAL                init (2),
 141                   MISS                   init (3)
 142                   )                      fixed bin internal static options (constant);
 143 
 144           dcl     (cleanup, logic_error) condition;
 145 
 146           dcl     (addr, after, before, bit, copy, divide, index, length, ltrim, maxlength, min, null, reverse, rtrim,
 147                   search, substr, unspec, verify)
 148                                          builtin;
 149 
 150 %page;
 151 %include access_mode_values;
 152 %page;
 153 %include terminate_file;
 154 %page;
 155           call cu_$af_return_arg (nargs, rs_ptr, rs_lth, code);
 156 
 157           if (code = 0)
 158           then do;
 159                     complain = active_fnc_err_;
 160                     return_string = "";
 161                     active_function = "1"b;
 162                end;
 163           else if (code = error_table_$not_act_fnc)
 164           then do;
 165                     complain = com_err_;
 166                     rs_ptr = null ();
 167                     active_function = "0"b;
 168                end;
 169           else do;
 170                     call com_err_ (code, WHOAMI);
 171                     return;
 172                end;
 173 
 174           call cu_$arg_list_ptr (alp);
 175 
 176           system_area_ptr = get_system_free_area_ ();       /* sundry initializations, for cleanup etc. */
 177           n_parts = 0;
 178           part.ptr (1) = null ();
 179           first_entry = 0;
 180           n_entries = 0;
 181           dname = "";
 182           entry_ptr = null ();
 183           fcb_ptr = null ();
 184 
 185           on condition (cleanup) call clean_up ();
 186 
 187           if nargs < 1
 188           then do;
 189 USAGE:
 190                     call complain (error_table_$noarg, WHOAMI,
 191                          "^/Usage:^-^a {crossref_pathname} entrypoint_name(s) {-control_args}", WHOAMI);
 192 
 193 MAIN_RETURN:
 194                     call clean_up ();
 195                     return;
 196                end;
 197 
 198           call process_args ();
 199 
 200           if n_entries = 0
 201           then /* must have at least one entrypoint, natch */
 202                goto USAGE;
 203 
 204           allocate entry in (system_area) set (entry_ptr);  /* allocate the info array */
 205 
 206           call check_entries ();
 207 
 208           call default_input_file ();
 209 
 210           call hcs_$status_minf (dname, ename, 1b /* chase */, fs_type, bitcount, code);
 211           if code ^= 0
 212           then do;
 213 BAD_XREF:
 214                     call complain (code, WHOAMI, "^a", pathname_ (dname, ename));
 215                     goto MAIN_RETURN;
 216                end;
 217 
 218           if fs_type = 1
 219           then /* segment */
 220                call initiate_segment ();
 221 
 222           else do;                                          /* must be an MSF */
 223                     if bitcount = 0
 224                     then do;                                /* but it's NOT */
 225                               code = error_table_$dirseg;
 226                               goto BAD_XREF;
 227                          end;
 228 
 229                     call initiate_msf ();
 230                end;
 231 
 232           if (debug & "1"b) ^= ""b
 233           then call print_parts ();
 234 
 235           if (debug & "01"b) = ""b
 236           then call print_matches ();
 237 
 238           return;
 239 %page;
 240 print_parts:
 241      proc ();
 242 
 243 /* Debugging procedure to list parts of cref file */
 244 
 245           dcl     part_idx               fixed bin;
 246 
 247           do part_idx = 1 to n_parts;
 248                call ioa_ ("Part ^d: ^d chars @ ^p.", part_idx, part.lth (part_idx), part.ptr (part_idx));
 249           end;
 250 
 251           call ioa_ ("");
 252 
 253           return;
 254      end print_parts;
 255 
 256 
 257 print_matches:
 258      proc ();
 259 
 260 /* procedure to print matches found in cref. */
 261 
 262           dcl     line_start             fixed bin (30);
 263           dcl     line_ptr               pointer;
 264           dcl     line_lth               fixed bin (21);
 265           dcl     line                   char (line_lth) based (line_ptr);
 266 
 267           dcl     match                  fixed bin;
 268           dcl     entry_idx              fixed bin;
 269           dcl     search_name            char (36) varying;
 270           dcl     exact                  bit (1) aligned;
 271           dcl     include                bit (1) aligned;
 272 
 273 
 274           do entry_idx = 1 to n_entries;
 275                search_name = substr (entry.name (entry_idx), 1, entry.non_star_lth (entry_idx));
 276                exact = (length (search_name) = length (entry.name (entry_idx)));
 277                include = entry.include (entry_idx);
 278 
 279                call find_line (search_name, include, exact, line_ptr, line_start, line_lth, match);
 280 
 281                if (debug & "001"b) ^= ""b
 282                then call ioa_ ("^[Exact^;Partial^;No^] match for ""^a"" in ^d char line at char ^d (^p):^/^a", match,
 283                          entry.name (entry_idx), line_lth, line_start, line_ptr, line);
 284 
 285                call process_entry (entry_idx, line_start, line_ptr, line_lth);
 286           end;
 287 
 288           return;
 289      end print_matches;
 290 %page;
 291 clean_up:
 292      proc ();
 293 
 294 /* cleanup procedure */
 295 
 296           dcl     s1p                    pointer;
 297           dcl     s1l                    fixed bin (21);
 298           dcl     s1                     char (s1l) based (s1p);
 299           dcl     part_idx               fixed bin;
 300 
 301           if entry_ptr ^= null ()
 302           then free entry in (system_area);
 303 
 304           if fcb_ptr = null ()
 305           then do;                                          /* not an MSF to close */
 306                     if part.ptr (1) ^= null ()
 307                     then /* but there is a segment */
 308                          call terminate_file_ (part.ptr (1), (0), TERM_FILE_TERM, (0));
 309                end;
 310 
 311           else do;                                          /* otherwise, close the MSF */
 312                     call msf_manager_$close (fcb_ptr);
 313                     do part_idx = 2 to (n_parts - 1) by 2;  /* and free all the strings */
 314                          s1p = part.ptr (part_idx);
 315                          s1l = part.lth (part_idx);
 316                          if part.allocated (part_idx)
 317                          then free s1 in (system_area);
 318                     end;
 319                end;                                         /* of closing MSF */
 320 
 321           return;
 322      end clean_up;
 323 %page;
 324 process_args:
 325      proc ();
 326 
 327 /* Simple procedure to process arguments */
 328 
 329           dcl     ap                     pointer;
 330           dcl     al                     fixed bin (21);
 331           dcl     arg                    char (al) based (ap);
 332           dcl     argno                  fixed bin;
 333 
 334           brief_sw, brief_error_sw = "0"b;
 335           debug = ""b;
 336           do argno = 1 to nargs;
 337                call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
 338 
 339                if index (arg, "-") = 1
 340                then if (^active_function) & ((arg = "-brief") | (arg = "-bf"))
 341                     then brief_sw = "1"b;
 342                     else if (^active_function) & ((arg = "-long") | (arg = "-lg"))
 343                     then brief_sw = "0"b;
 344                     else if arg = "-brief_errors" | arg = "-bfe"
 345                     then brief_error_sw = "1"b;
 346                     else if arg = "-debug" | arg = "-db"
 347                     then do;
 348                               if argno = nargs
 349                               then do;
 350                                         call complain (error_table_$noarg, WHOAMI,
 351                                              "^a must be followed by a debug bit mask.", arg);
 352                                         goto MAIN_RETURN;
 353                                    end;
 354                               argno = argno + 1;
 355                               call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
 356                               debug = bit (arg, 3);
 357                          end;
 358                     else if arg = "-long_errors" | arg = "-lgfe"
 359                     then brief_error_sw = "0"b;
 360                     else if (arg = "-pathname") | (arg = "-pn")
 361                     then do;
 362                               if argno = nargs
 363                               then do;
 364                                         call complain (error_table_$noarg, WHOAMI,
 365                                              "^a must be followed by a crossreference pathname.", arg);
 366                                         goto MAIN_RETURN;
 367                                    end;
 368                               argno = argno + 1;
 369                               call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
 370                               goto PATHNAME;
 371                          end;
 372 
 373                     else do;
 374                               call complain (error_table_$badopt, WHOAMI, "^a", arg);
 375                               goto MAIN_RETURN;
 376                          end;
 377 
 378                else if search (arg, "<>") > 0
 379                then
 380 PATHNAME:
 381                     do;                                     /* Looks Like a PATHNAME! */
 382                          if dname ^= ""                     /* Two PATHNAMES? */
 383                          then do;
 384                                    call complain (error_table_$too_many_args, WHOAMI,
 385                                         "Only one crossref pathname is allowed, but ^a appears to be a second pathname.",
 386                                         arg);
 387                                    goto MAIN_RETURN;
 388                               end;
 389 
 390                          call expand_pathname_$add_suffix (arg, SUFFIX, dname, ename, code);
 391                          if code ^= 0
 392                          then do;
 393                                    call complain (code, WHOAMI, "^a", arg);
 394                                    goto MAIN_RETURN;
 395                               end;
 396                     end;
 397 
 398                else do;                                     /* A SEARCH NAME (a search name) */
 399                          if first_entry = 0
 400                          then first_entry = argno;
 401                          n_entries = n_entries + 1;         /* otherwise, remember that we've seen an entrypoint */
 402                     end;
 403 
 404           end;                                              /* of loop through args */
 405 
 406           return;
 407      end process_args;
 408 %page;
 409 check_entries:
 410      proc ();
 411 
 412 /* This procedure is used to extract and validate the arguments from the command line
 413    which specify things to be searched for. */
 414 
 415           dcl     ap                     pointer;
 416           dcl     al                     fixed bin (21);
 417           dcl     arg                    char (al) based (ap);
 418           dcl     argno                  fixed bin;
 419 
 420           dcl     name                   char (36) varying;
 421           dcl     ep                     char (36) varying;
 422           dcl     i1                     fixed bin;
 423           dcl     entry_idx              fixed bin;
 424 
 425           entry_idx = 0;
 426           do argno = first_entry to nargs;
 427                call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
 428 
 429                if index (arg, "-") ^= 1 & search (arg, "<>") = 0
 430                then do;                                     /* thats us */
 431                          entry_idx = entry_idx + 1;         /* get to the next slot */
 432                          entry.argno (entry_idx) = argno;
 433                     end;
 434           end;
 435 
 436           do entry_idx = 1 to n_entries;                    /* validate the name portions */
 437                ep = "";
 438                call cu_$arg_ptr_rel (entry.argno (entry_idx), ap, al, (0), alp);
 439 
 440                name = before (arg, "$");                    /* split it in pieces */
 441                ep = after (arg, "$");
 442 
 443                if index (arg, ".incl") = 0
 444                then entry.include (entry_idx) = "0"b;
 445                else do;
 446                          entry.include (entry_idx) = "1"b;
 447 
 448                          if length (name) <= 25 & substr (reverse (name), 1, 5) = "lcni."
 449                          then name = name || ".*";
 450 
 451                          if ep ^= ""
 452                          then call bad_entry_format ("$ not allowed in include name.");
 453                     end;
 454 
 455                if length (name) > 32
 456                then call bad_entry_format ("Segment name too long.");
 457                if length (ep) > 256
 458                then call bad_entry_format ("Entrypoint name too long.");
 459 
 460                entry.name (entry_idx) = name;
 461                entry.ep (entry_idx) = ep;
 462 
 463                call check_star_name_$entry ((name), code);
 464                if code > 2
 465                then call bad_entry_format ("Invalid star name.");
 466                else if code = 2
 467                then call bad_entry_format ("Double star not allowed in segment name.");
 468                else if code = 1
 469                then do;                                     /* special stuff for hacking star names */
 470                          i1 = search (name, "*?");          /* find first star-like char -- there is guaranteed to be one */
 471                          if i1 = 1
 472                          then /* too complicated to implement this time */
 473                               call bad_entry_format ("Star names may not begin with star.");
 474                          entry.non_star_lth (entry_idx) = i1 - 1;
 475                                                             /* length of non-starred portion */
 476                     end;
 477                else entry.non_star_lth (entry_idx) = length (name);
 478                                                             /* otherwise, is whole thing */
 479 
 480                if length (ep) > 0
 481                then do;                                     /* validate entrypoint name, too */
 482                          call check_star_name_$entry ((ep), code);
 483                          if code > 2
 484                          then call bad_entry_format ("Invalid star name.");
 485                     end;
 486           end;                                              /* of validation loop */
 487 
 488           return;                                           /* end of main code of check_entries */
 489 %page;
 490 bad_entry_format:
 491      proc (P_message);
 492 
 493           dcl     P_message              char (*) parameter;
 494 
 495           call cu_$arg_ptr_rel (entry.argno (entry_idx), ap, al, (0), alp);
 496 
 497           call complain (0, WHOAMI, "Invalid search name ^a. ^a", arg, P_message);
 498           goto MAIN_RETURN;
 499 
 500      end bad_entry_format;
 501 
 502      end check_entries;
 503 %page;
 504 initiate_segment:
 505      proc ();
 506 
 507 /* This procedure is used to initiate a single segment if the xref is not an MSF;
 508    it creates, effectively, information about a one component MSF. */
 509 
 510           unspec (part (1)) = ""b;
 511 
 512           call initiate_file_ (dname, ename, R_ACCESS, part.ptr (1), bitcount, code);
 513           if code ^= 0
 514           then goto BAD_XREF;
 515 
 516           n_parts = 1;
 517 
 518           part.lth (1) = divide (bitcount, 9, 21, 0);
 519           part.first (1) = 1;                               /* first and only component */
 520           part.last (1) = part.lth (1);                     /* last char */
 521           part.allocated (1) = "0"b;                        /* should be terminated, not freed */
 522 
 523           return;
 524      end initiate_segment;
 525 %page;
 526 initiate_msf:
 527      proc ();
 528 
 529 /* This procedure is used to initiate all the components of an MSF, and then create
 530    extra "lines" between each component which contain all the characters after (but not
 531    including) the last newline in component N, followed by all the characters up to and
 532    including the first newline in component N+1. The starting addresses and lengths of
 533    each component are then updated appropriately to compensate for the characters
 534    thus extracted. */
 535 
 536           dcl     (s1p, s2p, s3p)        pointer;           /* assorted based strings */
 537           dcl     (s1l, s2l, s3l)        fixed bin (21);
 538           dcl     s1                     char (s1l) based (s1p);
 539           dcl     s2                     char (s2l) based (s2p);
 540           dcl     s3                     char (s3l) based (s3p);
 541 
 542           dcl     (i1, i2)               fixed bin (30);
 543           dcl     part_idx               fixed bin;
 544           dcl     component_idx          fixed bin;
 545 
 546 
 547           call msf_manager_$open (dname, ename, fcb_ptr, code);
 548           if (fcb_ptr = null ()) | (code ^= 0)
 549           then goto BAD_XREF;
 550 
 551           part_idx = 1;                                     /* incremented by two each time through */
 552           do component_idx = 0 by 1;
 553                unspec (part (part_idx)) = ""b;              /* initialize */
 554                unspec (part (part_idx + 1)) = ""b;
 555                part.ptr (part_idx + 1) = null ();
 556 
 557                call msf_manager_$get_ptr (fcb_ptr, component_idx, "0"b, part.ptr (part_idx), bitcount, code);
 558                if part.ptr (part_idx) = null ()
 559                then /* last one, probably */
 560                     goto MSF_INITIATED;
 561 
 562                part.lth (part_idx) = divide (bitcount, 9, 21, 0);
 563                n_parts = part_idx;
 564                part_idx = part_idx + 2;
 565           end;
 566 
 567 MSF_INITIATED:
 568           do part_idx = 1 to (n_parts - 2) by 2;            /* now, combine the end and beginning of each segment */
 569                s1p = part.ptr (part_idx);                   /* into a bare line, so that each part contains only */
 570                s1l = part.lth (part_idx);                   /* integral lines */
 571                i1 = length (s1) - index (reverse (s1), NEWLINE) + 2;
 572                                                             /* first char after last newline */
 573 
 574                s2p = part.ptr (part_idx + 2);               /* next segment */
 575                s2l = part.lth (part_idx + 2);
 576                i2 = index (s2, NEWLINE);                    /* first newline */
 577 
 578                s3l = length (substr (s1, i1)) + length (substr (s2, 1, i2));
 579                                                             /* length of string to be allocated */
 580                allocate s3 in (system_area) set (s3p);      /* -- sum of lengths of line parts */
 581 
 582                substr (s3, 1, length (substr (s1, i1))) = substr (s1, i1);
 583                                                             /* and copy in the two pieces */
 584                substr (s3, 1 + length (substr (s1, i1))) = substr (s2, 1, i2);
 585 
 586                part.lth (part_idx) = part.lth (part_idx) - length (substr (s1, i1));
 587                                                             /* shorten it by amount removed */
 588 
 589                part.ptr (part_idx + 1) = addr (substr (s3, 1, 1));
 590                                                             /* remember location of line */
 591                part.lth (part_idx + 1) = length (s3);
 592                part.allocated (part_idx + 1) = "1"b;
 593 
 594                part.ptr (part_idx + 2) = addr (substr (s2, i2 + 1));
 595                                                             /* move the beginning up */
 596                part.lth (part_idx + 2) = length (substr (s2, i2 + 1));
 597                                                             /* and shorten it */
 598           end;
 599 
 600           part.first (1) = 1;                               /* first char of part 1 is 1 */
 601           do part_idx = 1 to n_parts - 1;                   /* now, set the "first" char of each */
 602                part.first (part_idx + 1) = part.first (part_idx) + part.lth (part_idx);
 603           end;
 604 
 605           do part_idx = 1 to n_parts;                       /* now set part.last for all the parts */
 606                part.last (part_idx) = part.first (part_idx) + part.lth (part_idx) - 1;
 607           end;
 608 
 609           return;
 610      end initiate_msf;
 611 %page;
 612 locate_char:
 613      proc (P_idx, P_part_idx, P_part_offset);
 614 
 615 /* This procedure takes a character index (as counted from character one of
 616    part one) and returns the index of the part which contains it and
 617    an index into that part. */
 618 
 619           dcl     (
 620                   P_idx                  fixed bin (30),
 621                   P_part_idx             fixed bin,
 622                   P_part_offset          fixed bin (21)
 623                   )                      parameter;
 624 
 625           dcl     idx                    fixed bin;
 626 
 627           do idx = 1 to n_parts;
 628                if P_idx >= part.first (idx)
 629                then if P_idx <= part.last (idx)
 630                     then do;                                /* found it */
 631                               P_part_idx = idx;
 632                               P_part_offset = P_idx - part.first (idx) + 1;
 633                               return;
 634                          end;
 635           end;                                              /* of loop through parts */
 636 
 637           P_part_idx = -1;                                  /* force a fault if we fall through */
 638           P_part_offset = -1;
 639 
 640           return;
 641      end locate_char;
 642 %page;
 643 /* This procedure locates the beginning and end of the text line containing the
 644    referenced character, and returns a pointer to its first character and the length
 645    of the line. The line contains a trailing newline, unless the last line of the
 646    crossreference lacks one and is returned. */
 647 
 648 locate_line:
 649      proc (P_idx, P_line_ptr, P_line_start, P_line_lth);
 650 
 651           dcl     (
 652                   P_idx                  fixed bin (30),
 653                   P_line_ptr             pointer,
 654                   P_line_start           fixed bin (30),
 655                   P_line_lth             fixed bin (21)
 656                   )                      parameter;
 657 
 658           dcl     part_ptr               pointer;
 659           dcl     part_lth               fixed bin (21);
 660           dcl     part                   char (part_lth) based (part_ptr);
 661           dcl     part_idx               fixed bin;
 662           dcl     char_idx               fixed bin (21);
 663           dcl     first                  fixed bin (21);
 664           dcl     lth                    fixed bin (21);
 665 
 666           call locate_char (P_idx, part_idx, char_idx);
 667 
 668           part_ptr = part.ptr (part_idx);
 669           part_lth = part.lth (part_idx);
 670 
 671           first = index (reverse (substr (part, 1, char_idx)), NEWLINE);
 672           if first = 0
 673           then /* no previous newline, start at char 1 */
 674                first = 1;
 675           else first = char_idx - first + 2;
 676 
 677           lth = index (substr (part, first), NEWLINE);
 678           if lth = 0
 679           then /* no trailing newline */
 680                P_line_lth = length (substr (part, first));
 681           else P_line_lth = lth;                            /* otherwise, include the newline */
 682 
 683           P_line_start = part.first (part_idx) + first - 1; /* the index of the first char */
 684           P_line_ptr = addr (substr (part, first, 1));
 685 
 686           return;
 687      end locate_line;
 688 %page;
 689 next_line:
 690      proc (P_old_line_start, P_old_line_lth, P_new_line_ptr, P_new_line_start, P_new_line_lth);
 691 
 692 /* This procedure takes the index of the first character in a line, and returns pointer, start,
 693    and length for the next line in the file, or a null pointer if there is none. */
 694 
 695           dcl     (
 696                   P_old_line_start       fixed bin (30),
 697                   P_old_line_lth         fixed bin (21),
 698                   P_new_line_ptr         pointer,
 699                   P_new_line_start       fixed bin (30),
 700                   P_new_line_lth         fixed bin (21)
 701                   )                      parameter;
 702 
 703           dcl     part_ptr               pointer;
 704           dcl     part_lth               fixed bin (21);
 705           dcl     part                   char (part_lth) based (part_ptr);
 706           dcl     part_idx               fixed bin;
 707           dcl     char_idx               fixed bin (21);
 708           dcl     lth                    fixed bin (21);
 709 
 710 
 711           call locate_char (P_old_line_start + P_old_line_lth, part_idx, char_idx);
 712           if part_idx < 0
 713           then goto NO_APPROPRIATE_LINE;
 714 
 715           part_ptr = part.ptr (part_idx);
 716           part_lth = part.lth (part_idx);
 717 
 718           lth = index (substr (part, char_idx), NEWLINE);
 719           if lth = 0
 720           then /* no trailing newline */
 721                P_new_line_lth = length (substr (part, char_idx));
 722           else P_new_line_lth = lth;                        /* otherwise, include the newline */
 723 
 724           goto RETURN_INDICES;
 725 
 726 
 727 prev_line:
 728      entry (P_old_line_start, P_old_line_lth, P_new_line_ptr, P_new_line_start, P_new_line_lth);
 729 
 730           if P_old_line_start - 1 <= 0
 731           then goto NO_APPROPRIATE_LINE;
 732 
 733           call locate_line (P_old_line_start - 2, P_new_line_ptr, P_new_line_start, P_new_line_lth);
 734 
 735           if "1"b
 736           then return;
 737 
 738           call locate_char (P_old_line_start - 2, part_idx, char_idx);
 739           if part_idx < 0
 740           then goto NO_APPROPRIATE_LINE;
 741 
 742           part_ptr = part.ptr (part_idx);
 743           part_lth = part.lth (part_idx);
 744 
 745           lth = index (reverse (substr (part, 1, char_idx)), NEWLINE) + 1;
 746           if lth = 1
 747           then lth = char_idx + 1;
 748           else char_idx = char_idx - lth + 3;
 749 
 750           P_new_line_lth = lth;
 751           goto RETURN_INDICES;
 752 
 753 
 754 RETURN_INDICES:
 755           P_new_line_start = part.first (part_idx) + char_idx - 1;
 756                                                             /* the index of the first char */
 757           P_new_line_ptr = addr (substr (part, char_idx, 1));
 758 
 759           return;
 760 
 761 
 762 NO_APPROPRIATE_LINE:
 763           P_new_line_ptr = null ();
 764           P_new_line_start = -1;
 765           P_new_line_lth = -1;
 766           return;
 767 
 768      end next_line;
 769 %page;
 770 /* This procedure finds the line which either starts with P_string, or the first
 771    line after that in collating sequence. Collating sequence is strictly ASCII,
 772    except that anything containing the string ".incl." collates after anything
 773    that doesn't. The finding is done by binary search. */
 774 
 775 find_line:
 776      proc (P_string, P_include, P_exact, P_line_ptr, P_line_start, P_line_lth, P_matched);
 777 
 778           dcl     (
 779                   P_string               char (36) varying,
 780                   P_include              bit (1) aligned,
 781                   P_exact                bit (1) aligned,
 782                   P_line_start           fixed bin (30),
 783                   P_line_ptr             pointer,
 784                   P_line_lth             fixed bin (21),
 785                   P_matched              fixed bin
 786                   )                      parameter;
 787 
 788           dcl     include                bit (1) aligned;   /* whether P_string contains ".incl." */
 789           dcl     str_lth                fixed bin;
 790           dcl     backward               bit (1) aligned;   /* which direction are we scanning */
 791 
 792           dcl     (lb, ub)               fixed bin (30);    /* bounds for binary search */
 793           dcl     try                    fixed bin (30);
 794 
 795           dcl     (line_start, try_line_start)
 796                                          fixed bin (30);    /* line we work with */
 797           dcl     (line_ptr, try_line_ptr)
 798                                          pointer;
 799           dcl     (line_lth, try_line_lth)
 800                                          fixed bin (21);
 801           dcl     line                   char (line_lth) based (line_ptr);
 802 
 803           dcl     continue               bit (1) aligned;
 804           dcl     comparison             fixed bin;
 805           dcl     matched                fixed bin;
 806 
 807           dcl     last_char              fixed bin (30);
 808           dcl     first_char             fixed bin (30);
 809 %page;
 810           include = P_include;
 811           str_lth = length (P_string);
 812 
 813           lb = 1;
 814           ub = part.last (n_parts);
 815 
 816 ITERATE:
 817           try = divide ((lb + ub), 2, 30, 0);               /* beginning of loop -- see goto at bottom of procedure */
 818 
 819           call locate_line (try, line_ptr, line_start, line_lth);
 820 
 821           try_line_ptr = line_ptr;                          /* remember info about this line, in case we must search back */
 822           try_line_start = line_start;
 823           try_line_lth = line_lth;
 824 
 825           do while (index (FIRST_CH, substr (line, 1, 1)) = 0);
 826                                                             /* stop looping at the first non-whitespace */
 827                call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
 828                if line_ptr = null ()
 829                then /* last line */
 830                     goto LOOK_BACK_INSTEAD;
 831           end;                                              /* of finding next line with a name on it */
 832 
 833           call compare_line (line, P_string, include, comparison, matched);
 834 
 835           if comparison = EQUAL
 836           then /* strings are more or less equal. Finish and return */
 837                goto EQUAL_MATCH;
 838 
 839           last_char = line_start + line_lth - 1;            /* last char we have "looked" at */
 840 
 841           if comparison = LESS
 842           then do;                                          /* if LESS, then search backwards to the previous one */
 843 LOOK_BACK_INSTEAD:
 844                     line_ptr = try_line_ptr;                /* start from the line we ended up trying */
 845                     line_start = try_line_start;
 846                     line_lth = try_line_lth;
 847 
 848                     continue = "1"b;
 849                     do while (continue);                    /* look at prev line, stop when we hit a good one */
 850                          call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
 851                          if line_ptr = null ()
 852                          then /* first line */
 853                               goto FINISH_AND_RETURN;
 854 
 855                          if index (FIRST_CH, substr (line, 1, 1)) ^= 0
 856                          then continue = "0"b;              /* stop looping at the first non-whitespace */
 857                     end;                                    /* of finding next line with a name on it */
 858 
 859                     call compare_line (line, P_string, include, comparison, matched);
 860                                                             /* see what this line looks like */
 861 
 862                     if comparison = EQUAL
 863                     then goto EQUAL_MATCH;
 864 
 865                     first_char = line_start;                /* remember the index of the first char we look at */
 866                end;                                         /* of marching backward for "prev" comparison */
 867 
 868           else first_char = try_line_start;                 /* remember where we started looking */
 869 
 870           if comparison = LESS
 871           then /* reset the bounds */
 872                ub = first_char;
 873           else lb = last_char;
 874 
 875           if lb <= ub
 876           then /* go around and try again */
 877                goto ITERATE;                                /* Yes, I know it's an evil way to loop, but I think */
 878           else goto FINISH_AND_RETURN;                      /* it's actually somewhat clearer this way than it */
 879                                                             /* would have been with a do while loop */
 880 
 881 EQUAL_MATCH:
 882           if "1"b
 883           then do;                                          /* always scan backwards, just for laughs */
 884                     backward = "1"b;
 885                     continue = "1"b;
 886 
 887 EQUAL_MATCH_RESTART:
 888                     do while (continue);
 889                          if backward
 890                          then call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
 891                          else call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
 892                          if line_ptr = null ()
 893                          then if ^backward
 894                               then signal condition (logic_error);
 895                               else do;
 896                                         backward = "0"b;
 897                                         goto EQUAL_MATCH_RESTART;
 898                                    end;
 899 
 900                          if index (FIRST_CH, substr (line, 1, 1)) ^= 0
 901                          then do;                           /* see if this is a match */
 902                                    call compare_line (line, P_string, include, comparison, matched);
 903                                    if comparison ^= EQUAL
 904                                    then do;                 /* stop scan in this direction */
 905                                              if backward
 906                                              then backward = "0"b;
 907                                              else if comparison = LESS
 908                                              then goto FINISH_AND_RETURN;
 909                                         end;
 910                                    else if ^backward
 911                                    then /* really set, now */
 912                                         if ^P_exact | (matched = EXACT)
 913                                         then continue = "0"b;
 914                               end;
 915 
 916                     end;                                    /* of loop to find previous exact match */
 917                end;
 918 
 919 FINISH_AND_RETURN:
 920           P_line_ptr = line_ptr;
 921           P_line_start = line_start;
 922           P_line_lth = line_lth;
 923           P_matched = matched;
 924 
 925           return;
 926      end find_line;
 927 %page;
 928 /* This procedure compares P_string to the first token on P_line, setting P_comparison
 929    and P_matching appropriately. It is used to determine what direction to search in next,
 930    and also when to stop looping through lines. This is the procedure where the knowledge
 931    of the special effects of ".incl." on the collating sequence is embodied. */
 932 
 933 compare_line:
 934      proc (P_line, P_string, P_include, P_comparison, P_matching);
 935 
 936           dcl     (
 937                   P_line                 char (*),
 938                   P_string               char (36) varying,
 939                   P_include              bit (1) aligned,
 940                   P_comparison           fixed bin,
 941                   P_matching             fixed bin
 942                   )                      parameter;
 943 
 944           dcl     token_lth              fixed bin;
 945           dcl     token_ptr              pointer;
 946           dcl     token                  char (token_lth) based (token_ptr);
 947 
 948           dcl     test_lth               fixed bin;
 949 
 950           token_lth = search (P_line, WHITESPACE) - 1;      /* find the first token on the line */
 951           token_ptr = addr (substr (P_line, 1, 1));
 952           if token_lth < 0
 953           then /* no trailing delimiter */
 954                token_lth = length (P_line);
 955 
 956           P_matching = MISS;                                /* likely this is the case; only set it otherwise if not */
 957 
 958           if index (token, ".incl.") ^= 0
 959           then do;                                          /* we have hit an include file line */
 960                     if ^P_include
 961                     then do;                                /* but we are not searching for one, so punt */
 962                               P_comparison = LESS;
 963                               return;
 964                          end;
 965                end;
 966 
 967           else if substr (token, token_lth, 1) = ":"
 968           then do;
 969                     P_comparison = LESS;                    /* nasty error message at end of file */
 970                     return;
 971                end;
 972 
 973           else do;                                          /* otherwise, check the opposite */
 974                     if P_include
 975                     then do;                                /* include file always after than non-include */
 976                               P_comparison = GREATER;
 977                               return;
 978                          end;
 979                end;
 980 
 981           test_lth = min (length (token), length (P_string));
 982 
 983           if substr (P_string, 1, test_lth) > substr (token, 1, test_lth)
 984           then P_comparison = GREATER;
 985 
 986           else if substr (P_string, 1, test_lth) < substr (token, 1, test_lth)
 987           then P_comparison = LESS;
 988 
 989           else if token_lth < length (P_string)
 990           then /* short token is always greater than string */
 991                P_comparison = GREATER;
 992 
 993           else do;                                          /* they compare equal */
 994                     if length (token) = length (P_string)
 995                     then /* if strings are identical */
 996                          P_matching = EXACT;
 997                     else P_matching = PARTIAL;
 998 
 999                     P_comparison = EQUAL;
1000                end;
1001 
1002           return;
1003      end compare_line;
1004 %page;
1005 /* This procedure prints out formatted information for a single entry. It is given the
1006    location of the line containins the first reference to the entry. */
1007 
1008 process_entry:
1009      proc (P_entry_idx, P_line_start, P_line_ptr, P_line_lth);
1010 
1011           dcl     (
1012                   P_entry_idx            fixed bin,
1013                   P_line_start           fixed bin (30),
1014                   P_line_ptr             pointer,
1015                   P_line_lth             fixed bin (21)
1016                   )                      parameter;
1017 
1018           dcl     line_start             fixed bin (30);
1019           dcl     line_ptr               pointer;
1020           dcl     line_lth               fixed bin (21);
1021           dcl     line                   char (line_lth) based (line_ptr);
1022 
1023           dcl     name_starname          char (32);
1024           dcl     ep_starname            char (32);
1025           dcl     name                   char (36) varying;
1026           dcl     ep                     char (36) varying;
1027 
1028           dcl     n_entrypoints          fixed bin (17);
1029           dcl     header_bumf            char (64) varying;
1030           dcl     out_str                char (1000) varying;
1031           dcl     include                bit (1) aligned;
1032           dcl     comparison             fixed bin (17);
1033           dcl     matched                fixed bin (17);
1034           dcl     ep_scanning            bit (1) aligned;
1035           dcl     exact_match            bit (1) aligned;
1036           dcl     i1                     fixed bin (21);
1037           dcl     seg_name               char (32);
1038           dcl     synonym                bit (1) aligned;
1039           dcl     processing_synonym     bit (1) aligned;
1040           dcl     syn_name               char (32);
1041           dcl     saved_line_start       fixed bin (30);
1042           dcl     saved_line_lth         fixed bin (21);
1043           dcl     match                  fixed bin (17);
1044           dcl     len                    fixed bin (21);
1045           dcl     pos                    fixed bin (21);
1046 
1047 
1048           line_start = P_line_start;
1049           line_ptr = P_line_ptr;
1050           line_lth = P_line_lth;
1051 
1052           n_entrypoints = 0;
1053           out_str = "";
1054           header_bumf = "FOO!";
1055           processing_synonym = "0"b;
1056 
1057           name = substr (entry.name (P_entry_idx), 1, entry.non_star_lth (P_entry_idx));
1058           name_starname = entry.name (P_entry_idx);
1059           exact_match = (length (name) = length (entry.name (P_entry_idx)));
1060           include = entry.include (P_entry_idx);
1061           ep, ep_starname = entry.ep (P_entry_idx);
1062 
1063 /* set up to read the ----- bumf line */
1064 
1065 TRY_SYNONYM:
1066           call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
1067           ep_scanning = "0"b;                               /* no call to look at entrypoint lines yet */
1068 
1069           do while (line_ptr ^= null ());                   /* loop through the lines, looking for things to print */
1070 
1071                if index (FIRST_CH, substr (line, 1, 1)) ^= 0
1072                then do;                                     /* extract segment name */
1073                          call compare_line (line, name, include, comparison, matched);
1074                                                             /* is this line interesting? */
1075                          if comparison ^= EQUAL
1076                          then /* no longer equal */
1077                               goto FINISHED;                /* the first of these comparisons will always be spurious */
1078                          else if (matched ^= EXACT) & exact_match
1079                          then /* we've run out of candidates, even */
1080                               goto FINISHED;
1081 
1082                          ep_scanning, questionable_module, synonym = "0"b;
1083                          i1 = search (line, WHITESPACE);
1084                          if i1 = 0
1085                          then seg_name = line;
1086                          else do;
1087                                    seg_name = substr (line, 1, i1 - 1);
1088                                    if index (substr (line, i1 + 1), "(?)") ^= 0
1089                                    then questionable_module = "1"b;
1090                                    else if index (substr (line, i1 + 1), "SEE:") ^= 0
1091                                    then synonym = "1"b;
1092                               end;
1093 
1094                          if ^exact_match
1095                          then do;
1096                                    call match_star_name_ (seg_name, name_starname, code);
1097                                    if code ^= 0
1098                                    then goto NEXT_LINE;     /* it doesn't match -- ignore it */
1099                               end;
1100 
1101                          if include
1102                          then call process_include ();      /* well, is it ? */
1103                          else if synonym
1104                          then do;
1105                                    if processing_synonym
1106                                    then do;
1107                                              call complain (0, WHOAMI, "Nested synonym ^a.", name);
1108                                              goto MAIN_RETURN;
1109                                         end;
1110                                    saved_line_start = line_start;
1111                                    saved_line_lth = line_lth;
1112                                    syn_name = seg_name;
1113                                    name, name_starname =
1114                                         ltrim (rtrim (after (substr (line, i1 + 1), ":"), WHITESPACE), WHITESPACE);
1115                                    call find_line (name, "0"b, "1"b, line_ptr, line_start, line_lth, match);
1116                                    if (debug & "001"b) ^= ""b
1117                                    then call ioa_ ("^[Exact^;Partial^;No^] match for synonym ^a line[^d,^d]@^p:^/^a",
1118                                              match, name, line_start, line_lth, line_ptr, line);
1119                                    exact_match, processing_synonym = "1"b;
1120                                    goto TRY_SYNONYM;
1121                               end;
1122                          else do;
1123                                    if processing_synonym
1124                                    then seg_name = syn_name;
1125                                    ep_scanning = "1"b;
1126 NEXT_LINE:
1127                                    call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1128                               end;                          /* skip the segname line */
1129                     end;
1130 
1131                else if ep_scanning & substr (line, 1, 1) = SPACE
1132                then do;                                     /* see if it's an entrypoint name */
1133                          if index (FIRST_CH, substr (line, 2, 1)) ^= 0
1134                          then call process_entrypoint ();
1135                          else call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1136                     end;
1137 
1138                else do;
1139                          if ^include & (substr (line, 1, 1) = DASH)
1140                          then do;                           /* must be dat ole debbil --- bumf line */
1141                                    pos = index (line, "***** ") + 6;
1142                                    if pos > 6
1143                                    then do;
1144                                              len = index (substr (line, pos), " *****") - 1;
1145                                              if len > 0 then header_bumf = substr (line, pos, len);
1146                                         end;
1147                               end;
1148                          call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1149                     end;
1150           end;                                              /* otherwise, just skip it */
1151 
1152 FINISHED:
1153           if processing_synonym
1154           then do;
1155                     processing_synonym = "0"b;
1156                     name = substr (entry.name (P_entry_idx), 1, entry.non_star_lth (P_entry_idx));
1157                     name_starname = entry.name (P_entry_idx);
1158                     exact_match = (length (name) = length (entry.name (P_entry_idx)));
1159                     line_start = saved_line_start;
1160                     line_lth = saved_line_lth;
1161                     goto NEXT_LINE;
1162                end;
1163 
1164           if n_entrypoints = 0                              /* found nothing there */
1165           then if ^brief_error_sw
1166                then call complain (0, WHOAMI, "Not found: ^a^[$^a^]^/", name_starname, (ep_starname ^= ""), ep_starname);
1167                else ;
1168           else if ^active_function
1169           then call ioa_$nnl ("^a", out_str);               /* all done */
1170 
1171           return;                                           /* end of code for process_entry */
1172 %page;
1173 process_entrypoint:
1174      proc ();
1175 
1176 /* This procedure (internal to process_entry) collects information about a single entrypoint. */
1177 
1178           dcl     (idx, jdx)             fixed bin (21);
1179           dcl     ep_name                char (32);
1180           dcl     caller_name            char (32) varying;
1181 
1182           dcl     first_on_line          bit (1) aligned;
1183           dcl     questionable_entry     bit (1) aligned;
1184           dcl     header_output          bit (1) aligned;
1185           dcl     obj_name               char (72) varying;
1186           dcl     line_size              fixed bin (17);
1187           dcl     MAX_LINE_SIZE          fixed bin internal static options (constant) init (72);
1188 
1189 
1190           idx = search (substr (line, 2), WHITESPACE);
1191           ep_name = substr (line, 2, idx - 1);              /* extract the entrypoint name */
1192           idx = 1 + idx;
1193 
1194           if ep_starname ^= ""
1195           then do;                                          /* see if we should print this one */
1196                     call match_star_name_ ((ep_name), ep_starname, code);
1197                     if code ^= 0
1198                     then do;                                /* it doesn't match -- ignore it */
1199                               call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1200                               return;                       /* get to the beginning of the next line */
1201                          end;                               /* and return to let it get inspected */
1202                end;
1203 
1204           questionable_entry = "0"b;
1205           jdx = index (substr (line, idx), "(?)");
1206           if jdx > 0
1207           then do;
1208                     idx = idx + jdx + 3;
1209                     questionable_entry = ^questionable_module;
1210                end;
1211 
1212           n_entrypoints = n_entrypoints + 1;
1213 
1214           if (ep_name = seg_name)
1215           then /* figure out what to call this */
1216                obj_name = rtrim (seg_name);
1217           else if (ep_name = "")
1218           then obj_name = rtrim (seg_name) || "$";
1219           else obj_name = rtrim (seg_name) || "$" || rtrim (ep_name);
1220 
1221           line_size = MAX_LINE_SIZE + 1;                    /* force "overflow" for first time through */
1222           header_output = "0"b;                             /* whether we've commented on this entry yet */
1223 
1224 GET_NEXT_TOKEN:
1225           if ^active_function
1226           then /* If we're gonna be printing this, see if it's too big */
1227                if (length (out_str) + 200 > maxlength (out_str))
1228                then do;                                     /* time to flush the buffer */
1229                          call ioa_$nnl ("^a", out_str);
1230                          out_str = "";
1231                     end;
1232 
1233           if idx >= line_lth
1234           then do;                                          /* get the next line */
1235 GET_TO_NEXT_LINE:
1236                     call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1237 
1238                     if (substr (line, 1, min (2, length (line))) ^= TWO_SPACES) & (substr (line, 1, 1) ^= TAB)
1239                     then do;
1240                               if active_function
1241                               then return;                  /* Not gonna say anything */
1242 
1243                               if ^header_output
1244                               then do;                      /* whether we have said anything about this entry */
1245                                         if brief_sw
1246                                         then return;
1247                                         out_str = out_str || "No references to ";
1248                                         out_str = out_str || obj_name;
1249                                         out_str = out_str || " (";
1250                                         out_str = out_str || header_bumf;
1251                                         out_str = out_str || ")";
1252                                    end;
1253 
1254                               out_str = out_str || NEWLINE; /* finish it with two newlines */
1255                               out_str = out_str || NEWLINE; /* watch cretinous pl1 concatenation implementation */
1256                               return;                       /* and return for the next entrypoint */
1257                          end;
1258 
1259                     idx = 1;                                /* start at the beginning */
1260                end;
1261 
1262           jdx = verify (substr (line, idx), WHITESPACE);
1263           if jdx = 0
1264           then goto GET_TO_NEXT_LINE;
1265 
1266           idx = idx + jdx - 1;                              /* first non-white char */
1267           jdx = search (substr (line, idx), WHITESPACE) - 1;
1268           if jdx < 0
1269           then jdx = length (substr (line, idx));
1270 
1271           caller_name = substr (line, idx, jdx);
1272 
1273           if active_function
1274           then do;                                          /* Just add to the return string, and go back for more */
1275                     if length (return_string) > 0
1276                     then return_string = return_string || " ";
1277                     return_string = return_string || caller_name;
1278                     idx = idx + jdx;
1279                     goto GET_NEXT_TOKEN;
1280                end;
1281 
1282           if line_size + 2 + length (caller_name) > MAX_LINE_SIZE
1283           then do;
1284                     if ^header_output
1285                     then do;
1286                               out_str = out_str || "References to ";
1287                               out_str = out_str || obj_name;
1288                               out_str = out_str || ":  (";
1289                               out_str = out_str || header_bumf;
1290                               out_str = out_str || ")";
1291                               if questionable_entry
1292                               then out_str = out_str || " ** Not Found **";
1293                               out_str = out_str || NEWLINE;
1294                               out_str = out_str || copy (SPACE, 4);
1295 
1296                               header_output = "1"b;
1297                          end;
1298 
1299                     else do;
1300                               out_str = out_str || ",";
1301                               out_str = out_str || NEWLINE;
1302                               out_str = out_str || copy (SPACE, 4);
1303                          end;
1304 
1305                     line_size = 4;
1306                end;
1307 
1308           else if ^first_on_line
1309           then do;
1310                     out_str = out_str || ", ";
1311                     line_size = line_size + 2;
1312                end;
1313 
1314           out_str = out_str || caller_name;
1315           line_size = line_size + length (caller_name);
1316           first_on_line = "0"b;
1317 
1318           idx = idx + jdx;                                  /* get on to next token */
1319           goto GET_NEXT_TOKEN;
1320 
1321      end process_entrypoint;
1322 %page;
1323 process_include:
1324      proc ();
1325 
1326 /* This procedure (internal to process_entry) collects information about a single include file. */
1327 
1328           dcl     (idx, jdx)             fixed bin (21);
1329           dcl     caller_name            char (32) varying;
1330           dcl     first_on_line          bit (1) aligned;
1331           dcl     header_output          bit (1) aligned;
1332           dcl     incl_name              char (32) varying;
1333           dcl     incl_dtcm              char (40) varying;
1334           dcl     line_size              fixed bin (17);
1335           dcl     MAX_LINE_SIZE          fixed bin internal static options (constant) init (72);
1336 
1337 
1338           n_entrypoints = n_entrypoints + 1;
1339           incl_name = rtrim (seg_name);
1340 
1341           if index (line, "*****") = 0
1342           then call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1343 
1344           incl_dtcm = substr (line, index (line, "***** ") + 6);
1345           incl_dtcm = substr (incl_dtcm, 1, length (incl_dtcm) - 7);
1346 
1347           idx = line_lth;                                   /* force next_line */
1348           line_size = MAX_LINE_SIZE + 1;                    /* force "overflow" for first time through */
1349           header_output = "0"b;                             /* whether we've commented on this entry yet */
1350 
1351 GET_NEXT_TOKEN:
1352           if ^active_function
1353           then /* If we're gonna be printing this, see if it's too big */
1354                if (length (out_str) + 200 > maxlength (out_str))
1355                then do;                                     /* time to flush the buffer */
1356                          call ioa_$nnl ("^a", out_str);
1357                          out_str = "";
1358                     end;
1359 
1360           if idx >= line_lth
1361           then do;                                          /* get the next line */
1362 GET_TO_NEXT_LINE:
1363                     call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
1364 
1365                     if (substr (line, 1, 2) ^= TWO_TABS)
1366                     then if header_output
1367                          then do;                           /* whether we have said anything about this include incarnation */
1368                                    if active_function
1369                                    then return;             /* Not gonna say anything */
1370 
1371                                    out_str = out_str || NEWLINE;
1372                                                             /* add one newline for now */
1373                                    out_str = out_str || NEWLINE;
1374                                                             /* and another for later */
1375                                    return;                  /* and return for the next entrypoint */
1376                               end;
1377 
1378                     idx = 1;                                /* start at the beginning */
1379                end;
1380 
1381           jdx = verify (substr (line, idx), WHITESPACE);
1382           if jdx = 0
1383           then goto GET_TO_NEXT_LINE;
1384 
1385           idx = idx + jdx - 1;                              /* first non-white char */
1386           jdx = search (substr (line, idx), WHITESPACE) - 1;
1387           if jdx < 0
1388           then jdx = length (substr (line, idx));
1389 
1390           caller_name = substr (line, idx, jdx);
1391 
1392           if active_function
1393           then do;                                          /* Just add to the return string, and go back for more */
1394                     if length (return_string) > 0
1395                     then return_string = return_string || " ";
1396                     return_string = return_string || caller_name;
1397                     idx = idx + jdx;
1398                     header_output = "1"b;                   /* Force above logic to terminate properly */
1399                     goto GET_NEXT_TOKEN;
1400                end;
1401 
1402           if line_size + 2 + length (caller_name) > MAX_LINE_SIZE
1403           then do;
1404                     if ^header_output
1405                     then do;
1406                               out_str = out_str || "References to ";
1407                               out_str = out_str || incl_name;
1408                               out_str = out_str || ":  (";
1409                               out_str = out_str || incl_dtcm;
1410                               out_str = out_str || ")";
1411                               out_str = out_str || NEWLINE;
1412                               out_str = out_str || copy (SPACE, 4);
1413 
1414                               header_output = "1"b;
1415                          end;
1416 
1417                     else do;
1418                               out_str = out_str || ",";
1419                               out_str = out_str || NEWLINE;
1420                               out_str = out_str || copy (SPACE, 4);
1421                          end;
1422 
1423                     line_size = 4;
1424                end;
1425 
1426           else if ^first_on_line
1427           then do;
1428                     out_str = out_str || ", ";
1429                     line_size = line_size + 2;
1430                end;
1431 
1432           out_str = out_str || caller_name;
1433           line_size = line_size + length (caller_name);
1434           first_on_line = "0"b;
1435 
1436           idx = idx + jdx;                                  /* get on to next token */
1437           goto GET_NEXT_TOKEN;
1438 
1439      end process_include;
1440 
1441      end process_entry;
1442 %page;
1443 default_input_file:
1444      procedure;
1445 
1446           if dname ^= ""
1447           then return;
1448           ename = "";
1449 
1450           call expand_pathname_$add_suffix (DEFAULT_CREF_PATH, SUFFIX, dname, ename, code);
1451           if code ^= 0
1452           then do;
1453                     call complain (code, WHOAMI, "Bad default path ^a.", DEFAULT_CREF_PATH);
1454                     goto MAIN_RETURN;
1455                end;
1456 
1457      end default_input_file;
1458 
1459      end peruse_crossref;