1 
  2 
  3 
  4 dcl  fail_ct fixed bin init(0);
  5 dcl  db_sw bit (1) internal static init ("0"b);
  6 
  7 mrpg_parse_:       proc();
  8 
  9 /* Parser for tables created by LRK. */
 10 
 11 
 12           ps_max = 0;
 13 dcl ps_max fixed bin int static;
 14           report_sw = "0"b;
 15           begin_ct = 0;
 16           beginptr = null();
 17           sort_list.b, sort_list.e = null();
 18           hold_list.b, hold_list.e = null();
 19           depth = 0;
 20           stmtlistptr = addr(tree.exec);
 21           if_nest = 0;
 22           hold_ct = 0;
 23 
 24           current_state = 1;
 25 
 26           nil_sym = -1;       /* set nil_sym non-existant */
 27 
 28           ls_top, ps_top = 0;
 29           la_put, la_get = 1;
 30 
 31           err_ct = 0;
 32 
 33           la_ct = 0;
 34 
 35                                                             /* The parsing loop. */
 36 NEXT:
 37           if (current_state = 0)
 38           then do;
 39 done_parse:
 40 /*             call ioa_("ps_max = ^i",ps_max);*/
 41                return;
 42           end;
 43           current_table = current_state;
 44 
 45           string(db_data) = "";
 46           db_data.state = current_state;
 47 
 48 (subscriptrange):
 49 TRY_AGAIN:
 50           goto CASE (DPDA.v1(current_table));
 51 
 52 CASE (3): /* Shared look */   /* . . . */
 53           current_table = DPDA.v2(current_table);
 54 CASE (1): /* Look. */         /* . . . */
 55           db_data.type = "LOOK";
 56           la_use = mod(la_get+la_need-1,-lbound(lstk,1))+1;
 57           if (la_need = -lbound(lstk,1))
 58           then signal condition(lastk_ovflo);
 59 dcl  lastk_ovflo condition;
 60           la_need = la_need + 1;
 61           goto read_look;
 62 
 63 CASE (10):          /* Shared read */   /* . . . */
 64           current_table = DPDA.v2(current_table);
 65 
 66 CASE (9): /* Read. */         /* . . . */
 67 
 68           db_data.type = "READ";
 69           db_data.sl = ls_top+1;
 70 
 71           la_need = 1;
 72           la_use = la_get;
 73           goto read_look;
 74 
 75 CASE (2): /* Stack and Shared read */   /* . . . */
 76           current_table = DPDA.v2(current_table);
 77 
 78 CASE (0): /* Stack and Read. */         /* . . . */
 79 
 80           db_data.type = "READ";
 81           db_data.sl = ls_top+1;
 82           db_data.flag = "*";
 83 
 84           la_need = 1;
 85           la_use = la_get;
 86           if (ps_top = hbound(parse_stack,1))
 87           then signal condition(pstk_ovflo);
 88 dcl  pstk_ovflo condition;
 89           ps_top = ps_top+1;  /* Top of  parsing stack. */
 90           ps_max = max(ps_max,ps_top);
 91           parse_stack (ps_top) = current_state;   /* Stack the current state. */
 92           cur_lex_top (ps_top) = ls_top;         /* save current lex top (for recovery) */
 93 read_look:
 94           do while(la_ct < la_need);    /* make sure enough symbols are available */
 95                call scanner ();
 96                la_put = mod(la_put,-lbound(lstk,1))+1;
 97                la_ct = la_ct + 1;
 98           end;
 99           test_symbol = lstk.symbol(-la_use);
