1 /* format: style4,indattr,idind30 */
   2 lalr_grammar_parser_: proc (db_sw, local_recoveries, skip_recoveries, code);
   3 
   4 /* Parser for tables created by LALR. */
   5 
   6 dcl  code                          fixed bin (35) parameter;
   7 dcl  db_sw                         bit (1) parameter;
   8 
   9 %include lalr_parse_grammar_t_;
  10 dcl  1 stk                         (-4:100),
  11                                                             /* -4:-1 is the FIFO lookahead stack
  12                                                                1:100 is the LIFO lexical stack */
  13        2 symptr                    ptr,                     /* pointer to symbol (must be valid) */
  14        2 symlen                    fixed bin,               /* length of symbol (may be 0) */
  15        2 line_id                   aligned,                 /* identification of line where symbol begins */
  16          3 file                    fixed bin (17) unaligned,/* the include file number */
  17          3 line                    fixed bin (17) unaligned,/* the line number within the include file */
  18        2 symbol                    fixed bin,               /* encoding of the symbol */
  19        2 token_position            fixed bin (21),
  20        2 token_length              fixed bin,
  21        2 tag                       fixed bin;
  22 dcl  1 lookahead                   (-4:100) defined stk like stk;
  23 dcl  abs                           builtin;
  24 dcl  current_state                 fixed bin;               /* number of current state */
  25 dcl  current_table                 fixed bin;               /* number of current table */
  26 dcl  1 db_data                     unaligned,
  27        2 flag                      char (1),                /* * means stacked */
  28        2 state                     picture "zzz9",
  29        2 top                       picture "zzz9",
  30        2 filler                    char (2),
  31        2 type                      char (6),
  32        2 data                      char (100);
  33 dcl  db_item                       char (117) defined (db_data);
  34 dcl  db_separator                  char (1);
  35 dcl  divide                        builtin;
  36 dcl  error_count                   fixed bin;               /* When error_count > 0 it is the number of consecutive local
  37                                                                recoveries just performed plus the number of symbols that
  38                                                                must be read to "use up" the last of them. An error is not
  39                                                                possible while "using up" a local recovery. */
  40 dcl  false                         bit (1) internal static options (constant) init ("0"b);
  41 dcl  hbound                        builtin;
  42 dcl  i                             fixed bin;
  43 dcl  ioa_$nnl                      entry options (variable);
  44                                                             /* Parse stack underflow or local recovery encountered
  45                                                                impossible conditions.  Both caused by bad DPDA. */
  46 dcl  lalr_error_table_$parser_logic_error fixed bin (35) external static;
  47                                                             /* Parse, lexical, or lookahead stack overflow. */
  48 dcl  lalr_error_table_$parser_stack_overflow fixed bin (35) external static;
  49                                                             /* Recovery failed. */
  50 dcl  lalr_error_table_$parser_syntax_error fixed bin (35) external static;
  51                                                             /* Unrecognized table type in DPDA. */
  52 dcl  lalr_error_table_$parser_unrecognized_state fixed bin (35) external static;
  53 dcl  lb                            fixed bin;
  54 dcl  lbound                        builtin;
  55 dcl  stk_top                       fixed bin defined parse_stack_top; /* location of the top of the lexical stack */
  56 dcl  local_recoveries              fixed bin;               /* Count of successful local recoveries performed. */
  57 dcl  lookahead_count               fixed bin;               /* number of terminals in lookahead stack */
  58 dcl  lookahead_get                 fixed bin;               /* location in lookahead stack to get next symbol */
  59 dcl  lookahead_put                 fixed bin;               /* location in the lookahead stack to put next symbol */
  60 dcl  next_state                    fixed bin;               /* number of next state */
  61 dcl  nil_symbol                    fixed bin;               /* terminal symbol encoding for <nil> */
  62 dcl  null                          builtin;
  63 dcl  parse_stack                   (100) fixed bin aligned; /* parse stack */
  64 dcl  parse_stack_top               fixed bin;               /* location of the top of the parse stack */
  65 dcl  parse_stack2                  (100) fixed bin aligned; /* copy of parse stack used with recovery */
  66 dcl  production_number             fixed bin;               /* APPLY production number */
  67 dcl  read_count                    fixed bin;               /* Number of symbols read in a trial parse. */
  68 dcl  recov_msg                     char (250) varying;
  69 dcl  skip_recoveries               fixed bin;               /* count of skip recoveries performed */
  70 dcl  t                             fixed bin;
  71 dcl  test_state                    fixed bin;               /* top state from parse stack during look back lookups */
  72 dcl  test_symbol                   fixed bin defined test_state; /* encoding of current symbol */
  73 dcl  true                          bit (1) internal static options (constant) init ("1"b);
  74 dcl  ub                            fixed bin;
  75 dcl  unspec                        builtin;
  76 dcl  zero                          fixed bin internal static options (constant) init (0);
  77 %page;
  78           current_state = 1;
  79           parse_stack_top = 0;
  80           lookahead_put, lookahead_get = -1;
  81           if skip_size > 0 then
  82                nil_symbol = skip.v1 (2);                    /* Save encoding of <nil> in nil_symbol. */
  83           else nil_symbol = 10000;                          /* Set nil_symbol non-existant. */
  84           error_count = 0;
  85           local_recoveries = 0;
  86           skip_recoveries = 0;
  87           lookahead_count = 0;
  88           unspec (stk) = ""b;
  89           code = 0;                                         /* Preset the status code. */
  90 
  91 /* The parsing loop. */
  92 NEXT:
  93           if current_state = 0
  94           then do;
  95 parse_done:
  96                return;
  97           end;
  98           current_table = current_state;
  99           db_item = "";
 100           db_data.state = current_state;
 101           db_data.top = parse_stack_top;
 102           go to CASE (dpda.v1 (current_table));
 103 
 104 CASE (10):                                                  /* Obsolete -- Lookahead 1 (sometimes called read without
 105                                                                stacking) with shared transition table. */
 106 
 107 CASE (2):                                                   /* Read and stack and/or lookahead 1 (sometimes called
 108                                                                read without stacking) with shared transition table.
 109                                                                (Read transitions to state S are coded as +S while
 110                                                                lookahead transitions to state S are coded -S.) */
 111           current_table = dpda.v2 (current_table);
 112 
 113 CASE (0):                                                   /* Read and stack and/or lookahead 1 with neither a
 114                                                                default transition nor a marked symbol transition. */
 115 CASE (9):                                                   /* Obsolete -- Lookahead 1 (sometimes called
 116                                                                read without stacking). */
 117 CASE (15):                                                  /* Read and stack and/or lookahead 1 with
 118                                                                a default transition. */
 119 CASE (17):                                                  /* Read and stack and/or lookahead 1 with the table
 120                                                                continued at another state. */
 121 
 122           if lookahead_count <= 0                           /* Make sure a symbol is available. */
 123           then do;
 124                call scanner;
 125                if lookahead_put = lbound (lookahead, 1) then
 126                     lookahead_put = 0;
 127                lookahead_put = lookahead_put - 1;
 128                lookahead_count = lookahead_count + 1;
 129           end;
 130           test_symbol = lookahead.symbol (lookahead_get);
 131                                                             /* Look current symbol up in the read list. */
 132 search_table:
 133           lb = current_table + 1;
 134           ub = current_table + dpda.v2 (current_table);
 135           do while (lb <= ub);
 136                i = divide (ub + lb, 2, 17, 0);
 137                if dpda.v1 (i) = test_symbol
 138                then do;
 139                     next_state = dpda.v2 (i);
 140                     go to got_symbol;
 141                end;
 142                else if dpda.v1 (i) < test_symbol then
 143                     lb = i + 1;
 144                else ub = i - 1;
 145           end;
 146           if dpda.v1 (current_table + 1) < 0 then
 147                if dpda.v1 (current_table + 1) = -1
 148                then do;
 149                     current_state = -dpda.v2 (current_table + 1);
 150                     if db_sw
 151                     then do;
 152                          db_data.type = "LK01D";
 153                          db_data.data = get_terminal (lookahead_get);
 154                          call ioa_$nnl ("^a^/", db_item);
 155                     end;
 156                     go to NEXT;
 157                end;
 158                else do;
 159                     current_table = dpda.v2 (current_table + 1);
 160                     go to search_table;
 161                end;
 162 
 163           if error_count < 1 then
 164                if local_recovered () then
 165                     go to NEXT;
 166 
 167           if skip_size > 2
 168           then do;
 169                call skip_recovery;
 170                call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 171                go to NEXT;
 172           end;
 173 
 174           if db_sw then
 175                call ioa_$nnl (" ^4i^/", current_state);
 176           call set_line_id (lookahead_get, "FATAL");
 177           recov_msg = recov_msg || "at ";
 178           recov_msg = recov_msg || get_terminal (lookahead_get);
 179           recov_msg = recov_msg || ".";
 180           call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 181           code = lalr_error_table_$parser_syntax_error;
 182           go to parse_done;
 183 
 184 got_symbol:
 185           if db_sw then
 186                db_data.data = get_terminal (lookahead_get);
 187           if next_state < 0
 188           then do;                                          /* This is a lookahead transition. */
 189                db_data.type = "LK01";
 190                current_state = -next_state;
 191           end;
 192           else do;                                          /* This is a read transition. */
 193                db_data.type = "READ";
 194                db_data.flag = "*";
 195                if error_count > 0 then
 196                     error_count = error_count - 1;
 197                if parse_stack_top >= hbound (parse_stack, 1) then
 198                     call parse_stack_overflow;
 199                parse_stack_top = parse_stack_top + 1;
 200                parse_stack (parse_stack_top) = current_state; /* Stack the current state. */
 201                unspec (stk (parse_stack_top)) = unspec (lookahead (lookahead_get));
 202                if lookahead_get = lbound (lookahead, 1) then
 203                     lookahead_get = 0;
 204                lookahead_get = lookahead_get - 1;
 205                lookahead_count = lookahead_count - 1;
 206                current_state = next_state;
 207           end;
 208           if db_sw then
 209                call ioa_$nnl ("^a^/", db_item);
 210           go to NEXT;
 211 
 212 CASE (3):                                                   /* Multiple lookahead (k > 1) with shared look table. */
 213 CASE (1):                                                   /* Multiple lookahead (k > 1) without default transition. */
 214 CASE (14):                                                  /* Multiple lookahead (k > 1) with default transition. */
 215 CASE (16):                                                  /* Multiple lookahead (k > 1) with the table
 216                                                                continued at another state. */
 217 
 218 CASE (7):                                                   /* Obsolete state type -- Skip table. */
 219 CASE (8):                                                   /* Obsolete state type -- Skip recovery adjust table. */
 220 
 221 CASE (4):                                                   /* Apply by rule and alternative with lookback table. */
 222 CASE (5):                                                   /* Apply by rule and alternative without lookback. */
 223 CASE (6):                                                   /* Apply by rule and alternative with shared lookback table. */
 224 
 225 CASE (18):                                                  /* Apply by rule with lookback table. */
 226 CASE (19):                                                  /* Apply by rule without lookback. */
 227 CASE (20):                                                  /* Apply by rule with shared lookback table. */
 228 unrecognized_dpda_state:
 229           if lookahead_count <= 0
 230           then do;
 231                call scanner;
 232                if lookahead_put = lbound (lookahead, 1) then
 233                     lookahead_put = 0;
 234                lookahead_put = lookahead_put - 1;
 235                lookahead_count = 1;
 236           end;
 237           call set_line_id (lookahead_get, "LALR translator");
 238           recov_msg = recov_msg || "Unrecognized DPDA state encountered -- Parse fails.";
 239           call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 240           code = lalr_error_table_$parser_unrecognized_state;
 241           go to parse_done;
 242 
 243 CASE (13):                                                  /* Apply by production with shared lookback table. */
 244           current_table = dpda.v2 (current_state + 2);
 245 CASE (11):                                                  /* Apply by production with lookback table. */
 246 CASE (12):                                                  /* Apply by production without lookback. */
 247           production_number = dpda.v1 (current_state + 2);
 248           if production_number > 0 then
 249                call lalr_grammar_semantics_ (production_number);
 250 
 251           if db_sw
 252           then do;
 253                db_data.type = "APLY";
 254                db_data.data = "(";
 255                if dpda.v1 (current_state + 1) < 0 then
 256                     db_data.flag = "*";
 257                call ioa_$nnl ("^a^i", db_item, production_number);
 258                call print_production_name (production_number);
 259                call ioa_$nnl (")^-sd = ^i ", dpda.v1 (current_state + 1));
 260                if dpda.v1 (current_state + 1) > 0
 261                then do;
 262                     db_separator = "(";
 263                     do t = parse_stack_top to parse_stack_top - dpda.v1 (current_state + 1) + 1 by -1;
 264                          call ioa_$nnl ("^1a^d", db_separator, parse_stack (t));
 265                          db_separator = "";
 266                     end;
 267                     call ioa_$nnl (")");
 268                end;
 269                call ioa_$nnl ("^/");
 270           end;
 271                                                             /* Check for an apply of an empty production.
 272                                                                In this case the apply state number must be
 273                                                                pushed onto the parse stack.  (Reference
 274                                                                LaLonde, W. R.:  An efficient LALR Parser Generator.
 275                                                                Tech. Report CSRG-2, 1971, pp. 34-35.) */
 276           if dpda.v1 (current_state + 1) < 0
 277           then do;
 278                if parse_stack_top >= hbound (parse_stack, 1) then
 279                     call parse_stack_overflow;
 280                parse_stack (parse_stack_top + 1) = current_state;
 281           end;
 282                                                             /* Delete lexical & parse stack entries. */
 283           parse_stack_top = parse_stack_top - dpda.v1 (current_state + 1);
 284           if parse_stack_top <= 0
 285           then do;
 286                if skip_recoveries > 0
 287                then do;
 288                     call set_line_id (lookahead_get, "FATAL");
 289                     recov_msg = recov_msg
 290                          || "parser has lost its place due to failed skip recoveries.";
 291                     call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 292                     code = lalr_error_table_$parser_syntax_error;
 293                end;
 294                else do;
 295                     call set_line_id (lookahead_get, "LALR translator");
 296                     recov_msg = recov_msg || "lexical/parse stack empty -- Parse fails.";
 297                     call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 298                     code = lalr_error_table_$parser_logic_error;
 299                end;
 300                go to parse_done;
 301           end;
 302           test_state = parse_stack (parse_stack_top);
 303           lb = current_table + 3;
 304           ub = current_table + dpda.v2 (current_table);
 305           do while (lb <= ub);
 306                i = divide (ub + lb, 2, 17, 0);
 307                if dpda.v1 (i) = test_state
 308                then do;
 309                     current_state = dpda.v2 (i);
 310                     go to NEXT;
 311                end;
 312                else if dpda.v1 (i) < test_state then
 313                     lb = i + 1;
 314                else ub = i - 1;
 315           end;
 316           current_state = dpda.v2 (current_table + 2);
 317           go to NEXT;
 318 ^L
 319 local_recovered: proc returns (bit (1));
 320 
 321 /*
 322    ^O       This procedure  implements  the  LALR  local  error  recovery
 323    ^O       (using  the  DPDA  table).  This is done by using the current
 324    ^O       (bad) symbol and the next two  input  symbols.  All  possible
 325    ^O       parses  from  this  state  are  examined.  These trial parses
 326    ^O       proceed until both of the next two symbols  have  been  read.
 327    ^O       The  trial  parses  are  true simulations of what can happen,
 328    ^O       apply states are chosen according to  the  simulated  top  of
 329    ^O       parse stack.
 330 
 331    ^O       Given:
 332    ^O         A is an alternate symbol
 333    ^O         B is the current symbol (bad)
 334    ^O         N is the next input symbol
 335    ^O         T is the second next input symbol
 336    ^O         C is the current state
 337    ^O         R is a "next" read state
 338    ^O         F is a "next" read state following R
 339    ^O         G is a "next" read state following F
 340 
 341    ^O       The  following  table  indicates  the  recoveries  that   are
 342    ^O       possible  if  the  states  named  in  the column headings can
 343    ^O       accept the indicated symbols.
 344 
 345    ^O         C^H___R^H___F^H___G^H_
 346    ^O         N  B  T  x    Reverse B and N
 347    ^O         N  T  x  x    Delete B
 348    ^O         A  B  N  T    Insert A before B
 349    ^O         A  N  T  x    Replace B with A
 350 
 351    ^O       The recovery tries to find  a  useable  combination.  If  one
 352    ^O       exists,  the  search does  not   stop.  If  a  second  one is
 353    ^O       encountered, the search stops, a message is  generated  which
 354    ^O       says the choice is not unique, and then the first combination
 355    ^O       is used.
 356 
 357    ^O       Only terminals whose encoding is less than that  of  the  nil
 358    ^O       symbol are considered as alternate symbols by local recovery.
 359 
 360    ^O       There is a special precedence  rule  for  the  delete  B  and
 361    ^O       insert  A before B repairs. If both repairs are possible (but
 362    ^O       reverse B and N is not), delete B is performed if the encoded
 363    ^O       value  of  B  is  less  than the smallest encoded value of A;
 364    ^O       otherwise insert A before B is performed.
 365 
 366    ^O       Local recovery operates as described above when  2  is  given
 367    ^O       for  the  local_reads  parameter.  The  local_reads parameter
 368    ^O       specifies the number of symbols beyond the  bad  symbol  that
 369    ^O       must  be  accepted for a particular recovery to be considered
 370    ^O       successful. If, for example, 1 is given for local_reads,  the
 371    ^O       following table is used.
 372    ^O
 373    ^O         C^H___R^H___F^H_
 374    ^O         N  B  x    Reverse B and N
 375    ^O         N  x  x    Delete B
 376    ^O         A  B  N    Insert A before B
 377    ^O         A  N  x    Replace B with A
 378 
 379    ^O       The local recovery scheme was altered in September 1977 by Al
 380    ^O       Kepner  to  allow  local  recovery from errors encountered by
 381    ^O       look ahead states. Previously only errors encountered by read
 382    ^O       states  could  be  handled. The scheme was further altered in
 383    ^O       February 1982 by R. Eachus and P. Prange to base the recovery
 384    ^O       on the next n input symbols.  Previously only the next  input
 385    ^O       symbol was considered.
 386 */
 387 ^L
 388 dcl  best_alternate_symbol         fixed bin;               /* best alternate symbol from current repair method */
 389 dcl  delete_B                      fixed bin internal static options (constant) init (2);
 390 dcl  combinations                  fixed bin;               /* usable combinations found so far */
 391 dcl  insert_before_B               fixed bin internal static options (constant) init (3);
 392 dcl  lookahead_bad                 fixed bin;               /* lookahead index of the symbol B */
 393 dcl  lookahead_last                fixed bin;               /* lookahead index of the symbol position preceding B */
 394 dcl  lookahead_last_read           fixed bin;               /* lookahead index of the symbol position from which P was read */
 395 dcl  lookahead_next                fixed bin;               /* lookahead index of the symbol N */
 396 dcl  recovery_method               fixed bin;
 397 dcl  replace_B                     fixed bin internal static options (constant) init (4);
 398 dcl  transit                       fixed bin;               /* found alternate symbol to use from current state */
 399 
 400           if test_symbol < 0
 401           then do;
 402                call set_line_id (lookahead_get, "LALR translator");
 403                recov_msg = recov_msg
 404                     || "negative terminal (invalid parser DPDA); cannot recover.";
 405                call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 406                return (false);
 407           end;
 408           do while (lookahead_count < 2);
 409                call scanner;
 410                if lookahead_put = lbound (lookahead, 1) then
 411                     lookahead_put = 0;
 412                lookahead_put = lookahead_put - 1;
 413                lookahead_count = lookahead_count + 1;
 414           end;
 415           if db_sw then
 416                call dump_lookahead;
 417 
 418           lookahead_bad = lookahead_get;                    /* Calculate needed lookahead parameters. */
 419           if lookahead_get = lbound (lookahead, 1) then
 420                lookahead_next = -1;
 421           else lookahead_next = lookahead_get - 1;
 422           lookahead_last_read = lookahead_get + 1;
 423           if lookahead_last_read = 0 then
 424                lookahead_last_read = lbound (lookahead, 1);
 425           lookahead_last = lookahead_get + 1;
 426           if lookahead_last = 0 then
 427                lookahead_last = lbound (lookahead, 1);
 428 
 429           combinations = 0;
 430                                                             /* Try reversing B and N. */
 431           unspec (lookahead (0)) = unspec (lookahead (lookahead_bad));
 432           unspec (lookahead (lookahead_bad)) = unspec (lookahead (lookahead_next));
 433           unspec (lookahead (lookahead_next)) = unspec (lookahead (0));
 434           if db_sw then
 435                call ioa_$nnl ("#^- Reversing B and N.^/");
 436           call trial_parse (parse_stack_top, lookahead_get, 3);
 437           if read_count = 3 then
 438                combinations, recovery_method = 1;           /* Remember that this worked. */
 439           unspec (lookahead (lookahead_next)) = unspec (lookahead (lookahead_bad)); /* Put B and N back as they were. */
 440           unspec (lookahead (lookahead_bad)) = unspec (lookahead (0));
 441                                                             /* Try deleting the symbol B. */
 442           lookahead_count = lookahead_count - 1;
 443           if db_sw then
 444                call ioa_$nnl ("#^- Deleting B.^/");
 445           call trial_parse (parse_stack_top, lookahead_next, 2);
 446           if read_count = 2
 447           then do;
 448                if combinations = 0 then
 449                     recovery_method = delete_B;
 450                combinations = combinations + 1;
 451           end;
 452           lookahead_count = lookahead_count + 1;            /* Restore the lookahead. */
 453           if combinations < 2
 454           then do;
 455                                                             /* Try inserting alternate symbols before B. */
 456                lookahead_count = lookahead_count + 1;
 457                lookahead.symlen (lookahead_last_read) = 0;
 458                if db_sw then
 459                     call ioa_$nnl ("#^- Inserting alternate symbols before B.^/");
 460                call try_alternatives (insert_before_B);
 461                lookahead_count = lookahead_count - 1;       /* Restore the lookahead. */
 462                if combinations = 2 & recovery_method = delete_B then
 463                     if best_alternate_symbol < lookahead.symbol (0)
 464                     then do;
 465                          recovery_method = insert_before_B;
 466                          transit = best_alternate_symbol;
 467                     end;
 468           end;
 469 
 470           if combinations < 2
 471           then do;
 472                                                             /* Try replacing B with alternate symbols. */
 473                lookahead.symlen (lookahead_bad) = 0;
 474                if db_sw then
 475                     call ioa_$nnl ("#^- Replacing B with alternate symbols.^/");
 476                call try_alternatives (replace_B);
 477                unspec (lookahead (lookahead_bad)) = unspec (lookahead (0)); /* Restore the lookahead. */
 478           end;
 479 
 480           if combinations = 0 then
 481                return (false);
 482           call set_line_id (lookahead_bad, "WARNING");
 483           go to case (recovery_method);
 484 
 485 case (1):                                                   /* B and N reversed. */
 486           unspec (lookahead (lookahead_bad)) = unspec (lookahead (lookahead_next));
 487           unspec (lookahead (lookahead_next)) = unspec (lookahead (0));
 488           recov_msg = recov_msg || get_terminal (lookahead_next);
 489           recov_msg = recov_msg || " and ";
 490           recov_msg = recov_msg || get_terminal (lookahead_bad);
 491           recov_msg = recov_msg || " are reversed";
 492           go to done;
 493 
 494 case (2):                                                   /* B is an extra symbol. */
 495           lookahead_get = lookahead_next;
 496           lookahead_count = lookahead_count - 1;
 497           error_count = error_count - 1;
 498           recov_msg = recov_msg || "extraneous ";
 499           recov_msg = recov_msg || get_terminal (zero);
 500           recov_msg = recov_msg || " before ";
 501           recov_msg = recov_msg || get_terminal (lookahead_next);
 502           recov_msg = recov_msg || " ignored";
 503           go to done;
 504 
 505 case (3):                                                   /* Symbol leading to R is missing. */
 506           lookahead.symbol (lookahead_last_read) = transit;
 507           lookahead.symlen (lookahead_last_read) = 0;
 508           lookahead_get = lookahead_last_read;
 509           lookahead_count = lookahead_count + 1;
 510           error_count = error_count + 1;
 511           recov_msg = recov_msg || "missing ";
 512           recov_msg = recov_msg || get_terminal (lookahead_last_read);
 513           recov_msg = recov_msg || " is assumed before ";
 514           recov_msg = recov_msg || get_terminal (lookahead_bad);
 515           go to done;
 516 
 517 case (4):                                                   /* B is wrong symbol. */
 518           lookahead.symbol (lookahead_bad) = transit;
 519           lookahead.symlen (lookahead_bad) = 0;
 520           recov_msg = recov_msg || get_terminal (lookahead_bad);
 521           recov_msg = recov_msg || " substituted for erroneous ";
 522           recov_msg = recov_msg || get_terminal (zero);
 523 
 524 done:
 525           local_recoveries = local_recoveries + 1;
 526           error_count = error_count + 4;
 527           if combinations > 1 then
 528                recov_msg = recov_msg || " (other diagnoses are possible)";
 529           recov_msg = recov_msg || ".";
 530           call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
 531           if db_sw then
 532                call dump_lookahead;
 533           return (true);                                    /* Recovery completed. */
 534 ^L
 535 dump_lookahead: proc;
 536 dcl  i                             fixed bin;
 537                if db_sw
 538                then do;
 539                     do i = lookahead_get repeat i - 1 while (i ^= lookahead_put);
 540                          call ioa_$nnl ("#la (^i) ^3i ^a^/", i, lookahead.symbol (i), get_terminal (i));
 541                          if i = lbound (lookahead, 1) then
 542                               i = 0;
 543                     end;
 544                end;
 545           end dump_lookahead;
 546 %page;
 547 try_alternatives: proc (method);
 548 dcl  alternate_lookahead_get       fixed bin;
 549 dcl  alternate_symbol              fixed bin;
 550 dcl  method                        fixed bin parameter;
 551 dcl  min                           builtin;
 552 dcl  read_limit                    fixed bin;
 553 dcl  repair_loc                    fixed bin;
 554 dcl  repair_type                   char (10);
 555                if method = insert_before_B
 556                then do;
 557                     alternate_lookahead_get = lookahead_last_read;
 558                     read_limit = 4;
 559                     repair_loc = lookahead_last_read;
 560                     repair_type = "INSERT";
 561                end;
 562                else do;
 563                     alternate_lookahead_get = lookahead_get;
 564                     read_limit = 3;
 565                     repair_loc = lookahead_bad;
 566                     repair_type = "SUBSTITUTE";
 567                end;
 568                best_alternate_symbol = 10000;
 569                                                             /* The current table cannot possibly make a default transition.
 570                                                                If it did we wouldn't have detected an error. */
 571                current_table = current_state;
 572                if dpda.v1 (current_table) = 2 then
 573                     current_table = dpda.v2 (current_table);
 574 search_table:
 575                do i = current_table + 1 to current_table + dpda.v2 (current_table)
 576                     while (combinations < 2);
 577                     alternate_symbol = dpda.v1 (i);
 578                     if alternate_symbol < nil_symbol & alternate_symbol ^= 0
 579                     then do;
 580                          lookahead.symbol (repair_loc) = alternate_symbol;
 581                          if db_sw then
 582                               call ioa_$nnl ("#^- ^a ^a^/", repair_type, get_terminal (repair_loc));
 583                          call trial_parse (parse_stack_top, alternate_lookahead_get, read_limit);
 584                          if read_count = read_limit
 585                          then do;
 586                               best_alternate_symbol = min (best_alternate_symbol, alternate_symbol);
 587                               if combinations = 0
 588                               then do;
 589                                    recovery_method = method;
 590                                    transit = alternate_symbol;
 591                               end;
 592                               combinations = combinations + 1;
 593                          end;
 594                     end;
 595                end;
 596                if dpda.v1 (current_table + 1) = -2
 597                then do;
 598                     current_table = dpda.v2 (current_table + 1);
 599                     go to search_table;
 600                end;
 601                return;
 602           end try_alternatives;
 603      end local_recovered;
 604 ^L
 605 skip_recovery: proc;
 606 
 607 /*
 608    ^O       Skip recovery requires that the user define one or more  recovery
 609    ^O       terminal symbols by means of the
 610    ^O
 611    ^O                           -recover <nil> st1 st2 ...
 612    ^O
 613    ^O       control included in the  lalr  source.  st1  st2  etc.  are  skip
 614    ^O       terminals.  They  are  terminals  which  can end statements. They
 615    ^O       cause a table to be built for skip recovery. This table is a list
 616    ^O       of  read  and look ahead states which can follow the reading of a
 617    ^O       skip terminal or can be the first state to read a terminal. These
 618    ^O       states correspond to the beginnings of new statements.
 619    ^O
 620    ^O       Skip recovery is done  when  an  error  has  occurred  and  local
 621    ^O       recovery  (if used) was not successful. Basically what it does is
 622    ^O       to skip forward in the source by calling  the  scanner  until  it
 623    ^O       encounters  one of the skip terminals. It then looks backwards in
 624    ^O       the parse stack for a read state or a  state  applying  an  empty
 625    ^O       production which could have followed a state that read a previous
 626    ^O       occurrence of the skip symbol just found. If  one  is  found,  it
 627    ^O       tentatively  adjusts  the  lexical  stack  top (which is also the
 628    ^O       parse stack top) and then proceeds with a  trial  parse.  If  the
 629    ^O       path  from  the  state which could have read the skip terminal to
 630    ^O       the read or empty apply state found above has a sequence of  look
 631    ^O       ahead states (with no intervening non-empty apply states) leading
 632    ^O       to its ending state, the trial parse starts in the first of these
 633    ^O       look  ahead  states,  otherwise  it  starts  in the path's ending
 634    ^O       state.
 635    ^O
 636    ^O       Effectively a bad "statement" has been discarded.  In  this  case
 637    ^O       "statement" means an input string ending in a skip terminal which
 638    ^O       could have followed the _^Hi_^Hd_^He_^Hn_^Ht_^Hi_^Hc_^Ha_^Hl skip terminal (such as ";"  for
 639    ^O       example).  It includes the boundary terminal on the right. If the
 640    ^O       language  is  such  that  the  discarded  statement  is  optional
 641    ^O       (syntactically)  the  rest of the input can be checked for syntax
 642    ^O       errors. Note that two identical statements  need  not  be  parsed
 643    ^O       beginning  in  the same read state; e.g., the first of a sequence
 644    ^O       of statements could be parsed beginning in one read  state  while
 645    ^O       the  remaining statements could be parsed beginning in some other
 646    ^O       read state.
 647    ^O
 648    ^O       When a bad "statement" is discarded the parser  is  restarted  in
 649    ^O       the  state  in  which  it began to process that statement. If the
 650    ^O       next N input symbols encountered are  not  acceptable  from  this
 651    ^O       state,  the  parser  makes  another  attempt at error recovery by
 652    ^O       replacing the bad "statement" with the <nil>  symbol  defined  by
 653    ^O       the  -recover control and starting a second trial parse from this
 654    ^O       symbol. If neither trial parse is able to accept the next N input
 655    ^O       symbols  and  M pairs of trial parses have not yet been attempted
 656    ^O       for the current symbol, skip recovery looks further  backward  in
 657    ^O       the  parse  stack  for  a  different  read state which could have
 658    ^O       followed a state that read  a  previous  occurence  of  the  skip
 659    ^O       symbol  found  above.  The  trial parsing described above is then
 660    ^O       repeated.^L
 661    ^O       If none of the trial parses is able to accept the  next  N  input
 662    ^O       symbols  or  all  states  on  the parse stack are exhausted, skip
 663    ^O       recovery starts over without having made  an  adjustment  to  the
 664    ^O       stacks.  To  appreciate the effect of looking deeper in the parse
 665    ^O       stack consider the situation where the first trial parse attempts
 666    ^O       to  accept  a  <simple statement> and fails. Now assume M > 1 and
 667    ^O       the second trial parse attempts to accept a <compound statement>.
 668    ^O       It  is possible to obtain better recoverys with M = 2 than with M
 669    ^O       = 1 when such situations can occur. When one of the trial  parses
 670    ^O       accepts  the  next  N  input symbols, the lexical and parse stack
 671    ^O       adjustment is made final and normal parsing resumes.
 672    ^O
 673    ^O       Before starting the recovery process described above  the  parser
 674    ^O       pushes  the  current  state,  or  a read state following it if it
 675    ^O       makes only look transitions, onto the parse  stack.  This  serves
 676    ^O       two purposes. First, it ensures that the parse can restart in the
 677    ^O       current state when the error occurs  on  a  terminal  immediately
 678    ^O       following  a skip terminal. Second, it allows skip recovery to be
 679    ^O       done when the parse fails before reading any terminals.
 680    ^O
 681    ^O       The <nil> symbol is one which the scanner must NEVER  return.  It
 682    ^O       is  needed  because some languages do not allow all statements to
 683    ^O       occur at every point. This means that when you  back  up  to  the
 684    ^O       last  statement  beginning  point, you may not be allowed to have
 685    ^O       the statement you find next. As an example, take this grammar:
 686    ^O
 687    ^O            <g> ::= <i> | <g> <i> !
 688    ^O            <i> ::= <a> | <b> !
 689    ^O            <a> ::= a ; <rd> !
 690    ^O            <rd> ::= r ; | <rd> r ; !
 691    ^O            <b> ::= b ; <sd> !
 692    ^O            <sd> ::= s ; | <sd> s ; !
 693    ^O
 694    ^O       Then suppose that you intended to have an  input  like  line  (1)
 695    ^O       below, but instead you got (2):
 696    ^O
 697    ^O                 (1) a ; r ; r ; b ; s ; s ; s ; a ; r ; r ; r ;
 698    ^O                 (2) a ; r ; r ; b ; s ; s ; s   a ; r ; r ; r ;
 699    ^O
 700    ^O       Suppose that the grammar had specified
 701    ^O
 702    ^O                                     -recover <nil> ;
 703    ^O
 704    ^O       and local  recovery  is  not  used.  When  the  "s"  "a"  ";"  is
 705    ^O       encountered,  skip  recovery  will discard it as a bad statement.
 706    ^O       But this then means that it will miss the fact that it should  be
 707    ^O       entering the <a> rule. It will then get to the "r" but the parser
 708    ^O       will have restarted in a state which can read either an "a", "b",
 709    ^O       or  "s". So it will have to skip again. In this example, skipping
 710    ^O       will occur, one statement at a time, until EOI is  reached.  This
 711    ^O       means  that  no syntax checking is done in all of the "r" s which
 712    ^O       are skipped. This is not highly desireable.^L   ^O
 713    ^O       However, if you add a rule like this:
 714    ^O
 715    ^O            <a> ::= <nil> <rd> !
 716    ^O
 717    ^O       then the generated <nil> from skip recovery will allow  the  <rd>
 718    ^O       to  be  correctly  parsed,  reducing  the number of useless error
 719    ^O       messages by quite a bit, usually.
 720    ^O
 721    ^O       These <nil> rules can help parse thru misplaced statements during
 722    ^O       error  recovery,  but  will  never  accept these statements under
 723    ^O       normal circumstances. The semantics on these <nil>  rules  should
 724    ^O       then report an error.
 725 */
 726 ^L
 727 dcl  c                             fixed bin;               /* Terminal symbol encoding of the last symbol skipped. */
 728 dcl  (i, ii)                       fixed bin;
 729 dcl  (j, jj)                       fixed bin;
 730 dcl  k                             fixed bin;
 731 dcl  lookahead_get2                fixed bin;               /* lookahead index of the next symbol to be read. */
 732 dcl  lookahead_last                fixed bin;               /* lookahead index of the last symbol skipped. */
 733 
 734           skip_recoveries = skip_recoveries + 1;
 735           if parse_stack_top >= hbound (parse_stack, 1) then
 736                call parse_stack_overflow;
 737           parse_stack_top = parse_stack_top + 1;
 738           parse_stack (parse_stack_top) = current_state;
 739           unspec (stk (parse_stack_top)) = unspec (lookahead (lookahead_get));
 740           call set_line_id (lookahead_get, "FATAL");
 741           recov_msg = recov_msg || get_terminal (lookahead_get);
 742           recov_msg = recov_msg || " appears out of context";
 743           if lookahead.symbol (lookahead_get) = 0 then
 744                go to assume_final_state;
 745           recov_msg = recov_msg || ".  Skipped";
 746           if db_sw
 747           then do i = parse_stack_top by -1 while (i > 0);
 748                call ioa_$nnl ("@ps (^2i) ^4i^/", i, parse_stack (i));
 749           end;
 750           c = lookahead.symbol (lookahead_get);
 751           do while (c ^= 0);
 752                if lookahead_count <= 0                      /* If lookahead stack is empty, get a symbol. */
 753                then do;
 754                     call scanner;
 755                     if lookahead_put = lbound (lookahead, 1) then
 756                          lookahead_put = 0;
 757                     lookahead_put = lookahead_put - 1;
 758                     lookahead_count = 1;
 759                end;
 760                c = lookahead.symbol (lookahead_get);
 761                if db_sw then
 762                     call ioa_$nnl ("@          SKIP  ^a^/", get_terminal (lookahead_get));
 763                unspec (lookahead (0)) = unspec (lookahead (lookahead_get)); /* Save the symbol just skipped. */
 764                lookahead.symbol (lookahead_get) = nil_symbol; /* Change last symbol skipped into a nil symbol. */
 765                lookahead.symlen (lookahead_get) = 0;
 766                lookahead_last = lookahead_get;
 767                if lookahead_get = lbound (lookahead, 1) then
 768                     lookahead_get = 0;
 769                lookahead_get = lookahead_get - 1;
 770                lookahead_count = lookahead_count - 1;
 771                do i = 3 to 1 + skip.v2 (1);
 772                     if skip.v1 (i) = c
 773                     then do;
 774                          jj = skip.v2 (i);
 775                          do j = parse_stack_top to 1 by -1;
 776                               do ii = jj + 1 to jj + skip.v2 (jj);
 777                                    if skip.v1 (ii) = parse_stack (j)
 778                                    then do;
 779 new_trial_parse:
 780                                         lookahead_get2 = lookahead_get;
 781                                         current_state = skip.v2 (ii);
 782                                         call trial_parse (j - 1, lookahead_get2, 2);
 783                                         if read_count < 2
 784                                         then do;
 785                                                             /* Back up to the nil symbol in the lookahead stack. */
 786                                              lookahead_count = lookahead_count + 1;
 787                                              lookahead_get2 = lookahead_last;
 788                                              call trial_parse (j - 1, lookahead_get2, 2);
 789                                         end;
 790 
 791                                         if read_count >= 2
 792                                         then do;
 793                                              if db_sw
 794                                              then do;
 795                                                   call ioa_$nnl ("@    ^4d  ADJ   sd = ^d ",
 796                                                        parse_stack_top, parse_stack_top - j + 1);
 797                                                   if parse_stack_top > j
 798                                                   then do;
 799                                                        db_separator = "(";
 800                                                        do jj = parse_stack_top to j by -1;
 801                                                             call ioa_$nnl ("^1a^d", db_separator, parse_stack (jj));
 802                                                             db_separator = "";
 803                                                        end;
 804                                                        call ioa_$nnl (")");
 805                                                   end;
 806                                                   call ioa_$nnl ("^/");
 807                                              end;
 808                                              parse_stack_top = j - 1;
 809                                              lookahead_get = lookahead_get2;
 810                                              recov_msg = recov_msg || " from ";
 811                                              recov_msg = recov_msg || get_terminal (j);
 812                                              recov_msg = recov_msg || " on ";
 813                                              call append_line_id (j);
 814                                              recov_msg = recov_msg || " to ";
 815                                              recov_msg = recov_msg || get_terminal (zero);
 816                                              if c ^= 0
 817                                              then do;
 818                                                   recov_msg = recov_msg || " on ";
 819                                                   call append_line_id (zero);
 820                                              end;
 821                                              go to skip_exit;
 822                                         end;
 823                                    end;
 824                               end;
 825                          end;
 826                     end;
 827                end;
 828           end;
 829           recov_msg = recov_msg || " to end-of-information";
 830 assume_final_state:
 831           current_state = 0;
 832 skip_exit:
 833           recov_msg = recov_msg || ".";
 834           return;
 835      end skip_recovery;
 836 ^L
 837 trial_parse: proc (parse_stack_top_parameter, lookahead_get_parameter, read_limit);
 838 dcl  current_table                 fixed bin;
 839 dcl  i                             fixed bin;
 840 dcl  lookahead_get                 fixed bin init (lookahead_get_parameter);
 841 dcl  lookahead_get_parameter       fixed bin parameter;
 842 dcl  parse_stack_top               fixed bin init (parse_stack_top_parameter);
 843 dcl  parse_stack_top_parameter     fixed bin parameter;
 844 dcl  read_limit                    fixed bin parameter;
 845 dcl  trial_current_state           fixed bin init (current_state);
 846           parse_stack2 = parse_stack;
 847           read_count = 0;
 848 NEXT:
 849           if trial_current_state = 0
 850           then do;
 851                read_count = read_limit;
 852                return;
 853           end;
 854           db_item = "\";
 855           db_data.state = trial_current_state;
 856           db_data.top = parse_stack_top;
 857           current_table = trial_current_state;
 858           go to CASE (dpda.v1 (trial_current_state));
 859 
 860 CASE (2):                                                   /* Read and stack and/or lookahead 1 (sometimes called
 861                                                                read without stacking) with shared transition table.
 862                                                                (Read transitions to state S are coded as +S while
 863                                                                lookahead transitions to state S are coded -S.) */
 864 CASE (10):                                                  /* Obsolete -- Lookahead 1 (sometimes called read without
 865                                                                stacking) with shared transition table. */
 866           current_table = dpda.v2 (trial_current_state);
 867 CASE (0):                                                   /* Read and stack and/or lookahead 1 with neither a
 868                                                                default transition nor a marked symbol transition. */
 869 CASE (9):                                                   /* Obsolete -- Lookahead 1 (sometimes called
 870                                                                read without stacking). */
 871 CASE (15):                                                  /* Read and stack and/or lookahead 1 with
 872                                                                a default transition. */
 873 CASE (17):                                                  /* Read and stack and/or lookahead 1 with the table
 874                                                                continued at another state. */
 875 
 876 /* Make sure enough symbols are available. */
 877           do while (lookahead_count <= read_count);
 878                call scanner;
 879                if lookahead_put = lbound (lookahead, 1) then
 880                     lookahead_put = 0;
 881                lookahead_put = lookahead_put - 1;
 882                lookahead_count = lookahead_count + 1;
 883           end;
 884           test_symbol = lookahead.symbol (lookahead_get);
 885 search_table:
 886                                                             /* Look current symbol up in the read list. */
 887           lb = current_table + 1;
 888           ub = current_table + dpda.v2 (current_table);
 889           do while (lb <= ub);
 890                i = divide (ub + lb, 2, 17, 0);
 891                if dpda.v1 (i) = test_symbol
 892                then do;
 893                     next_state = dpda.v2 (i);
 894                     go to got_symbol;
 895                end;
 896                else if dpda.v1 (i) < test_symbol then
 897                     lb = i + 1;
 898                else ub = i - 1;
 899           end;
 900           if dpda.v1 (current_table + 1) < 0 then
 901                if dpda.v1 (current_table + 1) = -1
 902                then do;
 903                     trial_current_state = -dpda.v2 (current_table + 1);
 904                     if db_sw
 905                     then do;
 906                          db_data.type = "LK01D";
 907                          db_data.data = get_terminal (lookahead_get);
 908                          call ioa_$nnl ("^a^/", db_item);
 909                     end;
 910                     go to NEXT;
 911                end;
 912                else do;
 913                     current_table = dpda.v2 (current_table + 1);
 914                     go to search_table;
 915                end;
 916           return;
 917 
 918 got_symbol:
 919           if db_sw
 920           then do;
 921                if next_state < 0                            /* Is this a lookahead state? */
 922                then do;
 923                     db_data.type = "LK01";
 924                end;
 925                else db_data.type = "READ";
 926                db_data.data = get_terminal (lookahead_get);
 927                call ioa_$nnl ("^a^/", db_item);
 928           end;
 929           if next_state < 0
 930           then do;                                          /* This is a lookahead transition. */
 931                trial_current_state = -next_state;
 932                go to NEXT;
 933           end;
 934           else do;                                          /* This is a read transition. */
 935                read_count = read_count + 1;
 936                if read_count < read_limit
 937                then do;
 938                     if parse_stack_top >= hbound (stk, 1) then
 939                          call parse_stack_overflow;
 940                     parse_stack_top = parse_stack_top + 1;
 941                                                             /* Stack the current state. */
 942                     parse_stack2 (parse_stack_top) = trial_current_state;
 943                     if lookahead_get = lbound (lookahead, 1) then
 944                          lookahead_get = 0;
 945                     lookahead_get = lookahead_get - 1;
 946                     trial_current_state = next_state;
 947                     go to NEXT;
 948                end;
 949                return;
 950           end;
 951 
 952 CASE (3):                                                   /* Multiple lookahead (k > 1) with shared look table. */
 953 CASE (1):                                                   /* Multiple lookahead (k > 1) without default transition. */
 954 CASE (14):                                                  /* Multiple lookahead (k > 1) with default transition. */
 955 CASE (16):                                                  /* Multiple lookahead (k > 1) continued at another state. */
 956 
 957 CASE (7):                                                   /* Obsolete state type -- Skip table */
 958 CASE (8):                                                   /* Obsolete state type -- Skip recovery adjust table */
 959 
 960 CASE (4):                                                   /* Apply by rule and alternative with lookback table. */
 961 CASE (5):                                                   /* Apply by rule and alternative without lookback. */
 962 CASE (6):                                                   /* Apply by rule and alternative with shared lookback table. */
 963 
 964 CASE (18):                                                  /* Apply by rule with lookback table. */
 965 CASE (19):                                                  /* Apply by rule without lookback. */
 966 CASE (20):                                                  /* Apply by rule with shared lookback table. */
 967           go to unrecognized_dpda_state;
 968 
 969 CASE (13):                                                  /* Apply by production with shared lookback table. */
 970           current_table = dpda.v2 (trial_current_state + 2);
 971 CASE (11):                                                  /* Apply by production with lookback table. */
 972 CASE (12):                                                  /* Apply by production without lookback. */
 973           production_number = dpda.v1 (trial_current_state + 2);
 974 
 975           if db_sw
 976           then do;
 977                db_data.type = "APLY";
 978                db_data.data = "(";
 979                call ioa_$nnl ("^a^i", db_item, production_number);
 980                call print_production_name (production_number);
 981                call ioa_$nnl (")^-sd = ^i ", dpda.v1 (trial_current_state + 1));
 982                if dpda.v1 (trial_current_state + 1) > 0
 983                then do;
 984                     db_separator = "(";
 985                     do t = parse_stack_top to parse_stack_top - dpda.v1 (trial_current_state + 1) + 1 by -1;
 986                          call ioa_$nnl ("^1a^d", db_separator, parse_stack (t));
 987                          db_separator = "";
 988                     end;
 989                     call ioa_$nnl (")");
 990                end;
 991                call ioa_$nnl ("^/");
 992           end;
 993                                                             /* Check for an apply of an empty production.
 994                                                                In this case the apply state number must be
 995                                                                pushed onto the parse stack.  (Reference
 996                                                                LaLonde, W. R.:  An efficient LALR Parser Generator.
 997                                                                Tech. Report CSRG-2, 1971, pp. 34-35.) */
 998           if dpda.v1 (trial_current_state + 1) < 0
 999           then do;
