1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         * Copyright (c) 1972 by Massachusetts Institute of        *
   8         * Technology and Honeywell Information Systems, Inc.      *
   9         *                                                         *
  10         *********************************************************** */
  11 
  12 
  13 
  14 
  15 /****^  HISTORY COMMENTS:
  16   1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
  17      audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
  18      MCR8060 cobol.pl1 Reformatted code to new Cobol standard.
  19                                                    END HISTORY COMMENTS */
  20 
  21 
  22 /* Modified on 10/1/83 by FCH, [5.2...]. trace added */
  23 /* Modified on 11/25/81 by FCH, [5.1-3], main prog added to include file table, BUG519(phx11818) */
  24 /* Modified on 10/23/81 by FCH, [5.1-2], issue diag if long line found, phx11819(BUG517) */
  25 /* Modified on 10/13/81 by FCH, [5.1-1], hisi data alloc algorithm if cobol$multics */
  26 /* Modified on 10/02/81 by FCH, [5.0-1], formatting not forced if first char was tab, BUG511 */
  27 /* Modified on 07/11/81 by FCH, [4.4-9], work files clobbered if corres and debug phases used, phx10380(BUG492) */
  28 /* Modified on 05/27/81 by FCH, [4.4-8], size of work files reset to zero, phx09988(BUG485) */
  29 /* Modified on 05/26/81 by FCH, [4.4-7], cobol_ecs_info replaced by sys incl file status_structures, phx09946(BUG484) */
  30 /* Modified on 05/25/81 by FCH, [4.4-6], change message emitted when -table and -fmt used, phx09946(BUG484) */
  31 /* Modified on 05/19/81 by FCH, [4.4-5], default is table */
  32 /* Modified on 05/19/81 by FCH, [4.4-4], -sv and -lev may optionally be followed by spaces */
  33 /* Modified on 12/01/80 by FCH, [4.4-3], report writer phase added */
  34 /* Modified on 10/22/80 by FCH, COBOL_SYNTAX_TRACE_ changed to cobol_syntax_trace_ */
  35 /* Modified on 10/17/80 by PRP, [4.4-2], TR7956(BUG446), temp segs not cleaned up on bad arg error */
  36 /* Modified on 08/15/80 by FCH, [4.4-1], TR6483(BUG440), zero length source seg caused compiler to abort */
  37 /* Modified on 2/27/80 by PRP, [4.2-4], phx05396b  -sv4 fixed */
  38 /* Modified on 02/14/80 by FCH, [4.2-3], answered phx05331s */
  39 /* Modified on 02/12/80 by MHD, [4.2-2], answered phx05237o, phx05238u, and phx05231b */
  40 /* Modified on 10/26/79 by MHD, [4.1-3], left cobol_m2fp pointing to last minpral-2 for appending type 25 tokens */
  41 /* Modified on 10/18/79 by MHD, [4.1-2], deleted unused parameter to cobol_print_diag */
  42 /* Modified on 10/12/79 by FCH, [4.1-1], -card, revision to .ex.cobol */
  43 /* Modified on 08/17/79 by PRP, [4.0-6], fixed warning message for -fmt and -tb */
  44 /* Modified on 06/08/79  by PRP, [4.0-5], recursive call to compiler eliminated */
  45 /* Modified on 04/09/79 by FCH, [4.0-4], compatibility entry points added added */
  46 /* Modified on 04/02/79 by FCH, [4.0-3], debug phase added */
  47 /* Modified on 03/30/79 by FCH, [4.0-2], option -svNM added */
  48 /* Modified on 02/26/79 by FCH, [4.0-1], option -levN M added */
  49 /* Modified on 1/31/79 by FCH, [3.0-11], cobol equiv to cobol$id */
  50 /* Modified on 10/25/78 by RAL, [3.0-10], initilize ecs_info_table.diag_indicators */
  51 /* Modified on 10/25/78 by FCH, [3.0-9], area allocation standardized */
  52 /* Modified on 10/23/78 by RAL, [3.0-8], COPY ... REPLACING and REPLACE statements */
  53 /* Modified on 09/12/78 by RAL, [3.0-7], warning about the use of -tb and -fmt and probing source */
  54 /* Modified on 06/22/78 by RAL, [3.0-6], entries cobol$(push_name pop_name) */
  55 /* Modified on 06/06/78 by FCH, [3.0-5], delete list file before compilation */
  56 /* Modified on 05/24/78 by FCH, [3.0-4], logic of condition handling rewritten */
  57 /* Modified on 04/27/78 by FCH, [3.0-3], symbol section(compiler options) */
  58 /* Modified on 04/27/78 by FCH, [3.0-2], symbol section(source module path name) */
  59 /* Modified on 01/24/78 by FCH, [3.0-1], xref listing suppressed if fatals */
  60 /* Modified since Version 3.0 */
  61 
  62 
  63 
  64 
  65 
  66 
  67 
  68 /* format: style3 */
  69 cobol:
  70      proc;
  71 
  72 /*   This is the driver for the Multics COBOL compiler.
  73 It processes all compiler control options, establishes the source
  74 segment, and calls each phase of the compiler in order:
  75 
  76      Front:
  77           cobol_lex           (LEX)
  78           cobol_idedsyn       (ID/ED SYNTAX)
  79           cobol_ddsyntax      (DD SYNTAX)
  80           cobol_ddalloc       (DD ALLOCATION)
  81           cobol_repl3         (REPLACEMENT)
  82           cobol_ci_phase      (CORRESPONDING)
  83           cobol_pdstax        (PD SYNTAX)
  84           cobol_print_diag    (PRINT DIAG)
  85      Back:
  86           cobol_gen_driver_   (GENERATOR)
  87           cobol_make_xref_    (ANALYZER)
  88           cobol_fix_driver_   (FIXUP)
  89 
  90 All files used by the various phases are declared, opened and closed
  91 by the driver.  */
  92 
  93 /*************************************/
  94 id:
  95      entry;                                                 /*[3.0-11]*/
  96 
  97           string (trace) = ""b;
  98           MODE = 0;
  99           go to start;
 100 
 101 /*************************************/
 102 trace:
 103      entry;
 104 
 105           string (trace) = "1000"b;
 106           MODE = 0;
 107 
 108           go to start;
 109 
 110 rw:
 111      entry;
 112 
 113 /*[4.4-0]*/
 114           MODE = 5;                                         /*[4.4-0]*/
 115           go to start;
 116 
 117 gcos:
 118      entry;
 119 
 120 /*[4.0-4]*/
 121           call set_mode (1);                                /*[4.0-4]*/
 122           go to start;
 123 
 124 ibm_ansi:
 125      entry;
 126 
 127 /*[4.0-4]*/
 128           call set_mode (2);                                /*[4.0-4]*/
 129           go to start;
 130 
 131 ibm_ef:
 132      entry;
 133 
 134 /*[4.0-4]*/
 135           call set_mode (3);                                /*[4.0-4]*/
 136           go to start;
 137 
 138 multics:
 139      entry;
 140 
 141 /*[4.0-4]*/
 142           call set_mode (4);                                /*[4.0-4]*/
 143           go to start;
 144 
 145 copy_file_size:
 146      entry (bc);
 147 
 148 /*[5.1-2]*/
 149           call cobol_merge$copy_file_size (bc);             /*[5.1-2]*/
 150           return;
 151 
 152 /*[5.1.2]*/
 153 dcl       cobol_merge$copy_file_size
 154                               entry (fixed bin (24));       /*[5.1-2]*/
 155 dcl       bc                  fixed bin (24);
 156 
 157 push_name:
 158      entry (dir_name, entryname);                           /* [3.0-6] */
 159 
 160 /* This is called to push the source name and
 161                                   all include files onto a stack to be
 162                                     used to build the symbol table */
 163 
 164 
 165 dcl       dir_name            char (168);
 166 dcl       entryname           char (32);
 167 
 168           call hcs_$status_long (dir_name, entryname, 1, addr (branch_status), null (), mcode);
 169 
 170           c_name.ct = c_name.ct + 1;
 171 
 172 /* [3.0-9] */
 173           allocate source_name in (cobol_area) set (source_name_ptr);
 174                                                             /* [3.0-9] */
 175           source_name.prev_name_ptr = c_name.last_name_ptr; /* [3.0-9] */
 176           c_name.last_name_ptr = source_name_ptr;           /* [3.0-9] */
 177 
 178           l_dn = index (dir_name, " ") - 1;
 179           l_en = index (entryname, " ") - 1;
 180 
 181           source_name.sname = substr (dir_name, 1, l_dn) || ">" || substr (entryname, 1, l_en);
 182                                                             /*[4.4-7]*/
 183           source_name.uid = branch_status.uid;              /*[4.4-7]*/
 184           source_name.dtm = branch_status.dtcm;
 185 
 186           return;
 187 
 188 
 189 pop_name:
 190      entry returns (ptr);                                   /* [3.0-6] */
 191 
 192 /* This is call to pop the names off of
 193                                   a stack by cobol_sym_init.pl1 */
 194 
 195 /* [3.0-9] */
 196           if c_name.last_name_ptr = null ()
 197           then return (null ());                            /* [3.0-9] */
 198                                                             /* [3.0-9] */
 199           c_name.pname = c_name.last_name_ptr -> source_name.sname;
 200                                                             /* [3.0-9] */
 201           c_name.uid = c_name.last_name_ptr -> source_name.uid;
 202                                                             /* [3.0-9] */
 203           c_name.dtm = c_name.last_name_ptr -> source_name.dtm;
 204                                                             /* [3.0-9] */
 205           c_name.last_name_ptr = c_name.last_name_ptr -> source_name.prev_name_ptr;
 206 
 207           c_name.size = index (c_name.pname, " ") - 1;
 208           if c_name.size = -1
 209           then c_name.size = 168;
 210 
 211           return (addr (c_name));
 212 
 213 /* [3.0-9] */
 214 
 215 alloc:
 216      entry (alloc_size) returns (ptr);
 217 
 218 declare   alloc_size          fixed bin (35);               /**/
 219                                                             /**/
 220           allocate words in (cobol_area) set (source_name_ptr);
 221                                                             /**/
 222                                                             /**/
 223           return (source_name_ptr);                         /**/
 224 
 225 
 226 clean_up:
 227      entry;
 228 
 229 /*  This entry is called as a command to cleanup the compile time files. */
 230 /* The calling sequence is:
 231                                         cobol$clean_up
 232                               /*}*/
 233           if fpath ^= ""
 234           then do segname = "cobol_seg1_", "cobol_seg2_", "cobol_seg3_", "cobol_initval_", "cobol_ntbuff_",
 235                     "cobol_minpral-1_", "cobol_minpral-2_", /*[4.4-3]*/
 236                     "rwdd.incl.cobol", "rwpd.incl.cobol", "cobol_rmin2_", "cobol_r2min2_", "cobol_print_", "cobol_diags_",
 237                     "cobol_pdout_", "cobol_corrout_", "cobol_minpral-1_1", "cobol_minpral-2_1", "cobol_rmin2_1",
 238                     "cobol_pdout_1", "cobol_minpral-1_2", "cobol_minpral-2_2", "cobol_rmin2_2", "cobol_pdout_2",
 239                                                             /**/
 240                                                             /*                            "cobol_minpral-1_3","cobol_minpral-2_3","cobol_rmin2_3","cobol_pdout_3",
 241 /*                            "cobol_minpral-1_4","cobol_minpral-2_4","cobol_rmin2_4","cobol_pdout_4",
 242 /*                            "cobol_minpral-1_5","cobol_minpral-2_5","cobol_rmin2_5","cobol_pdout_5",
 243 /**/
 244                     "cobol_common_", "cobol_name_table_", "cobol_format_temp_";
 245 
 246                     call hcs_$delentry_file (fpath, segname, mcode);
 247 
 248                end;
 249 
 250           return;
 251 
 252 
 253 /*************************************/
 254 
 255 restart:
 256      entry;
 257 
 258           if ^restart
 259           then return;
 260 
 261           if abort_sw
 262           then go to finish;
 263           else abort_sw = "1"b;
 264 
 265           if intact
 266           then call cu_$cl;
 267           else if endgen_sw
 268           then go to finish;
 269           else if gen_sw
 270           then go to no_gen;
 271           else go to start_print_diag;
 272 
 273 define_data:
 274      entry;
 275 
 276 /*[5.1-2]*/
 277           call ided;                                        /*[5.1-2]*/
 278           call dd;
 279 
 280 /*[5.1-2]*/
 281           return;
 282 
 283 /*************************************/
 284 /* INITIALIZATION */
 285 
 286 start:    /***.....  Trace_Bit="0"b;/**/
 287           /***.....  Trace_Lev=1;/**/
 288           /***.....  Trace_Line=(60)".";/**/
 289           if recursion
 290           then do;
 291 
 292 /*[4.0-5]*/
 293                     call ioa_$ioa_stream ("error_output",
 294                          "cobol: Translation failed. Attempt to invoke COBOL recursively use release first.");
 295 
 296 /*[4.0-5]*/
 297                     return;
 298                end;
 299           else recursion = "1"b;
 300 
 301 /*[5.1-2]*/
 302           lex_quit = LEX_QUIT;                              /*[5.1-2]*/
 303           comp_term = COMP_TERM;
 304 
 305 /*[4.0-5]*/
 306 /* ESTABLISH CONDITION HANDLERS */
 307 
 308           on command_abort call COND ("command_abort");     /* [3.0-4] */
 309           on command_abort_ call COND ("command_abort_");   /* [3.0-4] */
 310           on cleanup call CLEANUP;
 311 
 312 
 313           restart = "0"b;
 314           cobol_sfp = null ();
 315           cobol_x2_fileno = 0;                              /* for optional jif file */
 316           p_err = "0"b;
 317           area_info_area.areap = null ();
 318 
 319           call cu_$af_arg_count (pc, mcode);
 320 
 321           if mcode = 0
 322           then do;
 323 
 324                     call com_err_ (0, "cobol", "This command may not be invoked as an active function");
 325                     go to comp_term;
 326 
 327                end;
 328           else if mcode ^= error_table_$not_act_fnc
 329           then do;
 330 
 331                     call com_err_ (mcode, "cobol");
 332                     go to comp_term;
 333 
 334                end;
 335 
 336           if pc = 0
 337           then /* if no arguments list options */
 338                do;
 339 
 340                     call print_options;
 341                     go to comp_term;
 342 
 343                end;
 344 
 345 
 346 /*[5.1-2]*/
 347           call init_cobol;
 348 
 349 /*[5.1-2]*/
 350           do i = 1 to pc;
 351 
 352 /*[5.1-2]*/
 353                call cu_$arg_ptr (i, arg_ptr, l, mcode);
 354 
 355 /*[5.1-2]*/
 356                call option;
 357 
 358 /*[5.1-2]*/
 359           end;
 360 
 361 /*[5.1-2]*/
 362           call setup;                                       /* initialize for compilation */
 363                                                             /*[5.1-2]*/
 364           call expand_phase;                                /* expand_phase_cobol_source */
 365 
 366 
 367 
 368 /*[5.1-2]*/
 369           call lex;                                         /* lexical analysis phase */
 370 
 371 /*[5.1-2]*/
 372           call cobol$define_data;
 373 
 374 /*[5.1-2]*/
 375           call ddalloc;                                     /* dd allocation phase */
 376 
 377 /*[5.1-2]*/
 378           call replace;                                     /* replacement phase */
 379 
 380 /*[5.1-2]*/
 381           call db_corr;                                     /* debug, corresponding phase */
 382 
 383 
 384 
 385 /*[5.1-2]*/
 386 /* pd syntax analysis phase */
 387 
 388           if time
 389           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
 390 
 391           fixed_common.syntax_trace = trace.pd;
 392 
 393 /*[5.1-2]*/
 394           call cobol_pdstax;
 395 
 396 /*[5.1-2]*/
 397           if mcode ^= 0
 398           then return;
 399 
 400           call cobol_swf_close (cobol_dfp, ST, tptr, 0);
 401 
 402           if time
 403           then call timer ("PD_SYNTAX.....");
 404 
 405 start_print_diag:                                           /*[5.1-2]*/
 406           call print_diag;                                  /*[5.1-2]*/
 407           call generator;
 408 
 409 no_gen:
 410           endgen_sw = "1"b;
 411 
 412 /*[5.1-2]*/
 413           call analyzer;
 414 
 415 /*[5.1-2]*/
 416           if fixed_common.fatal_no = 0 & opts.cu & ^abort_sw/*[5.1-2]*/
 417           then call fixup;
 418 
 419 finish:                                                     /*[5.1-2]*/
 420           call finish_proc;
 421 
 422           return;
 423 
 424 
 425 /* GENERALIZED ERROR PROCESSING */
 426 
 427 arg_error:
 428           call com_err_ (error_table_$badopt, "cobol", argb);
 429 
 430           go to COMP_TERM;
 431 
 432 missing_arg_error:
 433           call com_err_ (error_table_$noarg, "cobol");
 434 
 435           go to COMP_TERM;
 436 
 437 
 438 
 439 multics_error:
 440           segname = "";
 441 
 442 multics_file_error:
 443           call com_err_ (mcode, "cobol", "  ^a", segname);
 444 
 445 COMP_TERM:
 446           call finis;
 447 
 448           recursion = "0"b;
 449           return;
 450 
 451 LEX_QUIT:                                                   /*[5.1-2]*/
 452           call CLEANUP;                                     /*[5.1-2]*/
 453           call finis;
 454 
 455 /*[5.1-2]*/
 456           return;
 457 
 458 
 459 
 460 
 461 
 462 set_mode:
 463      proc (num);
 464 
 465 /*[4.0-4]*/
 466 declare   num                 fixed bin;
 467 
 468 /*[4.0-4]*/
 469           MODE = num;                                       /*[4.0-4]*/
 470           string (trace) = ""b;
 471 
 472      end;
 473 
 474 ssv:
 475      proc;
 476 
 477 /*[4.4-4]*/
 478 declare   ch                  char (1);
 479 
 480 /*[4.4-4]*/
 481           call cl_arg_check;
 482 
 483 /*[4.4-4]*/
 484           if m ^= 1
 485           then go to arg_error;
 486 
 487 /*[4.4-4]*/
 488           ch = substr (argb, 1, 1);
 489 
 490 /*[4.4-4]*/
 491           if ch < "1" | ch > "4"
 492           then go to arg_error;
 493 
 494 /*[4.4-4]*/
 495           call setsv (ch);
 496 
 497 /*[4.4-4]*/
 498           substr (arg, l, 2) = " " || ch;                   /*[4.4-4]*/
 499           l = l + 2;
 500 
 501      end;
 502 
 503 slv:
 504      proc;
 505 
 506 /*[4.4-4]*/
 507 declare   (ch1, ch2)          char (1);
 508 
 509 /*[4.4-4]*/
 510           ch2 = " ";
 511 
 512 /*[4.4-4]*/
 513           call cl_arg_check;
 514 
 515 /*[4.4-4]*/
 516           ch1 = substr (argb, 1, 1);
 517 
 518 /*[4.4-4]*/
 519           if ch1 < "1" | ch1 > "5"
 520           then go to arg_error;
 521 
 522 /*[4.4-4]*/
 523           if m = 1                                          /*[4.4-4]*/
 524           then call setlev (ch1, "3");                      /*[4.4-4]*/
 525           else if m = 2                                     /*[4.4-4]*/
 526           then do;
 527                     ch2 = substr (argb, 2, 1);
 528 
 529 /*[4.4-4]*/
 530                     if ch2 < "1" | ch2 > "3"
 531                     then go to arg_error;
 532 
 533 /*[4.4-4]*/
 534                     call setlev (ch1, ch2);                 /*[4.4-4]*/
 535                end;                                         /*[4.4-4]*/
 536           else go to arg_error;
 537 
 538 /*[4.4-4]*/
 539           substr (arg, l, 3) = " " || ch1 || ch2;           /*[4.4-4]*/
 540           l = l + 3;
 541 
 542      end;
 543 
 544 cl_arg_check:
 545      proc;
 546 
 547 /*[4.4-4]*/
 548           if i = pc
 549           then go to arg_error;
 550 
 551 /*[4.4-4]*/
 552           i = i + 1;
 553 
 554 /*[4.4-4]*/
 555           call cu_$arg_ptr (i, arg_ptr, m, mcode);
 556 
 557 /*[4.4-4]*/
 558           if mcode ^= 0
 559           then go to multics_error;
 560 
 561      end;
 562 
 563 comp_env:
 564      proc;
 565 
 566 /*[4.0-4]*/
 567 
 568 /*[4.0-4]*/
 569           go to M (MODE);                                   /* default */
 570 
 571 M (0):                                                      /*[4.0-4]*/
 572           go to MM;
 573 
 574 M (1):                                                      /* gcos */
 575                                                             /*[4.0-4]*/
 576           fixed_common.compile_mode = "101"b;
 577 
 578 /*[4.0-4]*/
 579           go to MM;
 580 
 581 M (2):                                                      /* ibm_ansi */
 582                                                             /*[4.0-4]*/
 583           fixed_common.compile_mode = "01"b;
 584 
 585 /*[4.0-4]*/
 586           go to MM;
 587 
 588 M (3):                                                      /* ibm_ef */
 589                                                             /*[4.0-4]*/
 590           fixed_common.compile_mode = "01"b;
 591 
 592 /*[4.0-4]*/
 593           go to MM;
 594 
 595 M (4):                                                      /* multics */
 596                                                             /*[5.1-1]*/
 597           fixed_common.compile_mode = "00011"b;
 598 
 599 /*[4.0-4]*/
 600           go to MM;
 601 
 602 M (5):                                                      /* rw */
 603                                                             /*[4.4-0]*/
 604           go to MM;
 605 
 606 /*        1  alphanumeric literal continuation ala gcos
 607                     2  " or ' allowed to delimit alphanumeric literals
 608                     3  replace tab by spaces to give a 72 char line
 609                     4 "$" and "_" allowed in data-names
 610                     5 hisi data allocation algorithm used
 611           */
 612 MM:
 613      end;
 614 
 615 
 616 init_cobol:
 617      proc;
 618 
 619 /* GET SOURCE PROGRAM NAME AND OPTIONS */
 620 
 621           upto = 0;
 622           cobol_options = "";
 623           cobol_options_len = 1;
 624 
 625           string (opts) = ""b;
 626           opts.pd = "1"b;                                   /* always print diagnostics on console*/
 627           opts.cu = "1"b;                                   /* produce object code */
 628           opts.m_wn = "1"b;                                 /*print warnings on terminal*/
 629           opts.m_fat = "1"b;                                /*   print fatals on terminal*/
 630                                                             /*[4.4-5]*/
 631           opts.pst = "1"b;                                  /* default is table */
 632 
 633           cobol_xlast8 = "0"b;
 634           time = "0"b;
 635           intact = "0"b;
 636           opts.card = "0"b;
 637           opts.exp, expand = "0"b;                          /* [3.0-8] */
 638           COMP_LEVEL = "5";
 639           LEVSV = "001"b;
 640           ddsyn_sw = "0"b;
 641           repl_sw = "0"b;
 642 
 643           rel = 1;                                          /* release files as default (truncate and terminate segments) */
 644 
 645           files_wd = "0"b;
 646           temp_dir_sw = "0"b;
 647           gen_sw = "0"b;
 648           endgen_sw = "0"b;
 649           abort_sw = "0"b;
 650 
 651 /*[4.4-5]*/
 652           no_tbl_pres, tbl_pres = "0"b;
 653 
 654 /* [3.0-9] */
 655           call init;
 656 
 657 /* [3.0-9] */
 658           if code ^= 0
 659           then go to multics_error;
 660 
 661      end;
 662 
 663 option:
 664      proc;
 665 
 666           if substr (argb, 1, 1) = "-"
 667           then do;
 668 
 669                     arg = substr (argb, 2);
 670 
 671 /*[4.4-5]*/
 672                     if arg = "table" | arg = "tb"
 673                     then do;
 674                               opts.pst = "1"b;
 675                               tbl_pres = "1"b;
 676                          end;
 677                     else if arg = "symbols" | arg = "sb" | arg = "source" | arg = "sc"
 678                     then call ioa_ ("cobol: Option ^a is obsolete, use -ls or -map (see cobol command)", argb);
 679                     else if arg = "map"
 680                     then do;
 681 
 682                               opts.exs = "1"b;
 683                               opts.m_map = "1"b;
 684                               opts.xrn = "1"b;
 685 
 686                          end;
 687 
 688 /*[4.0-2]*/
 689                     else /*[4.0-2]*/
 690                          if substr (arg, 1, 8) = "severity" /*[4.0-2]*/
 691                     then do;
 692                               if l = 10                     /*[4.0-2]*/
 693                               then call setsv (substr (arg, 9, 1));
 694                                                             /*[4.0-2]*/
 695                               else /*[4.0-2]*/
 696                                    if l = 11                /*[4.0-2]*/
 697                               then call setsv (substr (arg, 9, 1));
 698                                                             /*[4.4-4]*/
 699                               else /*[4.4-4]*/
 700                                    if l = 9                 /*[4.4-4]*/
 701                               then call ssv;                /*[4.4-4]*/
 702                               else go to arg_error;         /*[4.0-2]*/
 703                          end;                               /*[4.0-2]*/
 704                     else /*[4.0-2]*/
 705                          if substr (arg, 1, 2) = "sv"       /*[4.0-2]*/
 706                     then do;
 707                               if l = 4                      /*[4.0-2]*/
 708                               then call setsv (substr (arg, 3, 1));
 709                                                             /*[4.0-2]*/
 710                               else /*[4.0-2]*/
 711                                    if l = 5                 /*[4.0-2]*/
 712                               then call setsv (substr (arg, 3, 1));
 713                                                             /*[4.4-4]*/
 714                               else /*[4.4-4]*/
 715                                    if l = 3                 /*[4.4-4]*/
 716                               then call ssv;                /*[4.4-4]*/
 717                               else go to arg_error;         /*[4.0-2]*/
 718                          end;
 719 
 720                     else if arg = "brief" | arg = "bf"
 721                     then opts.m_bf = "1"b;
 722                     else if arg = "format" | arg = "fmt"
 723                     then opts.fmt = "1"b;
 724                     else if arg = "runtime_check" | arg = "rck"
 725                     then opts.oc = "1"b;
 726                     else if arg = "profile" | arg = "pf"
 727                     then opts.profile, opts.pst = "1"b;
 728                     else if arg = "check" | arg = "ck"
 729                     then opts.cu = "0"b;
 730                     else if arg = "list" | arg = "ls"
 731                     then do;
 732 
 733                               opts.exs = "1"b;
 734                               opts.xrn = "1"b;
 735                               opts.obj = "1"b;
 736 
 737                          end;
 738                     else if arg = "no_warning" | arg = "nw"
 739                     then opts.nw = "1"b;                    /*06-30-77*/
 740                     else if arg = "expand" | arg = "exp"
 741                     then opts.exp, expand = "1"b;           /* [3.0-8] */
 742                                                             /*[4.1-1]*/
 743                     else if arg = "card"
 744                     then opts.card = "1"b;
 745                     else if arg = "time" | arg = "tm"
 746                     then time = "1"b;
 747                     else if arg = "debug" | arg = "db"
 748                     then do;
 749 
 750                               intact = "1"b;
 751                               rel = 0;
 752 
 753                          end;                               /*[4.4-5]*/
 754                     else /*[4.4-5]*/
 755                          if arg = "no_table" | arg = "ntb"  /*[4.4-5]*/
 756                     then do;
 757                               opts.pst = "0"b;
 758                               no_tbl_pres = "1"b;
 759                          end;
 760                     else if arg = "temp_dir" | arg = "td"
 761                     then do;
 762 
 763                               files_wd = "1"b;
 764                               temp_dir_sw = "1"b;
 765                               i = i + 1;
 766 
 767                               if i > pc
 768                               then go to missing_arg_error;
 769 
 770                               call cu_$arg_ptr (i, arg_ptr, l, mcode);
 771                               if mcode ^= 0
 772                               then go to multics_error;
 773 
 774                               if substr (argb, 1, 1) = "-"
 775                               then go to missing_arg_error;
 776 
 777 /* following changes are for [4.1-1] and check to see if the */
 778 /* argument specified with  the temp_dir argument is a diectory */
 779 
 780                               call expand_pathname_ (argb, dpath, en_1, mcode);
 781 
 782                               if mcode ^= 0
 783                               then do;
 784 
 785 PATHNAME_ERROR:
 786                                         call com_err_ (mcode, "cobol", "^a", argb);
 787 
 788                                         go to comp_term;
 789 
 790                                    end;
 791 
 792                               call absolute_pathname_ (argb, fpath, mcode);
 793                                                             /* get it as a single component, as well */
 794 
 795                               if mcode ^= 0
 796                               then goto PATHNAME_ERROR;
 797 
 798                               if fpath ^= ">"               /* handle special case (ROOT).  */
 799                               then do;
 800 
 801                                         call hcs_$status_minf (dpath, en_1, 1, entry_type, (0), mcode);
 802 
 803                                         if mcode ^= 0
 804                                         then do;
 805 
 806                                                   call com_err_ (mcode, "cobol", "^a", fpath);
 807                                                   go to comp_term;
 808 
 809                                              end;
 810 
 811                                         if entry_type ^= DIRECTORY
 812                                         then do;
 813 
 814                                                   call com_err_ (error_table_$notadir, "cobol", "^a", fpath);
 815                                                   go to comp_term;
 816 
 817                                              end;
 818 
 819                                    end;                     /* then */
 820 
 821 /* end changes for [4.1-1] */
 822 
 823                          end;
 824                     else if arg = "working_dir" | arg = "wd"
 825                     then do;
 826 
 827                               files_wd = "1"b;
 828                               fpath = get_wdir_ ();
 829 
 830                               call ioa_ (
 831                                    "cobol: Obsolete -working_dir option accepted: use ""-temp_dir [wd]"" in future.");
 832 
 833                          end;
 834                     else if trace.on & substr (arg, 1, 5) = "trace"
 835                     then do;
 836 
 837                               trace_arg = arg;
 838 
 839                               if substr (arg, 6, 2) = "id"
 840                               then trace.id = "1"b;
 841                               else if substr (arg, 6, 2) = "dd"
 842                               then trace.dd = "1"b;
 843                               else if substr (arg, 6, 2) = "pd"
 844                               then trace.pd = "1"b;         /*[4.0-3]*/
 845                               else if substr (arg, 6, 2) = "db"
 846                               then trace.db = "1"b;         /*[4.4-3]*/
 847                               else if substr (arg, 6, 2) = "rw"
 848                               then trace.rw = "1"b;
 849                               else go to arg_error;
 850 
 851                               call cobol_syntax_trace_$reset_trace;
 852                               call cobol_syntax_trace_$initialize (addr (trace_arg));
 853 
 854                          end;                               /*[4.0-1]*/
 855                     else /*[4.0-1]*/
 856                          if substr (arg, 1, 5) = "level"    /*[4.0-1]*/
 857                     then do;
 858                               if l = 7                      /*[4.0-1]*/
 859                               then call setlev (substr (arg, 6, 1), "3");
 860                                                             /*[4.0-1]*/
 861                               else /*[4.0-1]*/
 862                                    if l = 8                 /*[4.0-1]*/
 863                               then call setlev (substr (arg, 6, 1), substr (arg, 7, 1));
 864                                                             /*[4.4-4]*/
 865                               else /*[4.4-4]*/
 866                                    if l = 6                 /*[4.4-4]*/
 867                               then call slv;                /*[4.4-4]*/
 868                               else go to arg_error;         /*[4.0-1]*/
 869                          end;                               /*[4.0-1]*/
 870                     else /*[4.0-1]*/
 871                          if substr (arg, 1, 3) = "lev"      /*[4.0-1]*/
 872                     then do;
 873                               if l = 5                      /*[4.0-1]*/
 874                               then call setlev (substr (arg, 4, 1), "3");
 875                                                             /*[4.0-1]*/
 876                               else /*[4.0-1]*/
 877                                    if l = 6                 /*[4.0-1]*/
 878                               then call setlev (substr (arg, 4, 1), substr (arg, 5, 1));
 879                                                             /*[4.4-4]*/
 880                               else /*[4.4-4]*/
 881                                    if l = 4                 /*[4.4-4]*/
 882                               then call slv;                /*[4.4-4]*/
 883                               else go to arg_error;         /*[4.0-1]*/
 884                          end;
 885                     else go to arg_error;
 886 
 887                     if temp_dir_sw
 888                     then do;
 889 
 890                               temp_dir_sw = "0"b;
 891                               substr (cobol_options, cobol_options_len, 9) = "temp_dir,";
 892 
 893                          end;
 894                     else substr (cobol_options, cobol_options_len, l + 1) = substr (arg, 1, l - 1) || ",";
 895 
 896                     cobol_options_len = cobol_options_len + l + 1;
 897 
 898                end;
 899           else do;
 900 
 901                     if p_err = "0"b
 902                     then do;
 903 
 904                               tpath = argb;
 905                               ltp = l;
 906                               p_err = "1"b;
 907                          end;
 908                     else go to arg_error;
 909 
 910                end;
 911 
 912 /*[4.4-5]*/
 913           if opts.profile                                   /*[4.4-5]*/
 914           then do;
 915                     opts.pst, tbl_pres = "1"b;
 916                     no_tbl_pres = "0"b;
 917                end;
 918 
 919      end;
 920 
 921 setup:
 922      proc;
 923 
 924 /*[4.4-5]*/
 925           if cobol_options = " "                            /*[4.4-5]*/
 926           then do;
 927                     cobol_options = "tb,";                  /*[5.5-5]*/
 928                     cobol_options_len = 5;                  /*[4.4-5]*/
 929                end;                                         /*[4.4-5]*/
 930           else if ^no_tbl_pres & ^tbl_pres                  /*[4.4-5]*/
 931           then do;
 932                     substr (cobol_options, cobol_options_len, 4) = "tb,";
 933                                                             /*[4.4-5]*/
 934                     cobol_options_len = cobol_options_len + 4;
 935                                                             /*[4.4-5]*/
 936                end;
 937 
 938           if cobol_options_len = 1
 939           then do;
 940 
 941                     cobol_options = "none";
 942                     cobol_options_len = 4;
 943                end;
 944           else do;
 945 
 946                     cobol_options_len = cobol_options_len - 2;
 947                     substr (cobol_options, cobol_options_len, 1) = ";";
 948                end;
 949 
 950           if p_err = "0"b
 951           then go to missing_arg_error;
 952 
 953 /* GET ENTRY NAME,DIRECTORY NAME AND PATH NAME */
 954 
 955           p_ptr = addr (dpath);
 956           e_ptr = addr (ename);
 957           tp_ptr = addr (tpath);
 958           fd_ptr = addr (fpath);
 959 
 960 /* Following changes made in [4.1-1] */
 961 /* begin changes */
 962 
 963           call expand_pathname_$add_suffix (tpb, "cobol", dpath, en_1, mcode);
 964 
 965           if mcode ^= 0
 966           then go to multics_error;
 967 
 968           call get_length (p_ptr, 168, ldp);
 969           call get_length (addr (en_1), 32, en_len);
 970 
 971           len = en_len - 6;
 972           ename = substr (en_1, 1, len);
 973 
 974           ln = substr (ename, 1, len) || ".list";
 975 
 976           call expand_pathname_ (lname, pln, ln, mcode);
 977 
 978           if mcode ^= 0
 979           then go to multics_error;
 980 
 981           tpath = dpb || ">" || enb;
 982 
 983           call get_length (tp_ptr, 168, ltp);
 984 
 985           pdpath = get_pdir_ ();
 986 
 987           if ^files_wd
 988           then fpath = pdpath;
 989 
 990           call get_length (fd_ptr, 168, fdlen);
 991 
 992 /* end changes in [4.1-1] */
 993 
 994           if fdlen < 0
 995           then fdlen = 168;
 996 
 997 
 998 /* START COMPILATION */
 999 
