1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Bull Inc., 1987                *
   6         *                                                         *
   7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   8         *                                                         *
   9         * Copyright (c) 1972 by Massachusetts Institute of        *
  10         * Technology and Honeywell Information Systems, Inc.      *
  11         *                                                         *
  12         *********************************************************** */
  13 
  14 
  15 
  16 /****^  HISTORY COMMENTS:
  17   1) change(87-03-05,Huen), approve(87-03-05,MCR7629), audit(87-04-15,RWaters),
  18      install(87-05-14,MR12.1-1030):
  19      Fix PL/1 errors 2141 -
  20      Print a warning message about the truncation of the listing segment name.
  21   2) change(88-08-23,RWaters), approve(88-08-23,MCR7914), audit(88-09-28,Huen),
  22      install(88-10-12,MR12.2-1163):
  23      Added the -no_prefix control argument.
  24   3) change(89-04-17,JRGray), approve(89-04-17,MCR8078), audit(89-04-18,Huen),
  25      install(89-06-09,MR12.3-1055):
  26      Modified to allow for archive component pathnames.
  27   4) change(89-08-01,RWaters), approve(89-08-01,MCR8069), audit(89-09-07,Vu),
  28      install(89-09-19,MR12.3-1068):
  29      Added the -version and -no_version control arguments.
  30                                                    END HISTORY COMMENTS */
  31 
  32 /*        PL/I COMMAND.
  33 
  34           This command has been rewritten in PL/I and observes Standard
  35           Service System conventions.  Modelled after the Fortran S.S.S.
  36           command written by John Gintell.
  37 
  38           Written by:         J.D.Mills
  39           On:                 26 September 1969
  40           Modified on:        16 October 1969, by JDM.
  41           Modified on:        30 October 1969, by JDM for multiple tree segments.
  42           Modified on:        13 November 1969, by JDM to call hcs_ directly.
  43           Modified on:        1 December 1969, by JDM to treat pre-expanded source correctly.
  44           Modified on:        5 December 1969, by BLW to print compilation times
  45           Modified on:        20 December 1969, by JDM for greater speed.
  46           Modified on:        28 January 1970 by BLW to use cu_
  47           Modified on:        18 March 1970 by BLW to call optimizer
  48           Modified on:        15 April 1970 by BLW for table option
  49           Modified on:         8 July 1970 by BLW for new expand_
  50           Modified on:        16 July 1970 by BLW for epilogue
  51           Modified on:        22 July 1970 by BLW for token_list in tree_
  52           Modified on:        6 August 1970 by PAG to eliminate varying strings in calls to hcs_ and
  53                               to check length of entry name and the suffix
  54           Modified on:        26 August 1970 by PAG for Version II
  55           Modified on:        18 September 1970 by PAG to optionally call semantic_translator
  56           Modified on:        27 September 1970 by PG to compute percentages in $times entry
  57           Modified on:        11 January 1971 by BLW to remove intermediate seg creation
  58                               and change to pl1_stat_
  59           Modified on:        29 January 1971 by BLW to be full PL/2 command
  60           Modified on:        5 February l97l by PG for lexical stuff.
  61           Modified on:        13 April 1971 by BLW to get ptr to error messages
  62           Modified on:        7 August 1971 by PG to combine context_processor into parse
  63           Modified on:        21 August 1971 by PG to combine lex and create_token
  64           Modified on:        21 October 1971 by BLW to call code_gen_
  65           Modified on:        15 January 1972 by BLW for profile option
  66           Modified on:        28 March 1972 by BLW for storage use summary
  67           Modified on:        27 June 1972 by PG for tssi_, msf_manager_, prepare_symbol_table, and the link option
  68           Modified on:        21 August 1972 by PG for find_include_file_
  69           Modified on:        20 December 1972 by RAB for 2 segment tree
  70           Modified on:        23 June 1975 by EEW to recognize arg: -separate_static
  71           Modified on:        4 December 1975 by EEW to fix cleanup problems (bug 1434)
  72           Modified on:        14 April 1976 by RAB to use get_line_length_
  73           Modified on:        22 June 1976 by RHS to support the "new" area package, with full "retry"
  74           Modified on:        29 July 1976 by RAB to not allow control args of the form "- xxxxxx"
  75           Modified on:        1 Dec 1976 by RAB for -long_profile
  76           Modified on:        16 Feb 1977 by RAB for -check_ansi
  77           Modified on:        April 1977 by RHS to use standard areas
  78           Modified on:        770504 by PG for EIS lex
  79           Modified on:        14 June 1977 by RAB for pl1_stat_$defined_list
  80           Modified on:        770712 by PG for pl1_severity_
  81           Modified on:        17 October 1977 by RAB to fix bug 1681
  82           Modified on:        26 September 1978 by PCK to flag unaligned decimal for Release 25, not accept -source and
  83                               -symbol control arguments, require a dash to precede every control argument,
  84                               and print the Release number of the compiler.
  85           Modified on:        10 Feb 1978 by RAB to clean up printing out of tree and xeq_tree info.
  86           Modified on:        24 May 1979 by PCK to implement options(packed_decimal)
  87           Modified on:        26 May 1979 by D. Spector to add -single_symbol_list (-ssl) control arg.
  88           Modified on:        3 October 1979 by PCK to allow pl1_version to be
  89                               bound with bound_pl1_ and rename pl1_error_messages_
  90           Modified on:        20 November 1979 by PCK to initialize cg_static_$in_prologue and
  91                               cg_static_$in_thunk to "0"b (part of the fix to bug 1858)
  92           Modified on:        4 March 1980 by M. N. Davidoff to clean up, fix bugs 1874, 1876, 1904, 1907 and allow
  93                               -source, -symbols (suggestion 1892).
  94           Modified on:        20 March 1980 by PCK to implement by name assignment
  95                               and increase the default error message width
  96           Modified on:        17 April 1980 by M. N. Davidoff to use pl1_error_messages_ for installed compiler.
  97           Modified on:        23 September 1980 by M. N. Davidoff to print message when invoked as an active function
  98                               (suggestion 1957) and did some restructuring to make planned modifications easier.
  99           Modified on:        16 October 1980 by M. N. Davidoff to move call to tree_manager$init to after the command
 100                               argument parsing loop (2024), implement -long, -no_check, -no_check_ansi, -no_list,
 101                               -no_optimize, -no_profile, -no_separate_static, -no_table, -no_debug, -no_time (1943), and to
 102                               make -table the default unless -no_table, -brief_table or -optimize were specified (1946).
 103           Modified on:        24 October 1980 by M. N. Davidoff to implement -prefix (1947).
 104           Modified on:        19 November 1981 by C. Hornig to allow long_profile with separate_static.
 105           Modified on:        25 April 1983 by Rick Gray to call find_source_file_ which allows archive
 106                               component pathnames.
 107           Modified on:        28 August 1984 by JAFalksen to use date_time_$format ("date_time",...
 108           Modified on:        15 January 1987 by S. Huen to print a warning message about the truncation of the listing segment name.
 109           Modified on:        15 August 1988 by RWaters to accept the -no_prefix control argument.
 110           Modified on:        28 February 1989 by RWaters to accept -version and -no_version.
 111 */
 112 /* format: style3,idind30 */
 113 pl1exl:
 114 v2pl1:
 115 pl1:
 116      procedure options (variable);
 117 
 118 /* automatic */
 119 
 120 declare   argument_no                   fixed bin;
 121 declare   arg_count                     fixed bin;
 122 declare   arg_length                    fixed bin (21);
 123 declare   arg_ptr                       ptr;
 124 declare   bitcnt                        fixed bin (24);
 125 declare   1 blast_ca,
 126             2 off                       bit (1),
 127             2 on                        bit (1),
 128             2 set                       bit (1);
 129 declare   blast_msg_len                 fixed bin (21);
 130 declare   blast_msg_ptr                 ptr;
 131 declare   1 ca                          aligned,
 132             2 no_optimize               bit (1),
 133             2 optimize                  bit (1),
 134             2 no_table                  bit (1),
 135             2 brief_table               bit (1),
 136             2 table                     bit (1),
 137             2 no_check                  bit (1),
 138             2 check                     bit (1),
 139             2 no_list                   bit (1),
 140             2 source                    bit (1),
 141             2 symbols                   bit (1),
 142             2 map                       bit (1),
 143             2 list                      bit (1),
 144             2 single_symbol_list        bit (1),
 145             2 brief                     bit (1),
 146             2 long                      bit (1),
 147             2 severity                  bit (1),
 148             2 no_profile                bit (1),
 149             2 profile                   bit (1),
 150             2 long_profile              bit (1),
 151             2 no_separate_static        bit (1),
 152             2 separate_static           bit (1),
 153             2 no_check_ansi             bit (1),
 154             2 check_ansi                bit (1),
 155             2 no_time                   bit (1),
 156             2 time                      bit (1),
 157             2 no_debug                  bit (1),
 158             2 debug                     bit (1),
 159             2 debug_semant              bit (1),
 160             2 debug_cg                  bit (1),
 161             2 no_cpdcls                 bit (1),
 162             2 cpdcls                    bit (1),
 163             2 no_link                   bit (1),
 164             2 link                      bit (1),
 165             2 prefix                    bit (1),
 166             2 no_version                bit (1);
 167 
 168 declare   called_cg                     bit (1) aligned;
 169 declare   clock_time                    fixed bin (71);
 170 declare   code                          fixed bin (35);
 171 declare   component                     fixed bin;
 172 declare   fcb                           ptr;
 173 declare   i                             fixed bin;
 174 declare   in_cg                         bit (1) aligned;
 175 declare   len                           fixed bin (21);
 176 declare   list_hold                     ptr;
 177 declare   list_size                     fixed bin (19);
 178 declare   listname                      char (32);
 179 declare   lname                         char (32) varying;
 180 declare   object_hold                   ptr;
 181 declare   objectname                    char (32);
 182 declare   output_pt                     ptr;
 183 declare   pathname                      char (256);
 184 declare   pd_faults                     fixed bin;
 185 declare   1 prefix                      aligned,
 186             2 mask                      bit (12),
 187             2 conditions                bit (12);
 188 declare   prefix_string_length          fixed bin (21);
 189 declare   prefix_string_ptr             ptr;
 190 declare   produce_listing               bit (1) aligned;
 191 declare   source_seg                    ptr;
 192 declare   sourcename                    char (32);
 193 declare   symbols_on                    bit (1) aligned;
 194 declare   translation_failed            bit (1) aligned;
 195 declare   wdirname                      char (168);
 196 
 197 /* based */
 198 
 199 declare   arg_string                    char (arg_length) based (arg_ptr);
 200 declare   blast_msg                     char (blast_msg_len) based (blast_msg_ptr);
 201 declare   digit_pic                     picture "9" based;
 202 declare   prefix_string                 char (prefix_string_length) based (prefix_string_ptr);
 203 declare   source_string                 char (len) based (source_seg);
 204 
 205 /* builtin */
 206 
 207 declare   (addrel, baseno, before, binary, char, clock, codeptr, convert, divide, index, hbound, lbound, length, ltrim,
 208           mod, null, rtrim, search, string, substr, verify)
 209                                         builtin;
 210 
 211 /* condition */
 212 
 213 declare   cleanup                       condition;
 214 declare   listing_overflow              condition;
 215 
 216 /* internal static */
 217 
 218 declare   HT_SP                         char (2) internal static options (constant) initial ("       ");
 219 declare   HT_SP_COMMA                   char (3) internal static options (constant) initial ("       ,");
 220 declare   blast_time                    fixed bin (71) internal static initial (0);
 221 declare   comptime                      char (64) var internal static;
 222 declare   error_messages                ptr internal static initial (null);
 223 declare   my_name                       char (3) internal static options (constant) initial ("pl1");
 224 declare   ncpu                          (0:7) fixed bin (71) internal static initial ((8) 0);
 225 declare   npages                        (0:7) fixed bin internal static;
 226 declare   number_free_segs              fixed bin internal static;
 227 declare   objectbc                      fixed bin (24) internal static;
 228 declare   phase_name                    (7) char (9) internal static options (constant)
 229                                         initial ("setup", "parse", "semantics", "optimizer", "code gen", "listing",
 230                                         "cleanup");
 231 declare   storage                       (0:7) char (10) internal static initial ((8) (1)"         0");
 232 declare   version                       char (132) varying internal static;
 233 declare   xeq_storage                   (0:7) char (10) internal static initial ((8) (1)"         0");
 234 
 235 /* external static */
 236 
 237 declare   cg_static_$debug              bit (1) aligned external static;
 238 declare   cg_static_$in_prologue        bit (1) aligned external static;
 239 declare   cg_static_$in_thunk           bit (1) aligned external static;
 240 declare   cg_static_$optimize           bit (1) aligned external static;
 241 declare   cg_static_$separate_static    bit (1) aligned external static;
 242 declare   cg_static_$stop_id            bit (27) external static;
 243 declare   cg_static_$support            bit (1) aligned external static;
 244 declare   error_table_$badopt           fixed bin (35) external static;
 245 declare   error_table_$entlong          fixed bin (35) external static;
 246 declare   error_table_$inconsistent     fixed bin (35) external static;
 247 declare   error_table_$translation_failed
 248                                         fixed bin (35) external static;
 249 declare   error_table_$zero_length_seg  fixed bin (35) external static;
 250 declare   pl1_blast_$blast_message      char (64) varying external static;
 251 declare   pl1_blast_$blast_on           bit (1) aligned external static;
 252 declare   pl1_blast_$blast_time         fixed bin (71) external static;
 253 declare   pl1_severity_                 fixed bin (35) external static;
 254 declare   pl1_stat_$abort_label         label external static;
 255 declare   pl1_stat_$brief_error_mode    bit (1) aligned external static;
 256 declare   pl1_stat_$by_name_free_list   ptr aligned external static;
 257 declare   pl1_stat_$by_name_parts_free_list
 258                                         ptr aligned external static;
 259 declare   pl1_stat_$by_name_parts_tree  ptr aligned external static;
 260 declare   pl1_stat_$by_name_ref_list    ptr aligned external static;
 261 declare   pl1_stat_$char_pos            fixed bin (21) external static;
 262 declare   pl1_stat_$check_ansi          bit (1) aligned external static;
 263 declare   pl1_stat_$compiler_invoked    bit (1) aligned external static;
 264 declare   pl1_stat_$compiler_name       char (8) varying external static;
 265 declare   pl1_stat_$constant_list       ptr external static;
 266 declare   pl1_stat_$debug_semant        bit (1) aligned external static;
 267 declare   pl1_stat_$defined_list        ptr external static;
 268 declare   pl1_stat_$dummy_block         ptr external static;
 269 declare   pl1_stat_$error_messages      ptr external static;
 270 declare   pl1_stat_$error_width         fixed bin external static;
 271 declare   pl1_stat_$generate_symtab     bit (1) aligned external static;
 272 declare   pl1_stat_$greatest_severity   fixed bin external static;
 273 declare   pl1_stat_$index               fixed bin external static;
 274 declare   pl1_stat_$last_statement_id   bit (36) external static;
 275 declare   pl1_stat_$line_count          fixed bin external static;
 276 declare   pl1_stat_$list_ptr            ptr external static;
 277 declare   pl1_stat_$listing_on          bit (1) aligned external static;
 278 declare   pl1_stat_$max_list_size       fixed bin (21) external static;
 279 declare   pl1_stat_$max_node_type       fixed bin external static;
 280 declare   pl1_stat_$new_fortran_option  bit (1) aligned external static;
 281 declare   pl1_stat_$node_name           (32) char (12) external static;
 282 declare   pl1_stat_$node_size           (32) fixed bin external static;
 283 declare   pl1_stat_$node_uses           (32) fixed bin external static;
 284 declare   pl1_stat_$ok_list             ptr external static;
 285 declare   pl1_stat_$optimize            bit (1) aligned external static;
 286 declare   pl1_stat_$options             char (400) varying external static;
 287 declare   pl1_stat_$options_packed_dec  bit (1) aligned external static;
 288 declare   pl1_stat_$pathname            char (168) varying external static;
 289 declare   pl1_stat_$phase               fixed bin external static;
 290 declare   pl1_stat_$print_cp_dcl        bit (1) aligned external static;
 291 declare   pl1_stat_$profile             bit (1) aligned external static;
 292 declare   pl1_stat_$profile_length      fixed bin external static;
 293 declare   pl1_stat_$root                ptr external static;
 294 declare   pl1_stat_$seg_name            char (32) varying external static;
 295 declare   pl1_stat_$severity_plateau    fixed bin external static;
 296 declare   pl1_stat_$single_symbol_list  bit (1) aligned external static;
 297 declare   pl1_stat_$stop_id             bit (27) external static;
 298 declare   pl1_stat_$table               bit (1) aligned external static;
 299 declare   pl1_stat_$temporary_list      ptr external static;
 300 declare   pl1_stat_$tree_area_ptr       ptr external static;
 301 declare   pl1_stat_$unaligned_dec       bit (1) aligned external static;
 302 declare   pl1_stat_$use_old_area        bit (1) aligned external static;
 303 declare   pl1_stat_$user_id             char (32) aligned external static;
 304 declare   pl1_stat_$validate_proc       ptr external static;
 305 declare   pl1_stat_$version             fixed bin external static;
 306 declare   pl1_stat_$xeq_tree_area_ptr   ptr external static;
 307 declare   pl1_version$pl1_release       char (3) varying external static;
 308 declare   pl1_version$pl1_version       char (256) varying external static;
 309 
 310 /* entry */
 311 
 312 /* Parts of the compiler */
 313 
 314 declare   code_gen_                     entry (char (32) varying, char (3) varying, char (132) varying, ptr, ptr, ptr,
 315                                         ptr, ptr, ptr, fixed bin (71), fixed bin, bit (1) aligned, bit (1) aligned,
 316                                         bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (1) aligned,
 317                                         bit (1) aligned, entry, entry, fixed bin (24), fixed bin, fixed bin (71),
 318                                         bit (1) aligned, ptr, bit (1) aligned, fixed bin, fixed bin (71), bit (1) aligned)
 319                                         ;
 320 declare   code_gen_$return_bit_count    entry (fixed bin (24), fixed bin, fixed bin (71), fixed bin, fixed bin (71));
 321 declare   error_$finish                 entry;
 322 declare   lex$terminate_source          entry;
 323 declare   optimizer                     entry (ptr);
 324 declare   parse                         entry (ptr, char (*), 1 aligned, 2 bit (12), 2 bit (12));
 325 declare   pl1_print$non_varying         entry (char (*) aligned, fixed bin);
 326 declare   pl1_print$non_varying_nl      entry (char (*) aligned, fixed bin);
 327 declare   pl1_print$varying_nl          entry (char (*) varying);
 328 declare   pl1_signal_catcher            entry (ptr, char (*), ptr, ptr, bit (1) aligned);
 329 declare   pl1_symbol_print              entry (ptr, bit (1) aligned, bit (1) aligned);
 330 declare   prepare_symbol_table          entry (ptr);
 331 declare   scan_token_table              entry;
 332 declare   semantic_translator           entry;
 333 declare   tree_manager$init             entry (label);
 334 declare   tree_manager$truncate         entry;
 335 
 336 /* Others */
 337 
 338 declare   com_err_                      entry options (variable);
 339 declare   com_err_$suppress_name        entry options (variable);
 340 declare   condition_                    entry (char (*), entry);
 341 declare   cu_$arg_count                 entry (fixed bin, fixed bin (35));
 342 declare   cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 343 declare   cpu_time_and_paging_          entry (fixed bin, fixed bin (71), fixed bin);
 344 declare   date_time_$format             entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
 345 declare   debug                         entry options (variable);
 346 declare   find_source_file_             entry (char (*), char (*), char (*), ptr, fixed bin (24), fixed bin (35));
 347 declare   get_line_length_$switch       entry (ptr, fixed bin (35)) returns (fixed bin);
 348 declare   get_group_id_                 entry () returns (char (32));
 349 declare   get_wdir_                     entry () returns (char (168));
 350 declare   hcs_$get_max_length_seg       entry (ptr, fixed bin (19), fixed bin (35));
 351 declare   hcs_$make_ptr                 entry (ptr, char (*), char (*), ptr, fixed bin (35));
 352 declare   hcs_$terminate_noname         entry (ptr, fixed bin (35));
 353 declare   hcs_$truncate_seg             entry (ptr, fixed bin (19), fixed bin (35));
 354 declare   how_many_users                entry options (variable);
 355 declare   ioa_                          entry options (variable);
 356 declare   ioa_$nnl                      entry options (variable);
 357 declare   msf_manager_$get_ptr          entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
 358 declare   system_info_$installation_id  entry (char (*));
 359 declare   tssi_$clean_up_file           entry (ptr, ptr);
 360 declare   tssi_$clean_up_segment        entry (ptr);
 361 declare   tssi_$finish_file             entry (ptr, fixed bin, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
 362 declare   tssi_$finish_segment          entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
 363 declare   tssi_$get_file                entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35));
 364 declare   tssi_$get_segment             entry (char (*), char (*), ptr, ptr, fixed bin (35));
 365 
 366 /* format: style3,inddcls */
 367 ^L
 368 %include condition_name;
 369 %include area_structures;
 370 %include pl1_version;
 371 ^L
 372 /* program */
 373 
 374           pl1_severity_ = 5;
 375 
 376           call cu_$arg_count (arg_count, code);
 377           if code ^= 0
 378           then do;
 379                     call com_err_ (code, my_name);
 380                     return;
 381                end;
 382 
 383           if pl1_stat_$compiler_invoked
 384           then do;
 385                     call com_err_ (0, my_name, "The compiler has been invoked with a previous invocation suspended.");
 386                     call com_err_ (error_table_$translation_failed, my_name,
 387                          "Attempt to invoke pl1 recursively. Use release first.");
 388                     return;
 389                end;
 390 
 391           call cpu_time_and_paging_ (npages (0), ncpu (0), pd_faults);
 392 
 393           do i = 1 to hbound (npages, 1);
 394                npages (i) = -1;
 395           end;
 396 
 397           number_free_segs = 0;
 398 
 399           if error_messages = null
 400           then begin;
 401                     declare   error_messages_name char (32);
 402 
 403                     version = pl1_version$pl1_version;
 404                     pl1_stat_$user_id = get_group_id_ ();
 405 
 406                     if pl1_version$pl1_release = "EXL"
 407                     then error_messages_name = "pl1exl_error_messages_";
 408                     else error_messages_name = "pl1_error_messages_";
 409 
 410                     call hcs_$make_ptr (codeptr (v2pl1), error_messages_name, "", error_messages, code);
 411                     if code ^= 0
 412                     then do;
 413                               call com_err_ (code, my_name, "^a", error_messages_name);
 414                               return;
 415                          end;
 416                end;
 417 
 418           pl1_stat_$error_messages = error_messages;
 419           pl1_stat_$greatest_severity = 5;
 420           pl1_stat_$compiler_name = my_name;
 421           pl1_stat_$use_old_area = "0"b;
 422 
 423           do i = 1 to pl1_stat_$max_node_type;
 424                pl1_stat_$node_uses (i) = 0;
 425           end;
 426 
 427           pl1_stat_$abort_label = abort_return;
 428 
 429           in_cg, called_cg, translation_failed, pl1_stat_$generate_symtab, pl1_stat_$last_statement_id,
 430                pl1_stat_$new_fortran_option, pl1_stat_$unaligned_dec, pl1_stat_$options_packed_dec, cg_static_$support,
 431                cg_static_$in_prologue, cg_static_$in_thunk = "0"b;
 432 
 433           pl1_stat_$error_width = get_line_length_$switch (null, code);
 434 
 435           pl1_stat_$validate_proc, pl1_stat_$constant_list, pl1_stat_$ok_list, pl1_stat_$dummy_block,
 436                pl1_stat_$defined_list, pl1_stat_$by_name_free_list, pl1_stat_$by_name_parts_free_list,
 437                pl1_stat_$by_name_parts_tree, pl1_stat_$by_name_ref_list, pl1_stat_$temporary_list = null;
 438 
 439           pl1_stat_$profile_length, pl1_stat_$index = 0;
 440 
 441           pl1_stat_$stop_id, cg_static_$stop_id = (27)"1"b;
 442 
 443           pl1_stat_$version = pl1_version;
 444 ^L
 445 /* Parse the command line arguments. */
 446 
 447           ca = ""b;
 448           argument_no = 0;
 449           do i = 1 to arg_count;
 450                call cu_$arg_ptr (i, arg_ptr, arg_length, code);
 451                if code ^= 0
 452                then do;
 453                          call com_err_ (code, my_name, "Argument ^d.", i);
 454                          return;
 455                     end;
 456 
 457                if index (arg_string, "-") = 1
 458                then if arg_string = "-no_optimize" | arg_string = "-not"
 459                     then do;
 460                               ca.no_optimize = "1"b;
 461                               ca.optimize = "0"b;
 462                          end;
 463 
 464                     else if arg_string = "-optimize" | arg_string = "-ot"
 465                     then do;
 466                               ca.no_optimize = "0"b;
 467                               ca.optimize = "1"b;
 468                          end;
 469 
 470                     else if arg_string = "-no_table" | arg_string = "-ntb"
 471                     then do;
 472                               ca.no_table = "1"b;
 473                               ca.brief_table = "0"b;
 474                               ca.table = "0"b;
 475                          end;
 476 
 477                     else if arg_string = "-brief_table " | arg_string = "-bftb"
 478                     then do;
 479                               ca.no_table = "0"b;
 480                               ca.brief_table = "1"b;
 481                               ca.table = "0"b;
 482                          end;
 483 
 484                     else if arg_string = "-table" | arg_string = "-tb"
 485                     then do;
 486                               ca.no_table = "0"b;
 487                               ca.brief_table = "0"b;
 488                               ca.table = "1"b;
 489                          end;
 490 
 491                     else if arg_string = "-no_check" | arg_string = "-nck"
 492                     then do;
 493                               ca.no_check = "1"b;
 494                               ca.check = "0"b;
 495                          end;
 496 
 497                     else if arg_string = "-check" | arg_string = "-ck"
 498                     then do;
 499                               ca.no_check = "0"b;
 500                               ca.check = "1"b;
 501                          end;
 502 
 503                     else if arg_string = "-no_list" | arg_string = "-nls"
 504                     then do;
 505                               ca.no_list = "1"b;
 506                               ca.source = "0"b;
 507                               ca.symbols = "0"b;
 508                               ca.map = "0"b;
 509                               ca.list = "0"b;
 510                               ca.single_symbol_list = "0"b;
 511                          end;
 512 
 513                     else if arg_string = "-source" | arg_string = "-sc"
 514                     then do;
 515                               ca.no_list = "0"b;
 516                               ca.source = "1"b;
 517                          end;
 518 
 519                     else if arg_string = "-symbols" | arg_string = "-sb"
 520                     then do;
 521                               ca.no_list = "0"b;
 522                               ca.symbols = "1"b;
 523                          end;
 524 
 525                     else if arg_string = "-map"
 526                     then do;
 527                               ca.no_list = "0"b;
 528                               ca.map = "1"b;
 529                          end;
 530 
 531                     else if arg_string = "-list" | arg_string = "-ls"
 532                     then do;
 533                               ca.no_list = "0"b;
 534                               ca.list = "1"b;
 535                          end;
 536 
 537                     else if arg_string = "-single_symbol_list" | arg_string = "-ssl"
 538                     then do;
 539                               ca.no_list = "0"b;
 540                               ca.single_symbol_list = "1"b;
 541                          end;
 542 
 543                     else if arg_string = "-brief" | arg_string = "-bf"
 544                     then do;
 545                               ca.brief = "1"b;
 546                               ca.long = "0"b;
 547                          end;
 548 
 549                     else if arg_string = "-long" | arg_string = "-lg"
 550                     then do;
 551                               ca.brief = "0"b;
 552                               ca.long = "1"b;
 553                          end;
 554 
 555                     else if index (arg_string, "-severity") = 1
 556                     then if ^parse_severity (arg_string, "-severity")
 557                          then return;
 558                          else ;
 559 
 560                     else if index (arg_string, "-sv") = 1
 561                     then if ^parse_severity (arg_string, "-sv")
 562                          then return;
 563                          else ;
 564 
 565                     else if arg_string = "-no_profile" | arg_string = "-npf"
 566                     then do;
 567                               ca.no_profile = "1"b;
 568                               ca.profile = "0"b;
 569                               ca.long_profile = "0"b;
 570                          end;
 571 
 572                     else if arg_string = "-profile" | arg_string = "-pf"
 573                     then do;
 574                               ca.no_profile = "0"b;
 575                               ca.profile = "1"b;
 576                               ca.long_profile = "0"b;
 577                          end;
 578 
 579                     else if arg_string = "-long_profile" | arg_string = "-lpf"
 580                     then do;
 581                               ca.no_profile = "0"b;
 582                               ca.profile = "0"b;
 583                               ca.long_profile = "1"b;
 584                          end;
 585 
 586                     else if arg_string = "-no_separate_static" | arg_string = "-nss"
 587                     then do;
 588                               ca.no_separate_static = "1"b;
 589                               ca.separate_static = "0"b;
 590                          end;
 591 
 592                     else if arg_string = "-separate_static" | arg_string = "-ss"
 593                     then do;
 594                               ca.no_separate_static = "0"b;
 595                               ca.separate_static = "1"b;
 596                          end;
 597 
 598                     else if arg_string = "-no_check_ansi"
 599                     then do;
 600                               ca.no_check_ansi = "1"b;
 601                               ca.check_ansi = "0"b;
 602                          end;
 603 
 604                     else if arg_string = "-check_ansi"
 605                     then do;
 606                               ca.no_check_ansi = "0"b;
 607                               ca.check_ansi = "1"b;
 608                          end;
 609 
 610                     else if arg_string = "-no_time" | arg_string = "-ntm"
 611                     then do;
 612                               ca.no_time = "1"b;
 613                               ca.time = "0"b;
 614                          end;
 615 
 616                     else if arg_string = "-time" | arg_string = "-tm"
 617                     then do;
 618                               ca.no_time = "0"b;
 619                               ca.time = "1"b;
 620                          end;
 621 
 622                     else if arg_string = "-no_debug" | arg_string = "-ndb"
 623                     then do;
 624                               ca.no_debug = "1"b;
 625                               ca.debug = "0"b;
 626                               ca.debug_semant = "0"b;
 627                               ca.debug_cg = "0"b;
 628                          end;
 629 
 630                     else if arg_string = "-debug" | arg_string = "-db"
 631                     then do;
 632                               ca.no_debug = "0"b;
 633                               ca.debug = "1"b;
 634                          end;
 635 
 636                     else if arg_string = "-debug_semant" | arg_string = "-dbse"
 637                     then do;
 638                               ca.no_debug = "0"b;
 639                               ca.debug_semant = "1"b;
 640                          end;
 641 
 642                     else if arg_string = "-debug_cg" | arg_string = "-dbcg"
 643                     then do;
 644                               ca.no_debug = "0"b;
 645                               ca.debug_cg = "1"b;
 646                          end;
 647 
 648                     else if arg_string = "-no_cpdcls"
 649                     then do;
 650                               ca.no_cpdcls = "1"b;
 651                               ca.cpdcls = "0"b;
 652                          end;
 653 
 654                     else if arg_string = "-cpdcls"
 655                     then do;
 656                               ca.no_cpdcls = "0"b;
 657                               ca.cpdcls = "1"b;
 658                          end;
 659 
 660                     else if arg_string = "-no_link" | arg_string = "-nlk"
 661                     then do;
 662                               ca.no_link = "1"b;
 663                               ca.link = "0"b;
 664                          end;
 665 
 666                     else if arg_string = "-link" | arg_string = "-lk"
 667                     then do;
 668                               ca.no_link = "0"b;
 669                               ca.link = "1"b;
 670                          end;
 671 
 672                     else if arg_string = "-version"
 673                     then do;
 674                               ca.no_version = "0"b;
 675                          end;
 676 
 677                     else if arg_string = "-no_version"
 678                     then do;
 679                               ca.no_version = "1"b;
 680                          end;
 681                     else if arg_string = "-no_prefix"
 682                     then do;
 683                               ca.prefix = "0"b;
 684                          end;
 685 
 686                     else if arg_string = "-prefix"
 687                     then do;
 688                               i = i + 1;
 689                               if i > arg_count
 690                               then do;
 691                                         call com_err_ (0, my_name, "Missing prefix string after -prefix.");
 692                                         return;
 693                                    end;
 694 
 695                               call cu_$arg_ptr (i, prefix_string_ptr, prefix_string_length, code);
 696                               if code ^= 0
 697                               then do;
 698                                         call com_err_ (code, my_name, "Argument ^d.", i);
 699                                         return;
 700                                    end;
 701 
 702                               ca.prefix = "1"b;
 703                          end;
 704 
 705                     else do;
 706                               call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
 707                               return;
 708                          end;
 709 
 710                else do;
 711                          argument_no = argument_no + 1;
 712                          if argument_no = 1                 /* process pathname later */
 713                          then pathname = arg_string;
 714                     end;
 715           end;
 716 
 717           if argument_no ^= 1
 718           then do;
 719                     if arg_count > 1 | ca.no_version
 720                     then call com_err_$suppress_name (0, my_name, "Usage: ^a path {-control_args}", my_name);
 721                     else do;                                /* identify version of compiler */
 722                               if pl1_version$pl1_release = "EXL"
 723                               then call ioa_ ("^a", pl1_version$pl1_version);
 724                               else call ioa_ ("PL/1 ^a", pl1_version$pl1_release);
 725                          end;
 726                     return;
 727                end;
 728 
 729 /* Apply defaults. */
 730 
 731           if ^ca.no_table & ^ca.brief_table & ^ca.optimize
 732           then ca.table = "1"b;
 733 
 734 /* We now know what options were specified. */
 735 
 736           pl1_stat_$options = "";
 737 
 738           pl1_stat_$optimize, cg_static_$optimize = ca.optimize;
 739           if ca.optimize
 740           then pl1_stat_$options = pl1_stat_$options || " optimize";
 741 
 742           if ca.brief_table
 743           then pl1_stat_$options = pl1_stat_$options || " brief_table";
 744 
 745           pl1_stat_$table = ca.table;
 746           if ca.table
 747           then pl1_stat_$options = pl1_stat_$options || " table";
 748 
 749           if ca.check
 750           then pl1_stat_$options = pl1_stat_$options || " check";
 751 
 752           if ca.source
 753           then pl1_stat_$options = pl1_stat_$options || " source";
 754 
 755           if ca.symbols
 756           then pl1_stat_$options = pl1_stat_$options || " symbols";
 757 
 758           if ca.map
 759           then pl1_stat_$options = pl1_stat_$options || " map";
 760 
 761           if ca.list
 762           then pl1_stat_$options = pl1_stat_$options || " list";
 763 
 764           pl1_stat_$single_symbol_list = ca.single_symbol_list;
 765           if ca.single_symbol_list
 766           then pl1_stat_$options = pl1_stat_$options || " single_symbol_list";
 767 
 768           symbols_on = ca.symbols | ca.map | ca.list | ca.single_symbol_list;
 769           produce_listing, pl1_stat_$listing_on = ca.source | symbols_on;
 770 
 771           pl1_stat_$brief_error_mode = ca.brief;
 772 
 773           if ca.severity
 774           then pl1_stat_$options = pl1_stat_$options || " severity" || convert (digit_pic, pl1_stat_$severity_plateau);
 775           else pl1_stat_$severity_plateau = 1;
 776 
 777           if ca.profile
 778           then pl1_stat_$options = pl1_stat_$options || " profile";
 779 
 780           if ca.long_profile
 781           then pl1_stat_$options = pl1_stat_$options || " long_profile";
 782 
 783           pl1_stat_$profile = ca.profile | ca.long_profile;
 784 
 785           cg_static_$separate_static = ca.separate_static;
 786           if ca.separate_static
 787           then pl1_stat_$options = pl1_stat_$options || " separate_static";
 788 
 789           pl1_stat_$check_ansi = ca.check_ansi;
 790 
 791           pl1_stat_$print_cp_dcl = ca.cpdcls;
 792           if ca.cpdcls
 793           then pl1_stat_$options = pl1_stat_$options || " cpdcls";
 794 
 795           cg_static_$debug = ca.debug | ca.debug_semant | ca.debug_cg;
 796           pl1_stat_$debug_semant = ca.debug_semant;
 797 
 798           if ca.link
 799           then pl1_stat_$options = pl1_stat_$options || " link";
 800 
 801           if ca.no_version
 802           then ;
 803           else do;
 804                     if pl1_version$pl1_release = "EXL"
 805                     then call ioa_ ("^a", pl1_version$pl1_version);
 806                     else call ioa_ ("PL/1 ^a", pl1_version$pl1_release);
 807                end;
 808 
 809           prefix = ""b;
 810           if ca.prefix
 811           then if ^parse_prefix (prefix_string)
 812                then return;
 813 
 814           pl1_stat_$options = ltrim (pl1_stat_$options);
 815 
 816 /* Find the source file. */
 817           call find_source_file_ (pathname, "pl1", sourcename, source_seg, bitcnt, code);
 818           if source_seg = null
 819           then do;
 820                     call com_err_ (code, my_name, "^a", pathname);
 821                     return;
 822                end;
 823 
 824           if bitcnt = 0
 825           then do;
 826                     call com_err_ (error_table_$zero_length_seg, my_name, "^a", pathname);
 827                     call hcs_$terminate_noname (source_seg, code);
 828                     return;
 829                end;
 830 
 831           objectname = before (sourcename || " ", ".pl1 ");
 832           objectname = before (objectname, ".ex ");
 833           pl1_stat_$pathname = pathname;
 834           pl1_stat_$seg_name = rtrim (objectname);
 835 
 836           len = divide (bitcnt + 8, 9, 21);
 837 
 838           if pl1_blast_$blast_on
 839           then if pl1_blast_$blast_time > blast_time
 840                then do;
 841                          call ioa_ ("^a", pl1_blast_$blast_message);
 842                          blast_time = clock ();
 843                     end;
 844 
 845           wdirname = get_wdir_ ();
 846           clock_time = clock ();
 847           comptime = date_time_$format ("date_time", clock_time, "", "");
 848 
 849           list_hold = null;
 850           object_hold = null;
 851 
 852           on cleanup
 853                begin;
 854                     if ^cg_static_$debug
 855                     then call truncate;
 856 
 857                     pl1_stat_$compiler_invoked = "0"b;
 858                end;
 859 ^L
 860           if produce_listing
 861           then begin;
 862                     declare   installation_id     char (32);
 863 
 864                     component = 0;
 865                     lname = rtrim (objectname);
 866                     if length (lname) > 27
 867                     then call com_err_ (error_table_$entlong, my_name,
 868                               "The name of the listing segment is truncated to ^a.lis", lname);
 869 
 870                     listname = lname || ".list";
 871 
 872                     call tssi_$get_file (wdirname, listname, pl1_stat_$list_ptr, list_hold, fcb, code);
 873                     if pl1_stat_$list_ptr = null
 874                     then do;
 875                               call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
 876                               call hcs_$terminate_noname (source_seg, code);
 877                               return;
 878                          end;
 879 
 880                     call hcs_$get_max_length_seg (pl1_stat_$list_ptr, list_size, code);
 881                     if code ^= 0
 882                     then do;
 883                               call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
 884                               call hcs_$terminate_noname (source_seg, code);
 885                               return;
 886                          end;
 887 
 888                     pl1_stat_$max_list_size = 4 * list_size;
 889                     pl1_stat_$char_pos = 1;
 890 
 891                     call pl1_print$non_varying_nl ("        COMPILATION LISTING OF SEGMENT " || rtrim (objectname), 0);
 892                     call pl1_print$non_varying_nl ("        Compiled by: " || pl1_version$pl1_version, 0);
 893 
 894                     call system_info_$installation_id (installation_id);
 895                     call pl1_print$non_varying_nl ("        Compiled at: " || installation_id, 0);
 896                     call pl1_print$non_varying_nl ("        Compiled on: " || comptime, 0);
 897 
 898                     if length (pl1_stat_$options) > 0
 899                     then do;
 900                               call pl1_print$non_varying ("     Options: ", 0);
 901                               call pl1_print$varying_nl (pl1_stat_$options);
 902                          end;
 903 
 904                     call pl1_print$non_varying_nl ("", 0);
 905                end;
 906 
 907           if produce_listing
 908           then on listing_overflow
 909                     begin;
 910                          declare   component_bit_count fixed binary (24);
 911 
 912                          component = component + 1;
 913 
 914                          call msf_manager_$get_ptr (fcb, component, "1"b /* create */, pl1_stat_$list_ptr,
 915                               component_bit_count, code);
 916 
 917                          if pl1_stat_$list_ptr ^= null
 918                          then call hcs_$get_max_length_seg (pl1_stat_$list_ptr, list_size, code);
 919 
 920                          if pl1_stat_$list_ptr = null | code ^= 0
 921                          then do;
 922                                    call com_err_ (code, my_name, "Component ^d of ^a^[>^]^a", component, wdirname,
 923                                         wdirname ^= ">", listname);
 924 
 925                                    if in_cg
 926                                    then call code_gen_$return_bit_count (objectbc, npages (5), ncpu (5), npages (6),
 927                                              ncpu (6));
 928 
 929                                    translation_failed = "1"b;
 930                                    goto close_list;
 931                               end;
 932 
 933                          pl1_stat_$max_list_size = 4 * list_size;
 934                          pl1_stat_$char_pos = 1;
 935                     end;
 936 ^L
 937 /* Call the phases of pl1. */
 938 
 939           call tree_manager$init (pl1_stat_$abort_label);
 940 
 941           pl1_stat_$phase = 1;
 942           pl1_severity_, pl1_stat_$greatest_severity = 0;
 943           pl1_stat_$compiler_invoked = "1"b;
 944 
 945           call condition_ ("any_other", pl1_signal_catcher);
 946 
 947           call cpu_time_and_paging_ (npages (1), ncpu (1), pd_faults);
 948 
 949           call parse (pl1_stat_$root, source_string, prefix);
 950 
 951           call cpu_time_and_paging_ (npages (2), ncpu (2), pd_faults);
 952           call set_storage_usage (storage (2), xeq_storage (2));
 953 
 954           if ca.debug_semant
 955           then do;
 956                     call ioa_$nnl ("Beginning semantic translator.^/debug: ");
 957                     call debug;
 958                end;
 959 
 960           pl1_stat_$phase = 2;
 961           call semantic_translator;
 962           call scan_token_table;
 963 
 964           call cpu_time_and_paging_ (npages (3), ncpu (3), pd_faults);
 965           call set_storage_usage (storage (3), xeq_storage (3));
 966 
 967           if ^ca.check
 968           then call generate_code (translation_failed);
 969 
 970 continue_from_abort:
 971           if translation_failed
 972           then call com_err_ (error_table_$translation_failed, my_name, "^a", sourcename);
 973 
 974           if ^called_cg
 975           then do;
 976                     call cpu_time_and_paging_ (npages (5), ncpu (5), pd_faults);
 977                     npages (6) = npages (5);
 978                     ncpu (6) = ncpu (5);
 979                end;
 980 
 981           if produce_listing
 982           then do;
 983                     if ^called_cg
 984                     then do;
 985                               if symbols_on
 986                               then call pl1_symbol_print (pl1_stat_$root, pl1_stat_$print_cp_dcl,
 987                                         ca.check | translation_failed | pl1_stat_$greatest_severity >= 3);
 988 
 989                               call pl1_print$non_varying_nl ("", 0);
 990 
 991                               if pl1_stat_$greatest_severity > 0
 992                               then call error_$finish;
 993                          end;
 994 
 995 close_list:
 996                     call tssi_$finish_file (fcb, component, 9 * pl1_stat_$char_pos - 9, "101"b, list_hold, code);
 997                     if code ^= 0
 998                     then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", listname);
 999                end;
