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-17,JRGray), approve(89-04-17,MCR8078), audit(89-04-18,Huen),
  17      install(89-06-09,MR12.3-1055):
  18      Modified to allow for archive component source programs.
  19   2) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
  20      install(89-07-31,MR12.3-1066):
  21      Removed the obsolete parameter source_line from the call to error_().
  22   3) change(89-08-01,RWaters), approve(89-08-01,MCR8069), audit(89-09-07,Vu),
  23      install(89-09-19,MR12.3-1068):
  24      Fix bug 1748.
  25   4) change(89-10-03,Vu), approve(89-10-03,MCR8139), audit(89-10-04,Blackmore),
  26      install(89-10-09,MR12.3-1086):
  27      Allow the use of named constants as replication factors.
  28   5) change(91-01-18,Blackmore), approve(91-01-18,MCR8234),
  29      audit(91-12-05,Huen), install(92-04-24,MR12.5-1011):
  30      Change entry pts. and dcl of 'constant_token' entry to allow passing a ptr
  31      to the current block, for the constant reference resolution fix.
  32                                                    END HISTORY COMMENTS */
  33 
  34 
  35 /* lex is the lexical analysis program for the Multics PL/I compiler.  Its primary responsibilities are:
  36           1. Break the source program into tokens.
  37           2. Process %include statements.
  38           3. Generate a line-numbered source listing.
  39           4. Diagnose errors in lexical syntax of programs.
  40 
  41    lex also performs several other chores during its operation that eliminate a few of the
  42    vagaries of the PL/I language, thus making the job of subsequent phases simpler.  They are:
  43           1. Apply string repetition factors.
  44           2. Apply bit-string radix factors.
  45           3. Determine the type of numeric constants.
  46           4. Notice equal signs at level 0 of parenthesis.
  47           5. Notice colons at level 0 of parenthesis.
  48 
  49    The original version of lex was written by J.D.Mills, 26 March 1968.
  50    Totally rewritten to use EIS in April, 1977 by P. Green.
  51    Modified 770713 by PG to put back in checks for errors 157 and 158.
  52    Modified 771020 by PG to fix 1677 (compiler faults if no status permission to main source program),
  53           and 1668 (lex can fault if a stmt has > 3000 tokens)
  54    Modified 780607 by PG to fix 1738 (print one more character of source line for errors 157 and 158)
  55    Modified 780804 by PG to fix 1759 (not supplying substitutable argument for errors 109 and 110).
  56    Modified 790730 by PG to use rank builtin, to create enter_token facility, reducing number of calls
  57           to create_token, and to implement %page and %skip.
  58    Modified 7 October 1980 by M. N. Davidoff to fix 1989 (uninitialized variable can cause lex to fault
  59           on null statements) and to implement 1914 (call com_err_ with find_include_file_ code).
  60    Modified 25 April 1983 by R Gray to allow archive component source files
  61    Modified 7 Feb 1989 by RW deleted obsolete parameter to error_
  62    Modified 1 Jan 1989 by RW print new message disallowing pathnames in
  63      the %include macro
  64 */
  65 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9 */
  66 lex:
  67      procedure (cblock);
  68 
  69 /* parameter */
  70 
  71 declare   cblock pointer parameter;                         /* pointer to current block */
  72 
  73 /* automatic */
  74 
  75 declare   action_index fixed bin,                           /* index of action to execute */
  76           bitcount fixed bin (24),                          /* bitcount of include segment */
  77           char_value fixed bin (9),                         /* numeric value of current character */
  78           code fixed bin (35),                              /* standard status code */
  79           current_char char (1) aligned,                    /* character that stopped the scan, char we are checking */
  80           depthx fixed bin,                                 /* do-loop temporary */
  81           decimal_value bit (9) aligned,                    /* flag meaning constant is decimal, not binary */
  82           dx fixed bin,                                     /* temporary used in radix expansion */
  83           error_number fixed bin (15),                      /* temp to hold error number for call to lex_error */
  84           error_token ptr,                                  /* temp to hold token ptr for call to lex_error */
  85           first_bit fixed bin,                              /* temporary used in radix expansion */
  86           float_value bit (9) aligned,                      /* flag meaning constant is float, not fixed */
  87           imaginary_value bit (9) aligned,                  /* flag meaning constant is imaginary, not real */
  88           include_file_length fixed bin (21),               /* length, in chars, of new include file */
  89           include_file_name char (32) varying,              /* name of include file */
  90           include_file_ptr ptr,                             /* ptr to base of include file */
  91           integral_value bit (9) aligned,                   /* flag meaning constant is integral, not fractional */
  92           k fixed bin,                                      /* index into t_table */
  93           line_length fixed bin (21),                       /* number of chars to be printed in listing */
  94           listing_on bit (1) aligned,                       /* flag meaning to generate a source listing */
  95           max_in_chars fixed bin,                           /* max string length before radix expansion */
  96           n fixed bin (21),                                 /* temp used when allocating a source node */
  97           new_file_number fixed bin (8),                    /* number of new source file */
  98           new_file_token_ptr ptr,                           /* ptr to token node for new include file name */
  99           page_macro bit (1) aligned,                       /* "1"b iff macro was %page, not %skip */
 100           parenthesis_level fixed bin (21),                 /* nesting depth of parenthesis in current statement */
 101           percent_sign_seen bit (1) aligned,                /* a %-sign was seen during scan...ck for %include later */
 102           protected bit (18) aligned,                       /* "1"b iff current (constant) token is protected from default */
 103           radix fixed bin,                                  /* radix of bit string begin expanded */
 104           rep_factor fixed bin,                             /* string replication factor */
 105           saved_token_index fixed bin,                      /* token_index at time % was seen */
 106           scan_index fixed bin (21),                        /* index (relative to source_index) of forward scan */
 107           string_max fixed bin (21),                        /* temporary used in rep_factor checking */
 108           string_token_start fixed bin (21),                /* if token_start = 0, string_token_start holds offset
 109                                                                of first char of token in source seg */
 110           strx fixed bin,                                   /* temporary used in radix expansion */
 111           temp_token_string char (256) varying,             /* copy of token used by replication and radix code */
 112           token_index fixed bin,                            /* index of current token being created */
 113           token_length fixed bin (21),                      /* length of token in characters */
 114           token_ptr ptr unal,                               /* ptr to current delimiter token */
 115           token_start fixed bin (21),                       /* index of first character of current token */
 116           token_string char (256) varying,                  /* current token in some hairy cases */
 117           token_string_ptr ptr,                             /* ptr to token string, wherever it is */
 118           token_type bit (9) aligned;                       /* type of current token */
 119 
 120 /* based */
 121 
 122 declare   source_string char (source_length) based (source_ptr),
 123                                                             /* overlay of current source segment */
 124           token_overlay char (token_length) based (token_string_ptr);
 125                                                             /* overlay of current token */
 126 
 127 /* builtins */
 128 
 129 declare   (addr, addrel, binary, bit, char, copy, divide, hbound, index, lbound, length, ltrim, null, rank, rtrim, search,
 130           string, substr, verify) builtin;
 131 
 132 /* entries */
 133 
 134 declare   com_err_ entry options (variable);
 135 declare   constant_token entry (ptr, ptr, bit(9) aligned, bit(9) aligned) returns (bit(9));
 136 declare   date_time_ entry (fixed bin (71), char (*));
 137 declare   find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
 138 declare   hcs_$terminate_noname entry (ptr, fixed bin (35));
 139 
 140 /* external static */
 141 
 142 declare   error_table_$noentry fixed bin (35) external static;
 143 declare   (
 144           pl1_stat_$cur_statement ptr,                      /* ptr to tree for current statement...cleared by lex */
 145           pl1_stat_$level_0_colon bit (1) aligned,          /* "1"b iff colon seen at level 0 of parens */
 146           pl1_stat_$level_0_equal bit (1) aligned,          /* "1"b iff equal sign seen at level 0 of parens */
 147           pl1_stat_$line_count fixed bin,                   /* grand total of number of source lines processed */
 148           pl1_stat_$listing_on bit (1) aligned,             /* "1"b iff line-numbered source listing being created */
 149           pl1_stat_$seg_name char (32) varying,             /* name of main source program, w/o .pl1 suffix */
 150           pl1_stat_$st_length fixed bin (21),               /* length of current statement */
 151           pl1_stat_$st_start fixed bin (21)                 /* 0-origin char offset of begining of current statement;
 152                                                                value -1 means it has never been set */
 153           ) external static;
 154 
 155 /* internal static */
 156 
 157 declare   (
 158           file_token_ptr ptr,                               /* ptr to token node for current file name */
 159           lexing_after_end_stmt bit (1) aligned,            /* "1"b iff main procedure has been lexed and we are
 160                                                                just scanning comments and white space */
 161           line_begins_in_comment bit (1) aligned,           /* "1"b iff source line begins inside a comment */
 162           line_number fixed bin (14),                       /* line number of current line in source segment */
 163           line_start fixed bin (21),                        /* offset of first char to be printed in listing */
 164           source_depth fixed bin,                           /* 0-origin nesting depth of include files */
 165           source_index fixed bin (21),                      /* index into current source segment */
 166           source_length fixed bin (21),                     /* length (in characters) of current source segment */
 167           source_ptr ptr,                                   /* pointer to base of current source segment */
 168           statement_number fixed bin (5),                   /* number of statement on current line */
 169           suppress_line_numbers bit (1) aligned             /* next listing line should not have source numbers */
 170           ) internal static;
 171 
 172 declare   (and_token_ptr, arrow_token_ptr, assignment_token_ptr, asterisk_token_ptr, cat_token_ptr, colon_token_ptr,
 173           comma_token_ptr, expon_token_ptr, ge_token_ptr, gt_token_ptr, le_token_ptr, left_parn_token_ptr, lt_token_ptr,
 174           minus_token_ptr, ne_token_ptr, ngt_token_ptr, nlt_token_ptr, not_token_ptr, or_token_ptr, percent_token_ptr,
 175           period_token_ptr, plus_token_ptr, right_parn_token_ptr, semi_colon_token_ptr, slash_token_ptr) ptr
 176                unaligned internal static;                   /* ptrs to like-named tokens */
 177 
 178 declare   1 file_stack (0:32) aligned internal static,      /* Pushdown stack used to process nested include files */
 179             2 source_ptr ptr,                               /* ptr to base of source segment */
 180             2 file_token_ptr ptr,                           /* ptr to token node for file name */
 181             2 source_index fixed bin (21),                  /* index (in chars) of lexical scan */
 182             2 source_length fixed bin (21),                 /* length (in chars) of source segment */
 183             2 line_number fixed bin (14),                   /* line number in source segment */
 184             2 file_number fixed bin (8);                    /* file number of source segment */
 185 
 186 declare   action_table (0:128) fixed bin internal static initial (/* what action label to take given ASCII char */ (9) 9,
 187                                                             /* 000-010          ctl chars */
 188                1,                                           /* 011              tab       */
 189                8,                                           /* 012              newline   */
 190                (2) 1,                                       /* 013-014          vt, np    */
 191                (19) 9,                                      /* 015-037          ctl chars */
 192                1,                                           /* 040              sp        */
 193                9,                                           /* 041              !         */
 194                2,                                           /* 042              "         */
 195                9,                                           /* 043              #         */
 196                9,                                           /* 044              $         */
 197                4,                                           /* 045              %         */
 198                17,                                          /* 046              &         */
 199                9,                                           /* 047              '         */
 200                18,                                          /* 050              (         */
 201                19,                                          /* 051              )         */
 202                10,                                          /* 052              *         */
 203                20,                                          /* 053              +         */
 204                21,                                          /* 054              ,         */
 205                11,                                          /* 055              -         */
 206                7,                                           /* 056              .         */
 207                5,                                           /* 057              /         */
 208                (10) 6,                                      /* 060-071          0 - 9     */
 209                22,                                          /* 072              :         */
 210                16,                                          /* 073              ;         */
 211                12,                                          /* 074              <         */
 212                23,                                          /* 075              =         */
 213                13,                                          /* 076              >         */
 214                (2) 9,                                       /* 077-100          ? @       */
 215                (26) 3,                                      /* 101-132          A - Z     */
 216                (3) 9,                                       /* 133-135          [ \ ]     */
 217                14,                                          /* 136              ^         */
 218                (2) 9,                                       /* 137-140          _ `       */
 219                (26) 3,                                      /* 141-172          a - z     */
 220                9,                                           /* 173              {         */
 221                15,                                          /* 174              |         */
 222                (3) 9,                                       /* 175-177          { ~ PAD   */
 223                9);                                          /* >177             non-ASCII */
 224 
 225 declare   command char (3) internal static options (constant) initial ("pl1");
 226 declare   (
 227           asterisk_or_newline char (2) initial ("*
 228 "),
 229           double_quote char (1) initial (""""),
 230           double_quote_or_newline char (2) initial ("""
 231 "),
 232           HT_VT_NP_SP char (4) initial ("         ^K^L "),
 233           identifier_characters char (64) initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"),
 234           newline char (1) initial ("
 235 "),
 236           newpage char (1) initial ("^L")
 237           ) internal static;
 238 
 239 /* include files */
 240 
 241 %include language_utility;
 242 %include nodes;
 243 %include pl1_tree_areas;
 244 %include radix_factor_constants;
 245 %include source_list;
 246 %include system;
 247 %include token;
 248 %include token_list;
 249 %include token_types;
 250 ^L
 251 /* program */
 252 
 253 /* Main entry to lex.  Convert the next source statement into tokens and return. */
 254 
 255           token_index = 0;
 256           protected = ""b;
 257           listing_on = pl1_stat_$listing_on;
 258           parenthesis_level = 0;
 259           pl1_stat_$level_0_colon = "0"b;
 260           pl1_stat_$level_0_equal = "0"b;
 261           percent_sign_seen = "0"b;
 262 
 263 action (1):                                                 /* SCAN WHITE SPACE */
 264           scan_index = verify (substr (source_string, source_index), HT_VT_NP_SP);
 265 
 266           if scan_index = 0 then
 267                go to end_of_source_reached_but_no_pending_token;
 268 
 269           source_index = source_index + scan_index;
 270           current_char = substr (source_string, source_index - 1, 1);
 271           char_value = rank (current_char);
 272 
 273           if char_value >= hbound (action_table, 1) then
 274                action_index = action_table (hbound (action_table, 1));
 275           else
 276                action_index = action_table (char_value);
 277 
 278           go to action (action_index);
 279 ^L
 280 action (2):                                                 /* SCAN STRING. current_char = double_quote */
 281           if source_index > source_length then do;
 282                call lex_error (362, file_token_ptr);        /* eof in string */
 283                go to end_of_source_reached_but_no_pending_token;
 284           end;
 285 
 286           token_start = source_index;                       /* skip over double_quote */
 287           string_token_start = source_index - 1;            /* save offset of double_quote for make_token */
 288           token_length = 0;
 289           token_type = char_string;                         /* tentative */
 290 
 291 rescan:
 292           scan_index = search (substr (source_string, source_index), double_quote_or_newline);
 293 
 294           if scan_index = 0 then do;
 295                call lex_error (362, file_token_ptr);        /* eof in string */
 296 
 297                if token_start = 0 /* filling copy of token */ then
 298                     token_string = token_string || substr (source_string, source_index);
 299                else
 300                     token_length = source_length - token_start + 1;
 301 
 302                go to end_of_source_reached;
 303           end;
 304 
 305           if substr (source_string, source_index + scan_index - 1, 1) = newline then do;
 306                if token_start = 0 then
 307                     token_string = token_string || substr (source_string, source_index, scan_index);
 308                else
 309                     token_length = token_length + scan_index;
 310 
 311                source_index = source_index + scan_index;
 312                call print_line;
 313                go to rescan;
 314           end;
 315 
 316 /* Found a matching quote. Ignore it. */
 317 
 318           if token_start = 0 then
 319                token_string = token_string || substr (source_string, source_index, scan_index - 1);
 320           else
 321                token_length = token_length + scan_index - 1;
 322 
 323           source_index = source_index + scan_index;
 324 
 325           if source_index > source_length /* not an error */ then
 326                go to end_of_source_reached;
 327 
 328           if substr (source_string, source_index, 1) = double_quote then do;
 329                if token_start > 0 then do;                  /* begin using copy, if we haven't already */
 330                     token_string = substr (source_string, token_start, token_length);
 331                     token_start = 0;
 332                end;
 333 
 334                token_string = token_string || double_quote;
 335                source_index = source_index + 1;
 336                go to rescan;
 337           end;
 338           else if substr (source_string, source_index, 1) = "b" then do;
 339                token_type = bit_string;
 340                source_index = source_index + 1;
 341 
 342                if source_index <= source_length then do;
 343                     radix = index ("1234", substr (source_string, source_index, 1));
 344 
 345                     if radix > 0 then
 346                          source_index = source_index + 1;
 347                     else
 348                          radix = 1;
 349                end;
 350                else
 351                     radix = 1;
 352 
 353                if token_start > 0 then do;
 354                     temp_token_string = substr (source_string, token_start, token_length);
 355                     token_start = 0;
 356                end;
 357                else
 358                     temp_token_string = token_string;
 359 
 360 /* We will now expand temp_token_string according to the specified
 361                             radix factor, and put the result into token_string */
 362 
 363                if radix = 4 then
 364                     if search (temp_token_string, capital_hex) ^= 0 then
 365                          dx = 5;
 366                     else
 367                          dx = 4;
 368                else
 369                     dx = radix;
 370 
 371                if verify (temp_token_string, digits (dx)) ^= 0 then do;
 372                                                             /* non-binary digit in bit string */
 373                     error_token = create_token (temp_token_string || "b", bit_string);
 374                     call lex_error (152, error_token);
 375                     token_type = char_string;
 376                     token_string = temp_token_string;
 377                end;
 378                else if radix > 1 then do;
 379                     max_in_chars = divide (max_bit_string_constant, radix, 21, 0);
 380                     token_string = "";
 381 
 382                     if length (temp_token_string) > max_in_chars then do;
 383                                                             /* radix factor makes bit string too long */
 384                          temp_token_string = substr (temp_token_string, 1, max_in_chars);
 385                          error_token =
 386                               create_token ("""" || temp_token_string || """b" || substr ("1234", radix, 1),
 387                               no_token /* fake type - suppress quoting */);
 388                          call lex_error (154, error_token); /* radix factor makes bit string too long */
 389                     end;
 390 
 391                     do strx = 1 to length (temp_token_string);
 392                          first_bit = radix * (index (digits (dx), substr (temp_token_string, strx, 1)) - 1) + 1;
 393                          token_string = token_string || substr (expand_bit_chars (radix), first_bit, radix);
 394                     end;
 395                end;
 396                else
 397                     token_string = temp_token_string;
 398           end;
 399 
 400           if token_index >= 3 /* is there room for a replication factor? */ then
 401                if token_list (token_index - 2) -> token.type = left_parn
 402                     & token_list (token_index) -> token.type = right_parn then do;
 403                     token_index = token_index - 3;          /* wipe out rep factor and parens */
 404 
 405                     if constant_token (cblock, token_list (token_index + 2), "777"b3, dec_integer) ^= dec_integer then
 406                          call lex_error (110, token_list (token_index + 2));
 407                                                             /* rep factor is not a decimal integer */
 408                     else do;
 409                          rep_factor = token_to_binary (token_list (token_index + 2));
 410 
 411                          if token_start > 0 then do;
 412                               temp_token_string = substr (source_string, token_start, token_length);
 413                               token_start = 0;
 414                          end;
 415                          else
 416                               temp_token_string = token_string;
 417 
 418                          if token_type = bit_string then
 419                               string_max = max_bit_string_constant;
 420                          else
 421                               string_max = max_char_string_constant;
 422 
 423                          if length (temp_token_string) * rep_factor > string_max then do;
 424                               error_token = create_token (temp_token_string || "b", bit_string);
 425                               call lex_error (109, error_token);
 426                                                             /* replicated string too long */
 427                               rep_factor = divide (string_max, length (temp_token_string), 21, 0);
 428                          end;
 429 
 430                          token_string = "";
 431                          do strx = 1 to rep_factor;
 432                               token_string = token_string || temp_token_string;
 433                          end;
 434                     end;
 435                end;
 436 
 437           if token_type = bit_string then do;
 438                if length (token_string) > max_bit_string_constant then do;
 439                                                             /* bit string too long */
 440                     token_string = substr (token_string, 1, max_bit_string_constant);
 441                     error_token = create_token (token_string || "b", bit_string);
 442                     call lex_error (100, error_token);
 443                end;
 444 
 445                token_string = token_string || "b";
 446           end;
 447           else if token_start > 0 then
 448                if token_length > max_char_string_constant then do;
 449                     token_length = max_char_string_constant;
 450                     error_token = create_token (substr (source_string, token_start, token_length), char_string);
 451                     call lex_error (100, error_token);      /* char string too long */
 452                end;
 453                else
 454                     ;
 455           else if length (token_string) > max_char_string_constant then do;
 456                                                             /* char string too long */
 457                token_string = substr (token_string, 1, max_char_string_constant);
 458                call lex_error (100, create_token ((token_string), char_string));
 459           end;
 460 
 461           if source_index > source_length then
 462                go to end_of_source_reached;
 463 
 464           call make_token;
 465           go to check_syntax_after_constant;
 466 ^L
 467 action (3):                                                 /* SCAN IDENTIFIERS */
 468           token_type = identifier;
 469           token_start = source_index - 1;
 470 
 471           scan_index = verify (substr (source_string, source_index), identifier_characters);
 472 
 473           if scan_index = 0 then do;
 474                source_index = source_length + 1;
 475                go to end_of_source_reached;
 476           end;
 477 
 478           source_index = source_index + scan_index - 1;
 479           call make_token;
 480 
 481 /* Now make sure the syntax after the identifier is correct. */
 482 
 483           current_char = substr (source_string, source_index, 1);
 484           char_value = rank (current_char);
 485           source_index = source_index + 1;
 486 
 487           if char_value >= hbound (action_table, 1) then
 488                action_index = action_table (hbound (action_table, 1));
 489           else
 490                action_index = action_table (char_value);
 491 
 492           if action_index = 2 /* double quote */ then do;
 493                error_token = token_list (token_index);
 494 
 495                if error_token -> token.string ^= "p" & error_token -> token.string ^= "pic"
 496                     & error_token -> token.string ^= "picture" then
 497                     call lex_error (158, error_token);      /* double quote after identifier */
 498           end;
 499 
 500           go to action (action_index);
 501 ^L
 502 /* SINGLE CHARACTER TOKENS */
 503 
 504 action (4):                                                 /* % */
 505           token_start = source_index - 1;
 506           if percent_sign_seen then
 507                call lex_error (125, null);                  /* %sign while parsing macro */
 508 
 509           percent_sign_seen = "1"b;
 510           saved_token_index = token_index;
 511           call print_line_before_include;
 512           call enter_token (percent_token_ptr);
 513           go to action (1);
 514 
 515 action (17):                                                /* & */
 516           token_start = source_index - 1;
 517           call enter_token (and_token_ptr);
 518           go to action (1);
 519 
 520 action (18):                                                /* ( */
 521           token_start = source_index - 1;
 522           parenthesis_level = parenthesis_level + 1;
 523           call enter_token (left_parn_token_ptr);
 524           go to action (1);
 525 
 526 action (19):                                                /* ) */
 527           token_start = source_index - 1;
 528           parenthesis_level = parenthesis_level - 1;
 529           call enter_token (right_parn_token_ptr);
 530           go to action (1);
 531 
 532 action (20):                                                /* + */
 533           token_start = source_index - 1;
 534           call enter_token (plus_token_ptr);
 535           go to action (1);
 536 
 537 action (21):                                                /* , */
 538           token_start = source_index - 1;
 539           call enter_token (comma_token_ptr);
 540           go to action (1);
 541 
 542 action (22):                                                /* : */
 543           token_start = source_index - 1;
 544           if parenthesis_level = 0 then
 545                pl1_stat_$level_0_colon = "1"b;
 546 
 547           call enter_token (colon_token_ptr);
 548           go to action (1);
 549 
 550 action (23):                                                /* = */
 551           token_start = source_index - 1;
 552           if parenthesis_level = 0 then
 553                pl1_stat_$level_0_equal = "1"b;
 554 
 555           call enter_token (assignment_token_ptr);
 556           go to action (1);
 557 ^L
 558 action (5):                                                 /* SEPARATE / AND /* */
 559           token_start = source_index - 1;                   /* tentative */
 560           token_type = slash;
 561 
 562           if source_index > source_length then
 563                go to end_of_source_reached;
 564 
 565           if substr (source_string, source_index, 1) ^= "*" then do;
 566                call enter_token (slash_token_ptr);
 567                go to action (1);
 568           end;
 569 
 570 /* Now lexing a comment */
 571 
 572           source_index = source_index + 1;
 573 
 574 rescan_comment:
 575           scan_index = search (substr (source_string, source_index), asterisk_or_newline);
 576           if scan_index = 0 then do;
 577                call lex_error (360, file_token_ptr);        /* eof in comment */
 578                go to end_of_source_reached_but_no_pending_token;
 579           end;
 580 
 581           source_index = source_index + scan_index;
 582 
 583           if substr (source_string, source_index - 1, 1) = newline then do;
 584                call print_line;
 585                line_begins_in_comment = "1"b;
 586                go to rescan_comment;
 587           end;
 588 
 589 /* at this point substr (source_string, source_index - 1, 1) is an asterisk */
 590 
 591           if substr (source_string, source_index, 1) = "/" then do;
 592                source_index = source_index + 1;
 593                go to action (1);
 594           end;
 595 
 596           go to rescan_comment;
 597 ^L
 598 action (6):                                                 /* SCAN NUMBERS AND ISUBS. current char = <digit> */
 599           token_start = source_index - 1;
 600           token_type = fixed_bin;                           /* set initial token_type & flags  */
 601           decimal_value = is_decimal_constant;              /* .. */
 602           imaginary_value = "0"b;                           /* .. */
 603           float_value = "0"b;                               /* .. */
 604           integral_value = is_integral_constant;            /* .. */
 605 
 606           if source_index > source_length then
 607                go to end_of_source_reached;
 608 
 609           call scan_past_digits;
 610 
 611           if substr (source_string, source_index, 1) = "." then do;
 612                integral_value = "0"b;
 613 
 614 scan_fraction:
 615                source_index = source_index + 1;
 616 
 617                if source_index > source_length then
 618                     go to end_of_source_reached;
 619 
 620                call scan_past_digits;
 621           end;
 622           else if source_index + 2 <= source_length then
 623                if substr (source_string, source_index, 3) = "sub" then do;
 624                     source_index = source_index + 3;
 625                     token_type = isub;
 626                     call make_token;
 627                     go to action (1);
 628                end;
 629 
 630           token_length = source_index - token_start;        /* remember length of mantissa for later error check */
 631 
 632           if (substr (source_string, source_index, 1) = "e") | (substr (source_string, source_index, 1) = "f") then do;
 633                if substr (source_string, source_index, 1) = "e" then
 634                     float_value = is_float_constant;
 635 
 636                integral_value = "0"b;
 637                source_index = source_index + 1;
 638 
 639                if source_index > source_length then do;
 640                     call missing_exponent;
 641                     go to end_of_source_reached;
 642                end;
 643 
 644                if (substr (source_string, source_index, 1) = "+") | (substr (source_string, source_index, 1) = "-")
 645                then do;
 646                     source_index = source_index + 1;
 647 
 648                     if source_index > source_length then do;
 649                          call missing_exponent;
 650                          go to end_of_source_reached;
 651                     end;
 652                end;
 653 
 654                call scan_past_digits;
 655           end;
 656 
 657           if substr (source_string, source_index, 1) = "b" /* binary constant */ then do;
 658                decimal_value = "0"b;
 659                scan_index = source_index;                   /* remember position of "b" */
 660                source_index = source_index + 1;
 661           end;
 662 
 663           if source_index <= source_length then
 664                if substr (source_string, source_index, 1) = "p" /* default suppression indicator */ then do;
 665                     source_index = source_index + 1;
 666                     protected = "1"b;
 667                end;
 668 
 669           if source_index <= source_length then
 670                if substr (source_string, source_index, 1) = "i" /* imaginary constant */ then do;
 671                     imaginary_value = is_imaginary_constant;
 672                     source_index = source_index + 1;
 673                end;
 674 
 675           if decimal_value = ""b /* is this a binary constant ? */ then
 676                if verify (substr (source_string, token_start, token_length), ".01") > 0 then do;
 677                     error_token =
 678                          create_token (substr (source_string, token_start, source_index - token_start), i_float_dec);
 679                                                             /* don't care about real token_type...guess safely */
 680                     call lex_error (153, error_token);      /* non-binary digit in apparent binary constant */
 681 
 682 /* Fix up the constant...restore the decimal attribute, and eliminate the "b" from
 683                             the token_string */
 684 
 685                     decimal_value = is_decimal_constant;
 686                     token_string = substr (source_string, token_start, scan_index - token_start);
 687 
 688                     if imaginary_value ^= ""b then
 689                          token_string = token_string || "i";
 690 
 691                     string_token_start = token_start;       /* save for make_token */
 692                     token_start = 0;
 693                end;
 694 
 695 /* If the constant is protected (and wasn't copied by the error recovery
 696              code above), then we have to copy it now in order to avoid getting
 697              the "p" into the token. */
 698 
 699           if (protected ^= ""b) & token_start > 0 then do;
 700                if imaginary_value ^= ""b then
 701                     token_length = source_index - token_start - 2;
 702                else
 703                     token_length = source_index - token_start - 1;
 704 
 705                token_string = substr (source_string, token_start, token_length);
 706                token_start = 0;
 707 
 708                if imaginary_value ^= ""b then
 709                     token_string = token_string || "i";
 710           end;
 711 
 712           if source_index > source_length then
 713                go to end_of_source_reached;
 714 
 715           call make_token;
 716 
 717 /* Now make sure the syntax after the constant is correct. */
 718 
 719 check_syntax_after_constant:
 720           current_char = substr (source_string, source_index, 1);
 721           char_value = rank (current_char);
 722           source_index = source_index + 1;
 723 
 724           if char_value >= hbound (action_table, 1) then
 725                action_index = action_table (hbound (action_table, 1));
 726           else
 727                action_index = action_table (char_value);
 728 
 729           if action_index = 3 | action_index = 6 | action_index = 2 /* alphabetics, numbers, double quote */ then
 730                call lex_error (157, token_list (token_index));
 731                                                             /* text after string */
 732 
 733           go to action (action_index);
 734 ^L
 735 action (7):                                                 /* SEPARATE . AND NUMBERS. current_char = "." */
 736           token_start = source_index - 1;
 737           token_type = period;                              /* assume for now */
 738 
 739           if source_index > source_length then
 740                go to end_of_source_reached;
 741 
 742           current_char = substr (source_string, source_index, 1);
 743                                                             /* grab next character */
 744           char_value = rank (current_char);
 745 
 746           if char_value <= hbound (action_table, 1) then
 747                if action_table (char_value) = 6 /* next char is a <digit> */ then do;
 748                     token_type = fixed_bin;                 /* set initial token_type & flags */
 749                     decimal_value = is_decimal_constant;    /* .. */
 750                     imaginary_value = "0"b;                 /* .. */
 751                     float_value = "0"b;                     /* .. */
 752                     integral_value = "0"b;                  /* .. */
 753                     go to scan_fraction;
 754                end;
 755 
 756           call enter_token (period_token_ptr);
 757           go to action (1);
 758 ^L
 759 action (8):                                                 /* SCAN NEWLINE */
 760           call print_line;
 761           go to action (1);
 762 ^L
 763 action (9):                                                 /* MISC ERRORS */
 764           if char_value < 32 | char_value >= 128 then do;
 765                error_number = 159;                          /* control chars & non-ASCII not allowed */
 766                error_token = create_token (char (bit (char_value, 9)) || "b", bit_string);
 767           end;
 768           else if (current_char = "_") | (current_char = "$") then do;
 769                error_number = 151;                          /* $ and _ may not start identifier */
 770                error_token = null;
 771           end;
 772           else do;
 773                error_number = 363;                          /* printing char ^a not allowed */
 774                error_token = create_token ((current_char), char_string);
 775           end;
 776 
 777           call lex_error (error_number, error_token);
 778           go to action (1);
 779 ^L
 780 action (10):                                                /* SEPARATE * AND ** */
 781           token_start = source_index - 1;
 782           token_type = asterisk;
 783           token_ptr = asterisk_token_ptr;
 784 
 785           if source_index > source_length then
 786                go to end_of_source_reached;
 787 
 788           if substr (source_string, source_index, 1) = "*" then do;
 789                source_index = source_index + 1;
 790                token_ptr = expon_token_ptr;
 791           end;
 792 
 793           call enter_token (token_ptr);
 794           go to action (1);
 795 ^L
 796 action (11):                                                /* SEPARATE - AND -> */
 797           token_start = source_index - 1;
 798           token_type = minus;
 799           token_ptr = minus_token_ptr;
 800 
 801           if source_index > source_length then
 802                go to end_of_source_reached;
 803 
 804           if substr (source_string, source_index, 1) = ">" then do;
 805                source_index = source_index + 1;
 806                token_ptr = arrow_token_ptr;
 807           end;
 808 
 809           call enter_token (token_ptr);
 810           go to action (1);
 811 ^L
 812 action (12):                                                /* SEPARATE < AND <= */
 813           token_start = source_index - 1;
 814           token_type = lt;
 815           token_ptr = lt_token_ptr;
 816 
 817           if source_index > source_length then
 818                go to end_of_source_reached;
 819 
 820           if substr (source_string, source_index, 1) = "=" then do;
 821                source_index = source_index + 1;
 822                token_ptr = le_token_ptr;
 823           end;
 824 
 825           call enter_token (token_ptr);
 826           go to action (1);
 827 ^L
 828 action (13):                                                /* SEPARATE > AND >= */
 829           token_start = source_index - 1;
 830           token_type = gt;
 831           token_ptr = gt_token_ptr;
 832 
 833           if source_index > source_length then
 834                go to end_of_source_reached;
 835 
 836           if substr (source_string, source_index, 1) = "=" then do;
 837                source_index = source_index + 1;
 838                token_ptr = ge_token_ptr;
 839           end;
 840 
 841           call enter_token (token_ptr);
 842           go to action (1);
 843 ^L
 844 action (14):                                                /* SEPARATE ^ AND ^= AND ^< AND ^> */
 845           token_start = source_index - 1;
 846           token_type = not;
 847           token_ptr = not_token_ptr;
 848 
 849           if source_index > source_length then
 850                go to end_of_source_reached;
 851 
 852           if substr (source_string, source_index, 1) = "=" then do;
 853                source_index = source_index + 1;
 854                token_ptr = ne_token_ptr;
 855           end;
 856           else if substr (source_string, source_index, 1) = "<" then do;
 857                source_index = source_index + 1;
 858                token_ptr = nlt_token_ptr;
 859           end;
 860           else if substr (source_string, source_index, 1) = ">" then do;
 861                source_index = source_index + 1;
 862                token_ptr = ngt_token_ptr;
 863           end;
 864 
 865           call enter_token (token_ptr);
 866           go to action (1);
 867 ^L
 868 action (15):                                                /* SEPARATE | AND || */
 869           token_start = source_index - 1;
 870           token_type = or;
 871           token_ptr = or_token_ptr;
 872 
 873           if source_index > source_length then
 874                go to end_of_source_reached;
 875 
 876           if substr (source_string, source_index, 1) = "|" then do;
 877                source_index = source_index + 1;
 878                token_ptr = cat_token_ptr;
 879           end;
 880 
 881           call enter_token (token_ptr);
 882           go to action (1);
 883 ^L
 884 action (16):                                                /* SCAN SEMICOLON.  current_char = ";" */
 885           token_start = source_index - 1;
 886 
 887           if percent_sign_seen then do;
 888                percent_sign_seen = "0"b;
 889                listing_on = pl1_stat_$listing_on;
 890                line_start = source_index;
 891                k = saved_token_index + 1;
 892 
 893                if token_list (token_index) -> token.type = percent /* %; */ then do;
 894                     token_index = saved_token_index;
 895                     go to action (1);                       /* ignore it */
 896                end;
 897 
 898                k = k + 1;
 899 
 900                if t_table.string = "page" | t_table.string = "skip" then do;
 901                     if t_table.string = "page" then
 902                          page_macro = "1"b;
 903                     else
 904                          page_macro = "0"b;
 905 
 906                     if k = token_index /* no argument */ then
 907                          n = 1;
 908                     else do;
 909                          k = k + 1;                         /* step over keyword */
 910 
 911                          if token_index - k + 1 < 3 /* must be at least 3 more tokens */ then
 912                               go to error_376;              /* a good programming lang wouldn't need this goto */
 913 
 914                          if t_table.type ^= left_parn | token_list (k + 1) -> token.type ^= dec_integer
 915                               | token_list (k + 2) -> token.type ^= right_parn then do;
 916 error_376:
 917                               call lex_error (376, null);   /* syntax error in %page macro */
 918                               k = token_index;              /* suppress possible error 375, below */
 919                               n = 1;
 920                          end;
 921                          else do;
 922                               n = token_to_binary (token_list (k + 1));
 923                               k = k + 2;
 924                          end;
 925                     end;
 926 
 927                     if listing_on then
 928                          if page_macro then
 929                               call pl1_print$non_varying (copy (newpage, n), 0);
 930                          else
 931                               call pl1_print$non_varying (copy (newline, n), 0);
 932 
 933                     if k ^= token_index then
 934                          call lex_error (375, null);        /* excess arguments ignored */
 935 
 936                     token_index = saved_token_index;
 937                     go to action (1);
 938                end;
 939 
 940                if t_table.string ^= "include" then do;
 941                     token_index = saved_token_index;
 942                     call lex_error (103, null);             /* not include or page */
 943                     go to action (1);
 944                end;
 945 
 946                k = k + 1;
 947 
 948                if (t_table.type = identifier) | (t_table.type = char_string) then
 949                     include_file_name = t_table.string;
 950                else do;
 951                     token_index = saved_token_index;
 952                     call lex_error (104, null);             /* filename not identifier or string */
 953                     go to action (1);
 954                end;
 955 
 956                if k ^= token_index then do;
 957                     token_index = saved_token_index;
 958                     call lex_error (441, null);             /* no semicolon */
 959                     go to action (1);
 960                end;
 961 
 962                token_index = saved_token_index;
 963 
 964                if length (include_file_name) >= 24 then do;
 965                     call lex_error (106, token_list (k));   /* filename too long */
 966                     go to action (1);
 967                end;
 968 
 969                include_file_name = include_file_name || ".incl.pl1";
 970                new_file_token_ptr = create_token ((include_file_name), identifier);
 971 
 972                call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount,
 973                     include_file_ptr, code);
 974 
 975                if include_file_ptr = null () then do;
 976                     if index (include_file_name, ">") ^= 0 | index (include_file_name, "<") ^= 0 then
 977                          call lex_error (392, new_file_token_ptr);
 978                                                             /* ">" and "<" not accepted in include macro */
 979                     else
 980                          call lex_error (107, new_file_token_ptr);
 981                                                             /* include file not found */
 982 
 983                end;
 984                else if code ^= 0 then
 985                     call com_err_ (code, command, "^a", include_file_name);
 986 
 987                if pl1_stat_$last_source = source_list_length then do;
 988                     call hcs_$terminate_noname (include_file_ptr, code);
 989                     call lex_error (129, new_file_token_ptr);
 990                                                             /* too many include files */
 991                     go to action (1);
 992                end;
 993 
 994                if source_depth > hbound (file_stack, 1) then do;
 995                     call hcs_$terminate_noname (include_file_ptr, code);
 996                     call lex_error (112, new_file_token_ptr);
 997                                                             /* nested too deep */
 998                     go to action (1);
 999                end;
1000 
1001                file_stack (source_depth).source_ptr = source_ptr;
1002                file_stack (source_depth).file_token_ptr = file_token_ptr;
1003                file_stack (source_depth).source_index = source_index;
1004                file_stack (source_depth).source_length = source_length;
1005                file_stack (source_depth).line_number = line_number;
1006                file_stack (source_depth).file_number = pl1_stat_$source_seg;
1007 
1008                do depthx = lbound (file_stack, 1) to source_depth;
1009                     if file_stack (depthx).source_ptr = include_file_ptr then do;
1010                          call hcs_$terminate_noname (include_file_ptr, code);
1011                          call lex_error (108, new_file_token_ptr);
1012                                                             /* infinite recursion */
1013                          go to action (1);
1014                     end;
1015                end;
1016 
1017 /* At this point it is OK to enter the include file */
1018 
1019                source_depth = source_depth + 1;
1020                include_file_length = divide (bitcount + 8, 9, 24, 0);
1021                new_file_number =
1022                     create_source (include_file_ptr, include_file_length, new_file_token_ptr, pl1_stat_$source_seg,
1023                     line_number);
1024 
1025                call enter_source_segment (include_file_ptr, include_file_length, new_file_token_ptr, new_file_number);
1026                go to action (1);
1027           end;
1028 
1029           call emit_semicolon;
1030 
1031           if lexing_after_end_stmt then
1032                call lex_error (99, null);                   /* text after end of program */
1033 
1034           return;
1035 ^L
1036 /* Control transfers here whenever the lex reaches the end of the current source segment. */
1037 
1038 end_of_source_reached:
1039           call make_token;
1040 
1041 end_of_source_reached_but_no_pending_token:
1042           if percent_sign_seen then do;
1043                call lex_error (71, null);                   /* eof in macro */
1044                percent_sign_seen = "0"b;                    /* ignore %include */
1045                token_index = saved_token_index;
1046           end;
1047 
1048           call print_line_at_eof;
1049 
1050           pl1_stat_$line_count = pl1_stat_$line_count + line_number;
1051 
1052           if source_depth = 0 /* we are now in the outermost file */ then do;
1053                if lexing_after_end_stmt then do;
1054                     if token_index > 0 /* any tokens generated? */ then
1055                          call lex_error (99, null);         /* text after eof */
1056 
1057                     return;
1058                end;
1059 
1060                if token_index > 0 then do;
1061                     call lex_error (361, null);             /* last stmt has no semicolon */
1062                     call emit_semicolon;
1063                     return;
1064                end;
1065 
1066                call lex_error (101, null);                  /* not enough end stmts */
1067 
1068                if token_index < token_list_length then
1069                     token_index = token_index + 1;
1070                token_list (token_index) = create_token ("end", identifier);
1071                                                             /* generate "end" */
1072                call emit_semicolon;                         /* generate ";" */
1073                pl1_stat_$st_length = 0;                     /* no source for this phony stmt */
1074                return;
1075           end;
1076 
1077           source_depth = source_depth - 1;                  /* we were in incl file...pop out */
1078           call enter_source_segment (file_stack (source_depth).source_ptr, file_stack (source_depth).source_length,
1079                file_stack (source_depth).file_token_ptr, file_stack (source_depth).file_number);
1080 
1081           source_index = file_stack (source_depth).source_index;
1082           line_start = source_index;
1083           line_number = file_stack (source_depth).line_number;
1084           go to action (1);
1085 ^L
1086 /* Entry to initialize all of the static variables used by the lex and create_token.
1087    This entry must be called before the first call to lex itself. */
1088 
1089 initialize_lex:
1090      entry (bv_source_ptr, bv_source_length);
1091 
1092 /* parameters */
1093 
1094 declare   (
1095           bv_source_ptr ptr,
1096           bv_source_length fixed bin (21)
1097           ) parameter;
1098 
1099 /* program */
1100 
1101 /* Initialize create_token, first */
1102 
1103           call create_token$init_hash_table;
1104 
1105 /* Initialize static variables */
1106 
1107           statement_number = 1;
1108 
1109           suppress_line_numbers = "0"b;
1110           line_begins_in_comment = "0"b;
1111           lexing_after_end_stmt = "0"b;
1112 
1113 /* Get static pointers to all the delimiter tokens */
1114 
1115           plus_token_ptr = create_token ("+", plus);
1116           minus_token_ptr = create_token ("-", minus);
1117           asterisk_token_ptr = create_token ("*", asterisk);
1118           slash_token_ptr = create_token ("/", slash);
1119           expon_token_ptr = create_token ("**", expon);
1120           not_token_ptr = create_token ("^", not);
1121           and_token_ptr = create_token ("&", and);
1122           or_token_ptr = create_token ("|", or);
1123           cat_token_ptr = create_token ("||", cat);
1124           ne_token_ptr = create_token ("^=", ne);
1125           lt_token_ptr = create_token ("<", lt);
1126           gt_token_ptr = create_token (">", gt);
1127           le_token_ptr = create_token ("<=", le);
1128           ge_token_ptr = create_token (">=", ge);
1129           ngt_token_ptr = create_token ("^>", ngt);
1130           nlt_token_ptr = create_token ("^<", nlt);
1131           assignment_token_ptr = create_token ("=", assignment);
1132           colon_token_ptr = create_token (":", colon);
1133           semi_colon_token_ptr = create_token (";", semi_colon);
1134           comma_token_ptr = create_token (",", comma);
1135           period_token_ptr = create_token (".", period);
1136           arrow_token_ptr = create_token ("->", arrow);
1137           left_parn_token_ptr = create_token ("(", left_parn);
1138           right_parn_token_ptr = create_token (")", right_parn);
1139           percent_token_ptr = create_token ("%", percent);
1140 
1141           source_depth = 0;
1142           pl1_stat_$source_seg = -1;
1143           pl1_stat_$last_source = -1;
1144           pl1_stat_$line_count = 0;
1145 
1146           new_file_token_ptr = create_token (pl1_stat_$seg_name || ".pl1", identifier);
1147 
1148 /* Create a source node for the main file */
1149 
1150           new_file_number = create_source (bv_source_ptr, bv_source_length, new_file_token_ptr, 0, 0);
1151 
1152 /* Enter the main source segment */
1153 
1154           call enter_source_segment (bv_source_ptr, bv_source_length, new_file_token_ptr, new_file_number);
1155           return;
1156 ^L
1157 /* Entry to terminate source segments. */
1158 
1159 terminate_source:
1160      entry;
1161 
1162           do pl1_stat_$last_source = pl1_stat_$last_source to 0 by -1;
1163                m = pl1_stat_$last_source;
1164                call hcs_$terminate_noname ((source.seg_ptr), code);
1165           end;
1166           return;
1167 ^L
1168 /* Entry to write the last line and check for text after the end statement. */
1169 
1170 write_last_line:
1171      entry (cblock);
1172 
1173 declare   1 source_info aligned,
1174             2 line_id char (9) unal,
1175             2 sp1 char (2) unal,
1176             2 file_id char (3) unal,
1177             2 sp2 char (4) unal,
1178             2 dtm char (16) unal,
1179             2 sp3 char (2) unal,
1180             2 include_name char (32) unal,
1181             2 sp4 char (2) unal,
1182             2 pathname char (168) unal;
1183 
1184 declare   line_id char (9) varying aligned;
1185 declare   five_digits picture "zzzzz";
1186 declare   three_digits picture "zz9";
1187 
1188 /* internal static */
1189 
1190 declare   header char (93) varying aligned int static options (constant) init ("^L        SOURCE FILES USED IN THIS COMPILATION.
1191 
1192 LINE      NUMBER  DATE MODIFIED     NAME                              PATHNAME");
1193 
1194 /* program */
1195 
1196           lexing_after_end_stmt = "1"b;
1197           call lex (cblock);                                /* see if anything there besides white space & comments */
1198 
1199           listing_on = pl1_stat_$listing_on;
1200 
1201           if ^listing_on then
1202                return;
1203 
1204           call pl1_print$varying_nl (header);
1205 
1206           do m = 0 to pl1_stat_$last_source;
1207                string (source_info) = "";
1208 
1209                if source.file_number = ""b then
1210                     line_id = "";
1211                else do;
1212                     three_digits = binary (source.file_number, 8);
1213                                                             /* known to take three digits at most */
1214                     line_id = ltrim (three_digits) || "-";
1215                end;
1216 
1217                five_digits = binary (source.line_number, 14);
1218                                                             /* known to take five digits at most */
1219                source_info.line_id = line_id || ltrim (five_digits);
1220 
1221                three_digits = m;                            /* known to take three digits at most */
1222                source_info.file_id = three_digits;
1223 
1224                call date_time_ (source.dtm, source_info.dtm);
1225                source_info.include_name = source.name -> token.string;
1226                source_info.pathname = source.pathname;
1227                n = length (string (source_info)) - length (source_info.pathname) + source.pathlen;
1228                call pl1_print$non_varying_nl (string (source_info), (n));
1229           end;
1230           return;
1231 ^L
1232 /* Internal procedures */
1233 
1234 /* Internal procedure to create a source node for the main file and each include file */
1235 /* Modified by Gray to allow archive component source */
1236 
1237 create_source:
1238      procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number, bv_line_number)
1239           returns (fixed bin (8));
1240 
1241 /* parameters */
1242 
1243 declare   (
1244           bv_source_ptr ptr,                                /* ptr to base of source segment */
1245           bv_source_length fixed bin (21),                  /* length in chars of source segment */
1246           bv_file_token_ptr ptr,                            /* ptr to token node of file name */
1247           bv_file_number fixed bin (8),                     /* number of file that contains %include stmt */
1248           bv_line_number fixed bin (14)                     /* number of line that contains %include stmt */
1249           ) parameter;
1250 
1251 /* automatic */
1252 
1253 declare   cname char (32),                                  /* archive component name */
1254           dname char (256),                                 /* directory name of source segment */
1255           dtm fixed bin (71),                               /* date-time modified of source segment */
1256           ename char (32),                                  /* real entry name of source segment */
1257           include_path char (256) varying,                  /* temporary */
1258           uid bit (36) aligned;                             /* file system unique id of segment */
1259 
1260 /* entries */
1261 
1262 declare   translator_info_$component_get_source_info
1263                entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35));
1264 
1265 /* external static */
1266 
1267 declare   pl1_stat_$node_uses (18) fixed bin external static;
1268                                                             /* number of nodes allocated, indexed by type */
1269 
1270 /* program */
1271 
1272           call translator_info_$component_get_source_info (bv_source_ptr, dname, ename, cname, dtm, uid, code);
1273           if code ^= 0 then do;
1274                call lex_error (344, bv_file_token_ptr);
1275                include_path = "UNKNOWN DIRECTORY NAME" || bv_file_token_ptr -> token.string;
1276                                                             /* give 'em something. */
1277                uid = ""b;
1278                dtm = 0;
1279           end;
1280           else if cname = "" then
1281                include_path = rtrim (dname, "> ") || ">" || rtrim (ename);
1282           else
1283                include_path = rtrim (dname, "> ") || ">" || before (ename || " ", ".archive ") || "::" || rtrim (cname);
1284 
1285           n = length (include_path);
1286 
1287           pl1_stat_$node_uses (14) = pl1_stat_$node_uses (14) + 1;
1288 
1289           m, pl1_stat_$last_source = pl1_stat_$last_source + 1;
1290           allocate source in (tree_area) set (source_list (m));
1291           source.node_type = source_node;
1292           source.seg_ptr = bv_source_ptr;
1293           source.name = bv_file_token_ptr;
1294           source.source_length = bv_source_length;
1295           source.pathname = include_path;
1296           source.file_number = bit (bv_file_number, 8);
1297           source.line_number = bit (bv_line_number, 14);
1298           source.uid = uid;
1299           source.dtm = dtm;
1300           return (m);
1301 
1302      end create_source;
1303 ^L
1304 /* Procedure to centralize the processing performed when the semicolon is reached. */
1305 
1306 emit_semicolon:
1307      procedure;
1308 
1309           if token_index = token_list_length then
1310                call lex_error (105, null);                  /* too many tokens */
1311           else
1312                token_index = token_index + 1;
1313 
1314           token_list (token_index) = semi_colon_token_ptr;
1315 
1316           if token_index = 1 /* we have just lexed a null statement */ then do;
1317                pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1318                pl1_stat_$statement_id.line_number = bit (line_number, 14);
1319                pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1320                pl1_stat_$st_start = token_start - 1;
1321           end;
1322 
1323           statement_number = statement_number + 1;
1324 
1325           if statement_number >= 1f5b /* check range of statement number */ then do;
1326                call lex_error (111, null);                  /* too many statements */
1327                statement_number = 1;
1328           end;
1329 
1330           if pl1_stat_$st_start ^= -1 /* if st_start has been set, set st_length */ then
1331                pl1_stat_$st_length = (source_index - 1) - pl1_stat_$st_start;
1332           pl1_stat_$cur_statement = null;
1333           return;
1334 
1335      end emit_semicolon;
1336 ^L
1337 /* Internal procedure to set some global variables each time a new source segment is entered */
1338 
1339 enter_source_segment:
1340      procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number);
1341 
1342 /* parameters */
1343 
1344 declare   (
1345           bv_source_ptr ptr,                                /* ptr to base of source segment */
1346           bv_source_length fixed bin (21),                  /* length in chars of source segment */
1347           bv_file_token_ptr ptr,                            /* ptr to token node of file name */
1348           bv_file_number fixed bin (8)                      /* number of new source file */
1349           ) parameter;
1350 
1351 /* program */
1352 
1353           source_ptr = bv_source_ptr;
1354           source_length = bv_source_length;
1355           source_index = 1;
1356           file_token_ptr = bv_file_token_ptr;
1357           pl1_stat_$source_seg = bv_file_number;
1358           line_number = 1;
1359           line_start = 1;
1360           pl1_stat_$st_start = -1;
1361           pl1_stat_$st_length = 0;
1362           return;
1363 
1364      end enter_source_segment;
1365 ^L
1366 /* Internal procedure to centralize error reporting by the lex. */
1367 
1368 lex_error:
1369      procedure (bv_error_number, bv_token_ptr);
1370 
1371 /* parameters */
1372 
1373 declare   (
1374           bv_error_number fixed bin (15),
1375           bv_token_ptr ptr
1376           ) parameter;
1377 
1378 /* automatic */
1379 
1380 declare   statement_length fixed bin (21);                  /* length (in chars) of current statement */
1381 
1382 /* program */
1383 
1384           pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1385           pl1_stat_$statement_id.line_number = bit (line_number, 14);
1386           pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1387 
1388           if pl1_stat_$st_start = -1 /* if st_start hasn't been set, do it now */ then do;
1389                pl1_stat_$st_start = line_start - 1;         /* print one source line... */
1390 
1391                if source_index > source_length /* if beyond eof, cancel stmt */ then
1392                     statement_length = 0;
1393                else
1394                     statement_length = (source_index - 1) - pl1_stat_$st_start;
1395           end;
1396           else
1397                statement_length = (source_index - 1) - pl1_stat_$st_start;
1398 
1399           call error_ (bv_error_number, pl1_stat_$statement_id, bv_token_ptr, pl1_stat_$source_seg, (pl1_stat_$st_start),
1400                (statement_length));
1401           return;
1402 
1403      end lex_error;
1404 ^L
1405 /* This procedure is called to enter a pointer to a token into the token
1406    list. */
1407 
1408 enter_token:
1409      procedure (P_token_ptr);
1410 
1411 /* parameters */
1412 
1413 declare   P_token_ptr ptr unal parameter;
1414 
1415 /* program */
1416 
1417           if token_index < token_list_length then
1418                token_index = token_index + 1;
1419 
1420           token_list (token_index) = P_token_ptr;
1421 
1422           if token_index = 1 /* Now emitting first token of a stmt... */ then do;
1423                pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1424                pl1_stat_$statement_id.line_number = bit (line_number, 14);
1425                pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1426 
1427                if token_start = 0 then
1428                     pl1_stat_$st_start = string_token_start - 1;
1429                                                             /* char_strings & bit_strings */
1430                else
1431                     pl1_stat_$st_start = token_start - 1;   /* everything else */
1432           end;
1433 
1434           return;
1435 
1436      end enter_token;
1437 ^L
1438 /* This procedure is called to make a token. */
1439 /* Convention:
1440           token_type is set to the correct type, OR is set to fixed_bin, in which case
1441                     the variables imaginary_value, float_value, decimal_value, and integral_value are all set.
1442           token_start is either set to the index of the first character of the token,
1443                     OR is zero and token_string contains the token.  If token_start is nonzero and token_type is char_string,
1444                     token_length is also set, otherwise it isn't.
1445           source_index is set to the index of the first character after the token. */
1446 
1447 make_token:
1448      procedure;
1449 
1450 /* automatic */
1451 
1452 declare   token_ptr ptr unal;
1453 
1454 /* program */
1455 
1456           if token_type = fixed_bin then
1457                token_type = token_type | imaginary_value | float_value | decimal_value | integral_value;
1458 
1459           if token_start > 0 then do;
1460                token_string_ptr = addr (substr (source_string, token_start, 1));
1461                                                             /* UGH */
1462 
1463                if token_type ^= char_string /* token_length is OK for char_strings */ then
1464                     token_length = source_index - token_start;
1465 
1466                if token_length > max_identifier_length then do;
1467                     token_length = max_identifier_length;
1468                     call lex_error (100, create_token (token_overlay, (token_type)));
1469                end;
1470           end;
1471           else do;
1472                token_string_ptr = addrel (addr (token_string), 1);
1473                                                             /* UGH */
1474                token_length = length (token_string);
1475           end;
1476 
1477           token_ptr = create_token$protected (token_overlay, (token_type), protected);
1478                                                             /* we pass token_type by value to get sta's, not stba's. */
1479 
1480           protected = ""b;
1481 
1482           call enter_token (token_ptr);
1483           return;
1484 ^L
1485 /* Internal procedure (quick block) version of create_token */
1486 
1487 %include create_token;
1488      end create_token;
1489 
1490      end make_token;
1491 ^L
1492 /* Internal procedure to centralize error recovery from eof in numeric tokens */
1493 
1494 missing_exponent:
1495      procedure;
1496 
1497           token_string = substr (source_string, token_start, source_index - token_start);
1498           token_string = token_string || "0";               /* provide an exponent */
1499           token_start = 0;
1500           call lex_error (155, create_token ((token_string), char_string));
1501                                                             /* missing exponent */
1502           return;
1503 
1504      end missing_exponent;
1505 ^L
1506 /* This procedure handles everything that needs to be done when a newline is seen */
1507 /* Convention: source_index must be set to the index of the character after the newline. */
1508 
1509 print_line:
1510      procedure;
1511 
1512           line_length = source_index - line_start;
1513 
1514           if listing_on then
1515                call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1516                     (line_begins_in_comment));
1517 
1518           line_start = source_index;
1519           line_number = line_number + 1;
1520 
1521           if line_number >= 1f14b /* check range of line number */ then
1522                if ^lexing_after_end_stmt /* doesn't matter if past program portion of segment */ then do;
1523                     call lex_error (46, null);              /* too many source lines */
1524                     line_number = 1;                        /* no use counting higher...node fields aren't big enough */
1525                end;
1526 
1527           statement_number = 1;
1528           suppress_line_numbers = "0"b;
1529           line_begins_in_comment = "0"b;
1530           return;
1531 
1532      end print_line;
1533 
1534 /* procedure to flush listing buffer of everything on last line of a segment.  There are two special cases
1535    to worry about: (1) the last line is empty, and (2) the last line doesn't end in a newline. */
1536 
1537 print_line_at_eof:
1538      procedure;
1539 
1540           line_length = source_index - line_start;
1541 
1542           if line_length = 0 then
1543                return;                                      /* nothing on last line. */
1544 
1545           if listing_on then
1546                call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1547                     (line_begins_in_comment));
1548 
1549           line_begins_in_comment = "0"b;
1550 
1551           if substr (source_string, source_index - 1, 1) = newline then do;
1552                suppress_line_numbers = "0"b;
1553                statement_number = 1;
1554           end;
1555           else
1556                suppress_line_numbers = "1"b;
1557 
1558           return;
1559 
1560      end print_line_at_eof;
1561 ^L
1562 /* procedure to flush listing buffer of everything on the line before the percent sign. */
1563 
1564 print_line_before_include:
1565      procedure;
1566 
1567           line_length = source_index - line_start - 1;      /* do not print percent sign */
1568 
1569           if line_length > 0 then do;                       /* if ll=0, percent sign is in column 1...nothing to print */
1570                if listing_on then
1571                     call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1572                          (line_begins_in_comment));
1573 
1574                suppress_line_numbers = "1"b;                /* we are no longer at the left margin */
1575                line_begins_in_comment = "0"b;
1576           end;
1577 
1578           listing_on = "0"b;                                /* in case %include is > 1 line long */
1579           return;
1580 
1581      end print_line_before_include;
1582 ^L
1583 /* Internal procedure to scan sequences of <digits>.  */
1584 /* Convention: source_index is on character after digit upon entry, and is on
1585    stopping break upon exit. */
1586 
1587 scan_past_digits:
1588      procedure;
1589 
1590           scan_index = verify (substr (source_string, source_index), "0123456789");
1591 
1592           if scan_index = 0 then do;                        /* eof reached */
1593                source_index = source_length + 1;            /* set to pseudo-char after eof */
1594                go to end_of_source_reached;
1595           end;
1596           else
1597                source_index = source_index + scan_index - 1;
1598           return;
1599 
1600      end scan_past_digits;
1601 
1602      end lex;