1000           if time | intact
1001           then call hcs_$get_usage_values (rb_pf, rb_tm, rb_pp);
1002 
1003           if intact
1004           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1005 
1006           cc = cc + 1;
1007           cobol_$compile_count = cc;
1008 
1009 /* DECLARE FILES TO THE IO SYSTEM */
1010 
1011           call cobol_vdwf (cobol_cmfp, fdir || ">cobol_common_");
1012           call cobol_vdwf (cobol_ntfp, fdir || ">cobol_name_table_");
1013           call cobol_swf (cobol_m1fp, fdir || ">cobol_minpral-1_");
1014           call cobol_swf (cobol_m2fp, fdir || ">cobol_minpral-2_");
1015                                                             /*[4.4-3]*/
1016           call cobol_swf (cobol_rwdd, fdir || ">rwdd.incl.cobol");
1017                                                             /*[4.4-3]*/
1018           call cobol_swf (cobol_rwpd, fdir || ">rwpd.incl.cobol");
1019           call cobol_swf (cobol_rm2fp, fdir || ">cobol_rmin2_");
1020           call cobol_swf (cobol_dfp, fdir || ">cobol_diags_");
1021           call cobol_swf (cobol_pfp, fdir || ">cobol_print_");
1022           call cobol_swf (cobol_$initval_file_ptr, fdir || ">cobol_initval_");
1023           call cobol_vdwf_open (cobol_ntfp, ST);
1024           call cobol_vdwf_open (cobol_cmfp, ST);
1025           call cobol_vdwf_sput (cobol_cmfp, ST, addr (common), 4 * size (fixed_common), fcom_key);
1026                                                             /* initialize fixed common */
1027           call cobol_vdwf_dget (cobol_cmfp, ST, cobol_com_ptr, fcom_ln, fcom_key);
1028                                                             /* set external pointer to it */
1029 
1030           call cobol_version$set;
1031 
1032 /*[4.4-0]*/
1033           if MODE ^= 0
1034           then call comp_env;
1035 
1036 
1037 
1038           if COMP_LEVEL ^= "5"
1039           then fixed_common.comp_level = COMP_LEVEL;
1040 
1041 /*[4.0-1]*/
1042           fixed_common.levsv = LEVSV;
1043           fixed_common.compiler_id = 3;
1044           cobol_$obj_seg_name = enb;
1045 
1046           call cobol_init_ (fpath, rtbuff_ptr);
1047 
1048 /*[4.0-4]*/
1049           call cobol_gns$set_table;
1050 
1051           if rtbuff_ptr = null ()
1052           then go to comp_term;
1053 
1054      end;
1055 
1056 expand_phase:
1057      proc;
1058 
1059           if time
1060           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1061 
1062 /* Following changes made in [4.1-1] */
1063 /* begin changes */
1064 
1065           call hcs_$initiate_count (dpath, en_1, "", BC, 1, cobol_sfp, mcode);
1066 
1067 /*[5.1-3]*/
1068           include_ptr (0) = pointer (cobol_sfp, 1);
1069 
1070           if cobol_sfp = null ()
1071           then do;
1072 
1073                     call com_err_ (mcode, "cobol", "^a", tpb || ".cobol");
1074 
1075                     goto comp_term;
1076 
1077                end;                                         /* then */
1078 
1079 /*[4.4-1]*/
1080           if BC = 0                                         /*[4.4-1]*/
1081           then do;
1082                     call com_err_ (0, "cobol", "Zero length segment. ^a", tpb || ".cobol");
1083 
1084 /*[4.4-1]*/
1085                     go to comp_term;
1086 
1087 /* zero length source segment */
1088 
1089 /*[4.4-1]*/
1090                end;
1091 
1092           if ^opts.fmt
1093           then if substr (first_source_line, 1, 6) ^= "      "
1094                then do;
1095 
1096                          ch1 = substr (first_source_line, 1, 1);
1097                                                             /*[5.0-1]*/
1098                          if ch1 > "9" | ch1 = "*" | ch1 = "/" | ch1 = "         "
1099                          then do;
1100 
1101                                    if opts.card
1102                                    then do;
1103 
1104                                              call ioa_ (M1);
1105                                              call ioa_ (M2);
1106 
1107                                              go to comp_term;
1108 
1109                                         end;                /* then */
1110 
1111                                    else call ioa_ (M1);
1112 
1113                                    opts.fmt, fixed_common.options.fmt = "1"b;
1114 
1115                                    call set_options (", (fmt);", 8);
1116 
1117                               end;                          /* then */
1118 
1119                     end;                                    /* then */
1120 
1121                else ;                                       /* do nothing */
1122 
1123           else do;
1124 
1125                     if opts.card
1126                     then do;
1127 
1128                               call ioa_ (M2);
1129 
1130                               go to comp_term;
1131 
1132                          end;                               /* then */
1133 
1134                end;                                         /* else */
1135 
1136           ecs = expand | opts.card | opts.fmt;
1137 
1138 
1139           if ecs & en_len > 9
1140           then if substr (en_1, en_len - 8) = ".ex.cobol"
1141                then do;
1142 
1143                          call ioa_ (M4);
1144                          expand, opts.exp, opts.card, opts.fmt = "0"b;
1145 
1146                     end;                                    /* then */
1147 
1148           call cobol_version$print;
1149 
1150 /* end changes for [4.1-1] */
1151 
1152           if ecs
1153           then do;
1154 
1155 /*[4.4-6]*/
1156                     if opts.pst
1157                     then call f_mess;
1158 
1159                     if time
1160                     then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1161 
1162                     save_sfp = cobol_sfp;
1163                     ecs_info_ptr = addr (ecs_info_table);
1164                     ecs_info_table.input_ptr = cobol_sfp;   /*[4.1-1]*/
1165                     ecs_info_table.card_indicator = opts.card;
1166                                                             /*[4.1-1]*/
1167                     ecs_info_table.exp_indicator = expand;
1168                     ecs_info_table.format_indicator = opts.fmt;
1169                     ecs_info_table.compiler_level = fixed_common.comp_level;
1170                     ecs_info_table.diag_indicators = "000"b;
1171                     ecs_info_table.fatal_count = 0;         /*[4.0-1]*/
1172                     ecs_info_table.levsv = fixed_common.levsv;
1173 
1174 /*[4.1-1]*/
1175                     ecs_info_table.dir = pdpath;            /*[4.1-1]*/
1176                     ecs_info_table.ent = substr (ename, 1, len) || ".ex.cobol";
1177 
1178                     call expand_cobol_source$expand (ecs_info_ptr, mcode);
1179 
1180                     if mcode ^= 0
1181                     then goto multics_error;
1182 
1183 /*[5.1-2]*/
1184                     BC = ecs_info_table.bc;
1185 
1186                     cobol_sfp = ecs_info_table.output_ptr;
1187                     fixed_common.fatal_no = fixed_common.fatal_no + ecs_info_table.fatal_count;
1188 
1189                     if time
1190                     then call timer ("EXPAND........");
1191                end;                                         /* [3.0-8] */
1192 
1193 /*[5.1-2]*/
1194           call cobol_merge$source_file_size (BC);
1195 
1196           entry_ptr = addr (branch_status);                 /* [3.0-6] */
1197 
1198           call hcs_$fs_get_path_name (cobol_sfp, dn, i, en, mcode);
1199                                                             /* [3.0-6] */
1200 
1201           if mcode ^= 0
1202           then goto multics_error;                          /* [3.0-6] */
1203 
1204           call push_name (dn, en);                          /* [3.0-6] */
1205 
1206      end;
1207 
1208 lex:
1209      proc;
1210 
1211           call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "ou");
1212           call cobol_swf_open (cobol_m2fp, ST, tptr, tln, "ou");
1213           call cobol_swf_open (cobol_pfp, ST, tptr, tln, "ou");
1214 
1215           fixed_common.descriptor = common.descriptor;
1216 
1217           call cobol_swf_open (cobol_dfp, ST, tptr, tln, "ou");
1218 
1219           save_m2fp = cobol_m2fp;
1220 
1221 /* START LEX PHASE */
1222 
1223           if time
1224           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1225 
1226           endlex_sw = "0"b;                                 /* 10-27-77 */
1227                                                             /*[4.4-3]*/
1228           fixed_common.syntax_trace = trace.rw;
1229 
1230           call cobol_lex (enb);
1231 
1232 /*[4.4-3]*/
1233           fixed_common.syntax_trace = "0"b;
1234           endlex_sw = "1"b;                                 /* 10-27-77 */
1235                                                             /*[4-1.2] cobol_m2fp = save_m2fp;*/
1236           fixed_common.last_print_rec = cobol_lpr;
1237 
1238           call cobol_swf_close (cobol_pfp, ST, tptr, 0);
1239 
1240           cobol_sfp = pointer (cobol_sfp, 0);               /* reset to start of source */
1241 
1242           if time
1243           then call timer ("LEX...........");
1244 
1245           if fixed_common.prog_name = "" | fixed_common.prog_name = substr (ename, 1, len)
1246           then tname = substr (ename, 1, len);
1247           else tname = substr (ename, 1, len) || "$" || fixed_common.prog_name;
1248 
1249           mcode = -3;                                       /* avoid stop run if only prog in run unit */
1250 
1251           call cobol_control_$cancel (tname, 0, 1, mcode);
1252 
1253 /*[5.1-2]*/
1254           if MODE = 5
1255           then go to lex_quit;
1256 
1257      end;
1258 
1259 ided:
1260      proc;
1261 
1262 /*************************************/
1263 /* POSITION FILES FOR ID/ED */
1264 
1265           if time
1266           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1267 
1268           call cobol_swf_close (cobol_m1fp, ST, tptr, 0);
1269           call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "in");
1270 
1271 /* START ID/ED SYNTAX PHASE */
1272 
1273           cobol_com_fileno = cobol_cmfp;                    /*{4.4-3]*/
1274           cobol_name_fileno, cobol_name_fileno_ptr = cobol_ntfp;
1275           cobol_min1_fileno = cobol_m1fp;
1276           fixed_common.syntax_trace = trace.id;
1277 
1278           call cobol_idedsyn;
1279 
1280           fixed_common.syntax_trace = "0"b;
1281 
1282           if fixed_common.prog_name = ""
1283           then fixed_common.prog_name = substr (ename, 1, len);
1284                                                             /* PROGRAM-ID missing */
1285 
1286           if time
1287           then call timer ("ID/ED SYNTAX..");
1288 
1289      end;
1290 
1291 dd:
1292      proc;
1293 
1294 /*************************************/
1295 /* START DD SYNTAX PHASE */
1296 
1297           if time
1298           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1299 
1300           fixed_common.syntax_trace = trace.dd;
1301 
1302           call cobol_ddsyntax;
1303 
1304           fixed_common.syntax_trace = "0"b;
1305 
1306           if time
1307           then call timer ("DD SYNTAX.....");
1308 
1309           call cobol_swf_close (cobol_m1fp, ST, tptr, rel); /* close and release cobol_minpral-1_ */
1310 
1311      end;
1312 
1313 
1314 ddalloc:
1315      proc;
1316 
1317 /*************************************/
1318 /* START DD ALLOCATION PHASE */
1319 
1320           if time
1321           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1322 
1323           call cobol_swf_open (cobol_$initval_file_ptr, ST, tptr, tln, "ou");
1324 
1325           ddsyn_sw = "1"b;
1326 
1327           call cobol_init_$segs (mcode, tpath);             /* [3.0-2] */
1328 
1329           if mcode ^= 0
1330           then go to comp_term;
1331 
1332 /*************************************/
1333 /* GET LINK OFFSET FOR COBOL RUN TIME PACKAGE */
1334 /*-04/08/76-*/
1335           linkoff = 0;
1336 
1337           call cobol_make_link_$type_4 (linkoff, "cobol_rts_");
1338 
1339           call cobol_ddalloc;
1340 
1341           if time
1342           then call timer ("DD ALLOCATION.");
1343 
1344      end;
1345 
1346 replace:
1347      proc;
1348 
1349 /*************************************/
1350 /* POSITION FILES FOR REPLACEMENT */
1351 
1352           if time
1353           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1354 
1355           call cobol_swf_close (cobol_$initval_file_ptr, ST, tptr, 0);
1356           call cobol_swf_close (cobol_m2fp, ST, tptr, 0);
1357           call cobol_vdwf_close (cobol_ntfp, ST, tptr, 0);
1358           call cobol_swf_open (cobol_m2fp, ST, tptr, tln, "in");
1359           call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "ou");
1360           call cobol_vdwf_open (cobol_ntfp, ST);
1361 
1362 /*[4.4-3]*/
1363 /*cobol_name_fileno_ptr = cobol_ntfp;*/
1364 
1365           cobol_curr_in = cobol_m2fp;
1366           cobol_curr_out = cobol_rm2fp;
1367 
1368 /* START REPLACEMENT PHASE */
1369 
1370           mem_size = 1048575;                               /* Number of bytes in 262143 words */
1371 
1372           call cobol_repl3 (mem_size, rtbuff_ptr);
1373 
1374           if time
1375           then call timer ("REPLACEMENT...");
1376 
1377           cobol_m2fp = cobol_curr_in;
1378           cobol_rm2fp = cobol_curr_out;
1379 
1380           call cobol_swf_close (cobol_m2fp, ST, tptr, rel); /* close and release input to replacement */
1381           call cobol_swf_close (cobol_rm2fp, ST, tptr, 0);  /* close and retain output from replacement */
1382           call cobol_swf (cobol_pdofp, fdir || ">cobol_pdout_");
1383           call cobol_swf_open (cobol_pdofp, ST, tptr, tln, "ou");
1384 
1385           repl_sw = "1"b;
1386 
1387      end;
1388 
1389 db_corr:
1390      proc;
1391 
1392           call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1393 
1394 /*[4.0-3]*/
1395           if fixed_common.corr | fixed_common.initl         /*[4.0-3]*/
1396           then do;
1397                     call START;                             /*OPEN(corrout_)*/
1398 
1399 /*[4.0-3]*/
1400                     call cobol_ci_phase;
1401 
1402 /*[4.0-3]*/
1403                     if fixed_common.debug                   /*[4.0-3]*/
1404                     then do;
1405                               call START_DB;                /* OPEN(rmin2_) */
1406 
1407 /*[4.0-3]*/
1408                               fixed_common.syntax_trace = trace.db;
1409                                                             /*[4.0-3]*/
1410                               call cobol_db_phase;          /*[4.0-3]*/
1411                               fixed_common.syntax_trace = "0"b;
1412 
1413 /*[4.0-3]*/
1414                               call FINISH_DB;               /* CLOSE(corrout_,rmin2_) */
1415                                                             /*[4.0-3]*/
1416                                                             /* OPEN(rmin2_) */
1417                                                             /*[4.0-3]*/
1418                          end;                               /*[4.4-9]*/
1419                     else call FINISH ("CORRESPONDING.");
1420 
1421 /*[4.0-3]*/
1422                end;                                         /*[4.0-3]*/
1423           else if fixed_common.debug                        /*[4.0-3]*/
1424           then do;
1425                     call START;                             /* OPEN(corrout_) */
1426 
1427 /*[4.0-3]*/
1428                     fixed_common.syntax_trace = trace.db;   /*[4.0-3]*/
1429                     call cobol_db_phase;                    /*[4.0-3]*/
1430                     fixed_common.syntax_trace = "0"b;
1431 
1432 /*[4.0-3]*/
1433                     call FINISH ("DEBUG.........");         /* CLOSE(rmin2_,corrout_) */
1434                                                             /*[4.0-3]*/
1435                                                             /* OPEN(corrout_) */
1436                                                             /*[4.0-3]*/
1437                end;
1438 
1439      end;
1440 
1441 print_diag:
1442      proc;
1443 
1444 /*************************************/
1445 /* START PRINT_DIAG PHASE */
1446 
1447 
1448           if fixed_common.fatal_no ^= 0
1449           then do;
1450 
1451                     if fixed_common.fatal_no > 1
1452                     then errorcon = "errors";
1453                     else errorcon = "error";
1454 
1455                     call ioa_ ("");
1456 
1457                     if abort_sw
1458                     then call com_err_ (0, "cobol", "^d other fatal ^a encountered in ^a to this point.",
1459                               fixed_common.fatal_no, errorcon, enb);
1460                     else call com_err_ (0, "cobol", "^d fatal ^a encountered in ^a.", fixed_common.fatal_no, errorcon,
1461                               enb);
1462 
1463                end;
1464 
1465           if time
1466           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1467 
1468           if opts.exs
1469           then do;
1470 
1471                     call delete_$path (pln, ln, "100111"b, "", mcode);
1472                                                             /* [3.0-5] */
1473 
1474                     wdir = get_wdir_ ();
1475                     call cobol_cselfle (ST, cobol_hfp, enb || ".list", " ", 0, "h", ""b);
1476                                                             /* open list file */
1477 
1478                end;
1479 
1480           call cobol_swf_open (cobol_pfp, ST, tptr, tln, "in");
1481           call cobol_swf_open (cobol_dfp, ST, tptr, tln, "in");
1482 
1483           if fixed_common.options.exp = "0"b
1484           then ecs_info_table.diag_indicators = "000"b;     /* [3.0-10] */
1485 
1486           call cobol_print_diag;                            /* [4.1-2] */
1487 
1488           call cobol_swf_close (cobol_pfp, ST, tptr, rel);  /* close and release cobol_print_ */
1489           call cobol_swf_close (cobol_dfp, ST, tptr, rel);  /* close and release cobol_diags_ */
1490           call cobol_swf_close (cobol_pdofp, ST, tptr, 0);
1491 
1492           if time
1493           then call timer ("PRINT DIAG....");
1494 
1495           call cobol_swf_close (cobol_rm2fp, ST, tptr, rel);/* close and release cobol_rmin2_ */
1496 
1497           if opts.exs
1498           then call cobol_cselfle (ST, cobol_hfp, " ", " ", 1, "k", "0"b);
1499                                                             /* close list file setting bitcount */
1500 
1501           if opts.exs
1502           then do;
1503 
1504                     segname = substr (cobol_$obj_seg_name, 1, index (cobol_$obj_seg_name, " ") - 1) || ".list";
1505 
1506                     call hcs_$initiate_count (wdir, segname, "", BC, 01b, cobol_$list_ptr, mcode);
1507 
1508                     if cobol_$list_ptr = null ()
1509                     then go to multics_file_error;
1510 
1511                     cobol_$list_off = divide (BC + 8, 9, 24, 0) + 1;
1512 
1513                end;
1514           else cobol_$list_ptr = null ();
1515 
1516 /*************************************/
1517 
1518           if fixed_common.fatal_no ^= 0 | ^opts.cu | abort_sw
1519           then do;
1520 
1521                     if fixed_common.fatal_no ^= 0 & ^abort_sw
1522                     then call com_err_ (error_table_$translation_failed, "cobol");
1523                     else if ^opts.cu
1524                     then call ioa_ ("cobol: No object program generated for ^a.", enb);
1525 
1526                     if intact & ^time
1527                     then call timer ("Front:");
1528 
1529                     go to no_gen;
1530 
1531                end;
1532 
1533           if intact & ^time
1534           then do;
1535 
1536                     call timer ("Front:");
1537                     call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1538 
1539                end;
1540 
1541 
1542      end;
1543 
1544 
1545 generator:
1546      proc;
1547 
1548 /*************************************/
1549 /*************************************/
1550 /* START GENERATOR PHASE */
1551 
1552           cobol_$next_tag = fixed_common.spec_tag_counter + 1;
1553           segname = "cobol_pdout_";
1554 
1555 
1556           call hcs_$initiate (fpath, segname, "", 0b, 00b, cobol_$minpral5_ptr, mcode);
1557 
1558           if cobol_$minpral5_ptr = null ()
1559           then go to multics_file_error;
1560 
1561           if opts.pst | opts.obj | opts.m_map
1562           then cobol_$pd_map_sw = 1;
1563           else cobol_$pd_map_sw = 0;
1564 
1565           if opts.pst
1566           then do;
1567 
1568                     call cobol_vdwf_close (cobol_ntfp, ST, tptr, 0);
1569                     call cobol_vdwf_open (cobol_ntfp, ST);
1570 
1571                end;
1572 
1573           gen_sw = "1"b;
1574 
1575           if time
1576           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1577 
1578           call cobol_gen_driver_;
1579 
1580           if time
1581           then call timer ("GENERATOR.....");
1582 
1583           cobol_$constant_offset = cobol_$con_wd_off - mod (cobol_$con_wd_off, 2);
1584 
1585      end;
1586 
1587 analyzer:
1588      proc;
1589 
1590 /*************************************/
1591 /* START ANALYZER PHASE */
1592 
1593           if opts.xrn & fixed_common.fatal_no = 0
1594           then do;                                          /*[3.0-1]*/
1595 
1596                     if time
1597                     then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1598 
1599                     call cobol_make_xref_;
1600 
1601                     if time
1602                     then call timer ("ANALYZER......");
1603 
1604                end;
1605 
1606      end;
1607 
1608 fixup:
1609      proc;
1610 
1611 /*************************************/
1612 /* START FIXUP PHASE */
1613 
1614           if time
1615           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1616 
1617           call cobol_fix_driver_;
1618 
1619           if time
1620           then call timer ("FIXUP.........");
1621 
1622           if intact & ^time
1623           then call timer ("Back :");
1624 
1625      end;
1626 
1627 finish_proc:
1628      proc;
1629 
1630 /* FINISH UP */
1631 
1632           if repl_sw
1633           then call cobol_swf_close (cobol_pdofp, ST, tptr, rel);
1634                                                             /* close and release cobol_pdout_ */
1635 
1636           if ddsyn_sw
1637           then call cobol_swf_close (cobol_$initval_file_ptr, ST, tptr, rel);
1638                                                             /* close and release cobol_initval_ */
1639 
1640           call cobol_vdwf_close (cobol_cmfp, ST, tptr, rel);/* close and release cobol_common_ */
1641 
1642           call cobol_vdwf_close (cobol_ntfp, ST, tptr, rel);/* close and release cobol_name_table_ */
1643 
1644           if abort_sw
1645           then call com_err_ (error_table_$translation_aborted, "cobol");
1646 
1647           call CLEANUP;                                     /* [3.0-4] */
1648 
1649 /* [3.0-9] */
1650           call finis;
1651 
1652           if time | intact
1653           then do;
1654 
1655                     pb_tm = rb_tm;
1656                     pb_pf = rb_pf;
1657                     pb_pp = rb_pp;
1658 
1659                     if time
1660                     then call timer ("TOTAL:");
1661                     else call timer ("Total:");
1662 
1663                end;
1664 
1665      end;
1666 
1667 
1668 
1669 
1670 
1671 /*[4.1-1]*/
1672 
1673 get_length:
1674      proc (p, l, j);
1675 
1676 declare   p                   ptr,
1677           l                   fixed bin,
1678           j                   fixed bin,
1679           name                char (l) based (p);
1680 
1681           j = index (name, " ");
1682 
1683           if j = 0
1684           then j = l;
1685           else j = j - 1;
1686 
1687      end get_length;
1688 
1689 /*[4.1-1]*/
1690 
1691 set_options:
1692      proc (str, size);
1693 
1694 declare   str                 char (*),
1695           size                fixed bin;
1696 
1697           if substr (cobol_options, cobol_options_len, 1) = ";"
1698           then cobol_options_len = cobol_options_len - 1;
1699 
1700           substr (cobol_options, cobol_options_len + 1, 8) = substr (str, 1, size);
1701 
1702           cobol_options_len = cobol_options_len + size;
1703 
1704      end set_options;
1705 
1706 
1707 /*[4.0-3]*/
1708 
1709 START:
1710      proc;
1711 
1712 /*[4.0-3]*/
1713 /*[4.0-3]*/
1714           if time
1715           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1716 
1717 /*[4.0-3]*/
1718           call cobol_swf (cobol_m1fp, fdir || ">cobol_corrout_");
1719                                                             /*[4.0-3]*/
1720           call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "ou");
1721                                                             /* output, corres or db */
1722 
1723 /*[4.0-3]*/
1724           cobol_rmin2fp = cobol_rm2fp;                      /* input, corres or db */
1725                                                             /*[4.0-3]*/
1726           cobol_x3fp = cobol_m1fp;                          /* output, corres or db */
1727 
1728      end;
1729 
1730 /*[4.0-3]*/
1731 
1732 FINISH:
1733      proc (ph_name);
1734 
1735 /*[4.0-3]*/
1736 /*[4.0-3]*/
1737 dcl       ph_name             char (14);
1738 
1739 /*[4.0-3]*/
1740           call cobol_swf_close (cobol_rm2fp, ST, tptr, 1);  /* input, corres or db */
1741 
1742 /*[4.0-3]*/
1743           cobol_rm2fp = cobol_x3fp;                         /* output of corres or db becomes input to pd */
1744 
1745 /*[4.0-3]*/
1746           call cobol_swf_close (cobol_x3fp, ST, tptr, 0);   /* output, corres or db */
1747                                                             /*[4.0-3]*/
1748           call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1749                                                             /* input, pd */
1750 
1751 /*[4.0-3]*/
1752           if time
1753           then call timer (ph_name);
1754 
1755      end;
1756 
1757 /*[4.0-3]*/
1758 
1759 START_DB:
1760      proc;
1761 
1762 /*[4.0-3]*/
1763 /*[4.0-3]*/
1764           if time
1765           then call hcs_$get_usage_values (pb_pf, pb_tm, pb_pp);
1766 
1767 /*[4.4-9]*/
1768           call cobol_swf_close (cobol_m1fp, ST, tptr, 0);   /* output, corres */
1769                                                             /*[4.4-9]*/
1770           call cobol_swf_close (cobol_rm2fp, ST, tptr, 0);  /* input, corres */
1771 
1772 /*[4.0-3]*/
1773           cobol_rmin2fp = cobol_m1fp;                       /* input, db */
1774                                                             /*[4.0-3]*/
1775           cobol_x3fp = cobol_rm2fp;                         /* output, db */
1776 
1777 /*[4.4-9]*/
1778           call cobol_swf_open (cobol_m1fp, ST, tptr, tln, "in");
1779                                                             /* input, db */
1780                                                             /*[4.4-9]*/
1781           call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "ou");
1782                                                             /* output, db */
1783 
1784      end;                                                   /*[4.0-3]*/
1785 
1786 FINISH_DB:
1787      proc;
1788 
1789 /*[4.0-3]*/
1790 /*[4.0-3]*/
1791           call cobol_swf_close (cobol_rmin2fp, ST, tptr, 1);/* input, db */
1792 
1793 /*[4.0-3]*/
1794           cobol_rm2fp = cobol_x3fp;                         /* output of db becomes input to pd */
1795 
1796 /*[4.0-3]*/
1797           call cobol_swf_close (cobol_x3fp, ST, tptr, 0);   /* output, db */
1798                                                             /*[4.0-3]*/
1799           call cobol_swf_open (cobol_rm2fp, ST, tptr, tln, "in");
1800                                                             /* input, pd */
1801 
1802 /*[4.0-3]*/
1803           if time
1804           then call timer ("DEBUG.........");
1805 
1806      end;                                                   /*[4.0-3]*/
1807 
1808 /*************************************/
1809 /* TIMER PROCEDURE */
1810 
1811 timer:
1812      proc (phase);
1813 
1814 dcl       phase               char (14);
1815 dcl       (temp, lp, rp)      fixed bin (35);
1816 
1817           call hcs_$get_usage_values (pe_pf, pe_tm, pe_pp);
1818           temp = pe_tm - pb_tm;
1819           pb_pf = pe_pf - pb_pf;
1820           pb_pp = pe_pp - pb_pp;
1821           lp = divide (temp, 1000000, 35, 0);
1822           rp = mod (temp, 1000000);
1823           rp = divide (rp, 1000, 35, 0);
1824 
1825           call ioa_ ("^a ^2d.^3d seconds,^3d pagefaults,^3d prepages.", phase, lp, rp, pb_pf, pb_pp);
1826           return;
1827      end timer;
1828 
1829 /*[4.0-1]*/
1830 
1831 setlev:
1832      proc (lv, sv);
1833 
1834 /*[4.0-1]*/
1835 dcl       (lv, sv)            char (1);
1836 
1837 /*[4.0-1]*/
1838           if lv < "1" | lv > "5"
1839           then go to arg_error;
1840 
1841 /*[4.0-1]*/
1842           COMP_LEVEL = lv;
1843 
1844 /*[4.0-1]*/
1845           if sv = "1"
1846           then LEVSV = "100"b;                              /*[4.0-1]*/
1847           else if sv = "2"
1848           then LEVSV = "010"b;                              /*[4.0-1]*/
1849           else if sv = "3"
1850           then LEVSV = "001"b;                              /*[4.0-1]*/
1851           else go to arg_error;
1852 
1853      end;
1854 
1855 /*[4.0-1]*/
1856 
1857 /*[4.0-2]*/
1858 
1859 setsv:
1860      proc (sv);
1861 
1862 
1863 /*[4.0-2]*/
1864 dcl       sv                  char (1);
1865 
1866 /*[4.0-2]*/
1867           if sv < "1" | sv > "4"
1868           then go to arg_error;
1869 
1870 /*[4.0-2]*/
1871           opts.m_obs = "1"b;
1872 
1873 /*[4.2-4]*/
1874           if sv = "4"                                       /*[4.2-4]*/
1875           then opts.m_fat, opts.m_wn, opts.m_obs = "0"b;    /*[4.0-2]*/
1876           else if sv = "3"                                  /*[4.0-2]*/
1877           then opts.m_wn, opts.m_obs = "0"b;                /*[4.0-2]*/
1878           else if sv = "2"                                  /*[4.0-2]*/
1879           then opts.m_obs = "0"b;
1880 
1881      end;
1882 
1883 /*[4.0-2]*/
1884 
1885 
1886 /*************************************/
1887 /* CLEANUP PROCEDURE FOR CLEANUP CONDITION */
1888 
1889 CLEANUP:
1890      proc;                                                  /* [3.0-4] */
1891 
1892           if ^recursion
1893           then return;                                      /* 10-27-77 */
1894 
1895           recursion = "0"b;
1896           revert cleanup;                                   /* [3.0-4] */
1897 
1898 /*[5.1-3]*/
1899           if cobol_$include_cnt > 0
1900           then do i = 0 to cobol_$include_cnt;
1901                     call cobol_cselfle (ST, include_ptr (i), " ", " ", 0, "k", "0"b);
1902                end;
1903 
1904           if ^intact
1905           then do segname = "cobol_seg1_", "cobol_seg2_", "cobol_seg3_", "cobol_initval_", "cobol_ntbuff_",
1906                     "cobol_minpral-1_", "cobol_minpral-2_", /*[4.4-3]*/
1907                     "rwdd.incl.cobol", "rwpd.incl.cobol", "cobol_rmin2_", "cobol_r2min2_", "cobol_print_", "cobol_diags_",
1908                     "cobol_pdout_", "cobol_corrout_",       /*[4.4-8]*/
1909                     "cobol_pdout_",                         /*[4.4-8]*/
1910                     "cobol_initval_",                       /*[4.4-8]*/
1911                     "cobol_print_",                         /*[4.4-8]*/
1912                     "cobol_diags_",                         /*[4.4-8]*/
1913                     "cobol_rmin2_",                         /*[4.4-8]*/
1914                     "cobol_minpral-1_", "cobol_minpral-2_", /*[4.4-8]*/
1915                     "cobol_name_table_", "cobol_common_", "cobol_name_table_", "cobol_format_temp_";
1916                     call hcs_$truncate_file (fpath, segname, 0, mcode);
1917                     call hcs_$terminate_file (fpath, segname, 0b, mcode);
1918                                                             /*[4.4-8]*/
1919                     call hcs_$set_bc (fpath, segname, 0, mcode);
1920                end;
1921 
1922 /* [3.0-9] */
1923           call finis;
1924 
1925           return;
1926 
1927      end CLEANUP;                                           /* [3.0-4] */
1928 
1929 COND:
1930      proc (cond_name);                                      /* [3.0-4] */
1931 
1932 declare   cond_name           char (*),
1933           code                fixed bin (35);               /* [3.0-4] */
1934 declare   find_condition_info_
1935                               entry (ptr, ptr, fixed bin (35));
1936                                                             /* [3.0-4] */
1937 
1938           call find_condition_info_ (null (), addr (cond_info), code);
1939                                                             /* [3.0-4] */
1940 
1941           call cobol_error (cond_name, cond_info.infoptr, "0"b);
1942                                                             /* [3.0-4] */
1943 
1944 /* [3.0-9] */
1945           call finis;
1946 
1947      end;
1948 
1949 
1950 cobol_error:
1951      proc (cond_name, sptr, cont);                          /* condition handler for compile time errors */
1952 
1953 dcl       sptr                ptr;
1954 dcl       cond_name           char (*);
1955 dcl       cont                bit (1);
1956 dcl       1 s                 based (sptr),
1957             2 name            char (32),
1958             2 len             fixed bin,
1959             2 string          char (0 refer (s.len));
1960 
1961 dcl       1 io                based (sptr),
1962             2 name            char (32),
1963             2 code            fixed bin (35),
1964             2 action          fixed bin,                    /* 1 - init */
1965                                                             /* 2 - open */
1966                                                             /* 3 - get */
1967                                                             /* 4 - put */
1968                                                             /* 5 - dget */
1969                                                             /* 6 - dput */
1970                                                             /* 7 - close */
1971                                                             /* 8 - bad cobol_cselfle type */
1972                                                             /* 9 - bad open mode for sequential file */
1973             2 iocb_ptr        ptr,
1974             2 file_type       fixed bin,                    /* 1 - source */
1975                                                             /* 2 - copy */
1976                                                             /* 3 - list */
1977                                                             /* 4 - cobol_swf */
1978                                                             /* 5 - cobol_vdwf */
1979             2 key             char (5);                     /* valid only for type 5, action 5 | 6 */
1980 
1981 dcl       action_con          (7) char (10)
1982                               init ("initialize", "open", "get", "put", "direct get", "direct put", "close");
1983 dcl       attach_descrip      char (172) varying based (io.iocb_ptr -> iocb.attach_descrip_ptr);
1984 
1985 start_error:
1986           if cond_name = "command_abort_" | cond_name = "command_abort"
1987                                                             /* [3.0-4] */
1988           then if s.name = "cobol_io_"
1989                then do;
1990 
1991                          if io.action > 7
1992                          then do;
1993 
1994                                    if action = 8
1995                                    then call com_err_ (error_table_$no_operation, "cobol", "Bad cobol_cselfle file type");
1996                                    else call com_err_ (error_table_$no_operation, "cobol",
1997                                              "Bad open mode for a sequential file");
1998 
1999                               end;
2000 
2001                          else if io.file_type = 0 | io.file_type > 3
2002                          then do;
2003 
2004                                    if io.file_type > 3
2005                                    then do;
2006 
2007                                              call com_err_ (error_table_$no_operation, "cobol",
2008                                                   "Attempting to ^a internal work file at ^p", action_con (io.action),
2009                                                   io.iocb_ptr);
2010 
2011                                              if io.file_type = 5 & (io.action = 4 | io.action = 5)
2012                                              then call com_err_ (0, "cobol", "Key is ^a", io.key);
2013 
2014                                         end;
2015 
2016                                    else call com_err_ (error_table_$no_operation, "cobol", "Referencing ^p", io.iocb_ptr);
2017 
2018                                    call com_err_ (error_table_$translation_aborted, "cobol");
2019 
2020                               end;
2021 
2022                          else call com_err_ (io.code, "cobol", substr (attach_descrip, 7));
2023                          go to comp_term;
2024 
2025                     end;
2026 
2027                else do;
2028 
2029                          if substr (s.name, 1, 6) = "cobol_"
2030                          then call com_err_ (0, "cobol", "Unrecoverable code generator error (^a).  ^a.",
2031                                    substr (s.name, 7), s.string);
2032                          else call com_err_ (0, "cobol", "Unrecoverable ^a error.  ^a.", s.name, s.string);
2033 
2034                     end;
2035 
2036           else do;                                          /* other condition */
2037 
2038                     call com_err_ (0, "cobol", "Unrecoverable error.  Unexpected condition signalled.");
2039 
2040                     if ^restart
2041                     then do;
2042                               restart = "1"b;
2043                               call cobol$restart;
2044                          end;
2045 
2046                     cont = "1"b;
2047 
2048                     return;
2049 
2050                end;
2051 
2052           if ^intact
2053           then do;
2054                     if abort_sw
2055                     then go to finish;                      /* recursion not allowed */
2056                     else abort_sw = "1"b;
2057 
2058                     if ^endlex_sw
2059                     then go to finish;
2060 
2061                     if endgen_sw
2062                     then go to finish;
2063                     else if gen_sw
2064                     then go to no_gen;
2065                     else go to start_print_diag;
2066                end;
2067           else call cu_$cl;
2068 
2069           return;
2070 
2071      end cobol_error;
2072 
2073 
2074 /*************************************/
2075 
2076 print_options:
2077      proc;
2078 
2079 dcl       message             char (80);
2080 
2081 /*[4.2-2]*/
2082 
2083 /*[4.2-3]*/
2084           call com_err_ (error_table_$noarg, "cobol");
2085 
2086           call cobol_version$print;
2087 
2088 /*[4.2-3]*/
2089           call ioa_ ("Usage: cobol path {ctl_args}");       /*[4.2-3]*/
2090           call ioa_ ("Control arguments:-map -list -no_table -profile");
2091                                                             /*[4.2-3]*/
2092           call ioa_ ("-brief -check -runtime_check -expand");
2093                                                             /*[4.2-3]*/
2094           call ioa_ ("-format -card -temp_dir PATH");       /*[4.2-3]*/
2095           call ioa_ ("-severity N -level NM");
2096 
2097      end print_options;
2098 
2099 
2100 
2101 
2102 init:
2103      proc;
2104 
2105 /**/
2106 /**/
2107           code = 0;                                         /**/
2108                                                             /**/
2109           call get_temp_segments_ ("cobol", temp_ptr, code);/**/
2110                                                             /**/
2111           if code ^= 0
2112           then return;                                      /**/
2113                                                             /**/
2114           area_infop = addr (area_info_area);               /**/
2115                                                             /**/
2116           area_info_area.version = area_info_version_1;     /**/
2117           area_info_area.owner = "cobol";                   /**/
2118           area_info_area.areap = temp_ptr (1);              /**/
2119           area_info_area.size = sys_info$max_seg_size;      /**/
2120                                                             /**/
2121           string (area_info_area.control) = "10001"b;       /**/
2122                                                             /**/
2123           call define_area_ (area_infop, code);             /**/
2124                                                             /**/
2125           if code ^= 0
2126           then return;                                      /**/
2127                                                             /**/
2128           cobol_area_ptr = temp_ptr (1);                    /**/
2129           c_name.last_name_ptr = null ();                   /**/
2130           c_name.ct = 0;
2131 
2132      end;
2133 
2134 /**/
2135 
2136 finis:
2137      proc;
2138 
2139 /**/
2140 /**/
2141           if area_info_area.areap ^= null ()
2142           then call release_area_ (area_info_area.areap);   /**/
2143                                                             /**/
2144           call release_temp_segments_ ("cobol", temp_ptr, code);
2145 
2146      end;
2147 
2148 /* [3.0-9] */
2149 
2150 f_mess:
2151      proc;
2152 
2153 /*[4.4-6]*/
2154           call ioa_ (M3);
2155 
2156 /*[4.4-6]*/
2157           call ioa_ ("cobol: " /*[4.4-6]*/
2158                || /*[4.4-6]*/ "Compilation will take place using the source program [pd]>" /*[4.4-6]*/
2159                || /*[4.4-6]*/ substr (ename, 1, len) /*[4.4-6]*/ || /*[4.4-6]*/ ".ex.cobol" /*[4.4-6]*/);
2160 
2161      end;
2162 
2163 declare   DIRECTORY           fixed bin (2) static internal options (constant) init (2);
2164 
2165 declare   1 stat              static,
2166             2 (entry_ptr, save_m2fp, arg_ptr, p_ptr, e_ptr, tp_ptr, fd_ptr)
2167                               ptr,
2168             2 (tptr, rtbuff_ptr, save_sfp, format_sfp)
2169                               ptr,
2170             2 (cobol_area_ptr, source_name_ptr)
2171                               ptr,
2172             2 temp_ptr        (1) ptr,
2173             2 (rb_pf, rb_pp, pb_pf, pb_pp, pe_pf, pe_pp)
2174                               fixed bin,
2175             2 (l_en, l_dn, linkoff, l, m, pc, i, MODE)
2176                               fixed bin,
2177             2 (ldp, ltp, len, fdlen, upto, en_len)
2178                               fixed bin,
2179             2 cc              fixed bin init (0),
2180             2 (rb_tm, pb_tm, pe_tm)
2181                               fixed bin (71),
2182             2 (mcode, code)   fixed bin (35),
2183             2 entry_type      fixed bin (2),
2184             2 mem_size        fixed bin (31),
2185             2 (fcom_ln, tln, rel)
2186                               fixed bin (15),
2187             2 BC              fixed bin (24),
2188             2 recursion       bit (1) init ("0"b),
2189             2 LEVSV           bit (3),
2190             2 ST              bit (32),
2191             2 (p_err, corr_sw, abort_sw, endlex_sw, gen_sw, endgen_sw, restart)
2192                               bit (1),
2193             2 (time, intact, expand, files_wd, temp_dir_sw)
2194                               bit (1),
2195             2 (repl_sw, ddsyn_sw, no_tbl_pres, tbl_pres, ecs)
2196                               bit (1),
2197             2 (lex_quit, comp_term)
2198                               label,
2199             2 answer          char (3) varying,
2200             2 ename           char (32) aligned,
2201             2 tpath           char (168) aligned,
2202             2 fpath           char (168) init (""),
2203             2 (tchar, COMP_LEVEL, ch1)
2204                               char (1),
2205             2 (segname, trace_arg, ln, en, en_1)
2206                               char (32),
2207             2 (pln, dn, dpath, pdpath, wdir)
2208                               char (168),
2209             2 arg             char (16),
2210             2 errorcon        char (6),
2211             2 tname           char (65),
2212             2 fcom_key        char (5);
2213 
2214 
2215 dcl       error_table_$noarg  fixed bin (35) ext static;
2216 dcl       error_table_$badopt fixed bin (35) ext static;
2217 dcl       error_table_$translation_failed
2218                               fixed bin (35) ext static;
2219 dcl       error_table_$not_act_fnc
2220                               fixed bin (35) ext static;
2221 dcl       error_table_$no_operation
2222                               fixed bin (35) ext static;
2223 dcl       error_table_$translation_aborted
2224                               fixed bin (35) ext static;
2225 dcl       error_table_$notadir
2226                               fixed bin (35) ext static;
2227 dcl       sys_info$max_seg_size
2228                               fixed bin (35) ext static;
2229 
2230           /***..... dcl Trace_Bit bit(1) static external;/**/
2231           /***..... dcl Trace_Lev fixed bin static external;/**/
2232           /***..... dcl Trace_Line char(60) static external;/**/
2233           /***.....   dcl ioa_$nnl entry options(variable);/**/
2234 
2235 dcl       1 trace             static,
2236             2 on              bit (1) init ("0"b),
2237             2 id              bit (1) init ("0"b),
2238             2 dd              bit (1) init ("0"b),
2239             2 pd              bit (1) init ("0"b),
2240             2 db              bit (1) init ("0"b),          /*[4.0-3]*/
2241             2 rw              bit (1) init ("0"b);          /*[4.4-3]*/
2242 
2243 dcl       01 ecs_info_table   automatic structure like ecs_info_table_;
2244 dcl       1 area_info_area    aligned automatic structure like area_info;
2245 
2246 dcl       1 common            static,                       /* initial values of fixed_common */
2247             2 prog_name       char (30) init (""),
2248             2 compiler_rev_no char (25) init (""),
2249             2 phase_name      char (6) init (""),
2250             2 currency        char (1) init ("$"),
2251             2 fatal_no        fixed bin (15) init (0),
2252             2 warn_no         fixed bin (15) init (0),
2253             2 proc_counter    fixed bin (15) init (0),
2254             2 spec_tag_counter
2255                               fixed bin (15) init (0),
2256             2 file_count      fixed bin (7) init (0),
2257             2 filedescr_offsets
2258                               (20) char (5) init ((20) (5)"0"),
2259             2 perf_alter_info char (5) init ("00000"),
2260             2 another_perform_info
2261                               char (5) init ("00000"),
2262             2 sort_in_info    char (5) init ("00000"),
2263             2 odo_info        char (5) init ("00000"),
2264             2 size_seg        fixed bin (15) init (0),
2265             2 size_offset     fixed bin (31) init (0),
2266             2 size_perform_info
2267                               char (5) init ("00000"),
2268             2 rename_info     char (5) init ("00000"),
2269             2 report_names    char (5) init ("00000"),
2270             2 rw_buf_seg      fixed bin (15) init (0),
2271             2 rw_buf_offset   fixed bin (31) init (0),
2272             2 rw_buf_length   fixed bin (31) init (0),
2273             2 file_keys       char (5) init ("00000"),
2274             2 search_keys     char (5) init ("00000"),
2275             2 dd_seg_size     fixed bin (31) init (65536),
2276             2 pd_seg_size     fixed bin (31) init (0),
2277             2 seg_limit       fixed bin (7) init (49),
2278             2 number_of_dd_segs
2279                               fixed bin (15) init (0),
2280             2 seg_info        char (5) init ("00000"),
2281             2 number_of_ls_pointers
2282                               fixed bin (15) init (0),
2283             2 link_sec_seg    fixed bin (15) init (0),
2284             2 link_sec_offset fixed bin (31) init (0),
2285             2 sra_clauses     fixed bin (15) init (0),
2286             2 fix_up_info     char (5) init ("00000"),
2287             2 linage_info     char (5) init ("00000"),
2288             2 first_dd_item   char (5) init ("00000"),
2289             2 sort_out_info   char (5) init ("00000"),
2290             2 db_info         char (5) init ("00000"),
2291             2 realm_info      char (5) init ("00000"),
2292             2 rc_realm_info   char (5) init ("00000"),
2293             2 last_file_key   char (5) init ("00000"),
2294             2 prog_coll_seq   fixed bin (15) init (0),
2295             2 sysin_fno       fixed bin (15) init (0),
2296             2 sysout_fno      fixed bin (15) init (0),
2297             2 dummy11         fixed bin (15) init (0),
2298             2 dummy12         fixed bin (15) init (0),
2299             2 dummy13         fixed bin (15) init (0),
2300             2 dummy14         fixed bin (15) init (0),
2301             2 dummy15         fixed bin (15) init (0),
2302             2 opts,
2303               3 cu            bit (1) unaligned,            /* produce a cu*/
2304               3 pst           bit (1) unaligned,            /* produce a symbol table */
2305               3 wn            bit (1) unaligned,            /* list warnings in listing*/
2306               3 obs           bit (1) unaligned,            /* list observations in listing */
2307               3 dm            bit (1) unaligned,            /* NA produce a data map*/
2308               3 xrl           bit (1) unaligned,            /* NA list cross reference by line number*/
2309               3 xrn           bit (1) unaligned,            /* list cross references by data name*/
2310               3 src           bit (1) unaligned,            /* NA list original source */
2311               3 obj           bit (1) unaligned,            /* list object code */
2312               3 exs           bit (1) unaligned,            /* list expanded source*/
2313               3 sck           bit (1) unaligned,            /* NA sequence check the source*/
2314               3 rno           bit (1) unaligned,            /*NA renumber the output source*/
2315               3 u_l           bit (1) unaligned,            /* convert lower case to upper case (1) or
2316                                            convert upper case to lower case (0).
2317                                            Only meaningful if cnv = 1. */
2318               3 cnv           bit (1) unaligned,            /* do concobol_version specified in u_l. */
2319               3 cos           bit (1) unaligned,            /* NA compile optional source statements */
2320               3 fmt           bit (1) unaligned,            /* accept pseudo-free-form source */
2321               3 profile       bit (1) unaligned,
2322               3 nw            bit (1) unaligned,            /* observations and warnings not printed on output listing*/
2323                                                             /*06-30-77*/
2324               3 exp           bit (1) unaligned,            /* option to call cobol_expand_source_ */
2325               3 card          bit (1) unaligned,            /*[4.1-1]*/
2326               3 fil2          bit (5) unaligned,
2327               3 m_map         bit (1) unaligned,            /* Produce a procedure division map*/
2328               3 m_bf          bit (1) unaligned,            /* print brief diags on terminal */
2329               3 m_fat         bit (1) unaligned,            /* print fatal diags on terminal */
2330               3 m_wn          bit (1) unaligned,            /* print warnings on terminal */
2331               3 m_obs         bit (1) unaligned,            /* print observations on terminal*/
2332               3 pd            bit (1) unaligned,            /* print diags on terminal */
2333               3 oc            bit (1) unaligned,            /* generate code for object time checking*/
2334             2 supervisor      bit (1) init ("0"b),
2335             2 dec_comma       bit (1) init ("0"b),
2336             2 init_cd         bit (1) init ("0"b),
2337             2 corr            bit (1) init ("0"b),
2338             2 initl           bit (1) init ("0"b),
2339             2 debug           bit (1) init ("0"b),
2340             2 report          bit (1) init ("0"b),
2341             2 sync_in_prog    bit (1) init ("0"b),
2342             2 pd_section      bit (1) init ("0"b),
2343             2 list_switch     bit (1) init ("1"b),
2344             2 alpha_cond      bit (1) init ("0"b),
2345             2 num_cond        bit (1) init ("0"b),
2346             2 spec_sysin      bit (1) init ("0"b),
2347             2 spec_sysout     bit (1) init ("0"b),
2348             2 dummy16         bit (1) init ("0"b),
2349             2 obj_dec_comma   bit (1) init ("0"b),
2350             2 default_sign_type
2351                               bit (3) init ("001"b),        /* trailing overpunch */
2352             2 default_display bit (1) init ("0"b),
2353             2 syntax_trace    bit (1) init ("0"b),
2354             2 dummy17_1       bit (17) init (""b),
2355             2 descriptor      bit (2) init ("10"b),
2356             2 levsv           bit (3) init ("001"b),        /*[4.0-1]*/
2357             2 dummy17         bit (5) init (""b),
2358             2 lvl_rstr        bit (32) init (""b),
2359             2 inst_rstr       bit (32) init (""b),
2360             2 comp_level      char (1) init ("5"),
2361             2 dummy18         char (30) init (""),
2362             2 object_sign     char (1) init (""),
2363             2 last_print_rec  char (5) init ("00000"),
2364             2 coll_seq_info   char (5) init ("00000"),
2365             2 sys_status_seg  fixed bin (15) init (0),
2366             2 sys_status_offset
2367                               fixed bin (31) init (0),
2368             2 compiler_id     fixed bin (15) init (3),
2369             2 date_comp_ln    fixed bin (15) init (0),
2370             2 compile_mode    bit (36) init ("0"b),
2371             2 default_temp    fixed bin (15) init (30),
2372             2 dummy26         fixed bin (15) init (0),
2373             2 display_device  fixed bin (15) init (0),
2374             2 dummy28         fixed bin (15) init (0),
2375             2 alphabet_offset fixed bin init (0);
2376 
2377 declare   1 MESS              static,
2378             2 M1              char (77)
2379                               init ("cobol: The -fmt option is assumed since the file is apparently in free format"),
2380             2 M2              char (60) init ("cobol: The -card option is inconsistant with the -fmt option"),
2381             2 M3              char (102)
2382                               init (
2383                               "cobol: A run time symbol table was requested and one of the options -expand, -format or -card was used"
2384                               ),
2385             2 M4              char (111)
2386                               init (
2387                               "cobol: The -exp option may not be used if the entry name of the source program ends in "".ex.cobol"""
2388                               );
2389 
2390 dcl       1 c_name            static,                       /*[3.0-9]*/
2391             2 ct              fixed bin,                    /*[3.0-9]*/
2392             2 size            fixed bin,                    /*[3.0-9]*/
2393             2 last_name_ptr   ptr,
2394             2 pname           char (168) aligned,
2395             2 uid             bit (36),
2396             2 dtm             bit (36);
2397 
2398 dcl       1 query_info        aligned static,
2399             2 cobol_version   fixed bin init (2),
2400             2 yes_or_no_sw    bit (1) unal init ("1"b),
2401             2 suppress_name_sw
2402                               bit (1) unal init ("0"b),
2403             2 status_code     fixed bin (35) init (0),
2404             2 query_code      fixed bin (35) init (0);
2405 
2406 dcl       01 anarea           based (rtbuff_ptr) aligned,
2407             02 dummy_ptr      ptr,
2408             02 rtarea         char (82000);
2409 
2410 
2411 dcl       argb                char (l) based (arg_ptr);
2412 dcl       tpb                 char (ltp) based (tp_ptr);    /* path name of source program (minus .cobol */
2413 dcl       dpb                 char (ldp) based (p_ptr);     /* path name of directory of source program */
2414 dcl       enb                 char (len) based (e_ptr);     /* name of object program */
2415 dcl       first_source_line   char (32) based (cobol_sfp);  /*[5.1-3]*/
2416 dcl       include_ptr         (0:1000) ptr based (cobol_$include_info_ptr);
2417 
2418 /* [3.0-9] */
2419 dcl       words               (alloc_size) fixed bin (35) based;
2420                                                             /* [3.0-9] */
2421 dcl       cobol_area          area based (cobol_area_ptr);
2422 dcl       lname               char (len + 5) based (addr (ln));
2423 
2424 
2425 dcl       1 source_name       based (source_name_ptr),      /* [3.0-9] */
2426             2 prev_name_ptr   ptr,
2427             2 sname           char (168) aligned,
2428             2 uid             bit (36),
2429             2 dtm             bit (36);
2430 
2431 declare   fdir                char (fdlen) based (fd_ptr);  /* pathname or dir containing work files */
2432 
2433 
2434 declare   (command_abort, command_abort_, cleanup)
2435                               condition;                    /* [3.0-4] */
2436 
2437 /*[5.1-2]*/
2438 declare   cobol$define_data   entry;
2439 
2440 dcl       expand_cobol_source$expand
2441                               entry (ptr, fixed bin (35));
2442 dcl       hcs_$fs_get_path_name
2443                               entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
2444 declare   hcs_$status_long    entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
2445                                                             /* [3.0-6] */
2446 declare   delete_$path        entry (char (*), char (*), bit (6), char (*), fixed bin (35));
2447                                                             /* [3.0-5] */
2448 
2449 dcl       (size, divide, index, mod, null, pointer, string, substr, addr)
2450                               builtin;
2451 
2452 dcl       cobol$restart       ext entry;
2453 dcl       cobol_control_$cancel
2454                               ext entry (char (*), fixed bin, fixed bin, fixed bin (35));
2455 dcl       cobol_version$print entry;
2456 dcl       cobol_make_link_$type_4
2457                               entry (fixed bin, char (*));
2458 dcl       cobol_version$set   entry;
2459 dcl       cu_$cl              ext entry;
2460 dcl       cobol_lex           ext entry (char (*));
2461 dcl       cobol_repl3         ext entry (fixed bin (31), ptr);
2462 dcl       cobol_print_diag    entry;
2463 
2464 dcl       (cobol_pdstax, cobol_ddsyntax, cobol_ddalloc, cobol_idedsyn, cobol_ci_phase, cobol_db_phase, cobol_gen_driver_,
2465           cobol_fix_driver_, cobol_make_xref_)
2466                               ext entry;
2467 
2468 
2469 dcl       (cobol_generator, cobol_fixup)
2470                               ext entry;
2471 dcl       cobol_source_formatter_
2472                               entry (ptr, ptr, fixed bin (15), fixed bin, fixed bin);
2473 dcl       cobol_init_         ext entry (char (168), ptr);
2474 dcl       cobol_init_$segs    ext entry (fixed bin (35), char (168) aligned);
2475                                                             /* [3.0-2] */
2476 dcl       condition_          entry (char (*), entry);
2477 dcl       get_pdir_           entry returns (char (168) aligned);
2478 dcl       get_wdir_           entry returns (char (168) aligned);
2479 
2480 /*[4.4-8]*/
2481 declare   hcs_$set_bc         entry (char (*), char (*), fixed bin (24), fixed bin (35));
2482 
2483 dcl       hcs_$delentry_file  entry (char (*), char (*), fixed bin (35));
2484 dcl       hcs_$truncate_file  entry (char (*), char (*), fixed bin, fixed bin (35));
2485 dcl       hcs_$truncate_seg   entry (ptr, fixed bin, fixed bin (35));
2486 dcl       hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35));
2487 dcl       hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
2488 dcl       revert_cleanup_proc_
2489                               entry;
2490 dcl       establish_cleanup_proc_
2491                               entry (entry);
2492 dcl       hcs_$make_seg       entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
2493 dcl       hcs_$initiate       entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
2494 dcl       com_err_            entry options (variable);
2495 dcl       hcs_$get_usage_values
2496                               ext entry (fixed bin, fixed bin (71), fixed bin);
2497 dcl       ioa_                entry options (variable);
2498 dcl       ioa_$ioa_stream     entry options (variable);
2499 dcl       cu_$arg_count       entry (fixed bin);
2500 dcl       cu_$af_arg_count    entry (fixed bin, fixed bin (35));
2501 dcl       cu_$arg_ptr         entry (fixed bin, ptr, fixed bin, fixed bin (35));
2502 dcl       cobol_syntax_trace_$initialize
2503                               entry (ptr);
2504 dcl       cobol_syntax_trace_$reset_trace
2505                               entry;
2506 dcl       cobol_gns$set_table entry;
2507 
2508 
2509 dcl       command_query_      entry options (variable);
2510 
2511 dcl       cobol_cselfle       entry (bit (32), ptr, char (*), char (3), fixed bin (15), char (1), bit (8)) ext;
2512 dcl       (cobol_swf, cobol_vdwf)
2513                               entry (ptr, char (*)) ext;
2514 dcl       cobol_vdwf_open     entry (ptr, bit (32)) ext;
2515 dcl       (cobol_vdwf_dget, cobol_vdwf_sput)
2516                               entry (ptr, bit (32), ptr, fixed bin (15), char (5));
2517 dcl       cobol_swf_open      entry (ptr, bit (32), ptr, fixed bin (15), char (2)) ext;
2518 dcl       (cobol_swf_close, cobol_vdwf_close)
2519                               entry (ptr, bit (32), ptr, fixed bin (15)) ext;
2520 
2521 declare   cobol_merge$source_file_size
2522                               entry (fixed bin (24));
2523 
2524 /* [3.0-9] */
2525 dcl       get_temp_segments_  entry (char (*), (*) ptr, fixed bin (35));
2526                                                             /* [3.0-9] */
2527 dcl       release_temp_segments_
2528                               entry (char (*), (*) ptr, fixed bin (35));
2529                                                             /* [3.0-9] */
2530 dcl       define_area_        entry (ptr, fixed bin (35));  /* [3.0-9] */
2531 dcl       release_area_       entry (ptr);
2532 
2533 
2534 dcl       expand_pathname_    entry (char (*), char (*), char (*), fixed bin (35)),
2535           absolute_pathname_  entry (char (*), char (*), fixed bin (35)),
2536           hcs_$status_minf    entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
2537           expand_pathname_$add_suffix
2538                               entry (char (*), char (*), char (*), char (*), fixed bin (35));
2539 
2540 
2541 %include cobol_;
2542 %include cobol_fixed_common;
2543 %include cobol_ext_;
2544 %include cobol_fsb;
2545 %include iocb;
2546 %include cobol_ecs_info;
2547 /* [3.0-8] */
2548 
2549 /*[4.4-7]*/
2550 declare   1 branch_status     aligned like status_branch;
2551 
2552 %include status_structures;
2553 
2554 %include area_info;
2555 /* [3.0-9] */
2556 
2557 declare   1 cond_info         static,
2558 %include cond_info;
2559      end cobol;