1000 
1001           if ^ca.check & ^translation_failed
1002           then do;
1003                     call hcs_$truncate_seg (output_pt, divide (objectbc + 35, 36, 19), code);
1004                     if code ^= 0
1005                     then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", objectname);
1006 
1007                     call tssi_$finish_segment (output_pt, objectbc, "110"b, object_hold, code);
1008                     if code ^= 0
1009                     then call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", objectname);
1010                end;
1011 
1012           call cpu_time_and_paging_ (npages (7), ncpu (7), pd_faults);
1013           call set_storage_usage (storage (5), xeq_storage (5));
1014 
1015           storage (6), storage (7) = storage (5);
1016           xeq_storage (6), xeq_storage (7) = xeq_storage (5);
1017 
1018           if ^cg_static_$debug
1019           then call truncate;
1020 
1021           pl1_severity_ = pl1_stat_$greatest_severity;
1022 
1023           pl1_stat_$compiler_invoked = "0"b;
1024 
1025           if ca.time
1026           then call print_times;
1027 
1028           return;
1029 
1030 abort_return:
1031           call com_err_ (0, my_name, "An unrecoverable error has occurred.");
1032           translation_failed = "1"b;
1033           goto continue_from_abort;
1034 ^L
1035 times:
1036      entry options (variable);
1037 
1038           call cu_$arg_count (arg_count, code);
1039           if code ^= 0
1040           then do;
1041                     call com_err_ (code, my_name);
1042                     return;
1043                end;
1044 
1045           if arg_count ^= 0
1046           then do;
1047                     call com_err_$suppress_name (0, my_name, "Usage: ^a$times", my_name);
1048                     return;
1049                end;
1050 
1051           call print_times;
1052 
1053           return;
1054 
1055 clean_up:
1056      entry options (variable);
1057 
1058           call cu_$arg_count (arg_count, code);
1059           if code ^= 0
1060           then do;
1061                     call com_err_ (code, my_name);
1062                     return;
1063                end;
1064 
1065           if arg_count ^= 0
1066           then do;
1067                     call com_err_$suppress_name (0, my_name, "Usage: ^a$clean_up", my_name);
1068                     return;
1069                end;
1070 
1071           object_hold = null;
1072           list_hold = null;
1073 
1074           call truncate;
1075           pl1_stat_$compiler_invoked = "0"b;
1076 
1077           return;
1078 ^L
1079 blast:
1080      entry options (variable);
1081 
1082           call cu_$arg_count (arg_count, code);
1083           if code ^= 0
1084           then do;
1085                     call com_err_ (code, my_name);
1086                     return;
1087                end;
1088 
1089           string (blast_ca) = ""b;
1090           argument_no = 0;
1091           do i = 1 to arg_count;
1092                call cu_$arg_ptr (i, arg_ptr, arg_length, code);
1093                if code ^= 0
1094                then do;
1095                          call com_err_ (code, my_name, "Argument ^d.", i);
1096                          return;
1097                     end;
1098 
1099                if arg_string = "-on"
1100                then do;
1101                          blast_ca.on = "1"b;
1102                          blast_ca.off = "0"b;
1103                     end;
1104 
1105                else if arg_string = "-off"
1106                then do;
1107                          blast_ca.on = "0"b;
1108                          blast_ca.off = "1"b;
1109                     end;
1110 
1111                else if arg_string = "-set"
1112                then do;
1113                          i = i + 1;
1114                          if i > arg_count
1115                          then do;
1116                                    call com_err_ (0, my_name, "Missing blast message after -set.");
1117                                    return;
1118                               end;
1119 
1120                          call cu_$arg_ptr (i, blast_msg_ptr, blast_msg_len, code);
1121                          if code ^= 0
1122                          then do;
1123                                    call com_err_ (code, my_name, "Argument ^d.", i);
1124                                    return;
1125                               end;
1126 
1127                          blast_ca.set = "1"b;
1128                     end;
1129 
1130                else if index (arg_string, "-") = 1
1131                then do;
1132                          call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
1133                          return;
1134                     end;
1135 
1136                else argument_no = argument_no + 1;
1137           end;
1138 
1139           if argument_no ^= 0 | string (blast_ca) = ""b
1140           then do;
1141                     call com_err_$suppress_name (0, my_name, "Usage: ^a$blast -control_args", my_name);
1142                     return;
1143                end;
1144 
1145           if blast_ca.set & (blast_ca.on | blast_ca.off)
1146           then do;
1147                     call com_err_ (error_table_$inconsistent, my_name, "-set and -^[on^;off^]", blast_ca.on);
1148                     return;
1149                end;
1150 
1151           if blast_ca.on
1152           then pl1_blast_$blast_on = "1"b;
1153 
1154           else if blast_ca.off
1155           then pl1_blast_$blast_on = "0"b;
1156 
1157           else if blast_ca.set
1158           then do;
1159                     pl1_blast_$blast_on = "0"b;
1160                     pl1_blast_$blast_message = blast_msg;
1161                     pl1_blast_$blast_time = clock ();
1162                     pl1_blast_$blast_on = "1"b;
1163                end;
1164 
1165           call ioa_ ("Accepted.");
1166 
1167           return;
1168 ^L
1169 parse_severity:
1170      procedure (arg_string, prefix) returns (bit (1) aligned);
1171 
1172           declare   arg_string          char (*);
1173           declare   prefix              char (*);
1174 
1175           declare   severity            fixed bin;
1176 
1177           if length (rtrim (arg_string)) = length (prefix) + 1
1178           then severity = index ("1234", substr (arg_string, length (prefix) + 1, 1));
1179           else severity = 0;
1180 
1181           if severity = 0
1182           then do;
1183                     call com_err_ (0, my_name, "Invalid severity level. ^a", arg_string);
1184                     return ("0"b);
1185                end;
1186 
1187           ca.severity = "1"b;
1188           pl1_stat_$severity_plateau = severity;
1189 
1190           return ("1"b);
1191      end parse_severity;
1192 ^L
1193 parse_prefix:
1194      procedure (prefix_string) returns (bit (1) aligned);
1195 
1196           declare   prefix_string       char (*);
1197 
1198           declare   scan_position       fixed bin (21);
1199 
1200           scan_position = verify (prefix_string, HT_SP);
1201           if scan_position = 0
1202           then return ("1"b);
1203 
1204           pl1_stat_$options = pl1_stat_$options || " prefix(";
1205 
1206           if ^parse_condition_name ()
1207           then return ("0"b);
1208           do while (scan_position <= length (prefix_string));
1209                if substr (prefix_string, scan_position, 1) ^= ","
1210                then do;
1211                          call com_err_ (0, my_name, "Missing comma between condition names. ^a", prefix_string);
1212                          return ("0"b);
1213                     end;
1214 
1215                scan_position = scan_position + 1;
1216 
1217                if ^parse_condition_name ()
1218                then return ("0"b);
1219           end;
1220 
1221           pl1_stat_$options = pl1_stat_$options || ")";
1222 
1223           return ("1"b);
1224 ^L
1225 parse_condition_name:
1226      procedure returns (bit (1) aligned);
1227 
1228           declare   enabled             bit (1) aligned;
1229           declare   i                   fixed bin;
1230           declare   token_length        fixed bin (21);
1231           declare   token_start         fixed bin (21);
1232 
1233           call skip_white_space;
1234 
1235           token_length = search (substr (prefix_string, scan_position), HT_SP_COMMA) - 1;
1236           if token_length < 0
1237           then token_length = length (substr (prefix_string, scan_position));
1238 
1239           if token_length = 0
1240           then do;
1241                     call com_err_ (0, my_name, "Missing condition name. ^a", prefix_string);
1242                     return ("0"b);
1243                end;
1244 
1245           token_start = scan_position;
1246           scan_position = scan_position + token_length;
1247 
1248           enabled = index (substr (prefix_string, token_start, token_length), "no") ^= 1;
1249           if ^enabled
1250           then do;
1251                     token_start = token_start + length ("no");
1252                     token_length = token_length - length ("no");
1253                end;
1254 
1255           do i = lbound (condition_name, 1) to hbound (condition_name, 1)
1256                while (condition_name (i) ^= substr (prefix_string, token_start, token_length));
1257           end;
1258 
1259           if i > hbound (condition_name, 1)
1260           then do;
1261                     call com_err_ (0, my_name, "Invalid condition name. ^[no^]^a", ^enabled,
1262                          substr (prefix_string, token_start, token_length));
1263                     return ("0"b);
1264                end;
1265 
1266 /* The variable i never equals 10.  This takes advantage of the condition_name
1267    array encoding.  This is the same algorithm that statement_type uses.  The
1268    long names and short names of the conditions are stored in the same array.
1269    The indices of the long name and the short name differ by 10.  The size
1270    condition has the same long name and short name. */
1271 
1272           i = mod (i, 10);
1273 
1274           if substr (prefix.mask, i, 1)
1275           then if substr (prefix.conditions, i, 1) ^= enabled
1276                then do;
1277                          call com_err_ (0, my_name,
1278                               "A condition may not be enabled and disabled in the prefix string. ^a", condition_name (i));
1279                          return ("0"b);
1280                     end;
1281                else ;
1282           else do;
1283                     substr (prefix.mask, i, 1) = "1"b;
1284                     substr (prefix.conditions, i, 1) = enabled;
1285 
1286                     if substr (pl1_stat_$options, length (pl1_stat_$options)) ^= "("
1287                     then pl1_stat_$options = pl1_stat_$options || ",";
1288 
1289                     if ^enabled
1290                     then pl1_stat_$options = pl1_stat_$options || "no";
1291 
1292                     pl1_stat_$options = pl1_stat_$options || rtrim (condition_name (i));
1293                end;
1294 
1295           call skip_white_space;
1296 
1297           return ("1"b);
1298 
1299 skip_white_space:
1300      procedure;
1301 
1302           declare   scan_length         fixed bin (21);
1303 
1304           scan_length = verify (substr (prefix_string, scan_position), HT_SP) - 1;
1305           if scan_length < 0
1306           then scan_length = length (substr (prefix_string, scan_position));
1307 
1308           scan_position = scan_position + scan_length;
1309      end skip_white_space;
1310 
1311      end parse_condition_name;
1312 
1313      end parse_prefix;
1314 ^L
1315 generate_code:
1316      procedure (translation_failed);
1317 
1318           declare   translation_failed  bit (1) aligned;
1319 
1320           translation_failed = "0"b;
1321 
1322           if pl1_stat_$greatest_severity >= 3
1323           then do;
1324                     call com_err_ (0, my_name, "An error of severity ^d has occurred.", pl1_stat_$greatest_severity);
1325 
1326                     if ca.debug_cg
1327                     then do;
1328                               call ioa_$nnl ("debug for -debug_cg: ");
1329                               call debug;
1330                          end;
1331 
1332                     translation_failed = "1"b;
1333                     return;
1334                end;
1335 
1336           if pl1_stat_$table | pl1_stat_$generate_symtab
1337           then do;
1338                     pl1_stat_$phase = 3;
1339                     call prepare_symbol_table (pl1_stat_$root);
1340                end;
1341 
1342           if ca.optimize
1343           then do;
1344                     pl1_stat_$phase = 4;
1345                     call optimizer (pl1_stat_$root);
1346                end;
1347 
1348           call cpu_time_and_paging_ (npages (4), ncpu (4), pd_faults);
1349           call set_storage_usage (storage (4), xeq_storage (4));
1350 
1351           call tssi_$get_segment (wdirname, objectname, output_pt, object_hold, code);
1352           if output_pt = null
1353           then do;
1354                     call com_err_ (code, my_name, "^a^[>^]^a", wdirname, wdirname ^= ">", objectname);
1355                     translation_failed = "1"b;
1356                     return;
1357                end;
1358 
1359           if baseno (output_pt) = baseno (source_seg)
1360           then do;
1361                     call com_err_ (0, my_name,
1362                          "The source segment is the same as the object segment. It has been truncated. ^a", pathname);
1363                     translation_failed = "1"b;
1364                     return;
1365                end;
1366 
1367           if ^ca.profile & ^ca.long_profile
1368           then pl1_stat_$profile_length = 0;
1369 
1370           if ca.debug_cg
1371           then do;
1372                     call ioa_$nnl ("Beginning code generator.^/debug: ");
1373                     call debug;
1374                end;
1375 
1376           in_cg = "1"b;
1377           pl1_stat_$phase = 5;
1378 
1379           call code_gen_ (pl1_stat_$seg_name, (my_name), version, pl1_stat_$root, pl1_stat_$validate_proc,
1380                pl1_stat_$temporary_list, pl1_stat_$constant_list, pl1_stat_$ok_list, output_pt, clock_time,
1381                pl1_stat_$profile_length, produce_listing, symbols_on, pl1_stat_$print_cp_dcl, ca.map, ca.list,
1382                pl1_stat_$table, pl1_stat_$generate_symtab, pl1_symbol_print, error_$finish, objectbc, npages (5),
1383                ncpu (5), ca.link, pl1_stat_$dummy_block, ca.brief_table, npages (6), ncpu (6), ca.long_profile);
1384 
1385           in_cg = "0"b;
1386           called_cg = "1"b;
1387      end generate_code;
1388 ^L
1389 print_times:
1390      procedure;
1391 
1392           declare   need_nl             bit (1) aligned;
1393           declare   tx                  float bin;
1394           declare   ty                  float bin;
1395 
1396           ty = -1e0;
1397           do i = hbound (ncpu, 1) to 1 by -1 while (ty < 0e0);
1398                ty = ncpu (i) - ncpu (0);
1399           end;
1400 
1401           if ty <= 0e0
1402           then do;
1403                     call com_err_ (0, my_name, "No times available.");
1404                     return;
1405                end;
1406 
1407           call ioa_ ("^/Segment ^a (^d lines) was compiled by ^a on ^a", pl1_stat_$seg_name, pl1_stat_$line_count,
1408                my_name, comptime);
1409 
1410           call how_many_users;
1411 
1412           call ioa_ ("^/Phase          CPU    %   Pages      Tree     Xeq_tree");
1413 
1414           do i = 1 to hbound (npages, 1);
1415                if npages (i) < 0
1416                then do;
1417                          ncpu (i) = ncpu (i - 1);
1418                          npages (i) = npages (i - 1);
1419                          storage (i) = storage (i - 1);
1420                          xeq_storage (i) = xeq_storage (i - 1);
1421                     end;
1422 
1423                tx = ncpu (i) - ncpu (i - 1);
1424                call ioa_ ("^9a^9.3f^6.1f^6d ^10a ^10a", phase_name (i), tx / 1.0e6, 1.0e2 * tx / ty,
1425                     npages (i) - npages (i - 1), storage (i), xeq_storage (i));
1426           end;
1427 
1428           call ioa_ ("TOTAL    ^9.3f      ^6d", ty / 1.0e6, npages (7) - npages (0));
1429 
1430           call ioa_ ("^/Summary of node usage in ^d free segments^/", number_free_segs);
1431           call ioa_ ((2)"NODE TYPE   NUMBER  SIZE   TOTAL^8x");
1432 
1433           need_nl = "0"b;
1434           do i = 1 to pl1_stat_$max_node_type;
1435                if pl1_stat_$node_uses (i) ^= 0
1436                then do;
1437                          call ioa_$nnl ("^12a^6d^6d^8d^[^/^;^8x^]", pl1_stat_$node_name (i), pl1_stat_$node_uses (i),
1438                               pl1_stat_$node_size (i), pl1_stat_$node_uses (i) * pl1_stat_$node_size (i), need_nl);
1439                          need_nl = ^need_nl;
1440                     end;
1441           end;
1442 
1443           call ioa_ ("^[^/^]", need_nl);
1444      end print_times;
1445 ^L
1446 truncate:
1447      procedure;
1448 
1449           call lex$terminate_source;
1450           call tree_manager$truncate;
1451 
1452           if object_hold ^= null
1453           then call tssi_$clean_up_segment (object_hold);
1454 
1455           if list_hold ^= null
1456           then call tssi_$clean_up_file (fcb, list_hold);
1457      end truncate;
1458 ^L
1459 set_storage_usage:
1460      procedure (tree_used, xeq_tree_used);
1461 
1462           declare   tree_used           char (*);
1463           declare   xeq_tree_used       char (*);
1464 
1465           declare   n                   fixed bin;
1466 
1467           tree_used = char (binary (pl1_stat_$tree_area_ptr -> area_header.next_virgin, 18), 10);
1468 
1469           number_free_segs = count_components (pl1_stat_$tree_area_ptr);
1470           if number_free_segs > 1
1471           then substr (tree_used, 1, 3) = "(" || convert (digit_pic, number_free_segs) || ")";
1472 
1473           xeq_tree_used = char (binary (pl1_stat_$xeq_tree_area_ptr -> area_header.next_virgin, 18), 10);
1474 
1475           n = count_components (pl1_stat_$xeq_tree_area_ptr);
1476           if n > 1
1477           then substr (xeq_tree_used, 1, 3) = "(" || convert (digit_pic, n) || ")";
1478 
1479           number_free_segs = number_free_segs + n;
1480 
1481           return;
1482 
1483 count_components:
1484      procedure (areap) returns (fixed bin);
1485 
1486           declare   areap               ptr;
1487 
1488           declare   p                   ptr;
1489           declare   i                   fixed bin;
1490 
1491           i = 0;
1492           do p = areap repeat addrel (p, p -> area_header.extend_info) -> extend_block.next_area while (p ^= null);
1493                i = i + 1;
1494           end;
1495 
1496           return (i);
1497      end count_components;
1498 
1499      end set_storage_usage;
1500 
1501      end v2pl1;