100 
101           m = 0;
102           do i = current_table+1 to current_table+DPDA.v2(current_table);
103                n = DPDA.v1(i);
104               if (n < 0)
105                then           n,m = -n;
106                if (n = test_symbol)
107                then do;
108                     next_state = DPDA.v2(i);
109                     goto got_symbol;
110                end;
111           end;
112 
113 
114           if (test_symbol = nil_sym)    /* if bad symbol was a generated one */
115           then do;
116                     la_get = mod(la_get,-lbound(lstk,1))+1;     /* ...drop it and try again */
117                     la_ct = la_ct - 1;
118                     goto read_look;
119           end;
120 
121 
122           if (m > 0)          /* if marked symbol was in table, use it */
123           then do;
124                next_state = DPDA.v2(m);
125                goto got_symbol;
126           end;
127 
128 
129 
130           if (err_ct <= 4)   /* max_recover * 2 */
131           then do;
132                if local_recovered()
133                then do;
134                     if (db_data.flag = "*")
135                     then ps_top = ps_top - 1;
136                     goto TRY_AGAIN;
137                end;
138 
139 
140 
141                if skip_recovered()
142                then do;
143                     call mrpg_error_(2,0,"^a",recov_msg);
144                     goto NEXT;
145                end;
146 
147 
148                if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^4i  ",current_state);
149 
150                call mrpg_error_(2,(lstk(-la_use).line),"Parse failed, symbol ^a", geterm(test_symbol,(la_use)));
151                fail_ct = fail_ct + 1;
152                if (fail_ct > 5)
153                then call mrpg_error_(3,0,"Parse recovery terminated.");
154                call mrpg_error_(0,0,"Symbol being dropped.");
155                goto retry;
156 
157           end;
158 
159 
160 got_symbol:
161 
162           err_ct = max(err_ct-1,0);
163 
164 
165           if db_sw
166           then do;
167                if (next_state < 0) /* is this a look-ahead state? */
168                then do;
169                     db_data.type = "LK01";
170                     db_data.sl = 0;
171                     db_look = la_need;
172                     db_data.data =       geterm(test_symbol,0);/* display only terminal "name" on look-ahead */
173                     db_data.flag = " ";
174                end;
175                else do;
176                     db_data.data =  getermc(test_symbol,la_get);      /* display terminal "name" and data, if available */
177                end;
178                call ioa_$ioa_switch_nnl(iox_$user_output,"^a^/",string(db_data));
179           end;
180 
181           current_state = next_state;
182           if (current_state < 0) then do;         /* Transition is a look-ahead state. */
183                current_state = -current_state;
184           end;
185           else do;
186 retry:
187                if (ls_top = hbound(lstk,1))
188                then signal condition(lstk_ovflo);
189 dcl  lstk_ovflo condition;
190                ls_top = ls_top + 1;
191                lstk(ls_top) = lstk(-la_get);
192                la_get = mod(la_get,-lbound(lstk,1)) + 1;
193                la_ct = la_ct - 1;
194           end;
195           goto NEXT;
196 
197 CASE (4): /* Apply state. */  /* . . . */
198 CASE (5): /* Apply single */  /* . . . */
199 CASE (6): /* Apply Shared */  /* . . . */
200           la_need = 1;
201           rulen = DPDA.v1(current_table+2);
202           altn = DPDA.v2(current_table+2);
203 
204                if db_sw
205           then do;
206                db_data.type = "APLY";
207                db_data.data = "(";
208                call ioa_$ioa_switch_nnl(iox_$user_output,"^a^i ^i)",string(db_data),rulen,altn);
209           end;
210 
211           if (rulen ^= 0)
212           then substr(used,abs(rulen),1) = "1"b;
213           if (rulen > 0) then do;
214                call semantics (rulen,altn);
215           end;
216 
217           if db_sw
218           then do;
219                t = ls_top - DPDA.v2(current_table+1);
220                call ioa_$ioa_switch_nnl(iox_$user_output," ^2i-^2a",t,substr(dt_s(lstk.datype(t)),1,2));
221                call ioa_$ioa_switch_nnl(iox_$user_output,"^-pd=^i ld=^i("
222                     ,DPDA.v1(current_table+1),DPDA.v2(current_table+1));
223                do t = ps_top to ps_top-DPDA.v1(current_table+1)+1 by -1;
224                     call ioa_$ioa_switch_nnl(iox_$user_output," ^d",parse_stack (t));
225                end;
226                call ioa_$ioa_switch_nnl(iox_$user_output,")^/");
227           end;
228 /**       Check for an apply of an empty production.
229           In this case the apply state number must be
230           pushed on the parse stack. (Reference
231           LaLonde, W. R.:  An Efficient LALR Parser Generator.
232           Tech. Report CSRG-2, 1971, pp. 34-35.)  **/
233           if DPDA.v1 (current_state+1) = -1 then do;
234                if (ps_top = hbound (parse_stack, 1))
235                then signal condition (pstk_ovflo);
236                parse_stack (ps_top+1) = current_state;
237           end;
238 
239           ps_top = ps_top - DPDA.v1(current_table+1);       /* Delete parse stack states. */
240           ls_top = ls_top - DPDA.v2(current_table+1);     /* delete lex stack states */
241           if (DPDA.v1(current_state) = 5)
242           then do;
243                current_state = DPDA.v2(current_table+3);
244                goto NEXT;
245           end;
246           if (DPDA.v1(current_state) = 6)
247           then do;
248                current_table = DPDA.v2(current_table+3);
249           end;
250           do i = current_table+4 to current_table+DPDA.v2(current_table);
251                if (DPDA.v1 (i) = parse_stack(ps_top))
252                then do;
253                     current_state = DPDA.v2(i);
254                     goto NEXT;
255                end;
256           end;
257           current_state = DPDA.v2(current_table+3);
258           goto NEXT;
259 
260 
261 
262 skip_recovered: proc returns (bit (1));
263 
264 dcl  (i,ii) fixed bin (24);
265 dcl  (j,jj) fixed bin (24);
266 dcl  c fixed bin (24);
267 dcl  dec4 pic "---9";
268 
269           if (DPDA.v1 (DPDAsize+1) ^= 1)                    /* no skip table */
270           then return ("0"b);
271           current_table = DPDAsize + 2;
272           dec4 = lstk (-la_get).line;
273           recov_msg = "LINE ";
274           recov_msg = recov_msg || dec4;
275           recov_msg = recov_msg || ". Unuseable token ";
276           recov_msg = recov_msg || geterm (test_symbol,la_get);
277           recov_msg = recov_msg || ".
278          Skipped to ";
279           nil_sym = DPDA.v1(current_table+1);
280           c = 1;
281           do while (c ^= 0);
282                if (la_ct = 0) then do;  /* if look-ahead stack is empty, get a symbol */
283                     call scanner ();
284                     la_put = mod(la_put,-lbound(lstk,1))+1;
285                     la_ct = 1;
286                end;
287                c = lstk.symbol (-la_get);
288                do i = current_table+2 to current_table+DPDA.v2(current_table);
289                     if (DPDA.v1 (i) = c)
290                     then do;
291                          jj = DPDA.v2(i);
292                          do j = ps_top to 1 by -1;
293                               do ii = jj+1 to jj + DPDA.v2(jj);
294                                    if (DPDA.v1(ii) = parse_stack (j))
295                                    then do;
296                                         ps_top = j-1;
297                                         ls_top = cur_lex_top (j);
298                                         current_state = DPDA.v1(ii);
299                                         recov_msg = recov_msg || geterm (c,0);
300                                         recov_msg = recov_msg || " on line ";
301                                         dec4 = lstk (-la_get).line;
302                                         recov_msg = recov_msg || dec4;
303                                                             /* generate a nil symbol into the look-ahead stack */
304                                         lstk(-la_get).symlen = 0;
305                                         lstk(-la_get).symbol = nil_sym;
306                                         return ("1"b);
307                                    end;
308                               end;
309                          end;
310                     end;
311                end;
312                la_get = mod(la_get,-lbound(lstk,1))+1;
313                la_ct = la_ct - 1;
314           end;
315           recov_msg = recov_msg || " EOI.";
316           current_state = 0;
317           return ("1"b);
318      end;
319 
320 
321 
322 dcl  (addr, mod,  fixed) builtin;
323 dcl  db_look pic "99" defined(db_data.type ) pos(3);
324 dcl  1 db_data,
325      2 flag char(1),          /* * means stacked */
326      2 state pic "zzz9",
327      2 fil1 char(1),
328      2 sl pic "zz",
329      2 fil2 char(1),
330      2 type char(6),
331      2 data char(100);
332 dcl  DDop(-1:2) char(4)int static init("LOOK","FINI","READ","ERR");
333 dcl  ioa_$ioa_switch_nnl      entry options(variable);
334 dcl  iox_$user_output         ptr ext static;
335 
336 dcl  1 lstk(-8:200)
337                                                             /* -8:-1 is the look-ahead stack (FIFO) */
338                                                             /* 1:200 is the lexical stack (LIFO) */
339      , 2 symptr ptr                                          /* pointer to symbol (must be valid) */
340      ,2  symlen fixed bin (24)                               /* length of symbol (may be 0) */
341      ,2  line fixed bin (24)                                 /* line where symbol begins */
342      ,2  symbol fixed bin (24)                                          /* encoding of symbol */
343      ,2  datype fixed bin                                   /* 1-BOOL, 2-CHAR, 3-ARITH */
344      ,2  node_ptr ptr
345      ,2  val fixed bin (24)
346      ,2  bchar fixed bin (24)
347      ,2  echar fixed bin (24);
348 dcl  ls_top fixed bin(24);   /* location of top of lexical stack */
349 dcl  cur_lex_top (200) fixed bin (24) aligned;          /* current lex top stack (with parse_stack) */
350 dcl  parse_stack (200) fixed bin (24) aligned;          /* parse stack */
351 dcl  altn fixed bin(24);      /* APPLY alternative number */
352 dcl  current_state fixed bin (24);      /* number of current state */
353 dcl  test_symbol fixed bin (24);        /* encoding of current symbol */
354 dcl  current_table fixed bin (24);      /* number of current table */
355 dcl  i fixed bin(24);         /* temp */
356 dcl  la_ct          fixed bin(24);      /* number of terminals in look-ahead stack */
357 dcl  la_get         fixed bin(24);      /* location in look_ahead stack to get next symbol */
358 dcl  la_need        fixed bin(24);      /* number of look-ahead symbols needed */
359 dcl  la_put         fixed bin(24);      /* location in look_ahead stack to put next symbol */
360 dcl  la_use         fixed bin(22);      /* location in look-ahead stack to test with */
361 
362 dcl  (m,n) fixed bin(24);
363 
364 dcl  next_state fixed bin(24);          /* number of next state */
365 dcl  nil_sym        fixed bin(24);
366 dcl  ps_top fixed bin (24);   /* location of top of parse stack */
367 dcl  recov_msg      char(150)var;
368 dcl  rulen fixed bin(24);     /* APPLY rule number */
369 dcl  t fixed bin (24);
370 dcl  ioa_ entry options(variable);
371 
372 geterm:   proc(idx,ids) returns(char(100)var);
373 
374 dcl  (idx,ids)      fixed bin(24);
375 dcl  temp char(100)var;
376 dcl  i fixed bin;
377 dcl  c_str char(20000)based;
378 
379                temp = "";
380 get_rest:
381                if (ids > 0)
382                then if (lstk(-ids).symlen > 0)
383                then do;
384                     temp = temp || """";
385                     temp = temp ||  substr(lstk(-ids).symptr->c_str,1,min(50,lstk(-ids).symlen));
386                     temp = temp || """";
387                     i = lstk(-ids).symbol;
388                     if (i < 24) | (i > 116) | ((i > 102) & (i < 109))
389                     then return (temp);
390                     temp = temp || " (RESERVED WORD)";
391                     return(temp);
392                end;
393                if (idx = 0)
394                then temp = "--EOI--";
395                else temp = substr(TC,TL.pt(idx),TL.ln(idx));
396                return(temp);
397 
398 getermc:  entry(idx,ids)returns(char(100)var);
399 
400                if (idx = 0)
401                then temp = "--EOI--";
402                else temp = substr(TC,TL.pt(idx),TL.ln(idx));
403                temp = temp || " ";
404                goto get_rest;
405           end;
406 
407 dcl  err_ct         fixed bin(24);
408 
409 
410 
411 local_recovered:    proc returns(bit(1));
412 
413 /*
414 "    this procedure implements the LRK local error recovery (using
415 "    the  DPDA  table).  This  is  done by using the current (bad)
416 "    symbol and the next input symbol. All  possible  parses  from
417 "    this state are examined. These trial parses proceed until the
418 "    next read state is encountered. The  trial  parses  are  true
419 "    simulations  of  what  can  happen,  apply  states are chosen
420 "    according to the simulated top of parse stack.
421 
422 "    Given:
423 "         B is the current symbol (bad)
424 "         N is the next input symbol
425 "         C is the current state
426 "         R is a "next" read state
427 "    These are the conditions which can exist.
428 "         C( N )    R( B N )    -kind-
429 "            0         1 0    symbol leading to R is missing
430 "            0         0 1    B is a wrong symbol
431 "            1         1 0    B and N reversed in input
432 "            1         0 x    B is an extra symbol in the input
433 "            0         0 0    recovery fails
434 
435 "    The recovery tries to find  a  useable  combination.  If  one
436 "    exists,  the  search  does  not  stop.  If  a  second  one is
437 "    encountered, the search stops, a message is  generated  which
438 "    says the choice is not unique, and then the first combination
439 "    is used.
440 */
441 
442 dcl  1 sws,
443           2 CNf bit(1)unal,   /* current state contains next symbol */
444           2 RBNf bit(2)unal;  /* next read matches bad or next symbol */
445 dcl  dupl bit(1);   /* duplicate choice indicator */
446 dcl  transit        fixed bin(24);      /* found alternate symbol to use from current state */
447 dcl  la_next        fixed bin(24);      /* temporary "next" look-ahead position */
448 dcl  alt_symbol     fixed bin(24);      /* current alternate symbol */
449 dcl  cycle(4000)    bit(1)unal;
450 dcl  default_symbol char(14)int static init("<error_symbol>");
451 dcl  next_symbol    fixed bin(24);
452 dcl  depth          fixed bin(24);
453 dcl  which          fixed bin;
454 
455           if (test_symbol < 0)
456           then do;
457                call mrpg_error_(3,(lstk(-la_get).line),"Negative terminal; cannot recover.");
458                return("0"b);
459           end;
460           do while(la_ct < 2);
461                call scanner ();
462                la_put = mod(la_put,-lbound(lstk,1)) + 1;
463                la_ct = la_ct + 1;
464           end;
465           la_next = mod(la_get,-lbound(lstk,1))+1;
466           next_symbol = lstk(-la_next).symbol;
467 dcl  string         builtin;
468           string(sws) = "0"b;
469           transit = 0;
470           dupl = "0"b;
471           depth = 0;
472           if db_sw then call dump_la;
473           do i = current_table+1 to current_table+DPDA.v2(current_table) while(^dupl);
474                alt_symbol = abs(DPDA.v1(i));
475                if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^4i ^4a ^i ^a^/",
476                current_state,DDop(sign(DPDA.v2(i))),alt_symbol,geterm(alt_symbol,0));
477                if (next_symbol = alt_symbol)
478                then CNf = "1"b;
479                else CNf = "0"b;
480                string(cycle) = "0"b;
481                call next_term((ps_top),(DPDA.v2(i)));
482           end;
483           recov_msg = "";
484           if (transit = 0)
485           then return("0"b);
486           which = -la_get;
487           goto case(fixed(string(sws)));
488 
489 case(0):  /* can't resolve it */
490           return("0"b);
491 
492 case(3):
493 case(7):  /* cannot occur */
494           signal condition(logic_error);
495 dcl  logic_error condition;
496 
497 case(1):  /* B is wrong symbol */
498           recov_msg = recov_msg || geterm(transit,0);
499           recov_msg = recov_msg || " used in place of erroneous ";
500           recov_msg = recov_msg || geterm(test_symbol,la_get);
501           la_next = la_get;
502           err_ct = err_ct + 2;
503           goto set_symbol;
504 
505 case(2):  /* symbol leading to R is missing */
506           recov_msg = recov_msg || "Missing ";
507           recov_msg = recov_msg || geterm(transit,0);
508           recov_msg = recov_msg || " is assumed before ";
509           recov_msg = recov_msg || geterm(test_symbol,la_get);
510           la_next = mod(la_get-2,-lbound(lstk,1)) + 1;          /* back up one in look-ahead stack */
511           la_ct = la_ct + 1;
512           err_ct = err_ct + 2;
513 set_symbol:
514           lstk(-la_next).symptr = addr(default_symbol);
515           lstk(-la_next).symlen = length(default_symbol);
516           lstk(-la_next).line = lstk(-(mod(la_put-2,-lbound(lstk,1))+1)).line;
517           lstk(-la_next).symbol = transit;
518           la_get = la_next;
519           if (transit = 15)
520           then parenct = parenct - 1;
521           if (transit = 14)
522           then parenct = parenct + 1;
523           goto done;
524 
525 case(4):
526 case(5):  /* B is an extra symbol */
527           recov_msg = recov_msg || "Extraneous ";
528           recov_msg = recov_msg || geterm(test_symbol,la_get);
529           recov_msg = recov_msg || " ignored before ";
530           recov_msg = recov_msg || geterm(next_symbol,la_next);
531           la_get = la_next;
532           la_ct = la_ct - 1;
533           err_ct = err_ct + 1;
534           goto done;
535 
536 case(6):  /* B and N reversed */
537           recov_msg = recov_msg || geterm(test_symbol,la_get);
538           recov_msg = recov_msg || " and ";
539           recov_msg = recov_msg || geterm(next_symbol,la_next);
540           recov_msg = recov_msg || " are reversed.";
541           lstk(ls_top+1) = lstk(-la_get);
542           lstk(-la_get) = lstk(-la_next);
543           lstk(-la_next) = lstk(ls_top+1);
544           err_ct = err_ct + 2;
545 done:
546           call mrpg_error_(2,(lstk(which).line),"^a",recov_msg);
547           if db_sw then call dump_la;
548           return("1"b);       /* recovery completed */
549 
550 
551 dump_la:       proc;
552 
553 dcl  ii   fixed bin(24);
554                     if db_sw then do;
555                          ii = la_get;
556                          do while (ii ^= la_put);
557                               call ioa_$ioa_switch_nnl(iox_$user_output,"#la(-^i) ^3i""^a""^/",
558                               ii,
559                               lstk(-ii).symbol,
560                               geterm(lstk(-ii).symbol,0));
561                               ii = mod(ii,-lbound(lstk,1))+1;
562                          end;
563                     end;
564                end;
565 
566 next_term:          proc(top,ns);
567 dcl  top  fixed bin(24),      /* top of parse stack for this invocation */
568           ns        fixed bin(24);      /* branch to follow */
569 
570 dcl  ect  fixed bin(24);
571 dcl  cur_st         fixed bin(24);      /* current state for this recursion */
572 dcl  rep  fixed bin(24);
573 dcl  s    fixed bin(24);
574 dcl  look_ahead     bit(1);
575 dcl  i    fixed bin(24);
576 
577           if (ns = 0)
578           then return;
579           depth = depth + 5;
580           if (ns < 0)
581           then look_ahead = "1"b;
582           else look_ahead = "0"b;
583 NEXT:
584           ns = abs(ns);
585           cur_st = ns;
586           goto CASE(DPDA.v1(cur_st));
587 
588 CASE (2): /* Stack and Shared read */   /* . . . */
589 CASE (3): /* Shared look */   /* . . . */
590 CASE (10): /* Shared read */  /* . . . */
591           cur_st = DPDA.v2(cur_st);
592 CASE (0): /* Stack and Read. */         /* . . . */
593 CASE (1): /* Look. */         /* . . . */
594 CASE (9): /* Read. */         /* . . . */
595           if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx^4i READ^/",depth,ns);
596           rep = 0;
597           do s = test_symbol, next_symbol while(^CNf);
598                rep = rep + 1;
599                do i = cur_st+1 to cur_st + DPDA.v2(cur_st) while(^dupl);
600                     if look_ahead
601                     then do;
602                               if (DPDA.v1(i) = alt_symbol)
603                               then call next_term((top),(DPDA.v2(i)));
604                     end;
605 
606                     else if (DPDA.v1(i) < 0)
607                     | (DPDA.v1(i) = s)
608 
609                     then do;
610           if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx(^i)^i^/",depth,rep,s);
611                          if  (RBNf = "00"b)
612                          then do;
613                               transit = alt_symbol;
614                               if (rep = 1)
615                               then RBNf = "10"b;
616                               else RBNf = "01"b;
617                          end;
618                          else dupl = "1"b;
619                     end;
620                end;
621           end;
622           if CNf
623           then do;
624                          if  (RBNf = "00"b)
625                          then do;
626                               transit = alt_symbol;
627                               RBNf = "01"b;
628                          end;
629                          else dupl = "1"b;
630           end;
631           depth = depth - 5;
632           return;
633 
634 
635 CASE (4): /* Apply state. */  /* . . . */
636 CASE (5): /* Apply single */  /* . . . */
637 CASE (6): /* Apply Shared */  /* . . . */
638           if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx^4i APLY^/",depth,ns);
639           top = top - DPDA.v1(cur_st+1);
640           if (DPDA.v1(cur_st) = 5)
641           then do;
642                ns = DPDA.v2(cur_st+3);
643                goto NEXT;
644           end;
645           else do;
646           if (DPDA.v1(cur_st) = 6)
647           then do;
648                cur_st = DPDA.v2(cur_st+3);
649           end;
650           do i = cur_st+4 to cur_st+DPDA.v2(cur_st);
651                if (DPDA.v1(i) = parse_stack(top))
652                then do;
653                     ns = DPDA.v2(i);
654                     goto NEXT;
655                end;
656           end;
657           ns = DPDA.v2(cur_st+3);
658           goto NEXT;
659 end;
660 end;
661 end;
662 
663 
664 %include mrpg_scan;
665 
666 
667 %include mrpg_sem_;
668 
669 end;
670