1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1988                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 /****^  HISTORY COMMENTS:
  15   1) change(68-04-28,Garman), approve(), audit(), install():
  16      Written by C. Garman.
  17   2) change(68-10-02,Garman), approve(), audit(), install():
  18      Modified to call write directly for entire segment or portion
  19       thereof, give ending-line request.
  20   3) change(69-07-16,Weaver), approve(), audit(), install():
  21      Modified by M. Weaver to change smm$initiate and some write_out
  22       calls.
  23   4) change(69-08-03,Voydock), approve(), audit(), install():
  24      Modified by V. Voydock.
  25   5) change(69-08-06,Weaver), approve(), audit(), install():
  26      Modified by M. Weaver (August 6 and August 8).
  27   6) change(69-08-11,Weaver), approve(), audit(), install():
  28      Modified by M. Weaver (add hcs_$status_minf)
  29   7) change(70-03-04,Karger), approve(), audit(), install():
  30      Modified by P. Karger (compiled under PL/I and prints date and time
  31       in header)
  32   8) change(70-03-25,Karger), approve(), audit(), install():
  33      Modified by P. Karger to change calls to tio_ to ios_
  34   9) change(70-06-19,Stone), approve(), audit(), install():
  35      Modified by E. Stone.
  36  10) change(76-10-27,VanVleck), approve(), audit(), install():
  37      Rewritten by THVV for new arguments, iox, etc.
  38  11) change(79-08-03,VanVleck), approve(), audit(), install():
  39      Modified by THVV for archive stuff.  Much help by MND.
  40  12) change(82-09-13,GDixon), approve(), audit(), install():
  41      Modified by G. Dixon -- when indenting, properly indent lines preceded
  42       by NP and VT chars.  Accept -in as short name for -indent (-ind).  Use
  43       prt_conv_ when -indent I is specified, where mod(I,10) ^= 0.  Fix bug
  44       which prevents -line_length from being honored.
  45  13) change(82-11-22,Wallman), approve(), audit(), install():
  46      Modified by E. Wallman:  Fixed bug that printed extra lines when -for
  47       was used with -pn.  Reformatted with format_pl1.
  48  14) change(82-11-24,Wallman), approve(), audit(), install():
  49      Modified by E. Wallman:  Fixed bug that left the last page short when
  50       -ppl and -no_vertsp were given.  Renamed many variables for readability.
  51  15) change(82-11-26,Wallman), approve(), audit(), install():
  52      Modified by E. Wallman:  Fixed remaining problems in error list thru #10.
  53  16) change(83-07-11,Texada), approve(), audit(), install():
  54      Modified by Greg Texada:  added -output_switch, -osw control args.
  55  17) change(83-09-28,GDixon), approve(), audit(), install():
  56      Modified by Gary Dixon:  simplify scheme for processing a line.
  57  18) change(83-12-01,Spitzer), approve(), audit(), install():
  58      Modified by C. Spitzer:  fix error msg, use pathname_.
  59  19) change(84-03-08,Spitzer), approve(), audit(), install():
  60      Modified by C. Spitzer:  use iox_$get_line to pause.
  61  20) change(84-07-10,Rochlis), approve(), audit(), install():
  62      Modified by Jon A. Rochlis:  do a reset_more control order before
  63       printing each file to make video users happy.
  64  21) change(84-08-21,Falksenj), approve(), audit(), install():
  65      Modified by J. A. Falksen:  utilize date_time_$format ("date_time",...
  66  22) change(85-01-10,Lippard), approve(85-01-30,MCR7165),
  67      audit(85-10-07,Blair), install(85-12-16,MR12.0-1001):
  68      Modified by Jim Lippard:  force vertsp mode when -vertsp is used, use
  69       initiate_file_ and terminate_file_, fix bug where -left_col blows up
  70       on first line of length greater than lc value.
  71  23) change(86-10-09,TLNguyen), approve(86-10-28,MCR7563),
  72      audit(86-10-29,Gilcrease), install(86-11-20,MR12.0-1217):
  73      Modified by Tai Nguyen: make the print command to display exactly
  74       n lines for a specified segment when the "-for" control argument
  75       was used.  Fixed an array subscriptrange codition at the run time
  76       when compiled with the following:
  77       -table -prefix size, strz, strg, subrg
  78  24) change(86-11-17,TLNguyen), approve(86-10-28,MCR7563),
  79      audit(86-11-17,Gilcrease), install(86-11-20,MR12.0-1217):
  80      Fixed bug which occurs when the line starts with a New Page character
  81      and the "-from" control argument is entered in the "print" command.
  82  25) change(86-11-26,TLNguyen), approve(86-11-26,MCR7563),
  83      audit(86-12-01,Gilcrease), install(86-12-02,MR12.0-1230):
  84      Fixed error which occurs when the two control arguments -for and -match
  85      work together in the print command.
  86  26) change(87-01-02,TLNguyen), approve(87-01-02,MCR7597),
  87      audit(87-01-09,Lippard), install(87-03-20,MR12.1-1006):
  88      Make the print command display an appropriative error message and do a
  89      reset_more control order between archive components for archive case.
  90  27) change(88-08-02,TLNguyen), approve(88-08-02,MCR7935),
  91      audit(88-08-30,Parisek), install(88-09-02,MR12.2-1097):
  92      make the print command with the -from_page P work as documented.
  93  28) change(89-04-28,Vu), approve(89-04-28,MCR8098), audit(89-05-08,Lee),
  94      install(89-06-09,MR12.3-1057):
  95      The print command will not enable the user's terminal mode to "vertsp".
  96      Delete all references to iox_$modes and sws.reset_modes by vp
  97      (phx20749 - Commands 514) and (phx20361 - Commands 762).
  98      Reformatted print.pl1
  99                                                    END HISTORY COMMENTS */
 100 
 101 
 102 /* format: style2,ind3,ll80,dclind4,comcol51,linecom */
 103 
 104 /* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 105 /*                                                                           */
 106 /* Name: print, pr                                                           */
 107 /*                                                                           */
 108 /* print ASCII text file on user console.                                    */
 109 /*                                                                           */
 110 /* Note: There is a known bug in this program which is fixable only by an    */
 111 /* unreasonable amount of effort.  The -match, -exclude, -from and -to       */
 112 /* control arguments will not find their target strings if it happens that   */
 113 /* they are split across MSF components. Fixing this bug would require a lot */
 114 /* of hair, incluing a buffer somewhere big enough for the reassembly of the */
 115 /* split line.  For now we ignore it.  Anybody who wants to fix it is        */
 116 /* welcome to.                                                               */
 117 /*                                                                           */
 118 /*                                                                           */
 119 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * *  *  *  * */
 120 
 121 
 122 print:
 123 pr:
 124    procedure;
 125 
 126       dcl arg                    char (arg_len) unaligned based (arg_ptr);
 127       dcl arg_len                fixed bin (21);
 128       dcl arg_list_ptr           ptr;
 129       dcl arg_ptr                ptr;
 130       dcl c                      fixed bin (35);
 131       dcl error_code             fixed bin (35);
 132       dcl exclude_arg_count      fixed bin;       /* number of -exclude args */
 133       dcl forcount               fixed bin;       /* # of input lines to print */
 134       dcl from_line              fixed bin;       /* starting line */
 135       dcl from_page              fixed bin;       /* lowest page number to print */
 136       dcl from_regexpr           char (from_regexpr_len + 2)
 137                                  based (from_regexpr_ptr);
 138       dcl from_regexpr_len       fixed bin (21);  /* length of above */
 139       dcl from_regexpr_ptr       ptr;             /* starting reg exp */
 140       dcl iarg                   fixed bin;       /* arg number */
 141       dcl indentation            fixed bin (21);  /* indentation */
 142       dcl input_path_count       fixed bin;       /* number of pathnames (zero, one, or more) */
 143       dcl junk                   fixed bin;
 144       dcl last_count             fixed bin;
 145       dcl left_col               fixed bin;       /* left side of print band */
 146       dcl match_arg_count        fixed bin;       /* number of -match args */
 147       dcl nargs                  fixed bin;       /* arg count */
 148       dcl output_buffer_size     fixed bin;       /* size of print buffer */
 149       dcl out_switch             ptr;             /* write output on this */
 150                                                   /* switch; its assumed */
 151                                                   /* attached & open for */
 152                                                   /* stream output. */
 153       dcl right_col              fixed bin;       /* right side of print band */
 154       dcl star_sel               fixed bin (2);   /* branches, or branches+links */
 155       dcl switch_name            char (32);       /* plain talk name of -osw */
 156       dcl to_line                fixed bin;       /* ending line */
 157       dcl to_page                fixed bin;       /* highest */
 158       dcl to_regexpr_len         fixed bin (21);
 159       dcl to_regexpr_ptr         ptr;             /* ending reg exp */
 160 
 161       dcl 1 sws,                                  /* switch bits */
 162             2 check_lines        bit (1),         /* TRUE if -match or -ex */
 163             2 dont_want_archive  bit (1),         /* TRUE if print archive as big file */
 164             2 from_line_given    bit (1),
 165             2 from_page_given    bit (1),
 166             2 had_an_arg         bit (1),         /* TRUE if any arg */
 167             2 last_given         bit (1),
 168             2 no_heading         bit (1),         /* TRUE if dont want heading */
 169             2 no_vertsp          bit (1),         /* TRUE if simulating NP and VT */
 170             2 one_iox_call       bit (1),         /* TRUE if can do in one call to iox */
 171             2 paging             bit (1),         /* TRUE if paged output is wanted */
 172             2 pause_after_page   bit (1),         /* TRUE if pause after page */
 173             2 pause_before_print bit (1),         /* TRUE if pause before printing */
 174             2 print_quick_way    bit (1),         /* TRUE if can do without prt_conv */
 175             2 print_trailing_nls bit (1),         /* TRUE if print some NLs at end like old print */
 176             2 to_line_given      bit (1),
 177             2 to_page_given      bit (1),
 178             2 want_heading       bit (1),         /* TRUE if print heading */
 179             2 want_line_numbers  bit (1);         /* TRUE if print line numbers */
 180 
 181       dcl archive_$next_component_info
 182                                  entry (ptr, fixed bin (24), ptr, ptr,
 183                                  fixed bin (35));
 184       dcl check_star_name_$entry entry (char (*), fixed bin (35));
 185       dcl com_err_               entry options (variable);
 186       dcl cu_$arg_count          entry (fixed bin, fixed bin (35));
 187       dcl cu_$arg_list_ptr       entry (ptr);
 188       dcl cu_$arg_ptr            entry (fixed bin, ptr, fixed bin (21),
 189                                  fixed bin (35));
 190       dcl cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21),
 191                                  fixed bin (35), ptr);
 192       dcl cv_dec_check_          entry (char (*), fixed bin (35))
 193                                  returns (fixed bin);
 194       dcl date_time_$format      entry (char (*), fixed bin (71), char (*),
 195                                  char (*)) returns (char (250) var);
 196       dcl expand_pathname_$component
 197                                  entry (char (*), char (*), char (*), char (*),
 198                                  fixed bin (35));
 199       dcl get_system_free_area_  entry () returns (ptr);
 200       dcl hcs_$star_             entry (char (*), char (*), fixed bin (2), ptr,
 201                                  fixed bin, ptr, ptr, fixed bin (35));
 202       dcl hcs_$status_minf       entry (char (*), char (*), fixed bin (1),
 203                                  fixed bin (2), fixed bin (24), fixed bin (35));
 204       dcl initiate_file_         entry (char (*), char (*), bit (*), ptr,
 205                                  fixed bin (24), fixed bin (35));
 206       dcl ioa_$ioa_switch        entry options (variable);
 207       dcl ioa_$ioa_switch_nnl    entry options (variable);
 208       dcl ioa_$rsnp              entry options (variable);
 209       dcl iox_$control           entry (ptr, char (*), ptr, fixed bin (35));
 210       dcl iox_$get_line          entry (ptr, ptr, fixed bin (21),
 211                                  fixed bin (21), fixed bin (35));
 212       dcl iox_$look_iocb         entry (char (*), ptr, fixed bin (35));
 213       dcl iox_$put_chars         entry (ptr, ptr, fixed bin (21),
 214                                  fixed bin (35));
 215       dcl match_star_name_       entry (char (*), char (*), fixed bin (35));
 216       dcl msf_manager_$close     entry (ptr);
 217       dcl msf_manager_$get_ptr   entry (ptr, fixed bin, bit (1), ptr,
 218                                  fixed bin (24), fixed bin (35));
 219       dcl msf_manager_$open      entry (char (*), char (*), ptr, fixed bin (35))
 220                                  ;
 221       dcl pathname_              entry (char (*), char (*))
 222                                  returns (char (168));
 223       dcl pathname_$component    entry (char (*), char (*), char (*))
 224                                  returns (char (194));
 225       dcl print_conv_$print_conv_
 226                                  entry;
 227       dcl prt_conv_              entry (ptr, fixed bin (21), ptr,
 228                                  fixed bin (21), ptr);
 229       dcl search_file_           entry (ptr, fixed bin (21), fixed bin (21),
 230                                  ptr, fixed bin (21), fixed bin (21),
 231                                  fixed bin (21), fixed bin (21), fixed bin (35))
 232                                  ;
 233       dcl search_file_$silent    entry (ptr, fixed bin (21), fixed bin (21),
 234                                  ptr, fixed bin (21), fixed bin (21),
 235                                  fixed bin (21), fixed bin (21), fixed bin (35))
 236                                  ;
 237       dcl terminate_file_        entry (ptr, fixed bin (24), bit (*),
 238                                  fixed bin (35));
 239 
 240       dcl (addr, clock, codeptr, divide, index, length, max, min, mod, null,
 241           reverse, rtrim, search, string, substr, sum, unspec)
 242                                  builtin;
 243       dcl cleanup                condition;
 244 
 245       dcl CR                     char (1) int static options (constant)
 246                                  init ("^M");
 247       dcl NL                     char (1) int static options (constant) init ("
 248 ");
 249       dcl NLCRVTNP               char (4) int static options (constant) init ("
 250 ^M^K^L");
 251       dcl NP                     char (1) int static options (constant) init ("^L");
 252       dcl NUL                    char (1) int static options (constant)
 253                                  init ("^@");
 254       dcl VT                     char (1) int static options (constant) init ("^K");
 255       dcl LONGEST_SEARCH_FILE_REXP
 256                                  fixed bin static options (constant) init (132);
 257       dcl MAX_BUFFER_LTH         fixed bin int static options (constant)
 258                                  init (1025);     /* types returned by check_star_name_ */
 259       dcl 1 type                 static options (constant),
 260             2 NOSTAR             fixed bin (35) init (0),
 261             2 STAR               fixed bin (35) init (1),
 262             2 STARSTAR           fixed bin (35) init (2);
 263       dcl TERMINATE_SEG          bit (4) internal static options (constant)
 264                                  init ("0010"b);
 265 
 266       dcl error_table_$bad_conversion
 267                                  fixed bin (35) ext static;
 268       dcl error_table_$badopt    fixed bin (35) ext static;
 269       dcl error_table_$dirseg    fixed bin (35) ext static;
 270       dcl error_table_$inconsistent
 271                                  fixed bin (35) ext static;
 272       dcl error_table_$long_record
 273                                  fixed bin (35) ext static;
 274       dcl error_table_$noarg     fixed bin (35) ext static;
 275       dcl error_table_$no_component
 276                                  fixed bin (35) ext static;
 277       dcl error_table_$nomatch   fixed bin (35) ext static;
 278       dcl error_table_$regexp_undefined
 279                                  fixed bin (35) ext static;
 280       dcl error_table_$zero_length_seg
 281                                  fixed bin (35) ext static;
 282       dcl iox_$user_input        ptr ext static;
 283       dcl iox_$user_output       ptr ext static;
 284 %page (2);
 285 /* ======================================================== */
 286 
 287 /* Set up default values */
 288 
 289       star_sel = star_BRANCHES_ONLY;              /* default is -no_chase */
 290       from_line, from_page = 1;                   /* default is to print whole file */
 291       to_page = -1;
 292       match_arg_count, exclude_arg_count, to_line, indentation, forcount,
 293            from_regexpr_len, to_regexpr_len, input_path_count = 0;
 294       string (sws) = "0"b;
 295       right_col = MAX_BUFFER_LTH;
 296       last_count, left_col = 1;
 297 
 298       pcip = addr (PCI);
 299       unspec (PCI) = ""b;
 300       pci.cv_proc = codeptr (print_conv_$print_conv_);
 301       pci.line = 1;
 302       pci.phys_line_length = MAX_BUFFER_LTH;
 303       pci.ctl_char = "1"b;
 304       pci.lpi = 6;
 305       pci.sheets_per_page = 1;
 306       pci.top_label_line = "";
 307       pci.bot_label_line = "";
 308       pci.overflow_off = "1"b;                    /* Don't put in NP */
 309       pci.label_wksp = null;
 310       pci.label_nelem = 0;
 311       switch_name = "user_output";                /* default switch */
 312       out_switch = iox_$user_output;
 313 
 314 /* Analyze all the control arguments. */
 315 
 316       call cu_$arg_list_ptr (arg_list_ptr);
 317       call cu_$arg_count (nargs, error_code);
 318       if error_code ^= 0
 319       then
 320          do;
 321             call com_err_ (error_code, "print");  /* can't be AF */
 322             return;
 323          end;
 324 
 325       do iarg = 1 to nargs;                       /* preprocess the args */
 326          call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
 327          if error_code ^= 0
 328          then
 329             do;
 330 ARG_READ_ERR:
 331                call com_err_ (error_code, "print", "Argument ^d.", iarg);
 332 RETURN:
 333                return;
 334             end;
 335 
 336          if index (arg, "-") ^= 1                 /* number or pathname? */
 337          then
 338             do;
 339                junk = cv_dec_check_ (arg, error_code);
 340 
 341                if error_code = 0                  /* its a number */
 342                then
 343                   do;
 344                      if input_path_count = 0      /* make "print 0" work as it used to */
 345                      then goto its_a_name;
 346 
 347                      if junk = 0                  /* 0's are not allowed */
 348                      then
 349                         do;
 350                            error_code = error_table_$bad_conversion;
 351                            goto ARG_ERR;
 352                         end;
 353 
 354                      if ^sws.from_line_given
 355                      then
 356                         do;
 357                            from_line = junk;
 358                            sws.from_line_given = "1"b;
 359                         end;
 360 
 361                      else if ^sws.to_line_given
 362                      then
 363                         do;
 364                            to_line = junk;
 365                            sws.to_line_given = "1"b;
 366                         end;
 367 
 368                      else
 369                         do;
 370                            call com_err_ (error_table_$inconsistent, "print",
 371                                 "Only one line range is allowed. ^a", arg);
 372                            return;
 373                         end;
 374                      sws.had_an_arg = "1"b;
 375                   end;
 376 
 377                else
 378                   do;                             /* non-numeric */
 379                      if search (arg, "*?") ^= 0   /* pretend starname matches 2 */
 380                      then input_path_count = input_path_count + 1;
 381 its_a_name:                                       /* count file names */
 382                      input_path_count = input_path_count + 1;
 383                   end;
 384             end;
 385 
 386          else
 387             do;
 388                sws.had_an_arg = "1"b;
 389 
 390                if arg = "-name" | arg = "-nm"
 391                then
 392                   do;
 393                      iarg = iarg + 1;
 394 
 395                      if iarg > nargs
 396                      then
 397                         do;
 398 miss_arg:
 399                            call com_err_ (error_table_$noarg, "print",
 400                                 "After ^a.", arg);
 401                            return;
 402                         end;                      /* count file names */
 403                      input_path_count = input_path_count + 1;
 404                   end;
 405 
 406                else if arg = "-from" | arg = "-fm"
 407                then call GET_FROM_TO (sws.from_line_given, from_regexpr_ptr,
 408                          from_regexpr_len, from_line);
 409 
 410                else if arg = "-to"
 411                then call GET_FROM_TO (sws.to_line_given, to_regexpr_ptr,
 412                          to_regexpr_len, to_line);
 413 
 414                else if arg = "-for"
 415                then forcount = GETNUM ();
 416 
 417                else if arg = "-from_page"
 418                then
 419                   do;
 420                      sws.from_page_given = "1"b;
 421                      from_page = GETNUM ();
 422                   end;
 423 
 424                else if arg = "-to_page"
 425                then
 426                   do;
 427                      sws.to_page_given = "1"b;
 428                      to_page = GETNUM ();
 429                   end;
 430 
 431                else if arg = "-indent" | arg = "-ind" | arg = "-in"
 432                then indentation = GETNUM ();
 433 
 434                else if arg = "-last" | arg = "-lt"
 435                then
 436                   do;
 437                      sws.last_given = "1"b;
 438                      last_count = GETNUM ();
 439                   end;
 440 
 441                else if arg = "-left_col" | arg = "-lc"
 442                then left_col = GETNUM ();
 443 
 444                else if arg = "-right_col" | arg = "-rc"
 445                then right_col = GETNUM ();
 446 
 447                else if arg = "-line_length" | arg = "-ll"
 448                then pci.phys_line_length = GETNUM ();
 449 
 450                else if arg = "-page_length" | arg = "-pl"
 451                then
 452                   do;
 453                      pci.page_length = GETNUM ();
 454                      pci.overflow_off = "0"b;     /* Do NP */
 455                   end;
 456 
 457                else if arg = "-phys_page_length" | arg = "-ppl"
 458                then pci.phys_page_length = GETNUM ();
 459 
 460                else if arg = "-stop" | arg = "-sp"
 461                then
 462                   do;                             /* pause after each page */
 463                      sws.pause_after_page = "1"b;
 464                      sws.pause_before_print = "1"b;
 465                   end;
 466 
 467                else if arg = "-wait" | arg = "-wt"
 468                then sws.pause_before_print = "1"b;
 469 
 470                else if arg = "-header" | arg = "-he"
 471                then
 472                   do;
 473                      sws.want_heading = "1"b;
 474                      sws.no_heading = "0"b;
 475                   end;
 476 
 477                else if arg = "-no_header" | arg = "-nhe"
 478                then sws.no_heading = "1"b;
 479 
 480                else if arg = "-no_archive" | arg = "-nac"
 481                then sws.dont_want_archive = "1"b;
 482 
 483                else if arg = "-archive" | arg = "-ac"
 484                then sws.dont_want_archive = "0"b;
 485 
 486                else if arg = "-no_vertsp"
 487                then sws.no_vertsp = "1"b;
 488 
 489                else if arg = "-vertsp"
 490                then sws.no_vertsp = "0"b;
 491 
 492                else if arg = "-match"
 493                then
 494                   do;
 495                      if iarg >= nargs
 496                      then goto miss_arg;
 497 
 498                      iarg = iarg + 1;
 499                      match_arg_count = match_arg_count + 1;
 500                   end;
 501 
 502                else if arg = "-ex" | arg = "-exclude"
 503                then
 504                   do;
 505                      if iarg >= nargs
 506                      then goto miss_arg;
 507 
 508                      iarg = iarg + 1;
 509                      exclude_arg_count = exclude_arg_count + 1;
 510                   end;
 511 
 512                else if arg = "-number" | arg = "-nb"
 513                then sws.want_line_numbers = "1"b;
 514 
 515                else if arg = "-chase"
 516                then star_sel = star_ALL_ENTRIES;
 517 
 518                else if arg = "-no_chase"
 519                then star_sel = star_BRANCHES_ONLY;
 520 
 521                else if arg = "-output_switch" | arg = "-osw"
 522                then
 523                   do;
 524                      iarg = iarg + 1;
 525                      call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
 526                      if error_code ^= 0
 527                      then goto ARG_READ_ERR;
 528 
 529                      call iox_$look_iocb (arg, out_switch, error_code);
 530                      if error_code ^= 0
 531                      then
 532                         do;
 533                            call com_err_ (error_code, "print",
 534                                 "Looking for output switch ^a", arg);
 535                            goto RETURN;
 536                         end;
 537                      switch_name = arg;
 538                   end;
 539 
 540                else
 541                   do;                             /* illegal */
 542                      error_code = error_table_$badopt;
 543 ARG_ERR:
 544                      call com_err_ (error_code, "print", "^a", arg);
 545                      return;
 546                   end;
 547             end;
 548       end;
 549 
 550 /* Control arguments are processed */
 551 
 552       if input_path_count = 0
 553       then
 554          do;
 555             call com_err_ (error_table_$noarg, "print", "No pathname given.");
 556             return;
 557          end;
 558 
 559       if (switch_name ^= "user_output")
 560            & (sws.pause_before_print | sws.pause_after_page)
 561       then                                        /* Can't give -stop or */
 562          do;                                      /* -wait with -osw */
 563             call com_err_ (error_table_$inconsistent, "print",
 564                  "-output_switch cannot be used with ^[-stop^;-wait^].",
 565                  sws.pause_after_page);
 566             return;
 567          end;
 568 
 569       if (sws.to_page_given | sws.from_page_given)
 570            & (sws.from_line_given | sws.to_line_given)
 571       then
 572          do;
 573             call com_err_ (error_table_$inconsistent, "print",
 574                  "Page and line specifiers cannot be used together.");
 575             return;
 576          end;
 577 
 578       if sws.from_line_given & sws.last_given
 579       then
 580          do;
 581             call com_err_ (error_table_$inconsistent, "print",
 582                  "-from and -last cannot be used together.");
 583             return;
 584          end;
 585 
 586       if sws.to_line_given & sws.from_line_given & to_line < from_line
 587            & from_regexpr_len + to_regexpr_len = 0/* but no REs in the range */
 588       then
 589          do;
 590             call com_err_ (error_table_$inconsistent, "print",
 591                  "-from ^d > -to ^d", from_line, to_line);
 592             return;
 593          end;
 594 
 595       if sws.from_page_given & sws.to_page_given & to_page < from_page
 596       then
 597          do;
 598             call com_err_ (error_table_$inconsistent, "print",
 599                  "-from_page ^d > -to_page ^d", from_page, to_page);
 600             return;
 601          end;
 602 
 603       if right_col < left_col
 604       then
 605          do;
 606             call com_err_ (error_table_$inconsistent, "print",
 607                  "-left_col ^d > -right_col ^d", left_col, right_col);
 608             return;
 609          end;
 610 
 611       if pci.phys_line_length < 5                 /* prt_conv_ cannot handle length < 5. */
 612       then                                        /* It gives fatal process errors when  */
 613          do;                                      /* attempting to process HT char. */
 614             call com_err_ (0, "print",
 615                  "Implementation restriction: -line_length must be greater than 4."
 616                  );
 617             return;
 618          end;
 619 
 620       sws.check_lines = match_arg_count > 0 | exclude_arg_count > 0;
 621 
 622       sws.paging =
 623            (pci.page_length ^= 0) | (pci.phys_page_length ^= 0)
 624            | sws.from_page_given | sws.to_page_given;
 625 
 626       sws.print_quick_way =
 627            (left_col <= 1) & (right_col = MAX_BUFFER_LTH)
 628            & (pci.phys_line_length = MAX_BUFFER_LTH) & (^sws.paging)
 629            & (mod (indentation, 10) = 0) & (^sws.no_vertsp);
 630 
 631       sws.one_iox_call =
 632            (forcount = 0) & ^sws.from_page_given & ^sws.to_page_given
 633            & (indentation = 0) & ^sws.pause_after_page & ^sws.no_vertsp
 634            & ^sws.from_line_given & ^sws.to_line_given & ^sws.last_given
 635            & ^sws.check_lines & ^sws.want_line_numbers;
 636 
 637       output_buffer_size = min (pci.phys_line_length, MAX_BUFFER_LTH);
 638 
 639       if right_col = MAX_BUFFER_LTH
 640       then right_col = output_buffer_size;
 641 
 642       if pci.phys_line_length = MAX_BUFFER_LTH
 643       then pci.phys_line_length = output_buffer_size;
 644 
 645       pci.rmarg = output_buffer_size;
 646 
 647       if pci.page_length = 0
 648       then pci.page_length = 131071;
 649 
 650       if pci.phys_page_length = 0
 651       then pci.phys_page_length = 66;
 652 
 653       if input_path_count = 1 & ^sws.had_an_arg   /* old way? */
 654       then sws.want_heading, sws.print_trailing_nls = "1"b;
 655 
 656       else if input_path_count > 1
 657       then sws.want_heading = "1"b;               /* default to head if many segs */
 658 
 659       if sws.no_heading
 660       then sws.want_heading = "0"b;               /* .. but may over-ride */
 661 
 662       match_arg_count = max (match_arg_count, 1); /* Illegal PL/I to have match_arg_count = 0 */
 663       exclude_arg_count = max (exclude_arg_count, 1);
 664                                                   /* .. anything to make Monte happy */
 665 %page (2);
 666 /* ------------------------------------------------------- */
 667 
 668 GET_FROM_TO:
 669    proc (bv_had, bv_regexpr_ptr, bv_regexpr_len, bv_line);
 670 
 671       dcl bv_had                 bit (1),
 672           bv_regexpr_ptr         ptr,
 673           bv_regexpr_len         fixed bin (21),
 674           bv_line                fixed bin;
 675 
 676       dcl range_arg              char (6) var;
 677 
 678       if iarg >= nargs                            /* nothing to look at? */
 679       then goto miss_arg;
 680 
 681       range_arg = arg;
 682       iarg = iarg + 1;
 683 
 684       call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
 685       if error_code ^= 0
 686       then goto ARG_READ_ERR;
 687 
 688       junk = cv_dec_check_ (arg, error_code);
 689 
 690       if bv_had                                   /* if we have already had */
 691       then
 692          do;                                      /* one of these */
 693             call com_err_ (error_table_$inconsistent, "print",
 694                  "Only one line range is allowed. ^a ^[^i^;^s^a^]", range_arg,
 695                  (error_code ^= 0), junk, arg);
 696             goto RETURN;
 697          end;
 698 
 699       bv_had = "1"b;                              /* well, we have one one */
 700 
 701       if arg_len >= 2 &                           /* check for /RE/ */
 702            index (arg, "/") = 1 & index (reverse (arg), "/") = 1
 703       then
 704          do;
 705             if arg_len = 2
 706             then error_code = error_table_$regexp_undefined;
 707             else call search_file_$silent (arg_ptr, 2, arg_len - 2, arg_ptr, 1,
 708                       arg_len, 0, 0, error_code);
 709             if error_code ^= 0 & error_code ^= error_table_$nomatch
 710             then
 711                do;
 712                   call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
 713                   goto RETURN;
 714                end;
 715 
 716             if arg_len > LONGEST_SEARCH_FILE_REXP + 2
 717             then                                  /* too long? */
 718                do;
 719                   call com_err_ (0, "print",
 720                        "Regular expressions may not be longer than ^d characters. ^/^-^a",
 721                        LONGEST_SEARCH_FILE_REXP + 2, arg);
 722                   goto RETURN;
 723                end;
 724 
 725             bv_regexpr_ptr = arg_ptr;
 726             bv_regexpr_len = arg_len - 2;
 727          end;
 728 
 729       else
 730          do;
 731             bv_line = cv_dec_check_ (arg, error_code);
 732             if error_code ^= 0 | bv_line < 1
 733             then
 734                do;
 735                   error_code = error_table_$bad_conversion;
 736 ARG_OPERAND_ERR:
 737                   call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
 738                   go to RETURN;
 739                end;
 740          end;
 741 
 742       return;
 743 
 744 /* ------------------------------------------------------- */
 745 
 746 GETNUM:
 747    entry () returns (fixed bin);
 748 
 749       dcl answer                 fixed bin;
 750 
 751       range_arg = arg;
 752       iarg = iarg + 1;                            /* yes */
 753       call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
 754       if error_code ^= 0
 755       then goto ARG_READ_ERR;
 756 
 757       answer = cv_dec_check_ (arg, error_code);
 758       if error_code ^= 0 | answer < 1
 759       then
 760          do;
 761             error_code = error_table_$bad_conversion;
 762             goto ARG_OPERAND_ERR;
 763          end;
 764       return (answer);
 765 
 766    end GET_FROM_TO;
 767 %page;
 768 /* Make a second pass over the arguments and store operands of -match & -exclude */
 769 
 770       begin;                                      /* needed because of adjustable arrays */
 771 
 772          dcl arg_token              char (6) var;
 773          dcl star_area              area based (star_area_ptr);
 774          dcl star_area_ptr          ptr;
 775          dcl star_entry_array       (star_entry_count) fixed bin
 776                                     based (star_entry_array_ptr);
 777          dcl star_entry_array_ptr   ptr;
 778          dcl match_string_ptr       (match_arg_count) ptr;
 779          dcl match_string_len       (match_arg_count) fixed bin (21);
 780          dcl match_string_count     fixed bin;
 781          dcl exclude_string_ptr     (exclude_arg_count) ptr;
 782          dcl exclude_string_len     (exclude_arg_count) fixed bin (21);
 783          dcl exclude_string_count   fixed bin;
 784          dcl ever_printed           bit (1);      /* global this command */
 785          dcl ever_had_err           bit (1);
 786          dcl ever_found_from        bit (1);
 787          dcl ever_found_page        bit (1);
 788          dcl seg_ptr                ptr;          /* -> msf component */
 789          dcl FCB_ptr                ptr;          /* -> FCB for msf */
 790          dcl had_err                bit (1);
 791          dcl dir_name               char (168);   /* directory name */
 792          dcl entry_name             char (32);
 793          dcl archive_element        char (32);
 794          dcl entry_star_type        fixed bin (35);
 795          dcl archive_element_star_type
 796                                     fixed bin (35);
 797          dcl archive_elements_found bit (1);
 798          dcl star_entry_array_index fixed bin;
 799          dcl star_entry_name        char (32);
 800 
 801          ever_printed, ever_had_err, ever_found_from, ever_found_page = "0"b;
 802          match_string_count, exclude_string_count = 0;
 803 
 804          if sws.check_lines
 805          then
 806             do iarg = 1 to nargs;
 807                call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
 808                     arg_list_ptr);
 809                if error_code ^= 0
 810                then goto ARG_READ_ERR;
 811 
 812                if arg = "-match"
 813                then
 814                   do;
 815                      iarg = iarg + 1;
 816                      call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
 817                           arg_list_ptr);
 818                      if error_code ^= 0
 819                      then goto ARG_READ_ERR;
 820 
 821                      if arg_len >= 2 &            /* check for /RE/ */
 822                           index (arg, "/") = 1 & index (reverse (arg), "/") = 1
 823                      then
 824                         do;
 825 
 826                            if arg_len = 2
 827                            then c = error_table_$regexp_undefined;
 828                            else call search_file_$silent (arg_ptr, 2,
 829                                      arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
 830                            if c ^= 0 & c ^= error_table_$nomatch
 831                            then
 832                               do;
 833                                  call com_err_ (c, "print", "-match ^a", arg);
 834                                  goto RETURN;
 835                               end;
 836                         end;
 837 
 838                      match_string_count = match_string_count + 1;
 839                      match_string_ptr (match_string_count) = arg_ptr;
 840                      match_string_len (match_string_count) = arg_len;
 841                   end;
 842 
 843                else if arg = "-ex" | arg = "-exclude"
 844                then
 845                   do;
 846                      arg_token = arg;
 847                      iarg = iarg + 1;
 848                      call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
 849                           arg_list_ptr);
 850                      if error_code ^= 0
 851                      then goto ARG_READ_ERR;
 852 
 853                      if arg_len >= 2 &            /* check for RE */
 854                           index (arg, "/") = 1 & index (reverse (arg), "/") = 1
 855                      then
 856                         do;
 857 
 858                            if arg_len = 2
 859                            then c = error_table_$regexp_undefined;
 860                            else call search_file_$silent (arg_ptr, 2,
 861                                      arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
 862                            if c ^= 0 & c ^= error_table_$nomatch
 863                            then
 864                               do;
 865                                  call com_err_ (c, "print", "^a ^a", arg_token,
 866                                       arg);
 867                                  goto RETURN;
 868                               end;
 869                         end;
 870 
 871                      exclude_string_count = exclude_string_count + 1;
 872                      exclude_string_ptr (exclude_string_count) = arg_ptr;
 873                      exclude_string_len (exclude_string_count) = arg_len;
 874                   end;                            /**/
 875 
 876                else if arg = "-name" | arg = "-nm"/* NAME can also look like a ctlarg */
 877                then iarg = iarg + 1;
 878             end;
 879 
 880          star_area_ptr = get_system_free_area_ ();
 881          star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr,
 882               FCB_ptr = null;
 883 
 884          on cleanup call CLEANER;
 885 
 886          input_path_count = 0;
 887 
 888 /* Make third pass over arguments to print each file named. */
 889 
 890          do iarg = 1 to nargs;
 891             had_err = "0"b;
 892             call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
 893                  arg_list_ptr);
 894             if error_code ^= 0
 895             then goto ARG_READ_ERR;
 896 
 897             junk = cv_dec_check_ (arg, error_code);
 898             if error_code = 0 & input_path_count > 0
 899             then ;                                /* ignore numeric args */
 900 
 901             else if index (arg, "-") = 1
 902             then
 903                do;                                /* skip other ctls */
 904                   if arg = "-name" | arg = "-nm"
 905                   then
 906                      do;
 907                         iarg = iarg + 1;
 908                         call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len,
 909                              error_code, arg_list_ptr);
 910                         if error_code ^= 0
 911                         then goto ARG_READ_ERR;
 912 
 913                         goto segname;
 914                      end;
 915 
 916                   else if arg = "-from" | arg = "-fm" | arg = "-to"
 917                        | arg = "-for" | arg = "-from_page" | arg = "-to_page"
 918                        | arg = "-indent" | arg = "-ind" | arg = "-in"
 919                        | arg = "-left_col" | arg = "-lc" | arg = "-right_col"
 920                        | arg = "-rc" | arg = "-line_length" | arg = "-ll"
 921                        | arg = "-page_length" | arg = "-pl"
 922                        | arg = "-phys_page_length" | arg = "-ppl"
 923                        | arg = "-match" | arg = "-exclude" | arg = "-ex"
 924                        | arg = "-output_switch" | arg = "-osw" | arg = "-last"
 925                        | arg = "-lt"
 926                   then iarg = iarg + 1;
 927                end;
 928 
 929             else
 930                do;                                /* non-ctl arg */
 931 segname:
 932                   call expand_pathname_$component (arg, dir_name, entry_name,
 933                        archive_element, error_code);
 934                   if error_code ^= 0
 935                   then goto ARG_ERR;
 936 
 937                   input_path_count = input_path_count + 1;
 938 
 939                   call check_star_name_$entry (entry_name, entry_star_type);
 940 
 941                   if entry_star_type ^= type.NOSTAR
 942                        & entry_star_type ^= type.STAR
 943                        & entry_star_type ^= type.STARSTAR
 944                   then
 945                      do;
 946                         had_err = "1"b;
 947                         call com_err_ (entry_star_type, "print", "^a",
 948                              entry_name);
 949                      end;
 950 
 951                   else
 952                      do;
 953                         if archive_element = ""
 954                         then archive_element_star_type = type.NOSTAR;
 955                         else call check_star_name_$entry (archive_element,
 956                                   archive_element_star_type);
 957 
 958                         if archive_element_star_type ^= type.NOSTAR
 959                              & archive_element_star_type ^= type.STAR
 960                              & archive_element_star_type ^= type.STARSTAR
 961                         then
 962                            do;
 963                               had_err = "1"b;
 964                               call com_err_ (archive_element_star_type, "print",
 965                                    "^a", archive_element);
 966                            end;
 967 
 968                         else
 969                            do;
 970                               archive_elements_found = "0"b;
 971 
 972                               if entry_star_type = type.NOSTAR
 973                               then                /* No stars */
 974                                    call PRINT_ONE_ENTRYNAME (dir_name,
 975                                         entry_name, archive_element,
 976                                         star_SEGMENT);
 977 
 978                               else
 979                                  do;              /* Has stars */
 980                                     call hcs_$star_ (dir_name, entry_name,
 981                                          star_sel, star_area_ptr,
 982                                          star_entry_count, star_entry_ptr,
 983                                          star_names_ptr, error_code);
 984                                     if error_code ^= 0
 985                                     then
 986                                        do;
 987                                           call com_err_ (error_code, "print",
 988                                                "^a",
 989                                                pathname_ (dir_name, entry_name))
 990                                                ;
 991                                           had_err = "1"b;
 992                                        end;
 993 
 994                                     else
 995                                        do;        /* Found some */
 996                                           allocate star_entry_array
 997                                                set (star_entry_array_ptr)
 998                                                in (star_area);
 999                                                   /* print starname segs in alpha order */
