1 /* ***********************************************************
   2    *                                                         *
   3    *                                                         *
   4    * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   5    * Copyright, (C) Honeywell Information Systems Inc., 1980 *
   6    *                                                         *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 /* An advanced feature text formatting program based on the concepts of runoff.
  11 
  12    The essential features of runoff are retained and many new, advanced
  13    features are added. The formatting and processing algorithms are grossly
  14    different. */
  15 
  16 /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */
  17 
  18 compose:
  19 comp:
  20   proc;
  21 
  22 /* GLOBAL INITIALIZE */
  23 
  24     compose_severity_ = 5;              /* all command line errors abort */
  25     unspec (null_info) = "0"b;
  26 
  27 /* check for recursive invocation */
  28     if re_call
  29     then
  30       do;                               /* if this flag is set, then */
  31         if substr (ips_mask, 36, 1)     /* ips_mask is off, turn it back on */
  32         then call hcs_$reset_ips_mask (ips_mask, ips_mask);
  33 
  34         call com_err_ (0, "compose",
  35              " A prior invocation has been interrupted.^/^-Type 'start', "
  36              || "'release', or 'program_interrupt' to finish it.");
  37         return;
  38       end;
  39 
  40 here:                                   /* "Where we are?" */
  41     call hcs_$fs_get_path_name (codeptr (here), compose_dir, 0, "", ercd);
  42     if ercd ^= 0
  43     then
  44       do;
  45         call com_err_ (ercd, "compose",
  46              "Setting referencing dir (dir containing compose).");
  47         return;
  48       end;                              /**/
  49                                         /* set constants structure pointer */
  50     compstat$compconst.ptr = addr (compstat$compconst.ptr);
  51 
  52     if dt_sw
  53     then call ioa_ ("^a (Vers. ^a)", rtrim (compose_dir),
  54               compstat$compconst.comp_version);
  55 
  56     if const.version ^= const_version   /* bad version? */
  57     then
  58       do;
  59         call com_err_ (error_table_$unimplemented_version, "compose",
  60              "Program constants structure.");
  61         return;
  62       end;
  63 
  64     const.comp_dir = compose_dir;
  65 
  66 /* establish the cleanup handler */
  67     on cleanup call comp_cleanup;       /* comp_init_ might signal it */
  68     re_call = "1"b;                     /* we have been called */
  69                                         /* initialize those parts of the */
  70                                         /* internal data base needed for */
  71     call comp_init_$one;                /* argument processing */
  72 %page;
  73 /* PROCESS COMMAND ARGUMENTS */
  74 
  75     call cu_$arg_count (nargs);         /* get argument count */
  76 
  77     if nargs = 0                        /* if none are given ... */
  78     then
  79       do;
  80         call com_err_ (0, "compose",
  81              "(Vers. ^a) Proper usage is: compose " || "paths {-control_args}",
  82              const.comp_version);
  83         goto clean_;
  84       end;
  85 
  86     optnptr = addr (option.argument_opt);
  87                                         /* option flags as bit (36)x */
  88 
  89     source_list.count = 0;              /* empty the source file table */
  90 
  91     on conversion
  92       begin;                            /* set a conversion error handler */
  93         call com_err_ (ercd, "compose",
  94              "Nonnumeric parameter given for ^a option.",
  95              rtrim (option_keyword));
  96         badcall = "1"b;                 /* set static flags */
  97         goto skip_arg;                  /* go to next arg */
  98       end;
  99 
 100     do iarg = 1 by 1 while (iarg <= nargs);
 101                                         /* do arguments one at a time */
 102       call cu_$arg_ptr (iarg, argp, argl, ercd);
 103                                         /* get an arg pointer */
 104       if ercd ^= 0
 105       then
 106         do;
 107           call com_err_ (ercd, "compose", "Reading argument ^d", iarg);
 108           goto clean_;
 109         end;
 110 
 111 no_param:
 112       if iarg > nargs                   /* if there aren't any more */
 113       then goto end_args;
 114 
 115       if index (arg, "-") ^= 1          /* if not an option */
 116       then
 117         do;                             /* if control line is already bad */
 118           if badcall                    /* is it numeric? */
 119           then if verify (arg, "0123456789") = 0
 120                then
 121                  do;
 122                    call com_err_ (0, "compose",
 123                         "The numeric parameter "
 124                         ||
 125                         """^a"" cannot be associated with a control argument.",
 126                         arg);
 127                    badcall = "1"b;
 128                    goto skip_arg;
 129                  end;
 130 
 131 is_a_file:                              /* process as an source file name */
 132                                         /* check file limit */
 133           if source_list.count = hbound (source_list.ptr, 1)
 134           then
 135             do;
 136               call com_err_ (0, "compose",
 137                    "Too many input files." || " Program limit is ^d.",
 138                    hbound (source_list.ptr, 1));
 139               goto clean_;
 140             end;                        /**/
 141                                         /* get a new source file block */
 142           source_list.count = source_list.count + 1;
 143           source_file_ptr =
 144                allocate (const.global_area_ptr, size (source_file));
 145           source_list.ptr (source_list.count) = source_file_ptr;
 146           source_file = init_file_data;
 147 
 148           call comp_get_file_$find (arg, source_file_ptr, (const.comp_dir),
 149                "1"b, "compin", ercd);
 150           if ercd ^= 0                  /* cant find it? */
 151           then
 152             do;
 153               badcall = "1"b;
 154               goto skip_arg;
 155             end;                        /**/
 156                                         /* if writing to a compout */
 157           if option.output_file_opt     /* check name length */
 158                & length (rtrim (source_file.entryname)) > 31
 159           then
 160             do;
 161               call com_err_ (0, "compose",
 162                    "Input entryname ""^a"" is too long", arg);
 163               badcall = "1"b;
 164               goto skip_arg;
 165             end;
 166 
 167           call comp_get_file_$open (source_file_ptr, "1"b, ercd);
 168           if ercd ^= 0                  /* cant use file? */
 169           then
 170             do;
 171               badcall = "1"b;
 172               goto skip_arg;
 173             end;
 174         end;
 175 
 176       else if index (arg, "-") = 1      /* is it an option? */
 177       then
 178         do;
 179 is_option:
 180           option_keyword = arg;         /* save option keyword */
 181                                         /* search option list */
 182           optndx = index (ctlargstr, option_keyword);
 183 
 184           if optndx = 0
 185           then
 186             do;
 187               call com_err_ (error_table_$badopt, "compose", """^a""", arg);
 188               badcall = "1"b;
 189             end;
 190 
 191           else
 192             do;                         /* calculate true index */
 193               optndx = option_data.flag_index (divide (optndx, 32, 17) + 1);
 194               optns (optndx) = "1"b;    /* set the flag */
 195 
 196               if optndx <= to_optndx    /* these have parameters */
 197               then
 198                 do;
 199                   iarg = iarg + 1;      /* fetch expected parameter */
 200                   call cu_$arg_ptr (iarg, argp, argl, ercd);
 201                   if ercd ^= 0
 202                   then
 203                     do;
 204 param_err:
 205                       if ercd ^= error_table_$noarg
 206                       then
 207                         do;
 208                           call com_err_ (ercd, "compose",
 209                                "Reading value for ^a option.",
 210                                rtrim (option_keyword));
 211                           badcall = "1"b;
 212                           goto skip_arg;
 213                         end;
 214                       argl = 0;         /*                   if ercd = error_table_$noarg
 215 /*                   then ercd = 0;*/
 216                     end;
 217 
 218 /* -arguments option */
 219                   if optndx = arg_optndx
 220                   then goto end_args;   /* abort arg processing */
 221 
 222 /* -change_bars option */
 223                   else if optndx = cb_optndx
 224                   then
 225                     do;
 226 cbar_opt:                               /* defaults only wanted? */
 227                       if index (arg, "-") = 1 | argl = 0
 228                       then goto no_param;
 229                                         /* copy parameter arg */
 230                       local_arg = arg;  /**/
 231                                         /* level */
 232                       if index (local_arg, ",") > 1
 233                       then option.cbar.level = before (local_arg, ",");
 234                       else if local_arg ^= "" & index (local_arg, ",") ^= 1
 235                       then option.cbar.level = local_arg;
 236                       local_arg = after (local_arg, ",");
 237                                         /**/
 238                                         /* placement */
 239                       if index (local_arg, ",") > 1
 240                       then option.cbar.place = before (local_arg, ",");
 241                       else if local_arg ^= "" & index (local_arg, ",") ^= 1
 242                       then option.cbar.place = before (local_arg, ",");
 243                       local_arg = after (local_arg, ",");
 244                                         /**/
 245                                         /* left mark */
 246                       if index (local_arg, ",") > 1
 247                            | local_arg ^= "" & index (local_arg, ",") ^= 1
 248                       then
 249                         do;
 250                           if index ("0123456789", substr (local_arg, 1, 1))
 251                                ^= 0
 252                           then
 253                             do;
 254                               option.cbar.left.sep =
 255                                    12000 * bin (substr (local_arg, 1, 1));
 256                               local_arg = substr (local_arg, 2);
 257                             end;
 258 
 259                           if index (local_arg, """") = 1
 260                           then
 261                             do;
 262                               local_arg = after (local_arg, """");
 263                               option.cbar.left.mark = before (local_arg, """");
 264                               local_arg = after (local_arg, """");
 265                             end;
 266                           else option.cbar.left.mark = before (local_arg, ",");
 267                         end;
 268                       local_arg = after (local_arg, ",");
 269                                         /**/
 270                                         /* right mark */
 271                       if index (local_arg, ",") > 1
 272                            | local_arg ^= "" & index (local_arg, ",") ^= 1
 273                       then
 274                         do;
 275                           if index ("0123456789", substr (local_arg, 1, 1))
 276                                ^= 0
 277                           then
 278                             do;
 279                               option.cbar.right.sep =
 280                                    12000 * bin (substr (local_arg, 1, 1));
 281                               local_arg = substr (local_arg, 2);
 282                             end;
 283                           if index (local_arg, """") = 1
 284                           then
 285                             do;
 286                               local_arg = after (local_arg, """");
 287                               option.cbar.right.mark =
 288                                    before (local_arg, """");
 289                               local_arg = after (local_arg, """");
 290                             end;
 291                           else option.cbar.right.mark =
 292                                     before (local_arg, ",");
 293                         end;
 294                       local_arg = after (local_arg, ",");
 295                                         /**/
 296                                         /* del mark */
 297                       if length (local_arg) > 0
 298                            | local_arg ^= "" & index (local_arg, ",") ^= 1
 299                       then
 300                         do;
 301                           if index ("0123456789", substr (local_arg, 1, 1))
 302                                ^= 0
 303                           then
 304                             do;         /* numeric 1st char is separation */
 305                               option.cbar.del.sep =
 306                                    12000 * bin (substr (local_arg, 1, 1));
 307                               local_arg = substr (local_arg, 2);
 308                             end;
 309                           if index (local_arg, """") = 1
 310                           then
 311                             do;
 312                               local_arg = after (local_arg, """");
 313                               option.cbar.del.mark = before (local_arg, """");
 314                               local_arg = after (local_arg, """");
 315                             end;
 316                           else option.cbar.del.mark = before (local_arg, ",");
 317                         end;
 318                       local_arg = after (local_arg, ",");
 319                     end;
 320 
 321 /* -change_bars_art option */
 322                   else if optndx = cba_optndx
 323                   then
 324                     do;
 325                       option.cbar_opt = "1"b;
 326                                         /* set -change_bars option */
 327                       goto cbar_opt;    /* and do as for -cb */
 328                     end;
 329 
 330 /* UNDOCUMENTED OPTION: -debug {n1}{,n2}
 331    Produces debugging output for lines n1 thru n2 of source file
 332    or given insert file */
 333                   else if optndx = db_optndx
 334                   then
 335                     do;
 336                       if ercd = 0
 337                       then
 338                         do;
 339                           if index (arg, "-") = 1
 340                           then goto is_option;
 341 
 342                           if verify (arg, "0123456789,$") ^= 0
 343                           then goto is_a_file;
 344                                         /* look for a comma */
 345                           i = index (arg, ",");
 346 
 347                           if i ^= 0     /* if one is given ... */
 348                           then
 349                             do;
 350                               if i > 1
 351                               then option.db_line_strt =
 352                                         bin (substr (arg, 1, i - 1));
 353 
 354                               if i < argl
 355                               then
 356                                 do;     /* if ",$" -> debug only end_output */
 357                                   if substr (arg, i + 1, 1) = "$"
 358                                   then option.db_line_end = -1;
 359                                   else option.db_line_end =
 360                                             bin (substr (arg, i + 1, argl - i))
 361                                             ;
 362                                 end;
 363                             end;
 364 
 365                           else option.db_line_strt = bin (arg);
 366                         end;
 367                     end;
 368 
 369 /* UNDOCUMENTED OPTION: -debug_all {n1}{,n2}
 370    Enables debug output for all input lines (including inserted files)
 371    encountered between lines n1 and n2 of the debug file */
 372                   else if optndx = dba_optndx
 373                   then
 374                     do;
 375                       option.debug_opt, option.db_all_opt = "1"b;
 376                       if ercd = 0
 377                       then
 378                         do;
 379                           if index ("0123456789,", substr (arg, 1, 1)) = 0
 380                           then goto no_param;
 381                           i = index (arg, ",");
 382                                         /* look for a comma */
 383 
 384                           if i ^= 0     /* if one is given ... */
 385                           then
 386                             do;
 387                               if i > 1
 388                               then option.db_after_line =
 389                                         bin (substr (arg, 1, i - 1));
 390 
 391                               if i < argl
 392                               then option.db_before_line =
 393                                         bin (substr (arg, i + 1, argl - i));
 394                             end;
 395 
 396                           else option.db_after_line = bin (arg);
 397                         end;
 398                     end;
 399 
 400 /* UNDOCUMENTED OPTION: -debug_file <file_name>
 401    Enables -debug output for a named file */
 402                   else if optndx = dbf_optndx
 403                   then
 404                     do;
 405                       option.debug_opt, option.db_file_opt = "1"b;
 406                       option.db_file = "ALLFILES";
 407                                         /* "" -> ALLFILES */
 408 
 409                       if index (arg, "-") = 1
 410                       then goto is_option;
 411 
 412                       else
 413                         do;
 414                           if arg ^= ""
 415                           then option.db_file = arg;
 416 
 417                           iarg = iarg + 1;
 418                                         /* fetch next arg */
 419                           call cu_$arg_ptr (iarg, argp, argl, ercd);
 420                           if ercd ^= 0
 421                           then if ercd = error_table_$noarg
 422                                then goto skip_arg;
 423 
 424                           if index (arg, "-") = 1
 425                                         /* no after line */
 426                           then goto is_option;
 427                           else option.db_file_after = bin (arg);
 428                         end;
 429                     end;
 430 
 431 /* -device option */
 432                   else if optndx = dv_optndx
 433                   then dsm_path = arg;
 434 
 435 /* -execute option */
 436                   else if optndx = ex_optndx
 437                   then
 438                     do;
 439                       call com_err_ (0, "compose",
 440                            "The -execute control argument is not yet implemented."
 441                            );
 442                       option.execute_opt = "0"b;
 443                                         /* REMOVE THIS CATCHER */
 444                       if index (arg, "-") = 1
 445                       then goto no_param;
 446                                         /* EXECUTE OPTION STUFF GOES HERE.
 447                                            MUST BE A QUOTED, SEMI-COLON */
 448                     end;                /* SEPARATED CONTROL STRING */
 449 
 450 /* -from option */
 451                   else if optndx = fm_optndx
 452                   then
 453                     do;
 454                       if option.pages_opt
 455                       then
 456                         do;
 457 page_err_1:
 458                           call com_err_ (0, "compose",
 459                                "The -from/-to and "
 460                                || "-pages options may not be used together.");
 461                           badcall = "1"b;
 462                           goto skip_arg;
 463                         end;
 464 
 465                       option.pglst (0).from = arg;
 466                     end;
 467 
 468 /* -galley option */
 469                   else if optndx = gl_optndx
 470                   then
 471                     do;
 472                       if ercd = 0
 473                       then
 474                         do;
 475 
 476                           if index ("0123456789,.", substr (arg, 1, 1)) = 0
 477                           then goto no_param;
 478 
 479                           i = index (arg, ",");
 480                                         /* look for a comma */
 481                           if i ^= 0     /* if one is given ... */
 482                           then
 483                             do;
 484                               if i > 1
 485                               then option.line_1 =
 486                                         bin (substr (arg, 1, i - 1));
 487 
 488                               if i < argl
 489                                    & substr (arg, i + 1, argl - i) ^= "$"
 490                               then option.line_2 =
 491                                         bin (substr (arg, i + 1, argl - i));
 492 
 493                               if option.line_2 < option.line_1
 494                               then
 495                                 do;
 496                                   call com_err_ (0, "compose",
 497                                        "Ending line number"
 498                                        || " less than starting line number.");
 499                                   badcall = "1"b;
 500                                 end;
 501                             end;
 502 
 503                           else option.line_1 = bin (arg);
 504                         end;
 505                     end;
 506 
 507 /* -hyphenation option */
 508                   else if optndx = hyph_optndx
 509                   then
 510                     do;
 511                       if argl = 0 | verify (arg, "0123456789") ^= 0
 512                       then goto no_param;
 513                       else option.hyph_size = bin (arg);
 514                     end;
 515 
 516 /* -indent option */
 517                   else if optndx = ind_optndx
 518                   then
 519                     do;
 520                       if search (arg, "0123456789.") ^= 1
 521                       then goto no_param;
 522                       else option.extra_indent =
 523                                 comp_read_$number ((arg), hscales, 1, 0,
 524                                 addr (null_info), ercd);
 525                       if ercd ^= 0
 526                       then goto no_param;
 527                     end;
 528 
 529 /* -input_file option */
 530                   else if optndx = if_optndx
 531                   then goto is_a_file;
 532 
 533 /* -linespace option */
 534                   else if optndx = ls_optndx
 535                   then
 536                     do;
 537                       if search (arg, "0123456789.") ^= 1
 538                       then goto no_param;
 539                       else option.linespace =
 540                                 comp_read_$number ((arg), hscales, 1, 0,
 541                                 addr (null_info), ercd);
 542                       if ercd ^= 0
 543                       then goto no_param;
 544                       else option.linespace = 12000 * dec (arg, 11, 3);
 545                     end;
 546 
 547 /* -output_file option */
 548                   else if optndx = of_optndx
 549                   then
 550                     do;
 551                       wdir = get_wdir_ ();
 552 
 553                       if argl > 0       /* if there is another arg */
 554                       then
 555                         do;
 556                           if index (arg, "-") = 1
 557                                         /* if no given path */
 558                           then goto is_option;
 559 
 560                           if search ("<>", arg) ^= 0
 561                                         /* if a path is given */
 562                           then
 563                             do;
 564                               call expand_pathname_ (arg, bulk_file.dir,
 565                                    bulk_file.entryname, ercd);
 566                               if ercd ^= 0
 567                               then
 568                                 do;
 569                                   call com_err_ (ercd, "compose",
 570                                        "Expanding path for ""^a""", arg);
 571                                   goto clean_;
 572                                 end;
 573                             end;
 574 
 575                           else
 576                             do;         /* only a name, use wdir */
 577                               if argl > 32
 578                               then
 579                                 do;
 580                                   call com_err_ (error_table_$entlong,
 581                                        "compose", "Bulk output file name.");
 582                                   goto clean_;
 583                                 end;
 584                               bulk_file.entryname = arg;
 585                               bulk_file.dir = wdir;
 586                             end;        /* construct the path name */
 587                           bulk_file.path =
 588                                rtrim (bulk_file.dir) || ">"
 589                                || rtrim (bulk_file.entryname);
 590                         end;
 591                     end;
 592 
 593 /* -pages option */
 594                   else if optndx = pg_optndx
 595                   then
 596                     do;
 597                       if option.from_opt | option.to_opt
 598                       then goto page_err_1;
 599                                         /* NG if already -from/-to */
 600 
 601                       if index (arg, "-") = 1
 602                                         /* if no list is given */
 603                       then goto is_option;
 604                                         /* do them all */
 605 
 606 pglst_loop:
 607                       if index (arg, ",") = 0
 608                                         /* if not a page pair */
 609                       then
 610                         do;
 611                           if option.pglstct >= 50
 612                           then
 613                             do;
 614 page_err_3:
 615                               call com_err_ (0, "compose",
 616                                    "More than 50 page selectors given.");
 617                               badcall = "1"b;
 618                               goto skip_arg;
 619                             end;
 620 
 621                           option.pglstct = option.pglstct + 1;
 622                           option.pglst (option.pglstct).from,
 623                                option.pglst (option.pglstct).to = arg;
 624                         end;
 625 
 626                       else
 627                         do;
 628                           if option.pglstct >= 50
 629                           then goto page_err_3;
 630 
 631                           option.pglstct = option.pglstct + 1;
 632                           option.pglst (option.pglstct).from =
 633                                before (arg, ",");
 634                           option.pglst (option.pglstct).to = after (arg, ",");
 635                         end;
 636 
 637                       iarg = iarg + 1;  /* fetch next list value */
 638                       call cu_$arg_ptr (iarg, argp, argl, ercd);
 639                       if ercd ^= 0
 640                       then if ercd = error_table_$noarg
 641                            then goto skip_arg;
 642                            else goto param_err;
 643 
 644                       if index (arg, "-") = 1
 645                                         /* must be end of page list */
 646                       then goto is_option;
 647 
 648                       goto pglst_loop;
 649                     end;
 650 
 651 /* -pages_changed option */
 652                   else if optndx = pgc_optndx
 653                   then
 654                     do;
 655                       if ercd ^= 0 | argl = 0
 656                       then goto skip_arg;
 657                       else if index (arg, "-") = 1
 658                       then goto is_option;
 659                       if argl > 2
 660                       then goto is_a_file;
 661                                         /* cancel default from */
 662                       option.pglst.from = "";
 663                       option.pgc_select = substr (arg, 1, 1);
 664                                         /* PAIR/SINGLE CODE GOES HERE */
 665                     end;
 666 
 667 /* -parameter option */
 668                   else if optndx = pm_optndx
 669                   then option.parameter = arg;
 670 
 671 /* -passes option */
 672                   else if optndx = pass_optndx
 673                   then
 674                     do;
 675                       if verify (arg, "0123456789.") ^= 0
 676                       then goto no_param;
 677                       else option.passes = bin (arg);
 678                     end;
 679 
 680 /* -to option */
 681                   else if optndx = to_optndx
 682                   then
 683                     do;
 684 
 685                       if option.pages_opt
 686                       then goto page_err_1;
 687 
 688                       option.pglst (0).to = arg;
 689                     end;
 690 
 691 skip_arg:
 692                 end;
 693             end;
 694         end;
 695     end;
 696 
 697 end_args:
 698     revert conversion;
 699 
 700     if option.debug_opt & ^dt_sw
 701     then call ioa_ ("^a (Vers. ^a)", rtrim (const.comp_dir),
 702               const.comp_version);
 703 
 704     if source_list.count = 0            /* if no source files were given */
 705     then
 706       do;
 707         call com_err_ (0, "compose", "No input files given.");
 708         badcall = "1"b;
 709       end;
 710 
 711     if badcall
 712     then goto clean_;
 713 
 714     if option.stop_opt                  /* if stop is given, also set wait */
 715     then option.wait_opt = "1"b;        /* as a first time flag */
 716 %page;
 717 /* INITIALIZE FOR EXECUTION BASED ON COMMAND LINE INPUT */
 718 
 719 /* extend the stack, errors will be caught by oob */
 720     call hcs_$set_max_length_seg (stackbaseptr (), sys_info$max_seg_size, ercd)
 721          ;
 722     if ercd ^= 0
 723     then
 724       do;
 725         call com_err_ (ercd, "compose", "Extending user stack.");
 726         goto clean_;
 727       end;
 728 
 729     if option.argument_opt              /* any command line arguments? */
 730     then
 731       do;                               /* how many? */
 732         command_arg_ct = max (nargs - iarg + 1, 0);
 733 
 734         if command_arg_ct > 0
 735         then
 736           do;
 737             command_arg_ptr =
 738                  allocate (const.global_area_ptr, size (command_arg));
 739 
 740             do i = iarg to nargs;       /* move them */
 741               call cu_$arg_ptr (i, argp, argl, ercd);
 742               if ercd ^= 0
 743               then
 744                 do;
 745                   call com_err_ (ercd, "compose", "Reading argument ^d", i);
 746                   goto clean_;
 747                 end;
 748 
 749               command_arg (i - iarg + 1) = arg;
 750               option.arg_count = option.arg_count + 1;
 751             end;
 752           end;                          /**/
 753                                         /* no args; cancel the option */
 754         else option.argument_opt = "0"b;
 755       end;
 756 
 757     if dsm_path = ""                    /* no device given? */
 758     then
 759       do;
 760         if option.output_file_opt       /* set defaults */
 761         then const.dsm_name = "printer.comp_dsm";
 762         else const.dsm_name = "ascii.comp_dsm";
 763       end;
 764     else
 765       do;
 766         call expand_pathname_$add_suffix (dsm_path, "comp_dsm", dsm_dir,
 767              const.dsm_name, ercd);
 768         if ercd ^= 0
 769         then
 770           do;
 771             call com_err_ (ercd, "compose",
 772                  "Expanding device table pathname.  ^a", dsm_path);
 773             go to clean_;
 774           end;
 775       end;                              /**/
 776                                         /* look for the device table */
 777     if search ("<>", dsm_path) = 0      /* if search is needed */
 778     then
 779       do;
 780         call search_paths_$find_dir ("compose", null (), (const.dsm_name),
 781              (const.comp_dir), dsm_dir, ercd);
 782         if ercd ^= 0
 783         then
 784           do;
 785             call com_err_ (ercd, "compose", "Searching for ^a.",
 786                  const.dsm_name);
 787             goto clean_;
 788           end;
 789       end;
 790 
 791     dsm_path = pathname_ (dsm_dir, (const.dsm_name));
 792 
 793 /* second init step - this is all */
 794     call comp_init_$two;                /* the data base stuff that is */
 795                                         /* needed for file processing and */
 796                                         /* doesnt depend on the contents of */
 797                                         /* the files or their size */
 798 
 799 /* initialize the device module */
 800     call hcs_$initiate (dsm_dir, const.dsm_name, const.dsm_name, 0, 0,
 801          dsm_baseptr, ercd);
 802     if dsm_baseptr = null ()
 803     then
 804       do;
 805         call com_err_ (ercd, "compose", "Initiating ^a", dsm_path);
 806         go to clean_;
 807       end;
 808     if ercd ^= 0
 809     then if ercd = error_table_$namedup
 810          then
 811            do;
 812              call term_$single_refname (const.dsm_name, (0));
 813              call hcs_$initiate (dsm_dir, const.dsm_name, const.dsm_name, 0, 0,
 814                   dsm_baseptr, ercd);
 815              if dsm_baseptr = null ()
 816              then
 817                do;
 818                  call com_err_ (ercd, "compose", "Forcibly initiating ^a",
 819                       dsm_path);
 820                  go to clean_;
 821                end;
 822            end;
 823 
 824 (nostrz):
 825 (nostrg):                               /* make a pointer to dvid table */
 826     option.device = before (const.dsm_name, ".comp_dsm");
 827     const.dvt_name = option.device || ".dvt";
 828     call hcs_$make_ptr (null (), const.dsm_name, const.dvt_name, const.dvidptr,
 829          ercd);
 830     if ercd ^= 0
 831     then
 832       do;
 833         call com_err_ (ercd, "compose", "Getting pointer to ^a$^a", dsm_path,
 834              const.dvt_name);
 835         goto clean_;
 836       end;
 837 
 838     if comp_dvid.version ^= comp_dvid_version
 839     then
 840       do;                               /* terminate device writer */
 841         call com_err_ (error_table_$unimplemented_version, "compose",
 842              "Device table ^a cannot be used with ^a>compose.", dsm_path,
 843              const.comp_dir);
 844         go to clean_;
 845       end;                              /* make a pointer to device table */
 846     const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r);
 847 
 848     call comp_dvt.outproc (2, ercd);    /* initialize output writer */
 849     if ercd ^= 0
 850     then
 851       do;
 852         call com_err_ (ercd, "compose",
 853              "Initializing device writer procedure.^/^-"
 854              || "Writer for ^a cannot be used with ^a>compose.", dsm_path,
 855              const.comp_dir);
 856         goto clean_;
 857       end;
 858 
 859     if option.number_brief_opt | option.number_append_opt
 860     then option.number_opt = "1"b;
 861 
 862     if option.galley_opt                /* adjust debug range if not given */
 863     then
 864       do;
 865         if ^option.db_file_opt
 866         then
 867           do;
 868             if option.db_line_strt = 0
 869             then option.db_line_strt = option.line_1;
 870             if option.db_all_opt & option.db_after_line = 0
 871             then option.db_after_line = option.line_1;
 872           end;
 873 
 874         if option.cbar_opt
 875         then option.cbar.place = "r";
 876       end;                              /**/
 877                                         /* output to terminal */
 878     if ^(option.output_file_opt | option.check_opt)
 879     then shared.compout_ptr = iox_$user_output;
 880 
 881 /* set up bulk output file */
 882     if ^option.check_opt & bulk_file.path ^= ""
 883     then
 884       do;
 885         call initiate_file_ (bulk_file.dir, bulk_file.entryname, W_ACCESS,
 886              bulk_file.ptr, 0, ercd);
 887         if ercd ^= 0 & ercd ^= error_table_$segknown
 888              & ercd ^= error_table_$namedup & ercd ^= error_table_$noentry
 889         then
 890           do;
 891             call com_err_ (ercd, "compose", "Accessing ^a", bulk_file.path);
 892             goto clean_;
 893           end;
 894 
 895         if bulk_file.ptr ^= null
 896         then
 897           do i = 1 to source_list.count;/* check for file overwrite */
 898             if baseno (source_list.ptr (i) -> source.pointer)
 899                  = baseno (bulk_file.ptr)
 900             then
 901               do;
 902                 call com_err_ (0, "compose",
 903                      "Output would overwrite " || "input file ^a",
 904                      source_list.ptr (i) -> source.path);
 905                 goto clean_;
 906               end;
 907           end;
 908 
 909         atd = "vfile_ " || bulk_file.path;
 910         shared.output_file = bulk_file.entryname;
 911 
 912         call iox_$attach_name ("COMPOUT", shared.compout_ptr, atd, null (),
 913              ercd);
 914         if ercd ^= 0
 915         then
 916           do;
 917             call com_err_ (ercd, "compose", "Attaching ^a",
 918                  bulk_file.entryname);
 919             goto clean_;
 920           end;
 921 
 922         call iox_$open (shared.compout_ptr, comp_dvt.open_mode, "0"b, ercd);
 923         if ercd ^= 0
 924         then
 925           do;
 926             call com_err_ (ercd, "compose", "Opening ^a", bulk_file.path);
 927             call iox_$detach_iocb (shared.compout_ptr, ercd);
 928             ercd = 0;
 929             goto clean_;
 930           end;
 931       end;
 932 
 933     source_ptr = allocate (const.global_area_ptr, size (source));
 934                                         /* pass -pm value to the file */
 935     shared.parameter = option.parameter;
 936     shared.param_pres = (shared.parameter ^= "");
 937 
 938     if option.passes > 1 | source_list.count > 1
 939     then
 940       do;
 941         const.save_shared_ptr =
 942              allocate (const.global_area_ptr, size (save_shared));
 943         save_shared = shared;           /* save all constructed data */
 944       end;
 945 
 946     if option.debug_opt &               /* debugging wanted? */
 947          option.db_line_end ^= 0        /* more than salutory? */
 948     then call ioa_ ("(debug display = picas, device = ^a)", option.device);
 949 
 950     if option.debug_opt & dt_sw
 951     then call ioa_ ("^5x(^a>^a)", rtrim (const.comp_dir), const.dsm_name);
 952 
 953     on program_interrupt                /* set a pi handler */
 954       goto print_pi_stuff;
 955 %page;
 956 /* PROCESS INPUT FILES */
 957 
 958     compose_severity_ = 0;              /* reset severity indicator */
 959 
 960     on cleanup call comp_cleanup;
 961 
 962 input_file_loop:
 963     do filndx = 1 to source_list.count;
 964 
 965       if option.debug_opt               /* initialize meter data */
 966       then
 967         do;
 968           call cpu_time_and_paging_ (pf_start, vcpu_start, 0);
 969           call hcs_$quota_read (get_pdir_ (), 0, 0, "0"b, "0"b, 0,
 970                pd_used_start, ercd);
 971         end;
 972 
 973       if filndx > 1                     /* for additional files */
 974       then shared = save_shared;        /* reinitialize shared data */
 975 
 976       if bulk_file.path = ""
 977       then shared.compout_not_headed = "1"b;
 978 
 979       call comp_init_$three;            /* third init step */
 980       call comp_dvt.outproc (2, ercd);  /* initialize output writer */
 981 
 982 /* open the next input file */
 983       source_file_ptr = source_list.ptr (filndx);
 984       source.label.count = 0;           /* discard old labels */
 985 
 986 (nostrz):
 987 (nostrg):
 988       shared.input_filename, shared.source_filename =
 989            before (source_file.entryname, ".compin");
 990       shared.insert_ptr, source_file.insert_ptr = source_ptr;
 991       unspec (insert) = "0"b;
 992       insert.file, call_box0 = source_file;
 993       insert.callers_name = "";         /**/
 994                                         /* if no debug file, set source file */
 995       if ^option.db_file_opt            /* as debug file */
 996       then option.db_file = shared.source_filename;
 997                                         /* not syntax check */
 998       if ^option.check_opt              /* and output to individual files */
 999            & option.output_file_opt & bulk_file.path = ""
1000       then
1001         do;
1002           call suffixed_name_$new_suffix ((source.entryname), "compin",
1003                "compout", compout_name, ercd);
1004           if ercd ^= 0
1005           then
1006             do;
1007               call com_err_ (ercd, "compose",
1008                    "Forming output file name for ^a", source.entryname);
1009               goto clean_;
1010             end;
1011 
1012           shared.output_file = compout_name;
1013           compout_path = pathname_ (wdir, compout_name);
1014 
1015           call initiate_file_ (wdir, compout_name, W_ACCESS, compout_seg_ptr,
1016                0, ercd);
1017           if ercd ^= 0 & ercd ^= error_table_$segknown
1018                & ercd ^= error_table_$namedup & ercd ^= error_table_$noentry
1019           then
1020             do;
1021               call com_err_ (ercd, "compose", "Accessing ^a", compout_path);
1022               goto skip_file;           /* skip this one */
1023             end;
1024 
1025           if baseno (source.pointer) = baseno (compout_seg_ptr)
1026           then
1027             do;
1028               call com_err_ (0, "compose",
1029                    "Output would overwrite " || "input file ^a",
1030                    source_list.ptr (i) -> source.path);
1031               goto skip_file;
1032             end;
1033 
1034           atd = "vfile_ " || compout_path;
1035           call iox_$attach_name ("COMPOUT", shared.compout_ptr, atd, null (),
1036                ercd);
1037           if ercd ^= 0
1038           then
1039             do;
1040               call com_err_ (ercd, "compose", "Attaching ^a", compout_name);
1041               compose_severity_ = 5;
1042               goto clean_;
1043             end;
1044           call iox_$open (shared.compout_ptr, comp_dvt.open_mode, "0"b, ercd);
1045           if ercd ^= 0
1046           then
1047             do;
1048               call com_err_ (ercd, "compose", "Opening ^a", compout_name);
1049               call iox_$detach_iocb (shared.compout_ptr, ercd);
1050               ercd = 0;
1051               compose_severity_ = 5;
1052               goto clean_;
1053             end;
1054 
1055           if option.passes > 1
1056           then
1057             do;
1058               save_shared.output_file = shared.output_file;
1059               save_shared.compout_ptr = shared.compout_ptr;
1060             end;
1061         end;
1062 
1063       if option.passes > 1
1064       then save_shared = shared;
1065 
1066 /* for given number of passes */
1067       do shared.pass_counter = option.passes by -1 to 1;
1068         if option.passes > 1 &          /* reinitialize shared data for */
1069              shared.pass_counter < option.passes
1070         then shared = save_shared;      /* each additional pass */
1071 
1072         call_stack.index = 0;           /* refresh file data */
1073         call_box0 = source_file;        /* refresh command line args */
1074         do i = 1 to option.arg_count;
1075           call comp_update_symbol_ ("1"b, "0"b, "0"b,
1076                "CommandArg" || ltrim (char (i)), command_arg (i));
1077         end;
1078 
1079         if shared.pass_counter <= 1     /* set print control */
1080         then if option.galley_opt & option.line_1 <= 1
1081                                         /* galley */
1082                   | ^option.galley_opt  /* or paged and not -from or -pages */
1083                   &
1084                   ^(option.from_opt | option.pages_opt | option.page_chng_opt)
1085              then shared.print_flag = "1"b;
1086                                         /* set page formatting parameters */
1087         page_parms = init_page_parms;
1088         page_parms.measure = min (comp_dvt.pdw_max, 468000);
1089         page.parms = page_parms;
1090 
1091         unspec (page_header) = "0"b;    /* and the control stuff */
1092         page_header.net = 720000;
1093         page_header.pageno = "";
1094         page_header.dot_addltr = "^?";  /* = PAD */
1095         page.hdr = page_header;         /**/
1096                                         /* start in column 0 */
1097         shared.colptr = page.column_ptr (0);
1098         unspec (colhdr) = "0"b;
1099         colhdr.balblk = 1;
1100         colhdr.net = 720000;
1101         col.hdr = colhdr;               /**/
1102                                         /* initialize parms */
1103         default_parms.measure, col0.parms.measure = page_parms.measure;
1104         default_parms.linespace = option.linespace;
1105         default_parms.fill_mode = ^option.nofill_opt;
1106 
1107         text_parms, footnote_parms = default_parms;
1108         call comp_font_ ("1"b, "", ""); /* initialize the font stack */
1109 
1110         const.current_parms_ptr = const.text_parms_ptr;
1111 
1112         if option.debug_opt             /* debugging wanted? */
1113         then
1114           do;
1115             if option.line_1 <= 1 & option.db_after_line <= 1
1116                  & option.db_line_strt <= 1 & option.db_line_end >= 1
1117                  & (option.db_file = "ALLFILES"
1118                  | shared.input_filename = option.db_file)
1119             then shared.bug_mode = "1"b;
1120           end;
1121         else shared.bug_mode = "0"b;    /**/
1122                                         /* net page/column space */
1123         call comp_util_$set_net_page ("0"b);
1124 
1125         if option.cbar_opt
1126         then
1127           do;
1128             unspec (meas1) = "0"b;      /* measure left mark */
1129             call comp_measure_ ((option.cbar.left.mark),
1130                  addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
1131                  addr (meas1), addr (meas2), addr (text_entry.info));
1132             option.cbar.left.width =
1133                  meas1.width + meas1.gaps * shared.EN_width;
1134 
1135             unspec (meas1) = "0"b;      /* measure right mark */
1136             call comp_measure_ ((option.cbar.right.mark),
1137                  addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
1138                  addr (meas1), addr (meas2), addr (text_entry.info));
1139             option.cbar.right.width =
1140                  meas1.width + meas1.gaps * shared.EN_width;
1141 
1142             unspec (meas1) = "0"b;      /* measure del mark */
1143             call comp_measure_ ((option.cbar.del.mark),
1144                  addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
1145                  addr (meas1), addr (meas2), addr (text_entry.info));
1146             option.cbar.del.width = meas1.width + meas1.gaps * shared.EN_width;
1147 
1148             option.cbar.space =
1149                  max (option.cbar.left.width + option.cbar.left.sep,
1150                  option.cbar.del.width + option.cbar.del.sep);
1151           end;
1152 
1153         ctltxtptr = ctl.ptr;            /* save pointer around re-init */
1154         unspec (ctl) = ""b;             /* clear control line structure */
1155         ctl.font, ctl.cur.font = default_parms.fntstk.entry (0);
1156         ctl.ptr = ctltxtptr;            /* set input buffer pointer */
1157         ctl.ptr -> txtstr = "";         /* and clear the buffer */
1158         ctl.fileno,                     /* command line file */
1159              source_file.fileno = 0;
1160         unspec (text_entry) = ""b;
1161         text_entry.quad = just;
1162         text_entry.linespace = option.linespace;
1163 
1164         shared.end_output = "0"b;       /* turn off flags */
1165         if option.pages_opt             /* set page list index */
1166         then option.pglstndx = 1;
1167         else option.pglstndx = 0;
1168 
1169         if shared.bug_mode
1170         then call ioa_ ("Input file - ^a", source.entryname);
1171                                         /* set a handler for aborting */
1172         on comp_abort goto file_abort;
1173 
1174         if option.debug_opt
1175         then call ioa_ ("(^a pass=^d)", shared.input_filename,
1176                   shared.pass_counter);
1177 
1178         call comp_;                     /* call formatter */
1179 
1180         if option.passes > 1 | source_list.count > 1
1181         then
1182           do;
1183             if option.passes > 1
1184             then
1185               do;
1186                 save_shared.compout_not_headed = shared.compout_not_headed;
1187                 save_shared.firstpass = "0"b;
1188               end;                      /**/
1189                                         /* close any auxiliary files */
1190             if shared.aux_file_data_ptr ^= null ()
1191             then if aux_file_data.count > 0
1192                  then
1193                    do i = 1 to aux_file_data.count;
1194                      if aux_file_data.entry (i).iocb_ptr ^= null ()
1195                      then
1196                        do;
1197                          call iox_$close (aux_file_data.entry (i).iocb_ptr,
1198                               ercd);
1199                          call iox_$detach_iocb (aux_file_data.entry (i)
1200                               .iocb_ptr, ercd);
1201                        end;
1202                      aux_file_data.count = 0;
1203                    end;
1204           end;
1205 
1206 file_abort:
1207       end;
1208 
1209       call comp_make_page_$cleanup;
1210 
1211       if const.errblk_ptr ^= null ()    /* if there is an error list */
1212       then
1213         do;
1214           if error.count > 0            /* any errors that havent been */
1215                & ^option.output_file_opt & ^option.check_opt
1216                                         /* reported? */
1217           then call print_errs;
1218         end;
1219 
1220       if option.number_opt & ^option.number_brief_opt
1221       then call print_files;
1222 
1223       if ^option.check_opt              /* close output file */
1224            & option.output_file_opt & length (bulk_file.path) = 0
1225       then
1226         do;
1227           call hcs_$set_ips_mask (""b, ips_mask);
1228                                         /* dont interrupt this */
1229           call iox_$close ((shared.compout_ptr), ercd);
1230           if ercd = 0
1231           then call iox_$detach_iocb ((shared.compout_ptr), ercd);
1232           shared.compout_ptr = null ();
1233 
1234           call hcs_$reset_ips_mask (ips_mask, ips_mask);
1235 
1236           if ercd ^= 0
1237           then
1238             do;
1239               call com_err_ (ercd, "compose",
1240                    "Closing/detaching compout file.");
1241               compose_severity_ = 5;
1242               goto clean_;
1243             end;
1244         end;
1245 
1246       if shared.compx_ptr ^= null ()    /* close the .compx file */
1247       then
1248         do;
1249           call hcs_$set_ips_mask (""b, ips_mask);
1250                                         /* dont interrupt this */
1251           call iox_$close ((shared.compx_ptr), ercd);
1252           if ercd = 0
1253           then call iox_$detach_iocb ((shared.compx_ptr), ercd);
1254           shared.compx_ptr = null ();
1255 
1256           call hcs_$reset_ips_mask (ips_mask, ips_mask);
1257 
1258           if ercd ^= 0
1259           then
1260             do;
1261               call com_err_ (ercd, "compose", "Closing/detaching compx file.");
1262               compose_severity_ = 5;
1263               goto clean_;
1264             end;
1265         end;
1266 
1267       if shared.aux_file_data_ptr ^= null ()
1268                                         /* terminate any aux files */
1269       then if aux_file_data.count > 0
1270            then
1271              do i = 1 to aux_file_data.count;
1272                if aux_file_data.entry (i).iocb_ptr ^= null ()
1273                then
1274                  do;
1275                    call iox_$close (aux_file_data.entry (i).iocb_ptr, ercd);
1276                    call iox_$detach_iocb (aux_file_data.entry (i).iocb_ptr,
1277                         ercd);
1278                    call adjust_bit_count_ ((aux_file_data.entry (i).dir),
1279                         (aux_file_data.entry (i).name), "1"b, 0, ercd);
1280                  end;
1281              end;                       /**/
1282                                         /* so clean wont try to close again */
1283       shared.aux_file_data_ptr = null ();
1284                                         /* a couple of NLs so ready */
1285       if shared.end_output &            /* message misses the form */
1286            ^(option.output_file_opt | option.check_opt)
1287       then call ioa_ ("^/");
1288 
1289       if option.debug_opt               /* capture process data */
1290       then
1291         do;
1292           call cpu_time_and_paging_ (pf_end, vcpu_end, 0);
1293           call hcs_$quota_read (get_pdir_ (), 0, 0, "0"b, "0"b, 0, pd_used_end,
1294                ercd);
1295 
1296           call ioa_ ("^5xdone (^a^26t^7.3f pf=^d qt=^d "
1297                || "blks=^d la=^d ta=^d sa=^d)", shared.input_filename,
1298                dec (vcpu_end - vcpu_start) / 1e6, pf_end - pf_start,
1299                pd_used_end - pd_used_start, tblkdata.block.count,
1300                tblkdata.line_area.count, tblkdata.text_area.count,
1301                text_area.string_area_count);
1302         end;                            /**/
1303                                         /* terminate any insert files */
1304       if const.insert_data_ptr ^= null ()
1305       then
1306         do;
1307           do i = 1 to insert_data.count;
1308             if insert_data.ptr (i) -> insert.fcb_ptr ^= null ()
1309             then call msf_manager_$close
1310                       ((insert_data.ptr (i) -> insert.fcb_ptr));
1311           end;
1312           insert_data.count, insert_data.index, insert_data.ref_area.count = 0;
1313         end;
1314 
1315 skip_file:
1316       if page.image_ptr ^= null ()      /* release the output image segment */
1317       then
1318         do;
1319           call release_temp_segment_ ("compose", page_image.text_ptr, ercd);
1320           if ercd ^= 0
1321           then
1322             do;
1323               call com_err_ (ercd, "compose",
1324                    "Releasing the output image segment.");
1325               compose_severity_ = 5;
1326               goto clean_;
1327             end;
1328         end;                            /**/
1329                                         /* release the local area */
1330       call translator_temp_$release_all_segments (const.local_area_ptr, ercd);
1331       if ercd ^= 0
1332       then
1333         do;
1334           call com_err_ (ercd, "compose", "Releasing the local storage area.");
1335           compose_severity_ = 5;
1336           goto clean_;
1337         end;
1338       const.local_area_ptr = null;      /* assure cleanliness */
1339 
1340     end input_file_loop;
1341 
1342 clean_:
1343     call comp_cleanup;                  /* END OF COMMAND - */
1344     return;                             /* RETURN TO COMMAND PROCESSOR */
1345 
1346 print_pi_stuff:                         /* PI display */
1347     on program_interrupt                /* do this only once */
1348       goto clean_;                      /**/
1349                                         /* if this null, we havent completed */
1350     if shared.insert_ptr ^= null        /* initializing and there cant be */
1351     then                                /* anything to print  */
1352       do;                               /* show file/line at QUIT/fault */
1353         call ioa_ ("Input file: ^a>^a (^a)^/Line no.:   ^d",
1354              rtrim (insert.dir), insert.entryname, insert.refname, ctl.lineno);
1355 
1356         if const.errblk_ptr ^= null ()  /* if there is an error list */
1357         then if error.count > 0         /* and errors havent been reported */
1358                   & ^option.output_file_opt & ^option.check_opt
1359              then call print_errs;
1360 
1361         if option.number_opt & ^option.number_brief_opt
1362         then call print_files;
1363       end;
1364 
1365     call iox_$control (iox_$user_input, "resetread", null (), ercd);
1366     goto clean_;
1367 
1368 /* this undocumented entry may be used externally
1369    to return to the first call state */
1370 clean:
1371   entry;                                /* if this flag is set, then */
1372     if substr (ips_mask, 36, 1)         /* ips_mask is off, turn it back on */
1373     then call hcs_$reset_ips_mask (ips_mask, ips_mask);
1374     call comp_cleanup;
1375     return;
1376 %page;
1377 /* CLEAN UP AFTER ERROR OR QUIT */
1378 
1379 comp_cleanup:
1380   proc;
1381     re_call = "0"b;                     /* reset recursive call flag; if */
1382                                         /* cleanup fails, the process is hosed anyway */
1383 
1384 
1385     if const.shared_ptr = null ()       /* nothing to clean up */
1386     then goto cln_return;               /**/
1387                                         /* clean up device writer */
1388     if const.outproc_ptr ^= null
1389     then call comp_dvt.outproc (3, ercd);
1390                                         /* dont bother me, I'm busy */
1391     call hcs_$set_ips_mask (""b, ips_mask);
1392 
1393     on cleanup call hcs_$reset_ips_mask (ips_mask, ips_mask);
1394 
1395     if shared.fcb_ptr ^= null ()        /* terminate input file */
1396     then call msf_manager_$close ((shared.fcb_ptr));
1397                                         /* terminate any insert files */
1398     if const.insert_data_ptr ^= null ()
1399     then
1400       do i = 1 to insert_data.count;
1401         if insert_data.ptr (i) -> insert.fcb_ptr ^= null ()
1402         then call msf_manager_$close ((insert_data.ptr (i) -> insert.fcb_ptr));
1403       end;
1404 
1405     if const.option_ptr ^= null ()
1406     then if option.output_file_opt      /* close the output file */
1407               & shared.compout_ptr ^= null ()
1408          then
1409            do;
1410              call iox_$close ((shared.compout_ptr), ercd);
1411              call iox_$detach_iocb ((shared.compout_ptr), ercd);
1412            end;
1413 
1414     if shared.compx_ptr ^= null ()      /* and the compx file */
1415     then
1416       do;
1417         call iox_$close ((shared.compx_ptr), ercd);
1418         call iox_$detach_iocb ((shared.compx_ptr), ercd);
1419       end;
1420 
1421     if shared.aux_file_data_ptr ^= null ()
1422                                         /* close any auxiliary files */
1423     then if aux_file_data.count > 0
1424          then
1425            do i = 1 to aux_file_data.count;
1426              if aux_file_data.entry (i).iocb_ptr ^= null ()
1427              then
1428                do;
1429                  call iox_$close (aux_file_data.entry (i).iocb_ptr, ercd);
1430                  call iox_$detach_iocb (aux_file_data.entry (i).iocb_ptr, ercd)
1431                       ;
1432                end;
1433              aux_file_data.count = 0;
1434            end;
1435     shared.aux_file_data_ptr = null (); /* keep it clean! */
1436 
1437     if const.errblk_ptr ^= null ()      /* if there is an error list */
1438     then call release_temp_segment_ ("compose", (const.errblk_ptr), ercd);
1439 
1440     if const.page_ptr ^= null
1441     then if page.image_ptr ^= null ()
1442          then call release_temp_segment_ ("compose", page_image.text_ptr, 0);
1443 
1444     if const.local_area_ptr ^= null
1445     then call translator_temp_$release_all_segments (const.local_area_ptr, 0);
1446     call translator_temp_$release_all_segments (const.global_area_ptr, 0);
1447     call hcs_$reset_ips_mask (ips_mask, ips_mask);
1448 
1449 cln_return:
1450     return;
1451   end comp_cleanup;
1452 
1453 print_errs:
1454   proc;                                 /* print the error list */
1455 
1456     on cleanup goto clean_;
1457 
1458     call ioa_ ("^/compose error list: ^d error^[s^] (Vers. ^a)", error.count,
1459          (error.count > 1), const.comp_version);
1460 
1461     if ^option.brief_opt
1462     then
1463       do;
1464         call iox_$put_chars (iox_$user_output, addr (error.text), error.next,
1465              ercd);
1466       end;
1467 
1468     call release_temp_segment_ ("compose", const.errblk_ptr, ercd);
1469 
1470   end print_errs;
1471 
1472 print_files:
1473   proc;
1474 
1475     dcl file_list_iocbp
1476                        ptr;
1477     dcl refptr         ptr;
1478 
1479     dcl ioa_$ioa_switch
1480                        entry options (variable);
1481 
1482     if const.option_ptr = null () | const.insert_data_ptr = null ()
1483     then return;                        /* no option or insert_data block */
1484                                         /* if the file list is wanted */
1485     if option.number_opt & ^option.number_brief_opt
1486     then
1487       do;
1488         if option.number_append_opt & option.output_file_opt
1489         then file_list_iocbp = shared.compout_ptr;
1490         else file_list_iocbp = iox_$user_output;
1491                                         /* show source file */
1492         call ioa_$ioa_switch (file_list_iocbp, "^/^-^a^[^/^]^42t^a",
1493              call_box0.refname, (length (call_box0.refname) >= 32),
1494              call_box0.path);
1495 
1496         do i = 1 to insert_data.ref_area.count;
1497                                         /* show insert files */
1498           refptr = insert_data.ref_area.ptr (i);
1499           do j = 1 to refptr -> insert_refs.count;
1500             call ioa_$ioa_switch (file_list_iocbp, "^4d^-^a^42t^a",
1501                  60 * (i - 1) + j, rtrim (refptr -> insert_refs.name (j)),
1502                  insert_data.ptr (refptr -> insert_refs.index (j))
1503                  -> insert.path);
1504           end;
1505         end;
1506 
1507         if option.output_file_opt
1508         then call ioa_$ioa_switch (file_list_iocbp, "^|");
1509       end;
1510   end print_files;
1511 
1512     dcl dt_sw          bit (1) static init ("0"b);
1513 dtn:
1514   entry;
1515     dt_sw = "1"b;
1516     return;
1517 dtf:
1518   entry;
1519     dt_sw = "0"b;
1520     return;
1521 %page;
1522 /* LOCAL STORAGE */
1523 
1524     dcl                                 /* bit index values for option flags */
1525         (
1526         arg_optndx     init (1),        /* -arguments */
1527         cb_optndx      init (2),        /* -change_bars */
1528         cba_optndx     init (3),        /* -change_bars_artwork */
1529         db_optndx      init (4),        /* -debug  */
1530         dba_optndx     init (5),        /* -debug_all */
1531         dbf_optndx     init (6),        /* -debug_file */
1532         dv_optndx      init (7),        /* -device */
1533         ex_optndx      init (8),        /* -execute */
1534         fm_optndx      init (9),        /* -from */
1535         gl_optndx      init (10),       /* -galley */
1536         hyph_optndx    init (11),       /* -hyphenate */
1537         ind_optndx     init (12),       /* -indent */
1538         if_optndx      init (13),       /* -input_file */
1539         ls_optndx      init (14),       /* -linespace */
1540         of_optndx      init (15),       /* -output_file */
1541         pg_optndx      init (16),       /* -pages */
1542         pgc_optndx     init (17),       /* -pages_changed */
1543         pm_optndx      init (18),       /* -parameter */
1544         pass_optndx    init (19),       /* -passes */
1545         tdir_optndx    init (20),       /* -temp_dir - NOT IMPLEMENTED */
1546         to_optndx      init (21)        /* -to */
1547         )              fixed bin static options (constant);
1548 /**** format: off */
1549       dcl 1 option_data  static options (constant),
1550             2 opt_name   (77) char (32) unal init (
1551                                         /* option names */
1552                                         /* CONTROL ARGS WITH PARAMETERS */
1553                "-arguments", "-ag",     /* -arguments */
1554                "-change_bars", "-cb",   /* -change_bars {A} {m}{l}{r}{d} */
1555                "-change_bars_art", "-cba", /* -change_bars_art {A} {m}{l}{r}{d} */
1556                "-debug", "", "",        /* -debug {n1}{,n2} - UNDOCUMENTED */
1557                "-debug_all", "",        /* -debug_all {n}{,n2} - UNDOCUMENTED */
1558                "-debug_file", "",       /* -debug_file {name} - UNDOCUMENTED */
1559                "-device", "-dev", "-dv",/* -device {name} */
1560                "-execute", "-ex",       /* -execute */
1561                "-from", "-fm",          /* -from {n} */
1562                "-galley", "-gl",        /* -galley {n1}{,n2} */
1563                "-hyphenate", "-hyph", "-hph", /* -hyphenate {size} */
1564                "-indent", "-in", "-ind", /* -indent {n} */
1565                "-input_file", "-if",    /* -input_file path */
1566                "-linespace", "-ls",     /* -linespace {n} */
1567                "-output_file", "-of",   /* -output_file {path} */
1568                "-pages", "-pgs", "-page", "-pg", /* -pages {n,n} */
1569                "-pages_changed", "-pgc",/* -pages_changed {A} */
1570                "-parameter", "-pm",     /* -parameter {string} */
1571                "-passes", "-pass",      /* -pass {n} */
1572                "-temp_dir", "-tdir", "-td", /* -temp_dir <path> */
1573                "-to",                   /* -to {n} */
1574                                         /* CONTROL ARGS WITHOUT PARAMETERS */
1575                "-annotate", "-ann",     /* -annotate */
1576                "-brief", "-bf",         /* -brief */
1577                "-check", "-ck",         /* -check */
1578                "", "",                  /* -cws - OBSOLETE */
1579                "-debug_pause", "",      /* -debug_pause - UNDOCUMENTED See comp_read_ */
1580                "-noart", "-noa",        /* -noart */
1581                "-nobell", "-no_bell", "-nob", /* -nobell */
1582                "-nofill", "-nof",       /* -nofill */
1583                "-nohit", "-noh",        /* -nohit */
1584                "-number", "-nb",        /* -number  */
1585                "-number_append", "-nba",/* -number_append */
1586                "-number_brief", "-nbb", /* -number_brief */
1587                "-stop", "-sp",          /* -stop */
1588                "-wait", "-wt"),         /* -wait */
1589                                         /* flag bit index values */
1590             2 flag_index (77) fixed bin init (1, 1
1591                                         /* -arguments {s s ...} */
1592                          , 2, 2         /* -change_bars {A}
1593                                            {m}{left}{right}{delete} */
1594                          , 3, 3         /* -change_bars_art {A}
1595                                            {m}{left}{right}{delete} */
1596                          , 4, 4, 4      /* -debug {n1}{,n2} UNDOCUMENTED */
1597                          , 5, 5         /* -debug_all {n1}{,n2} UNDOCUMENTED */
1598                          , 6, 6         /* -debug_file {name} UNDOCUMENTED */
1599                          , 7, 7, 7      /* -device {name} */
1600                          , 8, 8         /* -execute {"<ctl> <ctl> ... "} */
1601                          , 9, 9         /* -from {n} */
1602                          , 10, 10       /* -galley {n2}{,n2} */
1603                          , 11, 11, 11   /* -hyphenation <size> */
1604                          , 12, 12, 12   /* -indent <n> */
1605                          , 13, 13       /* -input_file path */
1606                          , 14, 14       /* -linespace <N> */
1607                          , 15, 15       /* -output_file <name> */
1608                          , 16, 16, 16, 16
1609                                         /* -pages {n,n} */
1610                          , 17, 17       /* -pages_changed {A} */
1611                          , 18, 18       /* -parameter <string> */
1612                          , 19, 19       /* -pass <n> */
1613                          , 20, 20, 20   /* -temp_dir <path> */
1614                          , 21           /* -to <n> */
1615                          , 22, 22       /* -annotote */
1616                          , 23, 23       /* -brief */
1617                          , 24, 24       /* -check */
1618                          , 25, 25       /* -compress_white_space - OBSOLETE */
1619                          , 26, 26       /* -debug_pause UNDOCUMENTED
1620                                            See comp_read_ */
1621                          , 27, 27       /* -noart */
1622                          , 28, 28, 28   /* -nobell */
1623                          , 29, 29       /* -nofill */
1624                          , 30, 30       /* -nohit */
1625                          , 31, 31       /* -number */
1626                          , 32, 32       /* -number_append */
1627                          , 33, 33       /* -number_brief */
1628                          , 34, 34       /* -stop */
1629                          , 35, 35);     /* -wait */
1630 /**** format: on */
1631 
1632     dcl argl           fixed;           /* command line argument length */
1633     dcl argp           ptr;             /* command line argument pointer */
1634     dcl atd            char (256);      /* attach desc for compout file */
1635                                         /* something smelly in command line */
1636     dcl badcall        bit (1) init ("0"b);
1637     dcl 1 bulk_file,                    /* data for bulk output file */
1638           2 dir        char (168) init (""),
1639           2 entryname  char (32) init (""),
1640           2 path       char (200) var init (""),
1641                                         /* seg pointer for overwrite check */
1642           2 ptr        ptr init (null);
1643     dcl dsm_dir        char (168);      /* dir containing comp_dsm */
1644                                         /* path of comp_dsm */
1645     dcl dsm_path       char (200) init ("");
1646     dcl ctltxtptr      ptr;             /* pointer to control line structure */
1647                                         /* local name of compose's dir */
1648     dcl compose_dir    char (168) aligned;
1649     dcl compout_name   char (32);       /* local name of compout file */
1650                                         /* path of compout file */
1651     dcl compout_path   char (200) var;
1652     dcl compout_seg_ptr                 /* pointer to **.compout */
1653                        ptr;
1654     dcl dsm_baseptr    ptr;
1655     dcl dsm_ercd       fixed bin (35);  /* error code for device module */
1656     dcl ercd           fixed bin (35);  /* system error code */
1657     dcl filndx         fixed bin;       /* index into source file table */
1658     dcl hscales        (7) fixed bin (31) static options (constant)
1659                        init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
1660     dcl (i, j)         fixed bin;       /* working index */
1661     dcl iarg           fixed bin;       /* command line argument counter */
1662     dcl ips_mask       bit (36) aligned static init (""b);
1663     dcl local_arg      char (200) var;  /* local copy of ctl arg for parsing */
1664     dcl 1 meas1        aligned like text_entry.cur;
1665                                         /* for cbar measuring */
1666     dcl 1 meas2        aligned like text_entry.cur;
1667                                         /* for cbar measuring */
1668     dcl nargs          fixed init (0);  /* number of command line arguments */
1669     dcl 1 null_info    aligned like text_entry.info;
1670     dcl option_keyword char (32);       /* option keyword for errors */
1671     dcl optndx         fixed bin;       /* flag index value for options */
1672     dcl optnptr        ptr;             /* pointer to option bit string */
1673     dcl optns          (36) bit (1) unal based (optnptr);
1674                                         /* option flag string */
1675     dcl pd_used_end    fixed (18);      /* pdir quota used at termination */
1676     dcl pd_used_start  fixed (18);      /* pdir quota used at invocation */
1677     dcl pf_end         fixed (35);      /* page faults at termination */
1678     dcl pf_start       fixed (35);      /* page faults at invocation */
1679                                         /* recursive call flag */
1680     dcl re_call        bit (1) static init ("0"b);
1681     dcl 1 source       aligned like insert based (source_ptr);
1682     dcl source_ptr     ptr;
1683     dcl 1 source_file  aligned like insert.file based (source_file_ptr);
1684     dcl source_file_ptr
1685                        ptr;
1686     dcl 1 source_list  aligned static,  /* source file table */
1687           2 count      fixed bin,       /* file count */
1688           2 ptr        (200) ptr;       /* data block pointers */
1689     dcl vcpu_start     fixed (71);      /* vcpu microseconds at invocation */
1690     dcl vcpu_end       fixed (71);      /* vcpu microseconds at termination */
1691     dcl wdir           char (168) init ("");
1692                                         /* working dir */
1693 
1694     dcl adjust_bit_count_
1695                        entry (char (168), char (32), bit (1), fixed,
1696                        fixed (35));
1697     dcl com_err_       entry options (variable);
1698     dcl cpu_time_and_paging_
1699                        entry (fixed bin (35), fixed bin (71), fixed bin (35));
1700     dcl cu_$arg_count  entry (fixed bin);
1701     dcl cu_$arg_ptr    entry (fixed bin, ptr, fixed bin, fixed bin (35));
1702     dcl expand_pathname_
1703                        entry (char (*), char (*), char (*), fixed bin (35));
1704     dcl expand_pathname_$add_suffix
1705                        entry (char (*), char (*), char (*), char (*) aligned,
1706                        fixed bin (35));
1707     dcl get_pdir_      entry returns (char (168));
1708     dcl get_quota      entry options (variable);
1709     dcl get_wdir_      entry returns (char (168));
1710     dcl hcs_$fs_get_path_name
1711                        entry (ptr, char (*) aligned, fixed bin (35),
1712                        char (*) aligned, fixed bin (35));
1713     dcl hcs_$initiate  entry (char (*), char (*) aligned, char (*) aligned,
1714                        fixed bin (1), fixed bin (2), ptr, fixed bin (35));
1715     dcl hcs_$make_ptr  entry (ptr, char (*) aligned, char (*) aligned, ptr,
1716                        fixed bin (35));
1717     dcl hcs_$make_seg  entry (char (*) aligned, char (*) aligned, char (*),
1718                        fixed bin (5), ptr, fixed bin (35));
1719     dcl hcs_$quota_read
1720                        entry (char (*), fixed bin (18), fixed bin (71),
1721                        bit (36) aligned, bit (36), fixed bin (1),
1722                        fixed bin (18), fixed bin (35));
1723     dcl hcs_$reset_ips_mask
1724                        entry (bit (36) aligned, bit (36) aligned);
1725     dcl hcs_$set_ips_mask
1726                        entry (bit (36) aligned, bit (36) aligned);
1727     dcl hcs_$set_max_length_seg
1728                        entry (ptr, fixed bin (18), fixed bin (35));
1729     dcl hcs_$truncate_seg
1730                        entry (ptr, fixed bin (19), fixed bin (35));
1731     dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24),
1732                        fixed bin (35));
1733     dcl iox_$attach_name
1734                        entry (char (*), ptr, char (*), ptr, fixed bin (35));
1735     dcl iox_$close     entry (ptr, fixed bin (35));
1736     dcl iox_$control   entry (ptr, char (*), ptr, fixed (35));
1737     dcl iox_$detach_iocb
1738                        entry (ptr, fixed bin (35));
1739     dcl iox_$open      entry (ptr, fixed bin (35), bit (1) aligned,
1740                        fixed bin (35));
1741     dcl iox_$put_chars entry (ptr, ptr, fixed bin (35), fixed bin (35));
1742     dcl msf_manager_$close
1743                        entry (ptr);
1744     dcl pathname_      entry (char (*), char (*)) returns (char (168));
1745     dcl release_temp_segment_
1746                        entry (char (*), ptr, fixed bin (35));
1747     dcl search_paths_$find_dir
1748                        entry (char (*), ptr, char (*), char (*), char (*),
1749                        fixed bin (35));
1750     dcl suffixed_name_$new_suffix
1751                        entry (char (*), char (*), char (*), char (32),
1752                        fixed bin (35));
1753     dcl term_$seg_ptr  entry (ptr, fixed bin (35));
1754     dcl term_$single_refname
1755                        entry (char (*) aligned, fixed bin (35));
1756     dcl terminate_file_
1757                        entry (ptr, fixed bin (24), bit (*), fixed bin (35));
1758     dcl translator_temp_$release_all_segments
1759                        entry (ptr, fixed bin (35));
1760 
1761 /* EXTERNAL STORAGE */
1762 
1763     dcl arg            char (argl) based (argp);
1764                                         /* command line argument */
1765     dcl command_arg    (command_arg_ct) char (1020) var
1766                        based (command_arg_ptr);
1767     dcl command_arg_ct fixed bin;
1768     dcl command_arg_ptr
1769                        ptr;             /* control arg names string */
1770     dcl ctlargstr      char (32 * hbound (option_data.opt_name, 1))
1771                        based (addr (option_data.opt_name));
1772 
1773     dcl (addr, after, before, baseno, bin, char, dec, divide, empty, hbound,
1774         index, length, ltrim, max, min, null, pointer, rtrim, search, size,
1775         stackbaseptr, substr, unspec, verify)
1776                        builtin;
1777 
1778     dcl (cleanup, comp_abort, conversion, program_interrupt)
1779                        condition;
1780 
1781     dcl (
1782         error_table_$badopt,
1783         error_table_$entlong,
1784         error_table_$namedup,
1785         error_table_$noarg,
1786         error_table_$noentry,
1787         error_table_$segknown,
1788         error_table_$unimplemented_version
1789         )              fixed (35) ext static;
1790 %page;
1791 %include access_mode_values;
1792 %include comp_aux_file;
1793 %include comp_column;
1794 %include comp_dvid;
1795 %include comp_dvt;
1796 %include comp_entries;
1797 %include comp_error;
1798 %include comp_fntstk;
1799 %include comp_footnotes;
1800 %include comp_insert;
1801 %include comp_option;
1802 %include comp_page;
1803 %include comp_shared;
1804 %include comp_text;
1805 %include compstat;
1806 %include terminate_file;
1807 %include translator_temp_alloc;
1808 
1809   end compose;