dcl fail_ct fixed bin init(0); dcl db_sw bit (1) internal static init ("0"b); mrpg_parse_: proc(); /* Parser for tables created by LRK. */ ps_max = 0; dcl ps_max fixed bin int static; report_sw = "0"b; begin_ct = 0; beginptr = null(); sort_list.b, sort_list.e = null(); hold_list.b, hold_list.e = null(); depth = 0; stmtlistptr = addr(tree.exec); if_nest = 0; hold_ct = 0; current_state = 1; nil_sym = -1; /* set nil_sym non-existant */ ls_top, ps_top = 0; la_put, la_get = 1; err_ct = 0; la_ct = 0; /* The parsing loop. */ NEXT: if (current_state = 0) then do; done_parse: /* call ioa_("ps_max = ^i",ps_max);*/ return; end; current_table = current_state; string(db_data) = ""; db_data.state = current_state; (subscriptrange): TRY_AGAIN: goto CASE (DPDA.v1(current_table)); CASE (3): /* Shared look */ /* . . . */ current_table = DPDA.v2(current_table); CASE (1): /* Look. */ /* . . . */ db_data.type = "LOOK"; la_use = mod(la_get+la_need-1,-lbound(lstk,1))+1; if (la_need = -lbound(lstk,1)) then signal condition(lastk_ovflo); dcl lastk_ovflo condition; la_need = la_need + 1; goto read_look; CASE (10): /* Shared read */ /* . . . */ current_table = DPDA.v2(current_table); CASE (9): /* Read. */ /* . . . */ db_data.type = "READ"; db_data.sl = ls_top+1; la_need = 1; la_use = la_get; goto read_look; CASE (2): /* Stack and Shared read */ /* . . . */ current_table = DPDA.v2(current_table); CASE (0): /* Stack and Read. */ /* . . . */ db_data.type = "READ"; db_data.sl = ls_top+1; db_data.flag = "*"; la_need = 1; la_use = la_get; if (ps_top = hbound(parse_stack,1)) then signal condition(pstk_ovflo); dcl pstk_ovflo condition; ps_top = ps_top+1; /* Top of parsing stack. */ ps_max = max(ps_max,ps_top); parse_stack (ps_top) = current_state; /* Stack the current state. */ cur_lex_top (ps_top) = ls_top; /* save current lex top (for recovery) */ read_look: do while(la_ct < la_need); /* make sure enough symbols are available */ call scanner (); la_put = mod(la_put,-lbound(lstk,1))+1; la_ct = la_ct + 1; end; test_symbol = lstk.symbol(-la_use); m = 0; do i = current_table+1 to current_table+DPDA.v2(current_table); n = DPDA.v1(i); if (n < 0) then n,m = -n; if (n = test_symbol) then do; next_state = DPDA.v2(i); goto got_symbol; end; end; if (test_symbol = nil_sym) /* if bad symbol was a generated one */ then do; la_get = mod(la_get,-lbound(lstk,1))+1; /* ...drop it and try again */ la_ct = la_ct - 1; goto read_look; end; if (m > 0) /* if marked symbol was in table, use it */ then do; next_state = DPDA.v2(m); goto got_symbol; end; if (err_ct <= 4) /* max_recover * 2 */ then do; if local_recovered() then do; if (db_data.flag = "*") then ps_top = ps_top - 1; goto TRY_AGAIN; end; if skip_recovered() then do; call mrpg_error_(2,0,"^a",recov_msg); goto NEXT; end; if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^4i ",current_state); call mrpg_error_(2,(lstk(-la_use).line),"Parse failed, symbol ^a", geterm(test_symbol,(la_use))); fail_ct = fail_ct + 1; if (fail_ct > 5) then call mrpg_error_(3,0,"Parse recovery terminated."); call mrpg_error_(0,0,"Symbol being dropped."); goto retry; end; got_symbol: err_ct = max(err_ct-1,0); if db_sw then do; if (next_state < 0) /* is this a look-ahead state? */ then do; db_data.type = "LK01"; db_data.sl = 0; db_look = la_need; db_data.data = geterm(test_symbol,0);/* display only terminal "name" on look-ahead */ db_data.flag = " "; end; else do; db_data.data = getermc(test_symbol,la_get); /* display terminal "name" and data, if available */ end; call ioa_$ioa_switch_nnl(iox_$user_output,"^a^/",string(db_data)); end; current_state = next_state; if (current_state < 0) then do; /* Transition is a look-ahead state. */ current_state = -current_state; end; else do; retry: if (ls_top = hbound(lstk,1)) then signal condition(lstk_ovflo); dcl lstk_ovflo condition; ls_top = ls_top + 1; lstk(ls_top) = lstk(-la_get); la_get = mod(la_get,-lbound(lstk,1)) + 1; la_ct = la_ct - 1; end; goto NEXT; CASE (4): /* Apply state. */ /* . . . */ CASE (5): /* Apply single */ /* . . . */ CASE (6): /* Apply Shared */ /* . . . */ la_need = 1; rulen = DPDA.v1(current_table+2); altn = DPDA.v2(current_table+2); if db_sw then do; db_data.type = "APLY"; db_data.data = "("; call ioa_$ioa_switch_nnl(iox_$user_output,"^a^i ^i)",string(db_data),rulen,altn); end; if (rulen ^= 0) then substr(used,abs(rulen),1) = "1"b; if (rulen > 0) then do; call semantics (rulen,altn); end; if db_sw then do; t = ls_top - DPDA.v2(current_table+1); call ioa_$ioa_switch_nnl(iox_$user_output," ^2i-^2a",t,substr(dt_s(lstk.datype(t)),1,2)); call ioa_$ioa_switch_nnl(iox_$user_output,"^-pd=^i ld=^i(" ,DPDA.v1(current_table+1),DPDA.v2(current_table+1)); do t = ps_top to ps_top-DPDA.v1(current_table+1)+1 by -1; call ioa_$ioa_switch_nnl(iox_$user_output," ^d",parse_stack (t)); end; call ioa_$ioa_switch_nnl(iox_$user_output,")^/"); end; /** Check for an apply of an empty production. In this case the apply state number must be pushed on the parse stack. (Reference LaLonde, W. R.: An Efficient LALR Parser Generator. Tech. Report CSRG-2, 1971, pp. 34-35.) **/ if DPDA.v1 (current_state+1) = -1 then do; if (ps_top = hbound (parse_stack, 1)) then signal condition (pstk_ovflo); parse_stack (ps_top+1) = current_state; end; ps_top = ps_top - DPDA.v1(current_table+1); /* Delete parse stack states. */ ls_top = ls_top - DPDA.v2(current_table+1); /* delete lex stack states */ if (DPDA.v1(current_state) = 5) then do; current_state = DPDA.v2(current_table+3); goto NEXT; end; if (DPDA.v1(current_state) = 6) then do; current_table = DPDA.v2(current_table+3); end; do i = current_table+4 to current_table+DPDA.v2(current_table); if (DPDA.v1 (i) = parse_stack(ps_top)) then do; current_state = DPDA.v2(i); goto NEXT; end; end; current_state = DPDA.v2(current_table+3); goto NEXT; skip_recovered: proc returns (bit (1)); dcl (i,ii) fixed bin (24); dcl (j,jj) fixed bin (24); dcl c fixed bin (24); dcl dec4 pic "---9"; if (DPDA.v1 (DPDAsize+1) ^= 1) /* no skip table */ then return ("0"b); current_table = DPDAsize + 2; dec4 = lstk (-la_get).line; recov_msg = "LINE "; recov_msg = recov_msg || dec4; recov_msg = recov_msg || ". Unuseable token "; recov_msg = recov_msg || geterm (test_symbol,la_get); recov_msg = recov_msg || ". Skipped to "; nil_sym = DPDA.v1(current_table+1); c = 1; do while (c ^= 0); if (la_ct = 0) then do; /* if look-ahead stack is empty, get a symbol */ call scanner (); la_put = mod(la_put,-lbound(lstk,1))+1; la_ct = 1; end; c = lstk.symbol (-la_get); do i = current_table+2 to current_table+DPDA.v2(current_table); if (DPDA.v1 (i) = c) then do; jj = DPDA.v2(i); do j = ps_top to 1 by -1; do ii = jj+1 to jj + DPDA.v2(jj); if (DPDA.v1(ii) = parse_stack (j)) then do; ps_top = j-1; ls_top = cur_lex_top (j); current_state = DPDA.v1(ii); recov_msg = recov_msg || geterm (c,0); recov_msg = recov_msg || " on line "; dec4 = lstk (-la_get).line; recov_msg = recov_msg || dec4; /* generate a nil symbol into the look-ahead stack */ lstk(-la_get).symlen = 0; lstk(-la_get).symbol = nil_sym; return ("1"b); end; end; end; end; end; la_get = mod(la_get,-lbound(lstk,1))+1; la_ct = la_ct - 1; end; recov_msg = recov_msg || " EOI."; current_state = 0; return ("1"b); end; dcl (addr, mod, fixed) builtin; dcl db_look pic "99" defined(db_data.type ) pos(3); dcl 1 db_data, 2 flag char(1), /* * means stacked */ 2 state pic "zzz9", 2 fil1 char(1), 2 sl pic "zz", 2 fil2 char(1), 2 type char(6), 2 data char(100); dcl DDop(-1:2) char(4)int static init("LOOK","FINI","READ","ERR"); dcl ioa_$ioa_switch_nnl entry options(variable); dcl iox_$user_output ptr ext static; dcl 1 lstk(-8:200) /* -8:-1 is the look-ahead stack (FIFO) */ /* 1:200 is the lexical stack (LIFO) */ , 2 symptr ptr /* pointer to symbol (must be valid) */ ,2 symlen fixed bin (24) /* length of symbol (may be 0) */ ,2 line fixed bin (24) /* line where symbol begins */ ,2 symbol fixed bin (24) /* encoding of symbol */ ,2 datype fixed bin /* 1-BOOL, 2-CHAR, 3-ARITH */ ,2 node_ptr ptr ,2 val fixed bin (24) ,2 bchar fixed bin (24) ,2 echar fixed bin (24); dcl ls_top fixed bin(24); /* location of top of lexical stack */ dcl cur_lex_top (200) fixed bin (24) aligned; /* current lex top stack (with parse_stack) */ dcl parse_stack (200) fixed bin (24) aligned; /* parse stack */ dcl altn fixed bin(24); /* APPLY alternative number */ dcl current_state fixed bin (24); /* number of current state */ dcl test_symbol fixed bin (24); /* encoding of current symbol */ dcl current_table fixed bin (24); /* number of current table */ dcl i fixed bin(24); /* temp */ dcl la_ct fixed bin(24); /* number of terminals in look-ahead stack */ dcl la_get fixed bin(24); /* location in look_ahead stack to get next symbol */ dcl la_need fixed bin(24); /* number of look-ahead symbols needed */ dcl la_put fixed bin(24); /* location in look_ahead stack to put next symbol */ dcl la_use fixed bin(22); /* location in look-ahead stack to test with */ dcl (m,n) fixed bin(24); dcl next_state fixed bin(24); /* number of next state */ dcl nil_sym fixed bin(24); dcl ps_top fixed bin (24); /* location of top of parse stack */ dcl recov_msg char(150)var; dcl rulen fixed bin(24); /* APPLY rule number */ dcl t fixed bin (24); dcl ioa_ entry options(variable); geterm: proc(idx,ids) returns(char(100)var); dcl (idx,ids) fixed bin(24); dcl temp char(100)var; dcl i fixed bin; dcl c_str char(20000)based; temp = ""; get_rest: if (ids > 0) then if (lstk(-ids).symlen > 0) then do; temp = temp || """"; temp = temp || substr(lstk(-ids).symptr->c_str,1,min(50,lstk(-ids).symlen)); temp = temp || """"; i = lstk(-ids).symbol; if (i < 24) | (i > 116) | ((i > 102) & (i < 109)) then return (temp); temp = temp || " (RESERVED WORD)"; return(temp); end; if (idx = 0) then temp = "--EOI--"; else temp = substr(TC,TL.pt(idx),TL.ln(idx)); return(temp); getermc: entry(idx,ids)returns(char(100)var); if (idx = 0) then temp = "--EOI--"; else temp = substr(TC,TL.pt(idx),TL.ln(idx)); temp = temp || " "; goto get_rest; end; dcl err_ct fixed bin(24); local_recovered: proc returns(bit(1)); /* " this procedure implements the LRK local error recovery (using " the DPDA table). This is done by using the current (bad) " symbol and the next input symbol. All possible parses from " this state are examined. These trial parses proceed until the " next read state is encountered. The trial parses are true " simulations of what can happen, apply states are chosen " according to the simulated top of parse stack. " Given: " B is the current symbol (bad) " N is the next input symbol " C is the current state " R is a "next" read state " These are the conditions which can exist. " C( N ) R( B N ) -kind- " 0 1 0 symbol leading to R is missing " 0 0 1 B is a wrong symbol " 1 1 0 B and N reversed in input " 1 0 x B is an extra symbol in the input " 0 0 0 recovery fails " The recovery tries to find a useable combination. If one " exists, the search does not stop. If a second one is " encountered, the search stops, a message is generated which " says the choice is not unique, and then the first combination " is used. */ dcl 1 sws, 2 CNf bit(1)unal, /* current state contains next symbol */ 2 RBNf bit(2)unal; /* next read matches bad or next symbol */ dcl dupl bit(1); /* duplicate choice indicator */ dcl transit fixed bin(24); /* found alternate symbol to use from current state */ dcl la_next fixed bin(24); /* temporary "next" look-ahead position */ dcl alt_symbol fixed bin(24); /* current alternate symbol */ dcl cycle(4000) bit(1)unal; dcl default_symbol char(14)int static init(""); dcl next_symbol fixed bin(24); dcl depth fixed bin(24); dcl which fixed bin; if (test_symbol < 0) then do; call mrpg_error_(3,(lstk(-la_get).line),"Negative terminal; cannot recover."); return("0"b); end; do while(la_ct < 2); call scanner (); la_put = mod(la_put,-lbound(lstk,1)) + 1; la_ct = la_ct + 1; end; la_next = mod(la_get,-lbound(lstk,1))+1; next_symbol = lstk(-la_next).symbol; dcl string builtin; string(sws) = "0"b; transit = 0; dupl = "0"b; depth = 0; if db_sw then call dump_la; do i = current_table+1 to current_table+DPDA.v2(current_table) while(^dupl); alt_symbol = abs(DPDA.v1(i)); if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^4i ^4a ^i ^a^/", current_state,DDop(sign(DPDA.v2(i))),alt_symbol,geterm(alt_symbol,0)); if (next_symbol = alt_symbol) then CNf = "1"b; else CNf = "0"b; string(cycle) = "0"b; call next_term((ps_top),(DPDA.v2(i))); end; recov_msg = ""; if (transit = 0) then return("0"b); which = -la_get; goto case(fixed(string(sws))); case(0): /* can't resolve it */ return("0"b); case(3): case(7): /* cannot occur */ signal condition(logic_error); dcl logic_error condition; case(1): /* B is wrong symbol */ recov_msg = recov_msg || geterm(transit,0); recov_msg = recov_msg || " used in place of erroneous "; recov_msg = recov_msg || geterm(test_symbol,la_get); la_next = la_get; err_ct = err_ct + 2; goto set_symbol; case(2): /* symbol leading to R is missing */ recov_msg = recov_msg || "Missing "; recov_msg = recov_msg || geterm(transit,0); recov_msg = recov_msg || " is assumed before "; recov_msg = recov_msg || geterm(test_symbol,la_get); la_next = mod(la_get-2,-lbound(lstk,1)) + 1; /* back up one in look-ahead stack */ la_ct = la_ct + 1; err_ct = err_ct + 2; set_symbol: lstk(-la_next).symptr = addr(default_symbol); lstk(-la_next).symlen = length(default_symbol); lstk(-la_next).line = lstk(-(mod(la_put-2,-lbound(lstk,1))+1)).line; lstk(-la_next).symbol = transit; la_get = la_next; if (transit = 15) then parenct = parenct - 1; if (transit = 14) then parenct = parenct + 1; goto done; case(4): case(5): /* B is an extra symbol */ recov_msg = recov_msg || "Extraneous "; recov_msg = recov_msg || geterm(test_symbol,la_get); recov_msg = recov_msg || " ignored before "; recov_msg = recov_msg || geterm(next_symbol,la_next); la_get = la_next; la_ct = la_ct - 1; err_ct = err_ct + 1; goto done; case(6): /* B and N reversed */ recov_msg = recov_msg || geterm(test_symbol,la_get); recov_msg = recov_msg || " and "; recov_msg = recov_msg || geterm(next_symbol,la_next); recov_msg = recov_msg || " are reversed."; lstk(ls_top+1) = lstk(-la_get); lstk(-la_get) = lstk(-la_next); lstk(-la_next) = lstk(ls_top+1); err_ct = err_ct + 2; done: call mrpg_error_(2,(lstk(which).line),"^a",recov_msg); if db_sw then call dump_la; return("1"b); /* recovery completed */ dump_la: proc; dcl ii fixed bin(24); if db_sw then do; ii = la_get; do while (ii ^= la_put); call ioa_$ioa_switch_nnl(iox_$user_output,"#la(-^i) ^3i""^a""^/", ii, lstk(-ii).symbol, geterm(lstk(-ii).symbol,0)); ii = mod(ii,-lbound(lstk,1))+1; end; end; end; next_term: proc(top,ns); dcl top fixed bin(24), /* top of parse stack for this invocation */ ns fixed bin(24); /* branch to follow */ dcl ect fixed bin(24); dcl cur_st fixed bin(24); /* current state for this recursion */ dcl rep fixed bin(24); dcl s fixed bin(24); dcl look_ahead bit(1); dcl i fixed bin(24); if (ns = 0) then return; depth = depth + 5; if (ns < 0) then look_ahead = "1"b; else look_ahead = "0"b; NEXT: ns = abs(ns); cur_st = ns; goto CASE(DPDA.v1(cur_st)); CASE (2): /* Stack and Shared read */ /* . . . */ CASE (3): /* Shared look */ /* . . . */ CASE (10): /* Shared read */ /* . . . */ cur_st = DPDA.v2(cur_st); CASE (0): /* Stack and Read. */ /* . . . */ CASE (1): /* Look. */ /* . . . */ CASE (9): /* Read. */ /* . . . */ if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx^4i READ^/",depth,ns); rep = 0; do s = test_symbol, next_symbol while(^CNf); rep = rep + 1; do i = cur_st+1 to cur_st + DPDA.v2(cur_st) while(^dupl); if look_ahead then do; if (DPDA.v1(i) = alt_symbol) then call next_term((top),(DPDA.v2(i))); end; else if (DPDA.v1(i) < 0) | (DPDA.v1(i) = s) then do; if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx(^i)^i^/",depth,rep,s); if (RBNf = "00"b) then do; transit = alt_symbol; if (rep = 1) then RBNf = "10"b; else RBNf = "01"b; end; else dupl = "1"b; end; end; end; if CNf then do; if (RBNf = "00"b) then do; transit = alt_symbol; RBNf = "01"b; end; else dupl = "1"b; end; depth = depth - 5; return; CASE (4): /* Apply state. */ /* . . . */ CASE (5): /* Apply single */ /* . . . */ CASE (6): /* Apply Shared */ /* . . . */ if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output,"#^vx^4i APLY^/",depth,ns); top = top - DPDA.v1(cur_st+1); if (DPDA.v1(cur_st) = 5) then do; ns = DPDA.v2(cur_st+3); goto NEXT; end; else do; if (DPDA.v1(cur_st) = 6) then do; cur_st = DPDA.v2(cur_st+3); end; do i = cur_st+4 to cur_st+DPDA.v2(cur_st); if (DPDA.v1(i) = parse_stack(top)) then do; ns = DPDA.v2(i); goto NEXT; end; end; ns = DPDA.v2(cur_st+3); goto NEXT; end; end; end; %include mrpg_scan; %include mrpg_sem_; end; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */