home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / pascal / qparser.arc / LR1SKEL.PAS < prev    next >
Pascal/Delphi Source File  |  1985-08-12  |  31KB  |  986 lines
  1. { Copyright (C) 1984 by QCAD Systems, Inc., All Rights Reserved }
  2.  
  3. {#P -- program line goes here }
  4. program #(input, output);
  5.  
  6.   { LR1SKEL:
  7.  
  8.       This is a skeleton file for an LALR(1) table-driven parser.
  9.       It is read by the LR1 parser generator and used to
  10.       construct a complete scanner and LALR(1) parser from
  11.       a source grammar.  Semantic actions must be added by
  12.       a user.
  13.  
  14.       Programs generated from this skeleton are compatible with the Turbo
  15.       Pascal compiler (a product of Borland International, Scotts
  16.       Valley, CA).  When using another Pascal, a number of changes
  17.       will probably have to be made.  Here is a partial list of the areas
  18.       that are likely to be affected in such a conversion:
  19.  
  20.          Constant initialization, e.g. the parser tables.  Changes
  21.             in PMACS may be needed.
  22.          File open and close statements.  Look for "assign", "reset",
  23.             "rewrite", and "ioresult" for possible Pascal differences.
  24.          Default CASE statement tag.  The Turbo tag is ELSE;
  25.             we've capitalized the case statement keyword ELSE to
  26.             distinguish it from "else" used in an "if-then-else".
  27.             (Some Pascals use OTHERWISE).
  28.          String operations and functions, also use of + to concatenate
  29.             strings.  Some Pascals have no string declarations or
  30.             functions.  Look for "string", "concat", "fillchar", "pos",
  31.             "copy", etc.
  32.          Predefined type BYTE = 0..255.
  33.          Form of compiler directives, e.g. "$I file" in curly braces.
  34.          Standard file names for the keyboard and console.  Look for
  35.             the names KBD and TRM in the source files.
  36.          Whether an initial READ is required for interactive console
  37.             input.
  38.       }
  39.  
  40.  
  41.   const
  42.     STACKSIZE = 60;   { maximum size of LR(1) parser stack }
  43.     EOS = 0;          { marks end of line in LINE }
  44.     EOFCH = 26;       { reader end-of-file character }
  45.     EOLCH = 12;       { end of line character }
  46.     LINELEN = 80;     { maximum length of a line }
  47.     STRTABLEN = 500;  { maximum number of chars in string table }
  48.     STRING_QUOTE = '''';  { character delimiting quoted strings }
  49.     MAXERRORS = 20;   { maximum errors before aborting }
  50.     HASHSIZE = 67;    { hash table size -- prime number! }
  51.     HLIMIT = 66;      { limit in hash table (hashsize minus one) }
  52.     MAXTOKLEN = 15;   { length of a token or symbol }
  53.  
  54. {#C -- constants defined by the parser generator go here }
  55.     IDENT_TOKLEN = #C;  { maximum user identifier length }
  56.     MAXRPLEN = #D;    { length of longest production right part }
  57.     TERM_TOKS = #E;   { number of terminal tokens }
  58.     NTERM_TOKS = #F;  { number of nonterminal tokens }
  59.     ALL_TOKS = #G;    { term_toks + nterm_toks }
  60.     IDENT_TOKX = #H;  { token number of <identifier> }
  61.     INT_TOKX = #I;    { token number of <integer> }
  62.     REAL_TOKX = #J;   { token number of <real> }
  63.     STR_TOKX = #K;    { token number of <string> }
  64.     STOP_TOKX = #L;   { token number of stopsign (end-of-file) }
  65.     GOAL_TOKX = #M;   { token number of goal }
  66.     EOL_TOKX = #N;    { token number of end-of-line }
  67.     READSTATE = #O;   { first READ state }
  68.     LOOKSTATE = #P;   { first LOOK state }
  69.     MAXSTATE = #Q;    { largest state number }
  70.     REDUCELEN = #R;   { number of productions }
  71.     RLTOKENS = #S;
  72.     SSTOKENS = #T;
  73.     PRODTOKS = #U;
  74.     TOKCHARS = #V;
  75.     START_STATE = #W;  { initial state }
  76.     STK_STATE_1 = #X;  { state initially pushed on stack }
  77. {#> -- end of constants }
  78. {#F -- form for FLAG constants }
  79.     #N = #V;
  80.  
  81.   type
  82.     INT = -32767..32767;
  83.     STRING8 = string[8];
  84.     STRING80 = string[80];
  85.     TOKRANGE = 1..term_toks;
  86.  
  87.     SYMBOL = packed array [1..maxtoklen] of char;
  88.     SYMTYPE = (RESERVED, SYMERR, USER);
  89.     SYMTABP = ^symtabtype;
  90.     SYMTABTYPE = record
  91.                    { structure for <identifier>s and keywords }
  92.                    NEXT: symtabp;
  93.                    LEVEL: int;
  94.                    SYM: symbol;
  95.                    case SYMT: symtype of
  96.                      reserved: (TOKVAL: tokrange);
  97.                      { add more options as needed }
  98.                  end;
  99.     SYMTABNAMES = array [symtype] of string[8];
  100.   const SYMTYPENAME: symtabnames =
  101.                   ('reserved', 'symerr  ', 'user    ');
  102.  
  103.   type
  104.     SEMTYPE = (OTHER, IDENT, FIXED, FLOAT, STRNG);
  105.     SEMRECP = ^semrec;
  106.     SEMREC = record   { semantic stack structure }
  107.                case SEMT: semtype of
  108.                  ident: (SYMP: symtabp);
  109.                  fixed: (NUMVAL: integer);  { fixed point }
  110.                  float: (RVAL: real);   { floating point }
  111.                  strng: (STX: int);  { position in strtab }
  112.                  { Add more options as needed }
  113.              end;
  114.     SEMTABNAMES = array [semtype] of string[5];
  115.   const SEMTYPENAME: semtabnames =
  116.                   ('other', 'ident', 'fixed', 'float', 'strng');
  117.  
  118.   type
  119.     STATE_STACK = array [0..stacksize] of int;
  120.     { Types for parser tables.  NB:  These type names are used by
  121.       the typed constant generation. }
  122.     STATE_ARRAY = array [1..maxstate] of int;
  123.     REDUCE_ARRAY = array [1..reducelen] of int;
  124.     POP_ARRAY = array [1..reducelen] of byte;
  125.     TOKEN_ARRAY = array [0..rltokens] of byte;
  126.     TOSTATE_ARRAY = array [0..rltokens] of int;
  127.     SS_ARRAY = array [0..sstokens] of int;
  128.     PROD_ARRAY = array [1..prodtoks] of byte;
  129.     TOKX_ARRAY = array [1..all_toks] of int;
  130.     TOKCHAR_ARRAY = array [1..tokchars] of char;
  131.     INSYM_ARRAY = array [1..lookstate] of int;
  132.  
  133. {#<C -- put typed constants here, if they've been requested }
  134.   const
  135.     { Static parser data structures (parser tables). }
  136. {#IP}
  137. {#>}
  138.  
  139.   var
  140.     { Dynamic parser data structures }
  141.     STACK:  state_stack;  { the LR(1) state stack }
  142.     SEMSTACK:  array [0..stacksize] of semrecp;  { semantics stack }
  143.     STACKX:  int;  { index of top of stack }
  144.  
  145. {#<~C -- the following are redundant if typed constants are used }
  146.     { Static parser data structures (parser tables). }
  147.     STATEX:  state_array;    { stack top index }
  148.     MAP:  reduce_array;      { mapping from state to apply numbers }
  149.     POPNO:  pop_array;       { reduce pop size }
  150.     TOKNUM:  token_array;    { token list }
  151.     TOSTATE:  tostate_array;  { read, look states }
  152.     STK_STATE:  ss_array;
  153.     STK_TOSTATE: ss_array;
  154. {#<D -- these are for parser stack dumps. }
  155.     PRODX:  reduce_array;    { prod index into ... }
  156.     PRODS:  prod_array;      { token number, index into ... }
  157.     INSYM:  insym_array;
  158. {#> -- end if for debugging. }
  159. {#> -- end if for typed constants. }
  160.  
  161. {#<D -- debugging (these cannot be typed constants.) }
  162.     { These guys are for printing tokens in parser stack dumps. }
  163.     TOKX:  tokx_array;       { token index, index into ... }
  164.     TOKCHAR:  tokchar_array;  { token characters }
  165. {#> -- end if for debugging. }
  166.  
  167.     { Lexical and token data }
  168.     LINE:  string[linelen];  { source line }
  169.     LX:  int;                { index of next character in LINE }
  170.     ERRPOS: int;             { current token position in LINE }
  171.     PROMPT_LEN:int;          { length of prompt string }
  172.     CH:  char;               { next character from input file }
  173.     TOKEN:  int;             { Next token in input list }
  174.     LSEMP:  semrecp;         { current semantics assoc. with token }
  175.     TOKENX:  int;            { index into TOKARY, LSEMPARY }
  176.     TOKARY:  array [0..1] of int;  { token queue }
  177.     LSEMPARY:  array [0..1] of semrecp;
  178.     ERRSYM:  symbol;        { special symbol reserved for errors }
  179.     { The next table can be omitted if real numbers are not used. }
  180.     PWR10_2:  array [0..8] of real;  { Binary powers of ten. }
  181.  
  182.     { Symbol table data }
  183.     SYMTAB: array [0..hlimit] of symtabp;
  184.     STRTAB: packed array [0..strtablen] of char;
  185.     STRTABX: int;
  186.  
  187.     SFILE, RFILE: text;      { source, report files }
  188.     SFILENAME, RFILENAME: string80;  { source, report file name }
  189.     TFILE: file of int;      { sometimes used for table inits }
  190.  
  191.     ERRORS: int;
  192.     DEBUG: int;              { >0 turns on some tracing }
  193.  
  194. { GENERAL UTILITIES }
  195.  
  196.   {*********************}
  197.   function RESP(MSG: string80):  char;
  198.     { print a message and return a single character response. }
  199.     var CH: char;
  200.   begin
  201.     write(msg);
  202.     read(kbd, ch);
  203.     writeln(ch);
  204.     resp := ch
  205.   end;
  206.  
  207.   {*********************}
  208.   function YESRESP (MSG: string80): boolean;
  209.     { query with a Y or N reply }
  210.     var CH: char;
  211.   begin
  212.     ch := resp(msg);
  213.     yesresp := (ch='y') or (ch='Y');
  214.   end;
  215.  
  216.   {******************}
  217.   procedure MORE(MSG: string80);
  218.     { print the string, and let the user type
  219.       any character to proceed. }
  220.     var FOO:  char;
  221.   begin
  222.     foo := resp(msg)
  223.   end;
  224.  
  225.   {******************}
  226.   procedure REPORT_ERR(MSG: string80);
  227.   begin
  228.     if errpos+prompt_len>1 then
  229.       write(rfile, ' ':errpos+prompt_len-1);
  230.     writeln(rfile, '^');  { mark error point }
  231.     writeln(rfile, 'ERROR: ', msg);
  232.     errors := errors+1;
  233.   end;
  234.  
  235.   {*******************}
  236.   procedure ABORT(MSG: string80);
  237.   begin
  238.     report_err(msg);
  239.     while true do more('FATAL -- PLEASE ABORT:')
  240.   end;
  241.  
  242.   {******************}
  243.   procedure ERROR(MSG: string80);
  244.   begin
  245.     report_err(msg);
  246.     if errors>maxerrors then abort('Error limit exceeded');
  247.     more('Type any character to continue:')
  248.   end;
  249.  
  250.   {*****************}
  251.   function UPSHIFT(CH: char): char;
  252.   begin
  253.     if (ch>='a') and (ch<='z') then
  254.       upshift := chr(ord(ch) - ord('a') + ord('A'))
  255.     else
  256.       upshift := ch
  257.   end;
  258.  
  259.   {$I skelsyms.pas}
  260.  
  261. {#<D -- debugging utilities. }
  262.   {$I skeldbug.pas}
  263.  
  264. {#> -- end debugging stuff. }
  265. { LEXICAL ANALYZER }
  266.  
  267.   {*******************}
  268.   procedure GETLINE;
  269.     { read the next source line, when nextch exhausts
  270.       the current one. }
  271.  
  272.     {.............}
  273.     procedure GENEOF;
  274.     begin
  275.       line := chr(eofch);
  276.       lx := 1
  277.     end;
  278.  
  279.     {............}
  280.     procedure GRABLINE;
  281.     begin
  282.       readln(sfile, line);
  283.       writeln(rfile, line);
  284.       lx := 1
  285.     end;
  286.  
  287.   begin { getline }
  288.     if sfilename='' then begin
  289.       { prompt if from the console file }
  290.       write('> ');
  291.       grabline;
  292.       if line = 'EOF' then geneof
  293.       end
  294.     else if eof(sfile) then
  295.       geneof
  296.     else
  297.       grabline;
  298. {#<E -- the line ending gets treated differently here. }
  299.     { The appended blank allows a reduction containing <EOL> to take
  300.       place before reading another line.  This behavior is essential
  301.       for interactive systems, and makes no difference in batch. }
  302.     line := line+chr(eolch)+' '
  303. {#: -- case where <EOL> is not significant. }
  304.     { The appended eol character ensures that tokens are broken over
  305.       line endings; they would otherwise be invisible to the scanner.
  306.       eolch allows the string scanner to distinguish ends of lines. }
  307.     line := line+chr(eolch)
  308. {#> -- end of eol business. }
  309.   end;
  310.  
  311.   {*******************}
  312.   procedure NEXTCH;
  313.     { gets next character from line }
  314.   begin
  315.     if lx > length(line) then
  316.       getline;
  317.     ch := line[lx];
  318.     { don't move past an eof mark }
  319.     if ch <> chr(eofch) then lx := lx+1
  320.   end;
  321.  
  322. {#<~E -- Pick a blank skipper, depending on appearance of <eol> }
  323.   {********************}
  324.   procedure SKIPBLANKS;  { when <eol> has NOT appeared }
  325.     { This considers left brace as an open comment and right brace
  326.       as a close-comment; comments may run over multiple lines. }
  327.   begin
  328.     repeat
  329.       while ch = ' ' do nextch;
  330.       if ch='{' then begin  { open a comment }
  331.         while (ch <> '}') and (ch <> chr(eofch)) do nextch;
  332.         if ch=chr(eofch) then
  333.           error('unclosed comment')
  334.         else
  335.           nextch
  336.       end
  337.     until ch <> ' '
  338.   end;
  339.  
  340. {#: -- the second choice}
  341.   {********************}
  342.   procedure SKIPBLANKS;  { when <eol> HAS appeared }
  343.     { This version of skipblanks treats everything from OC to the
  344.       end of a line as a comment. }
  345.     const OC= ';';
  346.   begin
  347.     while ch=' ' do nextch;
  348.     if ch=oc then while ch<>chr(eolch) do nextch
  349.   end;
  350.  
  351. {#> -- end of the selection}
  352.   {********************}
  353.   procedure PUTSTRCH(CH: char);
  354.   begin
  355.     if strtabx>strtablen then
  356.       abort('String table overflow ... please abort');
  357.     strtab[strtabx] := ch;
  358.     strtabx := strtabx+1;
  359.   end;
  360.  
  361.   {******************}
  362.   procedure PUTSTR(STR: string80);
  363.     var SX: int;
  364.   begin
  365.     for sx := 1 to length(str) do putstrch(str[sx]);
  366.     putstrch(chr(eos));
  367.   end;
  368.  
  369.   {****************}
  370.   procedure GET_SYMBOL;
  371.     var SX: int;
  372.         SYM: symbol;
  373.         STP: symtabp;
  374.   begin
  375.     fillchar(sym, maxtoklen, ' ');
  376.     sx := 1;
  377.     { keep snarfing alphanumeric characters.  up to the first
  378.       maxtoklen of them will be put in the symbol spelling. }
  379.     while ((ch>='a') and (ch<='z')) or
  380.           ((ch>='A') and (ch<='Z')) or
  381.           ((ch>='0') and (ch<='9')) or
  382.           (ch='_') do begin
  383.       if sx <= maxtoklen then
  384.         sym[sx] := upshift(ch);
  385.       sx := sx+1;
  386.       nextch;
  387.     end;
  388.     stp := makesym(sym, user, 0);  { the default level is 0 }
  389.     with lsemp^ do begin
  390.       if stp^.symt=reserved then begin
  391.         { a reserved keyword }
  392.         semt := other;
  393.         token := stp^.tokval;
  394.       end
  395.       else begin
  396.         semt := ident;
  397.         symp := stp;
  398.         token := ident_tokx;
  399.       end
  400.     end
  401.   end;
  402.  
  403.   {$I skelnum.pas}   { Number scanning }
  404.  
  405.   {*****************}
  406.   procedure GET_STRING;
  407.     { Scans a string, putting it into the string table, and setting
  408.       up the semantic record for it correctly.  Removing the "and
  409.       (ch <> chr(eolch))" clause in the WHILE loop below will allow
  410.       strings to run over the end of a line by storing embedded
  411.       eolch's.  However, this could have unpleasant consequences for
  412.       languages with <eol> in the grammar.  See the comments at the
  413.       end of getline. }
  414.     var END_OF_STRING:  boolean;
  415.   begin
  416.     nextch;  { get past the first quote mark }
  417.     lsemp^.semt := strng;
  418.     lsemp^.stx := strtabx;
  419.     repeat
  420.       while (ch <> chr(eofch)) and (ch <> chr(eolch))
  421.             and (ch <> string_quote) do begin
  422.         putstrch(ch);
  423.         nextch
  424.       end;
  425.       end_of_string := true;
  426.       { peek ahead a bit to see if there's a doubled quote }
  427.       if ch = string_quote then begin
  428.         nextch;
  429.         if ch = string_quote then begin
  430.           end_of_string := false;
  431.           putstrch(ch);
  432.           nextch
  433.         end
  434.       end
  435.       else if (ch = chr(eofch)) or (ch = chr(eolch)) then begin
  436.         error('unterminated string')
  437.       end
  438.     until end_of_string;
  439.     putstrch(chr(eos));
  440.     token := str_tokx;
  441.   end;
  442.  
  443.   {********************}
  444.   procedure GET_TOKEN;
  445.     { Pascal-style lexical analyzer -- sets TOKEN to token number }
  446.   begin
  447.     lsemp^.semt := other;  { default case }
  448.     skipblanks;
  449.     errpos:=lx-1;
  450.     case ch of
  451.       'a'..'z', 'A'..'Z': get_symbol;
  452.       '0'..'9':           get_number;
  453.       string_quote:       get_string;
  454. {#<D -- if debugging, invoke idebug on a bang (or other char). }
  455.       '!':  begin
  456.               idebug;
  457.               nextch;
  458.               get_token
  459.             end;
  460. {#>}
  461. {#G   special symbol cases go here }
  462.       ELSE  begin
  463.               if ch=chr(eofch) then
  464.                 token := stop_tokx
  465.               else if ch=chr(eolch) then begin
  466.                 nextch;
  467. {#<E            end-of-line token dealt with here }
  468.                 token := eol_tokx  { accept an end-of-line token }
  469. {#:}
  470.                 get_token  { go find another (significant) character }
  471. {#>}
  472.               end
  473.               else begin
  474.                 error('illegal character');
  475.                 nextch;
  476.                 get_token  { try again }
  477.               end
  478.             end { case alternatives }
  479.     end { case }
  480.   end { get_token };
  481.  
  482.   {*******************}
  483.   procedure NEXT_TOKEN;
  484.   begin
  485.     if tokenx>1 then begin
  486.       tokenx := 1;
  487.       get_token;  { goes into token, lsemp }
  488.       tokary[1] := token;
  489.       lsempary[1] := lsemp;
  490.     end
  491.     else begin
  492.       { is in tokary }
  493.       token := tokary[tokenx];
  494.       lsemp := lsempary[tokenx];
  495.     end
  496.   end;
  497.  
  498.   {*****************}
  499.   procedure TOKENREAD;
  500.   begin
  501.     tokenx := tokenx+1;
  502.   end;
  503.  
  504.   { LR(1) PARSER procedures }
  505.  
  506.   {*********************}
  507.   procedure APPLY(PFLAG, PRODLEN: int; TSEMP: semrecp);
  508.   begin
  509. {#A -- create an APPLY body }
  510.   end;
  511.  
  512.   {******************}
  513.   procedure INIT_SEM;
  514.     { Semantics initialization -- called before any productions
  515.       are applied. }
  516.   begin
  517.     writeln(rfile, 'Semantics initialized.')
  518.   end;
  519.  
  520.   {******************}
  521.   procedure END_SEM;
  522.     { Semantics conclusion -- called after the GOAL
  523.       production is applied. }
  524.   begin
  525.     writeln(rfile, 'Semantics concluded.')
  526.   end;
  527.  
  528.   {****************}
  529.   function ERROR_RECOVERY(var MSTACK: state_stack;
  530.                           var MSTACKX: int; MCSTATE: int): int;
  531.     label 99, 100;
  532.     var STACK: state_stack;  { local copy of stack }
  533.         STACKX,              { local stack pointer }
  534.         CSTATE,              { local state }
  535.         JSTX,                { temporary stack limit }
  536.         RX, TL: int;         { index into TOKNUM table }
  537.  
  538.     {...............}
  539.     procedure COPY_STACK;
  540.       var STX: int;
  541.     begin
  542.       if (jstx<0) or (jstx>mstackx) then abort('ERROR RECOVERY BUG');
  543.       for stx := 0 to jstx do
  544.         stack[stx] := mstack[stx];
  545.       stackx := jstx;
  546.       if jstx=mstackx then
  547.         cstate := mcstate
  548.       else
  549.         cstate := mstack[jstx+1];
  550.     end;
  551.  
  552.     {...............}
  553.     procedure PUSHREAD(CSTATE: int);
  554.       { adjusts the state stack }
  555.     begin
  556.       stackx := stackx+1;
  557.       if stackx>stacksize then
  558.         abort('stack overflow');
  559.       stack[stackx] := cstate;
  560.     end;
  561.  
  562.     {...............}
  563.     function TRIAL_PARSE: boolean;
  564.       { parses from current read state through the inserted and the
  565.         error token; if successful, returns TRUE. }
  566.       label 99;
  567.       var RX: int;
  568.     begin
  569.       trial_parse := true;  { until proven otherwise }
  570.       while cstate<>0 do begin
  571.         if cstate < readstate then begin
  572.           { a reduce state }
  573. {#<D      dump if debugging enabled. }
  574.           if debug > 3 then stk_dump('E*Reduce', stack,
  575.                                      stackx, cstate);
  576. {#>       end conditional. }
  577.           if popno[cstate]=0 then begin
  578.             { empty production }
  579.             pushread(stk_state[statex[cstate]]);
  580.             cstate := stk_tostate[statex[cstate]];
  581.           end
  582.           else begin
  583.             { non-empty production }
  584.             stackx := stackx - popno[cstate] + 1;
  585.             rx := statex[cstate];   { compute the GOTO state }
  586.             cstate := stack[stackx];
  587.             while (stk_state[rx]<>cstate) and
  588.                   (stk_state[rx]<>0) do rx := rx+1;
  589.             cstate := stk_tostate[rx];
  590.           end
  591.         end
  592.         else if cstate < lookstate then begin
  593.           { a read state }
  594.           next_token;  { need a token now }
  595. {#<D      dump if debugging enabled. }
  596.           if debug > 3 then stk_dump('E*Read', stack, stackx, cstate);
  597. {#>       end conditional. }
  598.           rx := statex[cstate];
  599.           while (toknum[rx]<>0) and
  600.                 (toknum[rx]<>token) do rx := rx+1;
  601.           if toknum[rx]=0 then begin
  602.             { failure }
  603.             trial_parse := false;
  604.             goto 99;
  605.           end
  606.           else begin
  607.             { did read something }
  608.             pushread(cstate);
  609.             cstate := tostate[rx];
  610.             tokenread;  { scan the token }
  611.             if tokenx>1 then goto 99 { successful }
  612.           end
  613.         end
  614.         else begin
  615.           { lookahead state }
  616.           next_token;  { need a token now }
  617. {#<D      dump if debugging enabled. }
  618.           if debug > 3 then stk_dump('E*Look', stack, stackx, cstate);
  619. {#>       end conditional. }
  620.           rx := statex[cstate];
  621.           while (toknum[rx]<>0) and
  622.                 (toknum[rx]<>token) do rx := rx+1;
  623.           cstate := tostate[rx];
  624.         end
  625.       end;
  626.     99:
  627.     end;
  628.  
  629.     {.................}
  630.     procedure INCR_ERRSYM;
  631.       { Note that this procedure assumes ASCII. }
  632.     begin
  633.       if errsym[6]='Z' then begin
  634.         errsym[5] := succ(errsym[5]);
  635.         errsym[6] := 'A';
  636.       end
  637.       else
  638.         errsym[6] := succ(errsym[6]);
  639.     end;
  640.  
  641.     {.................}
  642.     procedure MAKE_DEFAULT(TOKX: int; SEMP: semrecp);
  643.       { creates a default token data structure }
  644.       var SYM: symbol;
  645.     begin
  646.       with semp^ do begin
  647.         case tokx of
  648.           int_tokx:
  649.             begin
  650.               semt := fixed;
  651.               numval := 1;
  652.             end;
  653.           real_tokx:
  654.             begin
  655.               semt := float;
  656.               rval := 1.0;
  657.             end;
  658.           ident_tokx:
  659.             begin
  660.               semt := ident;
  661.               symp := makesym(errsym, symerr, 0);
  662.               incr_errsym;
  663.             end;
  664.           str_tokx:
  665.             begin
  666.               semt := strng;
  667.               stx := 0;  { default string at origin }
  668.             end;
  669.           ELSE
  670.             semt := other;
  671.         end { case tokx }
  672.       end
  673.     end;
  674.  
  675.   begin  { ERROR_RECOVERY }
  676.     if debug > 3 then writeln(rfile, 'Going into ERROR RECOVERY');
  677.     while true do begin
  678.       jstx := mstackx;
  679.       while jstx>=0 do begin
  680.         copy_stack;
  681.         rx := statex[cstate];
  682.         while toknum[rx]<>0 do begin
  683.           { scan through legal next tokens }
  684.           if debug > 3 then writeln(rfile, '...starting trial parse');
  685.           tokary[0] := toknum[rx];  { the insertion }
  686.           tokenx := 0;
  687.           if trial_parse then goto 99;  { it clicked! }
  688.           rx := rx+1;
  689.           if toknum[rx]<>0 then
  690.             copy_stack;
  691.         end;
  692.         jstx := jstx-1;  { reduce stack }
  693.       end;
  694.       if token=stop_tokx then begin
  695.         { empty stack, no more tokens }
  696.         cstate := 0;  { halt state }
  697.         tokenx := 2;
  698.         jstx := 0;  { bottom of stack }
  699.         goto 100;
  700.       end;
  701. {#<D}
  702.       if debug > 3 then begin
  703.         write(rfile, '...dropping token ');
  704.         tl := wrtok(tokary[1]);
  705.         writeln(rfile);
  706.       end;
  707. {#>}
  708.       tokenx := 2;
  709.       next_token;
  710. {#<D}
  711.       if debug > 3 then begin
  712.         write(rfile, 'New token ');
  713.         tl := wrtok(token);
  714.         writeln(rfile);
  715.       end
  716. {#>}
  717.     end;
  718.   99:  { found a solution }
  719.     copy_stack;
  720. {#<D}
  721.     if debug > 3 then begin
  722.       write(rfile, 'insertion of ');
  723.       tl := wrtok(tokary[0]);
  724.       writeln(rfile, ' succeeded');
  725.     end;
  726. {#>}
  727.     make_default(tokary[0], lsempary[0]);
  728.     tokenx := 0;  { forces a `real' rescan of the insertion }
  729.     if jstx<mstackx then
  730.       cstate := stack[jstx+1]
  731.     else
  732.       cstate := mcstate;  { cstate returned }
  733.   100:
  734.     error_recovery := cstate;
  735.     mstackx := jstx;
  736.     if debug > 3 then writeln(rfile, 'Ending error recovery');
  737.   end;
  738.  
  739.   {****************}
  740.   procedure PARSER;
  741.     { Carries out a complete parse, until
  742.       the halt state is seen -- same as empty stack}
  743.     var CSTATE, RX: int;
  744.         TSEMP: semrecp;
  745.  
  746.     {...............}
  747.     procedure PUSHREAD(CSTATE: int; SEMP: semrecp);
  748.       { do the push part of a readstate. }
  749.     begin
  750.       stackx := stackx+1;
  751.       if stackx>stacksize then
  752.         abort('stack overflow');
  753.       semstack[stackx]^ := semp^;
  754.       stack[stackx] := cstate;
  755.     end;
  756.  
  757.   begin
  758.     cstate := start_state;
  759.     stackx := -1;
  760.     new(tsemp);
  761.     tsemp^.semt := other;
  762.     pushread(stk_state_1, tsemp);
  763.     while cstate<>0 do begin
  764.       if cstate < readstate then begin
  765.         { a reduce state }
  766. {#<D    dump if debugging enabled. }
  767.         if debug > 0 then stk_dump('Reduce', stack, stackx, cstate);
  768. {#>     end conditional. }
  769.         if map[cstate] <> 0 then
  770.           { the semantics action }
  771.           apply(map[cstate], popno[cstate], tsemp);
  772.         if popno[cstate]=0 then begin
  773.           { empty production }
  774.           pushread(stk_state[statex[cstate]], tsemp);
  775.           cstate := stk_tostate[statex[cstate]];
  776.         end
  777.         else begin
  778.           { non-empty production:
  779.             semantics is preserved on a unit production A --> w,
  780.             where |w| = 1, unless something is in TSEMP.  Note that
  781.             if w is nonterminal, the production may be bypassed. }
  782.           stackx := stackx - popno[cstate] + 1;
  783.           if popno[cstate]=1 then begin
  784.             if tsemp^.semt<>other then
  785.               semstack[stackx]^ := tsemp^;
  786.           end
  787.           else
  788.             semstack[stackx]^ := tsemp^;
  789.           { compute the GOTO state }
  790.           rx := statex[cstate];
  791.           cstate := stack[stackx];
  792.           while (stk_state[rx]<>cstate) and (stk_state[rx]<>0) do
  793.             rx := rx+1;
  794.           cstate := stk_tostate[rx];
  795.         end;
  796.         tsemp^.semt := other;
  797.       end
  798.       else if cstate < lookstate then begin
  799.         { a read state }
  800.         next_token;  { need next token now }
  801. {#<D    dump if debugging enabled. }
  802.         if debug > 2 then stk_dump('Read', stack, stackx, cstate);
  803. {#>     end conditional. }
  804.         rx := statex[cstate];
  805.         while (toknum[rx]<>0) and (toknum[rx]<>token) do
  806.           rx := rx+1;
  807.         if toknum[rx]=0 then begin
  808.           error('syntax error');
  809.           cstate := error_recovery(stack, stackx, cstate);
  810.         end
  811.         else begin
  812.           pushread(cstate, lsemp);
  813.           cstate := tostate[rx];
  814.           tokenread;  { token has been scanned }
  815.         end
  816.       end
  817.       else begin
  818.         { lookahead state }
  819.         next_token;  { need another token now }
  820. {#<D    dump if debugging enabled. }
  821.         if debug > 2 then stk_dump('Look', stack, stackx, cstate);
  822. {#>     end conditional. }
  823.         rx := statex[cstate];
  824.         while (toknum[rx]<>0) and (toknum[rx]<>token) do
  825.           rx := rx+1;
  826.         cstate := tostate[rx];
  827.       end
  828.     end;
  829.     end_sem;
  830.   end;
  831.  
  832.   { PARSE INITIALIZATION }
  833.  
  834.   {*****************}
  835.   procedure INITTABLES;
  836.     var SX: int;
  837.  
  838. {#<F import the table file reading function if needed. }
  839.        {$I skelrtbl.pas}
  840. {#<D   debugging wanted, too?
  841.          {$I skeldtbl.pas}
  842. {#>    end debugging }
  843. {#:  else include the auxiliary functions needed by inline inits. }
  844.     {................}
  845.     procedure PUTSYM(STR: string80; TV: int);
  846.       var SYMP: symtabp;
  847.           TSYM: symbol;
  848.           I: int;
  849.     begin
  850.       fillchar(tsym, maxtoklen, ' ');
  851.       for i:=1 to length(str) do
  852.         tsym[i]:=str[i];
  853.       symp:=makesym(tsym, reserved, -1);
  854.       symp^.tokval:=tv;
  855.     end;
  856.  
  857. {#<D   also need to init debugging tables? }
  858.     {................}
  859.     procedure PUTTOK(PRINTVAL: string80;  TOKNUM, START: int);
  860.       { this procedure is used to initialize the token tables.
  861.         toknum is the number of the token to be initialized, and
  862.         start is where it should start in the tokchar array. }
  863.       var OFFSET:  int;
  864.     begin
  865.       tokx[toknum] := start;
  866.       for offset := 0 to length(printval)-1 do
  867.         tokchar[start+offset] := printval[offset+1];
  868.       tokchar[start+length(printval)] := chr(0)
  869.     end;
  870. {#>    end puttok insertion. }
  871. {#>  end table file conditional. }
  872.  
  873.     {................}
  874.     procedure INIT_PARSER_TABLES;
  875.       { initialize the parser tables }
  876.     begin
  877. {#<F  read from a table file? }
  878. {#T     insert table file name in next line. }
  879.         assign(tfile, '#');
  880.         reset(tfile);
  881.         read_header;
  882.         read_table_file;
  883. {#<D    take debugging info from the table file? }
  884.           read_debugging_tables;
  885. {#>     end if. }
  886.         close(tfile)
  887. {#:   not a table file; do the necessary inline inits }
  888. {#IS    inline symbol table inits. }
  889. {#<A    assignment style inits? }
  890. {#IP      do the parser tables inline. }
  891. {#>     end assignment inits. }
  892. {#<D    debugging? }
  893. {#IT      do the token tables inline. }
  894. {#>     end debugging }
  895. {#>   end of initialization style selection. }
  896.     end { init_parser_tables };
  897.  
  898.   begin { inittables }
  899.     pwr10_2[0] := 1E1;  {10^(2^0)}
  900.     pwr10_2[1] := 1E2;  {10^(2^1)}
  901.     pwr10_2[2] := 1E4;
  902.     pwr10_2[3] := 1E8;
  903.     pwr10_2[4] := 1E16;
  904.     pwr10_2[5] := 1E32;
  905.     errsym := 'ERR#AA         ';
  906.     new(lsempary[0]);
  907.     lsempary[0]^.semt := other;
  908.     new(lsempary[1]);
  909.     lsempary[1]^.semt := other;
  910.     lsemp := lsempary[1];
  911.     strtabx := 0;
  912.     putstr('ERROR');  { default error string }
  913.     tokenx := 2;  { no token queue }
  914.     for sx := 0 to hlimit do
  915.       symtab[sx] := nil;  { initialize symbol table }
  916.     for sx := 0 to stacksize do begin
  917.       new(semstack[sx]);
  918.       semstack[sx]^.semt := other;
  919.     end;
  920.     init_parser_tables;
  921.     init_sem;
  922.     line := '';  { fake a new line }
  923.     lx := 1;
  924.     errpos:=1;
  925.     nextch;  { fetch the first character, forcing a line read }
  926.   end;
  927.  
  928.   {$I-}
  929.   {*****************}
  930.   procedure OPENFILES;
  931.     { opens source and listing files. }
  932.     var SUCCESS:  boolean;
  933.   begin
  934.     { first, get the source file }
  935.     repeat
  936.       write('What source file? ');
  937.       readln(sfilename);
  938.       if sfilename = '' then begin
  939.         prompt_len:=2;
  940.         assign(sfile, 'con:')
  941.         end
  942.       else begin
  943.         prompt_len:=0;
  944.         assign(sfile, sfilename);
  945.         end;
  946.       reset(sfile);
  947.       success := (ioresult = 0);
  948.       if not success then
  949.         writeln('file doesn''t exist; try again')
  950.     until success;
  951.     { now, get the report file }
  952.     repeat
  953.       write('What report file? ');
  954.       readln(rfilename);
  955.       if rfilename = '' then
  956.         rfilename := 'con:';
  957.       success := true;
  958.       assign(rfile, rfilename);
  959.       if rfilename[length(rfilename)] <> ':' then begin
  960.         reset(rfile);
  961.         success := (ioresult <> 0);
  962.         close(rfile);
  963.         if not success then begin
  964.           success := yesresp('..already exists, purge it? ');
  965.           if success then erase(rfile)
  966.         end
  967.       end
  968.     until success;
  969.     rewrite(rfile)
  970.   end;
  971.   {$I+}
  972.  
  973. begin
  974. {#P -- put the program name here, too. }
  975.   writeln('# [an LALR(1) parser vs. 1-Mar-85]');
  976.   writeln;
  977.   errors := 0;
  978.   debug := 0;
  979.   openfiles;
  980.   inittables;
  981.   parser;  { does it all }
  982.   close(sfile);
  983.   close(rfile)
  984. end.
  985.  
  986.