1 /* BEGIN INCLUDE FILE ..... ted_gv_p_.incl.pl1 ..... 07/10/81 J Falksen      */
  2 
  3 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  4 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  5 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  6 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
  7 
  8 ted_gv_p_: proc ();
  9 
 10 /* Parser for tables created by LRK. */
 11 
 12       current_state = 1;
 13 
 14       ls_top, ps_top = 0;
 15       la_put, la_get = 1;
 16 
 17       la_ct = 0;
 18       call rule_0;
 19 
 20 /* The parsing loop. */
 21 NEXT:
 22       if (current_state = 0)
 23       then do;
 24 done_parse:
 25          if db_gv then call ioa_();
 26          call end_cf;
 27          cf.op = tdone_op;
 28          cf.len = 0;
 29          cf.siz = size (cf);
 30          call end_cf;
 31          if db_gv then call tedshow_ (comptr, "gvx");
 32          return;
 33       end;
 34       current_table = current_state;
 35 
 36       string (db_data) = "";
 37       db_data.state = current_state;
 38 
 39 (subscriptrange):
 40 TRY_AGAIN:
 41       goto CASE (DPDA.v1 (current_table));
 42 
 43 CASE (3):                               /* Shared look                       */
 44       current_table = DPDA.v2 (current_table);
 45 CASE (1):                               /* Look.                             */
 46       db_data.type = "LOOK";
 47       la_use = mod (la_get + la_need - 1, -lbound (ls, 1)) + 1;
 48       if (la_need = -lbound (ls, 1))
 49       then signal condition (lastk_ovflo);
 50 dcl lastk_ovflo     condition;
 51       la_need = la_need + 1;
 52       goto read_look;
 53 
 54 CASE (10):                              /* Shared read                       */
 55       current_table = DPDA.v2 (current_table);
 56 
 57 CASE (9):                               /* Read.                             */
 58 
 59       db_data.type = "READ";
 60 
 61       la_need = 1;
 62       la_use = la_get;
 63       goto read_look;
 64 
 65 CASE (2):                               /* Stack and Shared read             */
 66       current_table = DPDA.v2 (current_table);
 67 
 68 CASE (0):                               /* Stack and Read                    */
 69 
 70       db_data.type = "READ";
 71       db_data.flag = "*";
 72 
 73       la_need = 1;
 74       la_use = la_get;
 75       if (ps_top = hbound (parse_stack, 1))
 76       then do;
 77          msg = "tedgv_ parse stk oflow";
 78          goto print_error;
 79       end;
 80       ps_top = ps_top + 1;              /* Top of  parsing stack.            */
 81       parse_stack (ps_top) = current_state; /* Stack the current state.      */
 82       cur_lex_top (ps_top) = ls_top;    /* save cur lex top (for recovery)   */
 83 read_look:
 84       do while (la_ct < la_need);       /* ensure enough symbols available   */
 85          call scanner ();
 86          la_put = mod (la_put, -lbound (ls, 1)) + 1;
 87          la_ct = la_ct + 1;
 88       end;
 89       test_symbol = ls.symbol (-la_use);
 90 
 91       m = 0;
 92       do i = current_table + 1 to current_table + DPDA.v2 (current_table);
 93          if (DPDA.v1 (i) = test_symbol)
 94          then do;
 95             next_state = DPDA.v2 (i);
 96             goto got_symbol;
 97          end;
 98       end;
 99 