1000                if parse_stack_top >= hbound (parse_stack2, 1) then
1001                     call parse_stack_overflow;
1002                parse_stack2 (parse_stack_top + 1) = trial_current_state;
1003           end;
1004           parse_stack_top = parse_stack_top - dpda.v1 (trial_current_state + 1);
1005           if parse_stack_top > 0
1006           then do;
1007                do i = current_table + 3 to current_table + dpda.v2 (current_table);
1008                     if dpda.v1 (i) = parse_stack2 (parse_stack_top)
1009                     then do;
1010                          trial_current_state = dpda.v2 (i);
1011                          go to NEXT;
1012                     end;
1013                end;
1014                trial_current_state = dpda.v2 (current_table + 2);
1015                go to NEXT;
1016           end;
1017           return;
1018      end trial_parse;
1019 ^L
1020 get_terminal: proc (stk_index) returns (char (100) varying);
1021 
1022 dcl  stk_index                     fixed bin parameter;
1023 dcl  alphanumeric                  (0:511) bit (1) unaligned internal static options (constant) init (
1024                                    (32) (1)"0"b,            /* control characters */
1025                                    (4) (1)"0"b,             /* SP ! " # */
1026                                    "1"b,                    /* $ */
1027                                    (11) (1)"0"b,            /* % & ' ( ) * + , - . / */
1028                                    (10) (1)"1"b,            /* digits */
1029                                    (7) (1)"0"b,             /* :; < = > ? @ */
1030                                    (26) (1)"1"b,            /* upper case letters */
1031                                    (4) (1)"0"b,             /* [ \ ] ^ */
1032                                    "1"b,                    /* underscore */
1033                                    "0"b,                    /* ` */
1034                                    (26) (1)"1"b,            /* lower case letters */
1035                                    (5) (1)"0"b,             /* { | } ~ DEL */
1036                                    (384) (1)"0"b);          /* rest of 9-bit ASCII code set */
1037 dcl  temp                          char (100) varying;
1038 dcl  (length, min, rank, substr)   builtin;
1039 
1040           if stk.symbol (stk_index) = 0 then
1041                return ("end-of-information");
1042           else begin;
1043 dcl  symbol                        char (min (50, stk.symlen (stk_index))) based (stk.symptr (stk_index));
1044 dcl  terminal                      char (terminals_list.length (stk.symbol (stk_index)))
1045                                    defined (terminal_characters) position (terminals_list.position (stk.symbol (stk_index)));
1046                if length (terminal) > 2
1047                     & substr (terminal, 1, 1) = "<"
1048                     & substr (terminal, length (terminal), 1) = ">"
1049                then do;
1050                     temp = substr (terminal, 2, length (terminal) - 2);
1051                     if length (symbol) > 0
1052                     then do;
1053                          temp = temp || " ";
1054                          if substr (symbol, 1, 1) = """" | substr (symbol, 1, 1) = "'" then
1055                               temp = temp || symbol;
1056                          else do;
1057                               temp = temp || """";
1058                               temp = temp || symbol;
1059                               temp = temp || """";
1060                          end;
1061                     end;
1062                end;
1063                else if alphanumeric (rank (substr (terminal, 1, 1)))
1064                then do;
1065                     temp = "reserved word """;
1066                     if length (symbol) > 0 then
1067                          temp = temp || symbol;
1068                     else temp = temp || terminal;
1069                     temp = temp || """";
1070                end;
1071                else do;
1072                     temp = "operator symbol """;
1073                     temp = temp || terminal;
1074                     temp = temp || """";
1075                end;
1076                return (temp);
1077           end;
1078      end get_terminal;
1079 ^L
1080 print_production_name: proc (production_name_index);
1081 dcl  production_name_index         fixed bin parameter;
1082 dcl  variables_list_index          fixed bin;
1083 
1084           if production_names_size > 0
1085           then do;
1086                variables_list_index = -production_names (abs (production_name_index));
1087                begin;
1088 dcl  production_name               char (variables_list.length (variables_list_index))
1089                                    defined (variable_characters) position (variables_list.position (variables_list_index));
1090                     call ioa_$nnl (" ^a", production_name);
1091                end;
1092           end;
1093           return;
1094      end print_production_name;
1095 ^L
1096 %include lalr_grammar_scanner_;
1097 %page;
1098 %include lalr_grammar_semantics_;
1099 %page;
1100 parse_stack_overflow: proc;
1101 dcl  ltrim                         builtin;
1102 dcl  omega                         picture "zzzzz9";
1103           omega = hbound (stk, 1);
1104           call set_line_id (lookahead_get, "FATAL");
1105           recov_msg = recov_msg || "exceeded ";
1106           recov_msg = recov_msg || ltrim (omega);
1107           recov_msg = recov_msg || " entries of the parser's lexical/parse stack.  Parser cannot continue.";
1108           call lalr_print_ (static_data_ptr, "Un", "n", recov_msg);
1109           code = lalr_error_table_$parser_stack_overflow;
1110           go to parse_done;
1111      end parse_stack_overflow;
1112 
1113 
1114 append_line_id: proc (lookahead_use);
1115 
1116 dcl  lookahead_use                 fixed bin parameter;
1117 dcl  omega                         picture "------";
1118 dcl  setting_line_id               bit (1);
1119 dcl  severity                      char (*) parameter;
1120 
1121 dcl  ltrim                         builtin;
1122 
1123           recov_msg = recov_msg || "line ";
1124           setting_line_id = "0"b;
1125           go to append_line_number;
1126 set_line_id: entry (lookahead_use, severity);
1127           recov_msg = severity;
1128           recov_msg = recov_msg || " error on line ";
1129           setting_line_id = "1"b;
1130 append_line_number:
1131           if stk.file (lookahead_use) ^= 0
1132           then do;
1133                omega = stk.file (lookahead_use);
1134                recov_msg = recov_msg || ltrim (omega);
1135                recov_msg = recov_msg || "-";
1136           end;
1137           omega = stk.line (lookahead_use);
1138           recov_msg = recov_msg || ltrim (omega);
1139           if setting_line_id then
1140                recov_msg = recov_msg || ": ";
1141           return;
1142      end append_line_id;
1143 %page;
1144      end lalr_grammar_parser_;