1000                                           do star_entry_array_index = 1
1001                                                to star_entry_count;
1002                                              star_entry_array (
1003                                                   star_entry_array_index) =
1004                                                   star_entry_array_index;
1005                                           end;
1006 
1007                                           call SORT_STAR_ARRAY;
1008 
1009                                           do star_entry_array_index = 1
1010                                                to star_entry_count;
1011                                              star_entry_name =
1012                                                   star_names (
1013                                                   star_entries (
1014                                                   star_entry_array (
1015                                                   star_entry_array_index))
1016                                                   .nindex);
1017                                              call PRINT_ONE_ENTRYNAME (dir_name,
1018                                                   star_entry_name,
1019                                                   archive_element,
1020                                                   (
1021                                                   star_entries (
1022                                                   star_entry_array (
1023                                                   star_entry_array_index)).type)
1024                                                   );
1025                                           end;
1026                                        end;
1027 
1028                                     call CLEANER; /* Free storage */
1029                                  end;
1030                            end;
1031                      end;
1032 
1033                   if ^had_err & archive_element ^= "" & ^archive_elements_found
1034                   then
1035                      do;
1036                         had_err = "1"b;           /* fix bug for TR number 20687 */
1037                         error_code = error_table_$no_component;
1038                                                   /* end of fixing bug */
1039                         call com_err_ (error_code, "print", "^a",
1040                              pathname_$component (dir_name, entry_name,
1041                              archive_element));
1042                      end;
1043                end;
1044 
1045             if had_err
1046             then ever_had_err = "1"b;
1047          end;
1048 
1049          if ^ever_printed & ^ever_had_err
1050          then
1051             do;                                   /* gotta tell him something for his dime */
1052                if sws.from_line_given & ^ever_found_from & ^sws.last_given
1053                then if from_regexpr_len > 0
1054                     then call com_err_ (0, "print", "^a not matched.",
1055                               from_regexpr);
1056                     else call com_err_ (0, "print", "Line ^d not found.",
1057                               from_line);
1058 
1059                else if sws.from_page_given & ^ever_found_page
1060                then call com_err_ (0, "print", "Page ^d not found.", from_page);
1061 
1062                else call com_err_ (0, "print", "No lines selected.");
1063             end;
1064 
1065          else if sws.print_trailing_nls & ^ever_had_err
1066          then call ioa_$ioa_switch (out_switch, "^/");
1067 
1068 
1069 /*         return;                                /* Normal program exit (from inside begin block) */
1070 ^L
1071 /* ------------------------------------------------------- */
1072 
1073 SORT_STAR_ARRAY:
1074    proc;
1075 
1076       dcl d                      fixed bin,
1077           swap                   bit (1),
1078           t                      fixed bin;
1079 
1080       d = star_entry_count;
1081       do while (d > 1);
1082          d = divide (d + 1, 2, 17, 0);
1083          swap = "1"b;
1084          do while (swap);
1085             swap = "0"b;
1086             do star_entry_array_index = 1 to star_entry_count - d;
1087                if star_names (
1088                     star_entries (star_entry_array (star_entry_array_index))
1089                     .nindex)
1090                     >
1091                     star_names (
1092                     star_entries (star_entry_array (star_entry_array_index + d))
1093                     .nindex)
1094                then
1095                   do;
1096                      swap = "1"b;
1097                      t = star_entry_array (star_entry_array_index);
1098                      star_entry_array (star_entry_array_index) =
1099                           star_entry_array (star_entry_array_index + d);
1100                      star_entry_array (star_entry_array_index + d) = t;
1101                   end;
1102             end;
1103          end;
1104       end;
1105 
1106    end SORT_STAR_ARRAY;
1107 %page;
1108 CLEANER:
1109    proc;
1110 
1111       if star_names_ptr ^= null
1112       then free star_names in (star_area);
1113 
1114       if star_entry_ptr ^= null
1115       then free star_entries in (star_area);
1116 
1117       if star_entry_array_ptr ^= null
1118       then free star_entry_array in (star_area);
1119 
1120       if FCB_ptr ^= null
1121       then call msf_manager_$close (FCB_ptr);
1122 
1123       else if seg_ptr ^= null
1124       then call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));
1125 
1126       star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr, FCB_ptr =
1127            null;
1128 
1129    end CLEANER;
1130 %page (2);
1131 /* ------------------------------------------------------- */
1132 
1133 /* This subroutine handles the file system stuff.
1134    It knows how to handle MSFs and archives. */
1135 
1136 PRINT_ONE_ENTRYNAME:
1137    proc (dirname, ename, arch_elem_wanted, en_type);
1138 
1139       dcl dirname                char (168);      /* (arg) directory */
1140       dcl ename                  char (32);       /* (arg) entry */
1141       dcl arch_elem_wanted       char (32);       /* (arg) element */
1142       dcl en_type                fixed bin (2) uns;
1143                                                   /* (arg) whether to bitch */
1144 
1145       dcl 1 sws1,                                 /* switch bits */
1146             2 doing_archive      bit (1),         /* TRUE if doing an archive */
1147             2 found_first        bit (1),         /* flags for line select */
1148             2 found_last         bit (1),
1149             2 found_to           bit (1),
1150             2 last_msf_component bit (1),         /* TRUE for last MSF component, */
1151                                                   /* and all segs & archive elements */
1152             2 more_in_archive    bit (1),         /* TRUE if archive scanning */
1153             2 print_heading_first
1154                                  bit (1),         /* TRUE if printing heading */
1155             2 stop_after_first_elem
1156                                  bit (1),         /* TRUE if doing nonstar archive elem */
1157             2 paused             bit (1);         /* TRUE if we paused at the beginning of this entry */
1158 
1159       dcl 1 ACI                  like archive_component_info aligned;
1160       dcl (
1161           ARCH_COMP              init (3),
1162           MSF_COMP               init (2),
1163           SEG                    init (1)
1164           )                      fixed bin int static options (constant);
1165       dcl bitc                   fixed bin (24);  /* bit count */
1166       dcl comp_ptr               ptr;             /* if print archive */
1167                                                   /* MSF part or archive element */
1168       dcl component              char (seg_charct) based (comp_ptr);
1169       dcl ec1                    fixed bin (35);  /* err code */
1170       dcl entry_type             fixed bin (2);   /* arg to status */
1171       dcl error_code             fixed bin (35);  /* err code */
1172       dcl indent_string          char (indentation) init ("");
1173       dcl last_line_number       fixed bin;       /* number of input line last output. */
1174       dcl line_count             fixed bin;
1175       dcl last_slew              char (1);
1176       dcl line_length            fixed bin (21);  /* length of one line */
1177       dcl line_number            fixed bin;       /* line number to print */
1178       dcl msf_component          fixed bin;       /* component number */
1179       dcl msf_component_count    fixed bin (24);  /* highest component */
1180       dcl output_buffer          char (MAX_BUFFER_LTH);
1181       dcl output_buffer_ch       (MAX_BUFFER_LTH) char (1)
1182                                  defined output_buffer;
1183       dcl output_buffer_length   fixed bin (21);  /* amount currently used */
1184       dcl page_number            fixed bin;       /* current page number */
1185       dcl seg_charct             fixed bin (21);  /* char count of current seg */
1186       dcl seg_type               fixed bin;       /* type of entry passed to PRINT_ONE_SEG */
1187                                                   /*   can be: SEG, MSF_COMP, ARCH_COMP */
1188       dcl segment                char (seg_charct) based (seg_ptr);
1189       dcl slew                   char (1);        /* vertical motion char */
1190       dcl vt_length              fixed bin (21);  /* length of line up to next VT */
1191       dcl wanted_elem            char (32);
1192 
1193       call iox_$control (out_switch, "reset_more", null (), (0));
1194                                                   /* for video system users ... */
1195 
1196       last_line_number = 0;
1197       last_slew = NUL;
1198       sws1.doing_archive, sws1.found_to, sws1.paused = "0"b;
1199       sws1.last_msf_component = "1"b;
1200 
1201       call initiate_file_ (dirname, ename, R_ACCESS, seg_ptr, bitc, error_code);
1202 
1203       if seg_ptr = null
1204       then
1205          do;                                      /* Can't initiate: missing? or directory/msf? */
1206             call hcs_$status_minf (dirname, ename, 1, entry_type,
1207                  msf_component_count, ec1);
1208             if ec1 ^= 0
1209             then
1210                do;
1211                   if en_type = star_LINK
1212                   then return;                    /* don't complain about missing link target if * convention */
1213 
1214                   else
1215                      do;
1216                         error_code = ec1;
1217 abort:
1218                         call com_err_ (error_code, "print", "^a",
1219                              pathname_ (dirname, ename));
1220                         had_err = "1"b;
1221                         return;
1222                      end;
1223                end;
1224 
1225             if entry_type ^= star_DIRECTORY
1226             then goto abort;                      /* A seg we can't initiate */
1227 
1228 /* Directory */
1229 
1230             if msf_component_count < 1
1231             then
1232                do;                                /* really dir */
1233                   if en_type ^= star_SEGMENT
1234                   then return;                    /* quiet if star convention */
1235                   error_code = error_table_$dirseg;
1236                                                   /* don't print dirs */
1237                   goto abort;                     /* .. just fuss */
1238                end;
1239 
1240 /* Multisegment file case */
1241 
1242             else
1243                do;
1244                   seg_type = MSF_COMP;
1245                   call msf_manager_$open (dirname, ename, FCB_ptr, error_code);
1246                   if error_code ^= 0
1247                   then goto abort;
1248 
1249                   call RESET;
1250 
1251                   if sws.last_given               /* for -last */
1252                   then
1253                      do;
1254                         from_line = 0;
1255 
1256                         if sws.to_line_given & to_regexpr_len = 0
1257                         then from_line = max (to_line - last_count + 1, 1);
1258                                                   /* count lines in the MSF */
1259                         else
1260                            do;
1261                               do msf_component = 0
1262                                    to msf_component_count - 1
1263                                    while (^sws1.found_to);
1264                                  call msf_manager_$get_ptr (FCB_ptr,
1265                                       msf_component, "0"b, comp_ptr, bitc,
1266                                       error_code);
1267                                  if error_code ^= 0
1268                                  then goto MSF_err;
1269 
1270                                  seg_charct = divide (bitc + 8, 9, 21, 0);
1271 
1272                                  if seg_charct > 0
1273                                  then
1274                                     do;
1275                                        call COUNT_LINES (component,
1276                                             msf_component
1277                                             = msf_component_count - 1,
1278                                             line_count, sws1.found_to);
1279                                        from_line = from_line + line_count;
1280                                     end;
1281                               end;
1282                               from_line = max (from_line - last_count + 1, 1);
1283                            end;
1284                      end;
1285 
1286                   line_number = 1;
1287                   sws1.paused = "0"b;
1288 
1289                   do msf_component = 0 to msf_component_count - 1
1290                        while (^sws1.found_last);
1291 
1292                      call msf_manager_$get_ptr (FCB_ptr, msf_component, "0"b,
1293                           comp_ptr, bitc, error_code);
1294                      if error_code ^= 0
1295                      then goto MSF_err;
1296 
1297                      sws1.last_msf_component =
1298                           (msf_component = msf_component_count - 1);
1299                      seg_charct = divide (bitc + 8, 9, 21, 0);
1300                      if seg_charct = 0
1301                      then error_code = error_table_$zero_length_seg;
1302                                                   /* Actually print component */
1303                      else call PRINT_ONE_SEG (component);
1304                                                   /* dont count nnl lines twice */
1305                      if ^sws1.last_msf_component
1306                      then if substr (component, seg_charct, 1) ^= NL
1307                           then line_number = line_number - 1;
1308                   end;
1309 
1310 MSF_err:
1311                   if error_code ^= 0
1312                   then
1313                      do;
1314                         had_err = "1"b;
1315                         call com_err_ (error_code, "print",
1316                              "Component ^d of multisegment file ^a.",
1317                              msf_component, pathname_ (dirname, ename));
1318                      end;
1319 
1320                   call msf_manager_$close (FCB_ptr);
1321                end;                               /* of MSF */
1322             return;                               /* exit from MSF case */
1323          end;                                     /* seg_ptr = null */
1324 
1325 /* Segment case */
1326 
1327       error_code = 0;
1328       sws1.doing_archive =
1329            arch_elem_wanted ^= ""
1330            | (^sws.dont_want_archive
1331            & index (reverse (rtrim (ename)), reverse (".archive")) = 1);
1332 
1333 /* Archive case */
1334 
1335       if sws1.doing_archive
1336       then
1337          do;
1338             seg_type = ARCH_COMP;
1339             stop_after_first_elem = (archive_element_star_type = type.NOSTAR);
1340 
1341             if arch_elem_wanted = ""
1342             then
1343                do;
1344                   wanted_elem = "**";             /* print whole archive? */
1345                   stop_after_first_elem = "0"b;
1346                end;
1347             else wanted_elem = arch_elem_wanted;
1348 
1349             comp_ptr = null;
1350             ACI.version = ARCHIVE_COMPONENT_INFO_VERSION_1;
1351             sws1.more_in_archive = "1"b;
1352 
1353             do while (sws1.more_in_archive & error_code = 0);
1354                call archive_$next_component_info (seg_ptr, bitc, comp_ptr,
1355                     addr (ACI), error_code);
1356                if error_code = 0
1357                then
1358                   do;
1359                      if comp_ptr = null
1360                      then sws1.more_in_archive = "0"b;
1361 
1362                      else
1363                         do;
1364                            call match_star_name_ (ACI.name, wanted_elem,
1365                                 error_code);
1366                            if error_code ^= 0
1367                            then error_code = 0;
1368                            else
1369                               do;
1370                                  call RESET;
1371 
1372                                  seg_charct =
1373                                       divide (ACI.comp_bc + 8, 9, 21, 0);
1374                                  if seg_charct = 0
1375                                  then
1376                                     do;           /* archive wont let this happen, but ... */
1377                                        call com_err_ (
1378                                             error_table_$zero_length_seg,
1379                                             "print", "^a",
1380                                             pathname_$component (dirname, ename,
1381                                             ACI.name));
1382                                        had_err = "1"b;
1383                                     end;
1384 
1385                                  else
1386                                     do;
1387                                        archive_elements_found = "1"b;
1388 
1389                                        if sws.last_given
1390                                                   /* for -last */
1391                                        then
1392                                           do;
1393                                              if sws.to_line_given
1394                                                   & to_regexpr_len = 0
1395                                              then from_line =
1396                                                        max (to_line
1397                                                        - last_count + 1, 1);
1398                                              else
1399                                                 do;
1400                                                    call COUNT_LINES (component,
1401                                                         "1"b, from_line,
1402                                                         sws1.found_to);
1403                                                    from_line =
1404                                                         max (from_line
1405                                                         - last_count + 1, 1);
1406                                                 end;
1407                                           end;
1408 
1409                                        line_number = 1;
1410                                        sws1.paused = "0"b;
1411                                                   /* fixed bug for TR number 18887 */
1412                                        call iox_$control (out_switch,
1413                                             "reset_more", null (), (0));
1414                                                   /* for video system users ... */
1415                                                   /* end of fixing bug */
1416 
1417                                        call PRINT_ONE_SEG (component);
1418                                                   /* Terminate loop */
1419                                        if stop_after_first_elem
1420                                        then sws1.more_in_archive = "0"b;
1421                                     end;
1422                               end;
1423                         end;
1424                   end;                            /* error_code =  0 */
1425             end;                                  /* loop */
1426          end;                                     /* of archive case */
1427 
1428 /* Single segment file case. */
1429 
1430       else
1431          do;
1432             seg_type = SEG;
1433             call RESET;
1434 
1435             seg_charct = divide (bitc + 8, 9, 21, 0);
1436             if seg_charct ^= 0
1437             then
1438                do;
1439                   if sws.last_given               /* for -last */
1440                   then
1441                      do;
1442                         if sws.to_line_given & to_regexpr_len = 0
1443                         then from_line = max (to_line - last_count + 1, 1);
1444                         else
1445                            do;
1446                               call COUNT_LINES (segment, "1"b, from_line,
1447                                    sws1.found_to);
1448                               from_line = max (from_line - last_count + 1, 1);
1449                            end;
1450                      end;
1451 
1452                   line_number = 1;
1453                   sws1.paused = "0"b;
1454 
1455                   call PRINT_ONE_SEG (segment);
1456                end;
1457 
1458             else error_code = error_table_$zero_length_seg;
1459          end;                                     /* of ssf case */
1460 
1461       call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));
1462                                                   /* done with segment */
1463       seg_ptr = null;
1464       if error_code ^= 0
1465       then
1466          do;
1467             had_err = "1"b;
1468             call com_err_ (error_code, "print", "^a",
1469                  pathname_ (dirname, ename));
1470          end;
1471 
1472       return;                                     /* Normal exit from PRINT_ONE_ENTRYNAME */
1473 %page;
1474 /* ------------------------------------------------------- */
1475 
1476 RESET:
1477    proc;
1478 
1479       sws1.print_heading_first = sws.want_heading;/* treat archive elements as single files */
1480                                                   /* clear items not to be carried from one file to next */
1481       pci.level, pci.pos, pci.slew_residue, pci.sav_pos, pci.esc_state,
1482            pci.esc_num = 0;
1483       pci.temp, sws1.found_first, sws1.found_last = "0"b;
1484       page_number, pci.line = 1;
1485       line_count = 0;
1486       slew = NL;
1487    end RESET;
1488 %page;
1489 /* ------------------------------------------------------- */
1490 
1491 COUNT_LINES:                                      /* count lines in a segment */
1492    proc (seg, last_seg, lines, found_to);
1493 
1494 /* PARAMETERS */
1495 
1496       dcl seg                    char (*);
1497       dcl last_seg               bit (1);
1498       dcl lines                  fixed bin;
1499       dcl found_to               bit (1);
1500 
1501 /* LOCAL */
1502 
1503       dcl c                      fixed bin (35),
1504           char_index             fixed bin (21);
1505 
1506       char_index = 0;
1507       lines = 0;
1508 
1509       do while (char_index < seg_charct);
1510          line_length = index (substr (seg, char_index + 1), NL);
1511          if line_length > 0
1512          then lines = lines + 1;
1513          else
1514             do;                                   /* Last line of seg does   */
1515                if last_seg
1516                then                               /* NOT end with NL.  Count */
1517                     lines = lines + 1;            /* it if no more MSF comps.*/
1518                line_length = length (substr (seg, char_index + 1));
1519             end;
1520 
1521          if to_regexpr_len > 0                    /* using regexpr for to? */
1522          then
1523             do;
1524                call search_file_ (to_regexpr_ptr, 2, to_regexpr_len, addr (seg),
1525                     char_index + 1, char_index + line_length, 0, 0, c);
1526                if c = 0
1527                then
1528                   do;
1529                      found_to = "1"b;
1530                      if substr (seg, char_index + line_length, length (NL))
1531                           ^= NL
1532                      then                         /* if last line of segment */
1533                           lines = lines + 1;      /* matches /RE/, but does  */
1534                      return;                      /* not end with NL, count  */
1535                   end;                            /* this line.              */
1536             end;
1537          char_index = char_index + line_length;
1538       end;
1539 
1540    end COUNT_LINES;
1541 %page;
1542 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1543 
1544 /* This subroutine does the actual printing.
1545    It deals with one segment at a time, which may be either an SSF,
1546    one component of a MSF, or an archive element. */
1547 
1548 PRINT_ONE_SEG:
1549    proc (segment);
1550 
1551       dcl segment                char (*);        /* seg to be printed */
1552 
1553       dcl char_index             fixed bin (21);  /* index of last char used */
1554       dcl line_count_this_page   fixed bin;       /* lines per page, for paging */
1555       dcl line_length            fixed bin (21);  /* length of one line */
1556       dcl print_this_line        bit (1);
1557       dcl region_begin           fixed bin (21);  /* char_index at sws1.found_first */
1558       dcl seg_ptr                ptr;             /* -> seg to be printed */
1559       dcl segarray               (seg_charct) char (1) based (seg_ptr);
1560 
1561       seg_ptr = addr (segment);
1562 
1563       char_index, line_count_this_page = 0;
1564 
1565       if (sws.print_quick_way & sws.one_iox_call) /* Print whole segment */
1566       then                                        /* without from/to */
1567 PRINT_QUICK_WAY:                                  /* tests, etc */
1568          do;
1569             if sws.pause_before_print
1570             then call PAUSE;
1571 
1572             call PRINT_HEAD;
1573             call PRINT_STRING (seg_ptr, seg_charct);
1574             ever_printed = "1"b;
1575             return;                               /* Normal exit, easy case */
1576          end PRINT_QUICK_WAY;
1577 
1578 PRINT_SEG:                                        /* loop through lines of */
1579       do while (char_index < seg_charct & ^sws1.found_last);
1580                                                   /* segment, printing those*/
1581                                                   /* that pass tests. */
1582          line_length = index (substr (segment, char_index + 1), NL);
1583          if line_length = 0                       /* no EOL, take the rest */
1584          then line_length = length (substr (segment, char_index + 1));
1585 
1586          call PRINT_ONE_LINE ();
1587          line_number = line_number + 1;
1588 
1589       end PRINT_SEG;
1590 
1591 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
1592 /*                                                                                        */
1593 /* If file doesn't end with a NP character as its very last character, then we must       */
1594 /* output final NP when paging.  This is ONLY done for last component of MSF, not for     */
1595 /* earlier components.                                                                    */
1596 /*                                                                                        */
1597 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
1598 
1599       if (seg_type ^= MSF_COMP | sws1.last_msf_component)
1600            &
1601            ^(pci.line = 1 & pci.pos = 0 & pci.level = 0 & pci.slew_residue = 0)
1602       then                                        /* This tests for file not */
1603          do;                                      /* ending with NP. */
1604 
1605             if pci.pos > 0 | pci.slew_residue = -1
1606             then                                  /* If file doesn't end */
1607                do;                                /* with a NL, NP or VT, */
1608                   slew = NL;                      /* force NL to be present. */
1609                   call SLEW ();
1610                end;
1611 
1612             if sws.paging                         /* When paging, end file */
1613             then                                  /* with a NP char. */
1614                do;
1615                   slew = NP;
1616                   call SLEW ();
1617                end;
1618          end;
1619 
1620       return;                                     /* Normal exit, medium and hard cases */
1621 %page;
1622 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1623 
1624 /* This routine is used if we are printing one line at a time.
1625    It knows how to mess with the insides of the line */
1626 
1627 PRINT_ONE_LINE:
1628    proc;
1629 
1630       print_this_line = "1"b;
1631 
1632       call CHECK_FROM_LINE ();                    /* Check -from/-to line. */
1633       if print_this_line
1634       then call CHECK_TO_LINE ();
1635       if print_this_line
1636       then print_this_line = MATCH_EXCLUDE ();
1637 
1638       if print_this_line
1639       then                                        /* check page boundaries. */
1640            if sws.to_page_given
1641            then if page_number > to_page
1642                 then
1643                    do;
1644                       sws1.found_last = "1"b;
1645                       return;
1646                    end;
1647 
1648       if print_this_line & (page_number >= from_page)
1649       then
1650          do;
1651             if sws.pause_before_print & ^sws1.paused
1652             then
1653                do;
1654                   call PAUSE;
1655                   sws1.paused = "1"b;
1656                end;
1657 
1658             call PRINT_HEAD;                      /* Print heading before 1st line of file. */
1659             ever_found_page = "1"b;
1660             ever_printed = "1"b;
1661          end;
1662       else print_this_line = "0"b;
1663 
1664       if sws.print_quick_way
1665       then
1666          do;
1667             if print_this_line
1668             then call PROCESS_LINE_VIA_IOX (addr (segarray (char_index + 1)),
1669                       line_length);
1670 
1671          end;
1672       else
1673          do;
1674             if ^sws.no_vertsp                     /* prt_conv_ converts VT  */
1675             then                                  /* to some number of NLs. */
1676                do;                                /* In vertsp mode, we     */
1677                   vt_length =                     /* want VT itself to be   */
1678                        index (substr (segment, char_index + 1, line_length), VT)
1679                        ;
1680                   do while (vt_length > 0);       /* output. Special-case VT*/
1681                      call                         /* in this code.          */
1682                           PROCESS_LINE_VIA_PRT_CONV (
1683                           addr (segarray (char_index + 1)), vt_length,
1684                           print_this_line, "0"b, "1"b);
1685                      char_index = char_index + vt_length;
1686                      line_length = line_length - vt_length;
1687                      vt_length =
1688                           index (substr (segment, char_index + 1, line_length),
1689                           VT);
1690                   end;                            /* do while (vt_length) */
1691                end;                               /* if ^sws.no_vertsp */
1692 
1693             call                                  /* Call prt_conv_ on line */
1694                  PROCESS_LINE_VIA_PRT_CONV (addr (segarray (char_index + 1)),
1695                  line_length, print_this_line, "0"b, "0"b);
1696          end;                                     /* else do */
1697 
1698       char_index = char_index + line_length;
1699 
1700       if forcount > 0
1701       then
1702          do;                                      /* forcount and line_count */
1703             if line_count >= forcount
1704             then
1705                do;                                /* must be check here after */
1706                   sws1.found_last = "1"b;         /* printing each line.     */
1707                   seg_charct = char_index + line_length;
1708                end;
1709          end;
1710 
1711    end PRINT_ONE_LINE;
1712 %page;
1713 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1714 
1715 CHECK_FROM_LINE:
1716    proc;
1717 
1718       dcl c                      fixed bin (35);
1719 
1720       region_begin = char_index;
1721       if sws1.found_first
1722       then return;
1723 
1724       if from_regexpr_len > 0
1725       then
1726          do;
1727             call search_file_ (from_regexpr_ptr, 2, from_regexpr_len,
1728                  addr (segment), char_index + 1, char_index + line_length, 0, 0,
1729                  c);
1730             if c = 0
1731             then
1732                do;
1733                   ever_found_from, sws1.found_first = "1"b;
1734                   from_line = line_number;
1735                end;
1736             else print_this_line = "0"b;
1737          end;
1738       else if line_number >= from_line
1739       then ever_found_from, sws1.found_first = "1"b;
1740       else print_this_line = "0"b;
1741 
1742    end CHECK_FROM_LINE;
1743 %page;
1744 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1745 
1746 CHECK_TO_LINE:
1747    proc;
1748 
1749       dcl c                      fixed bin (35);
1750 
1751       if ^sws.to_line_given & (forcount = 0)
1752       then return;
1753 
1754       if to_regexpr_len > 0                       /* need regexpr for to? */
1755       then
1756          do;
1757             call search_file_ (to_regexpr_ptr, 2, to_regexpr_len,
1758                  addr (segment), char_index + 1, char_index + line_length, 0, 0,
1759                  c);
1760             if c = 0
1761             then
1762                do;
1763                   sws1.found_last = "1"b;
1764                   seg_charct = char_index + line_length;
1765                end;
1766          end;
1767 
1768       else if to_line > 0
1769       then
1770          do;
1771             if line_number >= to_line
1772             then
1773                do;
1774                   if substr (segment, char_index + line_length, 1) = NL
1775                   then
1776                      do;
1777                         sws1.found_last = "1"b;
1778                         seg_charct = char_index + line_length;
1779                      end;
1780                end;
1781          end;
1782 
1783    end CHECK_TO_LINE;
1784 %page;
1785 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1786 
1787 LINENO_AND_INDENT:
1788    proc (strike_level, chars_for_line);
1789 
1790       dcl strike_level           fixed bin,
1791           chars_for_line         fixed bin (21);
1792 
1793       if last_slew = ""
1794       then
1795          do;
1796             last_line_number = line_number;
1797             last_slew = slew;
1798             return;
1799          end;
1800 
1801       if sws.want_line_numbers
1802       then if strike_level = 0 & last_slew ^= CR
1803            then if line_number ^= last_line_number
1804                 then call ioa_$ioa_switch_nnl (out_switch, "^8i  ", line_number)
1805                           ;
1806                 else call ioa_$ioa_switch_nnl (out_switch, "^8i+ ", line_number)
1807                           ;
1808            else call ioa_$ioa_switch_nnl (out_switch, "^-");
1809       last_line_number = line_number;
1810       last_slew = slew;
1811 
1812       if indentation > 0 & chars_for_line > 0     /* Indent? */
1813       then call PRINT_STRING (addr (indent_string), indentation);
1814 
1815    end LINENO_AND_INDENT;
1816 %page (2);
1817 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1818 
1819 /*  This subroutine checks if the current line is printable in the presence
1820    of the control args -match and -exclude */
1821 
1822 MATCH_EXCLUDE:
1823    proc returns (bit (1));
1824 
1825       dcl jj                     fixed bin;
1826       dcl c                      fixed bin (35);
1827       dcl srchp                  ptr,
1828           srchl                  fixed bin (21);
1829       dcl srch                   char (srchl) based (srchp);
1830       dcl (matched, excluded)    bit (1);
1831 
1832       if ^sws.check_lines
1833       then return ("1"b);
1834 
1835       matched = "0"b;
1836       do jj = 1 to match_string_count while (^matched);
1837          srchp = match_string_ptr (jj);
1838          srchl = match_string_len (jj);
1839 
1840          if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
1841          then
1842             do;
1843                call search_file_ (srchp, 2, srchl - 2, addr (segment),
1844                     char_index + 1, char_index + line_length, 0, 0, c);
1845                if c = 0
1846                then matched = "1"b;
1847             end;
1848 
1849          else if index (substr (segment, char_index + 1, line_length), srch)
1850               ^= 0
1851          then matched = "1"b;
1852       end;
1853 
1854       if match_string_count > 0 & ^matched
1855       then return ("0"b);
1856 
1857       excluded = "0"b;
1858       do jj = 1 to exclude_string_count;
1859          srchp = exclude_string_ptr (jj);
1860          srchl = exclude_string_len (jj);
1861 
1862          if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
1863          then
1864             do;
1865                call search_file_ (srchp, 2, srchl - 2, addr (segment),
1866                     char_index + 1, char_index + line_length, 0, 0, c);
1867                if c = 0
1868                then excluded = "1"b;
1869             end;
1870 
1871          else if index (substr (segment, char_index + 1, line_length), srch)
1872               ^= 0
1873          then excluded = "1"b;
1874       end;
1875 
1876       return (^excluded);
1877 
1878    end MATCH_EXCLUDE;
1879 %page;
1880 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1881 
1882 PAUSE:
1883    proc;
1884 
1885       dcl buffer                 char (256);
1886 
1887       error_code = error_table_$long_record;
1888       do while (error_code = error_table_$long_record);
1889                                                   /* This call skips one input line: i.e. pauses */
1890          call iox_$get_line (iox_$user_input, addr (buffer), 256, (0),
1891               error_code);
1892       end;
1893 
1894       call iox_$control (iox_$user_input, "resetread", null, (0));
1895 
1896    end PAUSE;
1897 
1898 %page;
1899 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1900 
1901 /* Print the heading. Uglinesses of this output format are for compatibility
1902    with the old print. I don't like them either. */
1903 
1904 PRINT_HEAD:
1905    proc;
1906 
1907       dcl date                   char (64) var,
1908           head_line              char (250),
1909           head_line_len          fixed bin (21);
1910 
1911       if ^sws1.print_heading_first
1912       then return;
1913 
1914       if sws1.doing_archive
1915       then
1916          do;                                      /* New format */
1917             date = date_time_$format ("date_time", ACI.time_modified, "", "");
1918             call ioa_$rsnp ("^/^2-^a::^a^-^a^/", head_line, head_line_len,
1919                  ename, ACI.name, date);
1920          end;
1921 
1922       else
1923          do;
1924             date = date_time_$format ("date_time", clock (), "", "");
1925             call ioa_$rsnp ("^/^2-^a^-^a^2/", head_line, head_line_len, ename,
1926                  date);
1927          end;
1928       if sws.print_quick_way | sws.one_iox_call
1929       then call PRINT_STRING (addr (head_line), head_line_len);
1930       else
1931          do;
1932             call PROCESS_LINE_VIA_PRT_CONV (addr (head_line), head_line_len,
1933                  "1"b, "1"b, "0"b);
1934             line_count = line_count - 1;          /* After printed the heading,  */
1935          end;                                     /* "line_count" must not be    */
1936       sws1.print_heading_first = "0"b;            /* incremented by one. Avoid   */
1937                                                   /* errors error when enters    */
1938    end PRINT_HEAD;                                /* print foo -for N -he -ind N */
1939 %page;
1940 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1941 
1942 PRINT_STRING:
1943    proc (ptr, len);
1944 
1945       dcl ptr                    ptr,
1946           len                    fixed bin (21);
1947 
1948       call iox_$put_chars (out_switch, ptr, len, error_code);
1949       if error_code ^= 0
1950       then
1951          do;
1952             call com_err_ (error_code, "print", "Writing to switch ^a.",
1953                  switch_name);
1954             go to RETURN;
1955          end;
1956 
1957    end PRINT_STRING;
1958 %page;
1959 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
1960 
1961 /* This routine processes line fragments where each       */
1962 /* fragment ends with a NL, VT, NP or CR.  These are the  */
1963 /* slew characters needed to drive proper slew processing.*/
1964 
1965 PROCESS_LINE_VIA_IOX:
1966    proc (line_ptr_parm, line_len_parm);
1967 
1968       dcl line_ptr_parm          ptr,             /* ptr to output line. */
1969           line_len_parm          fixed bin (21);  /* length of output line. */
1970 
1971       dcl end_of_output_line     fixed bin (21);  /* location in line of */
1972                                                   /* VT, NL, or NP char. */
1973 
1974       dcl line_len               fixed bin (21),
1975           line_ptr               ptr,
1976           line                   char (line_len) based (line_ptr),
1977           line_array             (line_len) char (1) based (line_ptr);
1978 
1979       line_ptr = line_ptr_parm;                   /* copy, because we change */
1980       line_len = line_len_parm;                   /* these values.           */
1981 
1982       do while (line_len > 0);
1983          end_of_output_line = search (line, NLCRVTNP);
1984          if end_of_output_line > 0
1985          then
1986             do;
1987                slew = line_array (end_of_output_line);
1988                end_of_output_line = end_of_output_line - 1;
1989             end;                                  /* remove slew char from */
1990                                                   /* end of output line.   */
1991          else
1992             do;
1993                slew = "";
1994                end_of_output_line = length (line);
1995             end;
1996 
1997          ever_found_page = "1"b;
1998          call LINENO_AND_INDENT (0, end_of_output_line);
1999 
2000          if end_of_output_line ^= 0
2001          then call PRINT_STRING (addr (line), end_of_output_line);
2002 
2003          call SLEW ();
2004 
2005          if (end_of_output_line + 1) < line_len   /* not at the end of the line*/
2006          then line_ptr = addr (line_array (end_of_output_line + 2));
2007          line_len = line_len - (end_of_output_line + 1);
2008 
2009       end;
2010 
2011       line_count = line_count + 1;
2012 
2013    end PROCESS_LINE_VIA_IOX;
2014 %page;
2015 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
2016 
2017 /* This routine calls prt_conv_ to process a single line.  It may be called */
2018 /* many times for lines which are overlength or contain overstrikes.        */
2019 /* HTs are converted to SP chars, VT to NLs (unless vertical_tab = "1"b),   */
2020 /* and NP to NLs.  Overstriking is handling by using CR to overlay line     */
2021 /* images atop one another.                                                 */
2022 
2023 PROCESS_LINE_VIA_PRT_CONV:
2024    proc (line_ptr_parm, line_len_parm, print_this_line, header, vertical_tab);
2025 
2026       dcl line_ptr_parm          ptr,             /* ptr to output line. */
2027           line_len_parm          fixed bin (21),  /* length of output line. */
2028           print_this_line        bit (1),         /* on if line passed all */
2029                                                   /* tests for printing      */
2030                                                   /* except -from_page.  We  */
2031                                                   /* do -from_page test here */
2032                                                   /* since line may span     */
2033                                                   /* pages                   */
2034           header                 bit (1),         /* on when printing header */
2035           vertical_tab           bit (1);         /* on when line fragment  */
2036                                                   /* ends with VT, not NL   */
2037 
2038       dcl chars_done             fixed bin (21);  /* number of chars processed from line. */
2039       dcl chars_for_line         fixed bin (21);  /* amount of output buffer to actually print */
2040       dcl chars_to_do            fixed bin (21);  /* number of chars left on page */
2041       dcl (saved_line_length, saved_rmarg)
2042                                  fixed bin;
2043 
2044       dcl line_len               fixed bin (21),
2045           line_ptr               ptr,
2046           line                   char (line_len) based (line_ptr),
2047           line_array             (line_len) char (1) based (line_ptr);
2048 
2049       if header                                   /* When printing header, */
2050       then                                        /* don't honor           */
2051          do;                                      /* -line_length          */
2052             saved_line_length = pci.phys_line_length;
2053             pci.phys_line_length = length (output_buffer);
2054             saved_rmarg = pci.rmarg;
2055             pci.rmarg = length (output_buffer);
2056          end;
2057 
2058       line_ptr = line_ptr_parm;                   /* copy, because we change */
2059       line_len = line_len_parm;                   /* these values.           */
2060 
2061       chars_to_do = length (line);                /* loop, calling prt_conv_ */
2062       do while (chars_to_do > 0 | pci.slew_residue > 0);
2063          line_count_this_page = pci.line;         /* remember line count     */
2064                                                   /* before output. SLEW uses*/
2065                                                   /* this.                   */
2066          call prt_conv_ (addr (line), chars_to_do, addr (output_buffer),
2067               output_buffer_length, addr (pci));
2068          chars_done = length (line) - chars_to_do;
2069 
2070          if chars_done > 0                        /* prevent subcriptrange  */
2071                                                   /* (underflow) condition  */
2072                                                   /* when a line contains   */
2073                                                   /* BACK SPACES characters.*/
2074          then line_ptr = addr (line_array (chars_done));
2075 
2076          slew = output_buffer_ch (output_buffer_length);
2077 
2078          output_buffer_length = output_buffer_length - 1;
2079                                                   /* remove slew char from */
2080                                                   /* end of output line.   */
2081 
2082          if vertical_tab & slew = NL              /* For VT mapped in NL   */
2083          then                                     /* (rather than NP),     */
2084             do;                                   /* change slew to VT and */
2085                slew = VT;                         /* ignore prt_conv_ NLs. */
2086                pci.slew_residue = 0;              /* SLEW proc outputs VT. */
2087             end;
2088 
2089          if header                                /* Ignore -left_col and    */
2090                                                   /* -right_col for header.  */
2091          then chars_for_line = output_buffer_length;
2092          else chars_for_line =
2093                    min (right_col, output_buffer_length) - left_col + 1;
2094 
2095 /* watch for negative character counts */
2096          if chars_for_line < 0
2097          then chars_for_line = 0;
2098 
2099          if print_this_line & (page_number >= from_page)
2100          then                                     /* Do -from_page test, and */
2101             do;                                   /* print line if it passes */
2102                ever_found_page = "1"b;
2103                if ^header
2104                then call LINENO_AND_INDENT (pci.level, chars_for_line);
2105                call PRINT_STRING (addr (output_buffer_ch (left_col)),
2106                     chars_for_line);
2107                call SLEW ();
2108             end;                                  /* if have not done yet    */
2109          if chars_done < line_len                 /* then always moves the   */
2110          then line_ptr = addr (line_array (2));   /* pointer to the NEXT     */
2111          line_len = line_len - chars_done;        /* character in the line.  */
2112                                                   /* Then update line_len by */
2113                                                   /* starting from the char  */
2114                                                   /* pointed by the pointer  */
2115                                                   /* to the remaining line.  */
2116 
2117          if slew = NP                             /* After NP, redo the   */
2118          then                                     /* -to_page test.       */
2119             do;
2120                page_number = page_number + 1;
2121                if sws.to_page_given
2122                then
2123                   do;
2124                      if page_number > to_page
2125                      then
2126                         do;
2127                            sws1.found_last = "1"b;
2128                            return;
2129                         end;
2130                   end;
2131             end;
2132       end;
2133 
2134       if header                                   /* After header, restore */
2135       then                                        /* -line_length info.    */
2136          do;
2137             pci.phys_line_length = saved_line_length;
2138             pci.rmarg = saved_rmarg;
2139          end;
2140 
2141       line_count = line_count + 1;
2142 
2143    end PROCESS_LINE_VIA_PRT_CONV;
2144 %page;
2145 /* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */
2146 
2147 SLEW:
2148    proc;
2149 
2150       dcl needct                 fixed bin;
2151 
2152       if slew = ""                                /* no slew */
2153       then return;
2154 
2155       if slew = CR
2156       then go to real_slew;
2157 
2158       if slew = NP                                /* ejecting a page? */
2159       then
2160          do;
2161             if sws.pause_after_page
2162             then
2163                do;
2164                   call PRINT_STRING (addr (NL), 1);
2165                   call PAUSE;
2166                end;
2167             else if ^sws.no_vertsp
2168             then goto real_slew;
2169 
2170             else                                  /* Compute lines needed */
2171                do;
2172                   needct = pci.phys_page_length - line_count_this_page + 1;
2173                   call ioa_$ioa_switch_nnl (out_switch, "^v/", needct);
2174                   line_count_this_page = 0;
2175                end;
2176          end;
2177 
2178       else if slew = VT                           /* VT is never simulated */
2179       then go to real_slew;                       /* by us. prt_conv_ does */
2180                                                   /* the simulation.       */
2181 
2182       else                                        /* NL slew.              */
2183          do;
2184             line_count_this_page = line_count_this_page + 1;
2185 real_slew:
2186             call PRINT_STRING (addr (slew), 1);
2187          end;
2188 
2189    end SLEW;
2190 
2191    end PRINT_ONE_SEG;
2192 
2193    end PRINT_ONE_ENTRYNAME;
2194 
2195       end;                                        /* of begin block */
2196 ^L
2197 %include prt_conv_info;
2198 
2199       dcl 1 PCI                  like pci aligned;
2200 %page;
2201 %include star_structures;
2202 %page;
2203 %include archive_component_info;
2204 %page;
2205 %include access_mode_values;
2206 
2207    end print;