100       msg = "Vxx) Syntax- ";
101       goto gv_msg_com;
102 
103 got_symbol:
104 
105 
106       if db_gv
107       then do;
108          if (next_state < 0)            /* is this a look-ahead state?       */
109          then do;
110             db_data.type = "LK01";
111             db_look = la_need;
112                                         /* show only "name" on look-ahead    */
113             db_data.data = geterm (test_symbol, 0);
114             db_data.flag = " ";
115          end;
116          else db_data.data = getermc (test_symbol, la_get);
117                                         /* display terminal "name" and data, */
118                                         /*  if available                     */
119 
120          call ioa_$ioa_switch_nnl (iox_$user_output, "^a^/", string (db_data));
121       end;
122 
123       current_state = next_state;
124       if (current_state < 0)            /* Transition is a look-ahead state. */
125       then current_state = -current_state;
126       else do;
127          if (ls_top = hbound (ls, 1))
128          then do;
129             msg = "tedgv_ lex stk oflow";
130             goto print_error;
131          end;
132          ls_top = ls_top + 1;
133          ls (ls_top) = ls (-la_get);
134          la_get = mod (la_get, -lbound (ls, 1)) + 1;
135          la_ct = la_ct - 1;
136       end;
137       goto NEXT;
138 
139 CASE (4):                               /* Apply state. */ /* . . . */
140 CASE (5):                               /* Apply single */ /* . . . */
141 CASE (6):                               /* Apply Shared */ /* . . . */
142       la_need = 1;
143       rulen = DPDA.v1 (current_table + 2);
144       altn = DPDA.v2 (current_table + 2);
145 
146       if db_gv
147       then do;
148          db_data.type = "APLY";
149          db_data.data = "(";
150          call ioa_$ioa_switch_nnl (iox_$user_output, "^a^i ^i)",
151             string (db_data), rulen, altn);
152       end;
153 
154       if (rulen > 0)
155       then call sem (rulen, altn);
156 
157       if db_gv
158       then do;
159          call ioa_$ioa_switch_nnl (iox_$user_output, "^-pd=^i ld=^i(",
160             DPDA.v1 (current_table + 1), DPDA.v2 (current_table + 1));
161          do t = ps_top to ps_top - DPDA.v1 (current_table + 1) + 1 by -1;
162             call ioa_$ioa_switch_nnl (iox_$user_output, " ^d",
163                parse_stack (t));
164          end;
165          call ioa_$ioa_switch_nnl (iox_$user_output, ")^/");
166       end;
167 
168 /* Delete parse and lex stack states                                         */
169       ps_top = ps_top - DPDA.v1 (current_table + 1);
170       ls_top = ls_top - DPDA.v2 (current_table + 1);
171       if (DPDA.v1 (current_state) = 5)
172       then do;
173          current_state = DPDA.v2 (current_table + 3);
174          goto NEXT;
175       end;
176       if (DPDA.v1 (current_state) = 6)
177       then do;
178          current_table = DPDA.v2 (current_table + 3);
179       end;
180       do i = current_table + 4 to current_table + DPDA.v2 (current_table);
181          if (DPDA.v1 (i) = parse_stack (ps_top))
182          then do;
183             current_state = DPDA.v2 (i);
184             goto NEXT;
185          end;
186       end;
187       current_state = DPDA.v2 (current_table + 3);
188       goto NEXT;
189 
190 
191 
192 
193 dcl (addr, mod, fixed) builtin;
194 dcl db_look         pic "99" defined (db_data.type) pos (3);
195 dcl 1 db_data,
196       2 flag        char (1),           /* * means stacked                   */
197       2 state       pic "zzz9",
198       2 fil1        char (2),
199       2 type        char (6),
200       2 data        char (100);
201 dcl DDop            (-1:2) char (4) int static init
202                     ("LOOK", "FINI", "READ", "ERR");
203 dcl ioa_$ioa_switch_nnl entry options (variable);
204 dcl iox_$user_output ptr ext static;
205 
206 dcl 1 ls            (-4:50),            /* -4:-1 look-ahead stack (FIFO)     */
207                                         /* 1:50 lexical stack (LIFO)         */
208       2 symptr      ptr,                /* pointer to symbol (must be valid) */
209       2 symlen      fixed bin,          /* length of symbol (may be 0)       */
210       2 line        fixed bin (21),     /* line where symbol begins          */
211       2 symbol      fixed bin,          /* encoding of symbol                */
212       2 true        fixed bin,
213       2 false       fixed bin,
214       2 loc         fixed bin;
215 dcl ls_top          fixed bin;          /* location of top of lexical stack  */
216 dcl cur_lex_top     (100) fixed bin; /* current lex top stack                */
217 dcl parse_stack     (100) fixed bin; /* parse stack                          */
218 dcl altn            fixed bin;          /* APPLY alternative number          */
219 dcl current_state   fixed bin;          /* number of current state           */
220 dcl test_symbol     fixed bin;          /* encoding of current symbol        */
221 dcl current_table   fixed bin;          /* number of current table           */
222 dcl i               fixed bin (21);
223 dcl la_ct           fixed bin;          /* # terminals in look-ahead stack   */
224 dcl la_get          fixed bin;          /* where to get next symbol          */
225 dcl la_need         fixed bin;          /* # look-ahead symbols needed       */
226 dcl la_put          fixed bin;          /* where to put next symbol          */
227 dcl la_use          fixed bin (22);     /* where stack to test with          */
228 
229 dcl (m, n)          fixed bin;
230 
231 dcl next_state      fixed bin;          /* number of next state              */
232 dcl ps_top          fixed bin;          /* location of top of parse stack    */
233 dcl recov_msg       char (150) var;
234 dcl rulen           fixed bin;          /* APPLY rule number                 */
235 dcl t               fixed bin;
236 dcl ioa_            entry options (variable);
237 
238 geterm: proc (idx, ids) returns (char (100) var);
239 
240 dcl (idx, ids)      fixed bin;
241 dcl temp            char (100) var;
242 dcl c_str           char (20000) based;
243 
244       temp = "";
245 get_rest:
246       if (ids > 0)
247       then if (ls (-ids).symlen > 0)
248            then do;
249               temp = temp || """";
250               temp = temp || substr (ls (-ids).symptr -> c_str, 1,
251                  min (50, ls (-ids).symlen));
252               temp = temp || """";
253               return (temp);
254            end;
255       if (idx = 0)
256       then temp = "--EOI--";
257       else temp = substr (TC, TL.pt (idx), TL.ln (idx));
258       return (temp);
259 
260 getermc: entry (idx, ids) returns (char (100) var);
261 
262       if (idx = 0)
263       then temp = "--EOI--";
264       else temp = substr (TC, TL.pt (idx), TL.ln (idx));
265       temp = temp || " ";
266       goto get_rest;
267    end; %page;
268 scanner: proc;
269 
270       ls (-la_put).symptr = addr (rl_c (rl_i));
271       ls (-la_put).symlen = 0;
272       cft.t, cft.f = 0;
273       ls (-la_put).symbol = 9;
274       ls (-la_put).loc = gvx.tot_len + 1;
275       ls (-la_put).true = gvx.tot_len + 4;
276       ls (-la_put).false = gvx.tot_len + 5;
277       i = index ("(^|&)
278  ", rl_c (rl_i));
279       if (i > 0)
280       then do;
281          rl_i = rl_i + 1;
282          ls (-la_put).symbol = min (8, i + 2);
283          return;
284       end;
285       if (rl_c (rl_i) = "{")
286       then do;
287          cft.op = teval_op;
288          i = index (substr (rl_s, rl_i), "}");
289          call add_length (i);
290          cft.da = substr (rl_s, rl_i, i);
291          rl_i = rl_i + i;
292       end;
293       else do;
294          cft.op = tsrch_op;
295          call scan;
296          rl_i = expr_b + expr_l + 1;
297          cft.cexpml = 100;              /* DO THIS RIGHT!                    */
298          call tedsrch_$compile (addr (rl_c (expr_b)), expr_l,
299             addr (cft.cexpml), "1"b, (dbase.lit_sw), msg, code);
300          if (code ^= 0)
301          then goto print_error;
302 dcl bfb             fixed bin based;
303          cft.cexpml = cft.cexpl + 4;
304         call add_length((cft.cexpml));
305       end;
306       cft.siz = size (cft);
307       call end_cf;
308    end scanner; %skip (4);
309 rule_0: proc;
310 
311       if req_ch = "g"
312       then i = 1;
313       else i = 2;
314       ls (-1).symbol = i;
315       ls (-1).symptr = addr (rl_c (rl_i));
316       ls (-1).symlen = 0;
317       ls (-1).loc, ls (-1).true, ls (-1).false = 0;
318       la_put = 2;
319       la_ct = 1;
320 
321       return;
322    end rule_0;
323 
324 %include ted_gv_;
325 
326    end;
327 
328 
329 /* END INCLUDE FILE ..... ted_gv_p_.incl.pl1 .....                           */