1 /**** Parser for tables created by LRK.                                      */
  2 
  3 dcl iti             fixed bin;
  4 
  5           current_state = 1;
  6           lst, ps_top = 0;
  7           la_put, la_get = 1;
  8           la_ct = 0;
  9 
 10 /* The parsing loop. */
 11 NEXT:
 12           if (current_state = 0)
 13           then do;
 14 done_parse:
 15 finish:
 16              if db_eval
 17              then call ioa_$ioa_switch_nnl (db_output, " **FINI**^2/");
 18              code = 0;
 19              ain_l = nc - 1;
 20              return;
 21           end;
 22           current_table = current_state;
 23           string (db_data) = "";
 24           db_data.state = current_state;
 25 (subscriptrange):
 26           goto CASE (DPDA.v1 (current_table));
 27 
 28 CASE (3): /*** Shared look */
 29           current_table = DPDA.v2 (current_table);
 30 CASE (1): /**** Look. */
 31           la_use = mod (la_get + la_need - 1, -lbound (ls, 1)) + 1;
 32           if (la_need = -lbound (ls, 1))
 33           then signal condition (lastk_ovflo);
 34 dcl lastk_ovflo     condition;
 35           la_need = la_need + 1;
 36           goto read_look;
 37 
 38 CASE (10):
 39           current_table = DPDA.v2 (current_table);
 40 
 41 CASE (9):
 42           db_data.type = "READ";
 43           la_need = 1;
 44           la_use = la_get;
 45           goto read_look;
 46 CASE (2): /*** Stack and Shared read */
 47           current_table = DPDA.v2 (current_table);
 48 
 49 CASE (0): /*** Stack and Read. */
 50           db_data.type = "READ";
 51           db_data.flag = "*";
 52           la_need = 1;
 53           la_use = la_get;
 54           if (ps_top = hbound (parse_stack, 1))
 55           then signal condition (pstk_ovflo);
 56 dcl pstk_ovflo      condition;
 57           ps_top = ps_top + 1;          /* Top of  parsing stack.            */
 58           parse_stack (ps_top) = current_state; /* Stack the current state.  */
 59           cur_lex_top (ps_top) = lst;   /* save cur lex top (for recovery)   */
 60 read_look:
 61           do while (la_ct < la_need);   /* make sure enuf symbols available  */
 62              ls.symbol (-la_put) = scanner ();
 63              la_put = mod (la_put, -lbound (ls, 1)) + 1;
 64              la_ct = la_ct + 1;
 65           end;
 66           test_symbol = ls.symbol (-la_use);
 67           if (test_symbol = 56) & (current_state ^= 1)
 68           then do;                      /* execute MACRO (bad news)          */
 69              ps_top = ps_top + 1;
 70              parse_stack (ps_top) = current_state;
 71              next_state = -1;
 72              ind = ind + 2;
 73              goto got_symbol;
 74           end;
 75           else do i = current_table + 1
 76              to current_table + DPDA.v2 (current_table);
 77              if (DPDA.v1 (i) = test_symbol)
 78              then do;
 79                 next_state = DPDA.v2 (i);
 80                 goto got_symbol;
 81              end;
 82           end;
 83 
 84 
 85 error:
 86           if db_eval
 87           then do;
 88              db_data.type = "ERR";
 89              db_data.data = getermc (test_symbol, la_get);
 90              call ioa_$ioa_switch_nnl (db_output, "^vx^a^/", ind,
 91                 string (db_data));
 92           end;
 93           msg = "Vxx) Syntax- eval. ";
 94 err_text:
 95           iti = input.loc1 (0);
 96           input.loc1 (level) = nc;
 97           input.loc0 (level) = lgnc;
 98           msg = msg || """";
 99           do i = 0 to level;
100              if (i ^= 0)
101              then msg = msg || "
102           ";
103              msg = msg || substr (input.pt (i) -> is,
104                 input.loc0 (i), input.loc1 (i) - input.loc0 (i));
105           end;
106           msg = msg || """";
107 err_ret:
108           code = 10;
109           return;
110 
111 got_symbol:
112           if db_eval
113           then do;
114              if (next_state < 0)        /* is this a look-ahead state?       */
115              then do;
116                 db_data.type = "LK01";
117                 db_look = la_need;
118                 db_data.data = geterm (test_symbol, 0);
119                                         /* 0 means display only terminal     */
120                                         /*  "name" on look-ahead             */
121 /****           if (la_need = 1) then db_data.flag = "*";                    */
122              end;
123              else do;
124                 db_data.data = getermc (test_symbol, la_get);
125                                         /* display terminal "name" and data, */
126                                         /*  if available                     */
127 /****           db_data.flag = "*";                                          */
128              end;
129              call ioa_$ioa_switch_nnl (db_output, "^vx^a^/", ind,
130                 string (db_data));
131           end;
132           current_state = next_state;
133           if (current_state < 0) then do; /* Transition is look-ahead state. */
134              current_state = -current_state;
135           end;
136           else do;
137              if (lst = hbound (ls, 1))
138              then signal condition (lstk_ovflo);
139 dcl lstk_ovflo      condition;
140              lst = lst + 1;
141              ls (lst) = ls (-la_get);
142              if db_eval then call dump_ls;
143              la_get = mod (la_get, -lbound (ls, 1)) + 1;
144              la_ct = la_ct - 1;
145           end;
146           goto NEXT;
147 
148 CASE (7):
149           msg = "CASE7 encountered.";
150           goto err_text;
151 
152 CASE (8):
153           msg = "CASE8 encountered.";
154           goto err_text;
155 
156 CASE (4): /*** Apply state. */
157 CASE (5): /*** Apply single */
158 CASE (6): /*** Apply Shared */
159           la_need = 1;
160           p_del = DPDA.v1 (current_table + 1);
161           l_del = DPDA.v2 (current_table + 1);
162           rulen = DPDA.v1 (current_table + 2);
163           altn = DPDA.v2 (current_table + 2);
164           if (rulen > 0)
165           then call ted_vtab_ (rulen, altn);
166           if db_eval
167           then do;
168              db_data.type = "APLY";
169              db_data.data = "(";
170              call ioa_$ioa_switch_nnl (db_output, "^vx^a^i ^i)", ind,
171                 string (db_data), rulen, altn);
172           end;
173           if ex_sw
174           then do;
175              if db_eval
176                 then call ioa_$ioa_switch_nnl (db_output, "[ex]");
177              p_del = p_del + 2;
178              l_del = l_del + 1;
179           end;
180           if db_eval
181           then do;
182              call ioa_$ioa_switch_nnl (db_output, "^-pd=^i ld=^i(",
183                 p_del, l_del);
184              do t = ps_top to ps_top - p_del + 1 by -1;
185                 call ioa_$ioa_switch_nnl (db_output, " ^d",
186                    parse_stack (t));
187              end;
188              call ioa_$ioa_switch_nnl (db_output, ")^/");
189           end;
190           if (DPDA.v1 (current_table + 1) = -1) /* Empty rule                */
191           then parse_stack (ps_top + 1) = current_table;
192           ps_top = ps_top - p_del;      /* drop "p_del" parse stack states.  */
193           lst = lst - l_del;            /* drop "l_del" lex stack states     */
194           if db_eval then call dump_ls;
195 /**** l_del is (number of symbols in production)-1                           */
196 dump_ls: proc;
197      call ioa_
198         ("ls(^i)=^p,^3i [^i] ^i-^[aexp ^s^i^;cat ^p,^i,^i^;lexp ^s^i^]",
199         lst, ls(lst).symptr, ls(lst).symlen, ls(lst).symbol, ls(lst).type,
200         ls(lst).type+1, ls(lst).pt, ls(lst).num, ls(lst).loc);
201   end dump_ls;
202           if ex_sw
203           then do;
204              ex_sw = "0"b;
205              current_state = parse_stack (ps_top + 1);
206              ind = ind - 2;
207              goto NEXT;
208           end;
209           if (DPDA.v1 (current_state) = 6)
210           then do;
211              current_table = DPDA.v2 (current_table + 3);
212           end;
213           jaf = parse_stack (ps_top);
214           do i = current_table + 4 to current_table + DPDA.v2 (current_table);
215              if (DPDA.v1 (i) = jaf)
216              then do;
217                 current_state = DPDA.v2 (i);
218                 goto NEXT;
219              end;
220           end;
221           current_state = DPDA.v2 (current_table + 3);
222           goto NEXT;
223 
224 dcl (addr, mod, fixed) builtin;
225 dcl db_look         pic "99" defined (db_data.type) pos (3);
226 dcl 1 db_data,
227       2 flag        char (1),           /* "*" means stacked                 */
228       2 state       pic "zzz9",
229       2 fil1        char (2),
230       2 type        char (6),
231       2 data        char (100);
232 dcl ioa_$ioa_switch_nnl entry options (variable);
233 dcl iox_$user_output ptr ext static;
234 dcl 1 ls            (-4:50),            /* -4:-1   look-ahead stack (FIFO)   */
235                                         /*  1:50   lexical stack (LIFO)      */
236       2 symptr      ptr,                /* pointer to symbol (must be valid) */
237       2 symlen      fixed bin (21),     /* length of symbol (may be 0)       */
238       2 line        fixed bin (21),     /* line where symbol begins          */
239       2 symbol      fixed bin (21),     /* encoding of symbol                */
240       2 pt          ptr,
241       2 mask        bit (36),
242       2 type        fixed bin,          /* 0-aexp 1-cat 2-lexp               */
243       2 num         fixed bin (21),
244       2 loc         fixed bin (21);
245 
246 dcl (ABREV          init (-1),
247     AEXP            init (0),
248     CAT             init (1),
249     LEXP            init (2)
250     )               fixed bin (21) int static options (constant);
251 dcl lst             fixed bin (21);     /* location of top of lexical stack  */
252 dcl cur_lex_top     (100) fixed bin;    /* current lex top stack             */
253                                         /*  (with parse_stack)               */
254 dcl parse_stack     (100) fixed bin;    /* parse stack                       */
255 dcl altn            fixed bin (21);     /* APPLY alternative number          */
256 dcl current_state   fixed bin;          /* number of current state           */
257 dcl test_symbol     fixed bin;          /* encoding of current symbol        */
258 dcl current_table   fixed bin;          /* number of current table           */
259 dcl i               fixed bin (21);     /* temp                              */
260 dcl la_ct           fixed bin;          /* # terms in look-ahead stack       */
261 dcl la_get          fixed bin;          /* look_ahead stack get next symbol  */
262 dcl la_need         fixed bin;          /* # look-ahead symbols needed       */
263 dcl la_put          fixed bin;          /* look_ahead stack put next symbol  */
264 dcl la_use          fixed bin (22);     /* look-ahead stack test symbol      */
265 dcl next_state      fixed bin;          /* # next state                      */
266 dcl nil_sym         fixed bin;
267 dcl ps_top          fixed bin;          /* top of parse stack                */
268 dcl recov_msg       char (150) var;
269 dcl rulen           fixed bin (21);     /* APPLY rule number                 */
270 dcl t               fixed bin (21);
271 dcl jaf             fixed bin (21);
272 dcl ioa_            entry options (variable);
273 dcl (l_del, p_del)  fixed bin;
274 
275 geterm: proc (idx, ids) returns (char (100) var);
276 
277 dcl (idx, ids)      fixed bin;
278 dcl temp            char (100) var;
279 dcl c_str           char (20000) based;
280 
281       temp = "";
282 get_rest:
283       if (ids > 0)
284       then if (ls (-ids).symlen > 0)
285            then do;
286               temp = temp || """";
287               temp = temp || substr (ls (-ids).symptr -> c_str,
288                  1, min (50, ls (-ids).symlen));
289               temp = temp || """";
290               return (temp);
291            end;
292       if (idx = 0)
293       then temp = "--EOI--";
294       else temp = substr (TC, TL.pt (idx), TL.ln (idx));
295       return (temp);
296 getermc: entry (idx, ids) returns (char (100) var);
297 
298       if (idx = 0)
299       then temp = "--EOI--";
300       else temp = substr (TC, TL.pt (idx), TL.ln (idx));
301       temp = temp || " ";
302       goto get_rest;
303    end;