{ Copyright (C) 1984, 1985, 1986 by QCAD Systems, Inc.,
  All Rights Reserved }

{#P -- program line goes here }
program #(input, output);

  { LR1SKEL:

      This is a skeleton file for an LALR(1) table-driven parser for
      use with QPARSER.  It is read by the LR1P program generator
      and used to construct a complete scanner and LALR(1) parser
      from a grammar table file.  Semantic actions must be added
      by the user.

      The created program asks for source and report files.  You
      may use file names, or just press return to use the console.
      Note, though, that the output may be buffered in either case.

      Programs generated from this skeleton are compatible with the
      Turbo Pascal compiler (Borland International, Scotts Valley, CA)
      on the IBM PC, and DEC Pascal (Digital Equipment Corp.) on the VAX.
      When using another Pascal, a number of changes may have to be made.
      Here is a partial list of the areas that are likely to be affected
      in such a conversion:

         Constant initialization, e.g. the parser tables.  Changes
            in PMACS may be needed.
         File open and close statements.  Look for "assign", "reset",
            "rewrite", and "ioresult" for possible Pascal differences.
         Default CASE statement tag.  The Turbo tag is ELSE;
            we've capitalized the case statement keyword ELSE to
            distinguish it from "else" used in an "if-then-else".
            (Some Pascals use OTHERWISE).
         String operations and functions, also use of + to concatenate
            strings.  Some Pascals have no string declarations or
            functions.  Look for "string", "concat", "fillchar", "pos",
            "copy", etc.
         Predefined type BYTE = 0..255.
         Form of compiler directives, e.g. "$I file" in curly braces.
         Standard file names for the keyboard and console.  Look for
            the names KBD and TRM in the source files.
         Whether an initial READ is required for interactive console
            input.
      }


  const
    STACKSIZE = 60;   { maximum size of LR(1) parser stack }
    EOS = 0;          { marks end of line in LINE }
    EOFCH = 26;       { reader end-of-file character }
    EOLCH = 12;       { end of line character }
    LINELEN = 80;     { maximum length of a line }
    STRTABLEN = 500;  { maximum number of chars in string table }
    STRING_QUOTE = '''';  { character delimiting quoted strings }
    MAXERRORS = 20;   { maximum errors before aborting }
    HASHSIZE = 67;    { hash table size -- prime number! }
    HLIMIT = 66;      { limit in hash table (hashsize minus one) }
    MAXTOKLEN = 15;   { length of a token or symbol }

{#C -- constants defined by the parser generator go here }
    IDENT_TOKLEN = #C;  { maximum user identifier length }
    MAXRPLEN = #D;    { length of longest production right part }
    TERM_TOKS = #E;   { number of terminal tokens }
    NTERM_TOKS = #F;  { number of nonterminal tokens }
    ALL_TOKS = #G;    { term_toks + nterm_toks }
    IDENT_TOKX = #H;  { token number of <identifier> }
    INT_TOKX = #I;    { token number of <integer> }
    REAL_TOKX = #J;   { token number of <real> }
    STR_TOKX = #K;    { token number of <string> }
    STOP_TOKX = #L;   { token number of stopsign (end-of-file) }
    GOAL_TOKX = #M;   { token number of goal }
    EOL_TOKX = #N;    { token number of end-of-line }
    READSTATE = #O;   { first READ state }
    LOOKSTATE = #P;   { first LOOK state }
    MAXSTATE = #Q;    { largest state number }
    REDUCELEN = #R;   { number of productions }
    RLTOKENS = #S;
    SSTOKENS = #T;
    PRODTOKS = #U;
    TOKCHARS = #V;
    START_STATE = #W;  { initial state }
    STK_STATE_1 = #X;  { state initially pushed on stack }
{#> -- end of constants }
{#F -- form for FLAG constants }
    #N = #V;

  type
    INT = -32767..32767;
    STRING8 = string[8];
    STRING80 = string[80];
    TOKRANGE = 1..term_toks;

    SYMBOL = packed array [1..maxtoklen] of char;
    SYMTYPE = (RESERVED, SYMERR, USER);
    SYMTABP = ^symtabtype;
    SYMTABTYPE = record
                   { structure for <identifier>s and keywords }
                   NEXT: symtabp;
                   LEVEL: int;
                   SYM: symbol;
                   case SYMT: symtype of
                     reserved: (TOKVAL: tokrange);
                     { add more options as needed }
                 end;
    SYMTABNAMES = array [symtype] of string[8];
  const SYMTYPENAME: symtabnames =
                  ('reserved', 'symerr  ', 'user    ');

  type
    SEMTYPE = (OTHER, IDENT, FIXED, FLOAT, STRNG);
    SEMRECP = ^semrec;
    SEMREC = record   { semantic stack structure }
               case SEMT: semtype of
                 ident: (SYMP: symtabp);
                 fixed: (NUMVAL: integer);  { fixed point }
                 float: (RVAL: real);   { floating point }
                 strng: (STX: int);  { position in strtab }
                 { Add more options as needed }
             end;
    SEMTABNAMES = array [semtype] of string[5];
  const SEMTYPENAME: semtabnames =
                  ('other', 'ident', 'fixed', 'float', 'strng');

  type
    STATE_STACK = array [0..stacksize] of int;
    { Types for parser tables.  NB:  These type names are used by
      the typed constant generation. }
    STATE_ARRAY = array [1..maxstate] of int;
    REDUCE_ARRAY = array [1..reducelen] of int;
    POP_ARRAY = array [1..reducelen] of byte;
    TOKEN_ARRAY = array [0..rltokens] of byte;
    TOSTATE_ARRAY = array [0..rltokens] of int;
    SS_ARRAY = array [0..sstokens] of int;
    PROD_ARRAY = array [1..prodtoks] of byte;
    TOKX_ARRAY = array [1..all_toks] of int;
    TOKCHAR_ARRAY = array [1..tokchars] of char;
    INSYM_ARRAY = array [1..lookstate] of int;

{#<C -- put typed constants here, if they've been requested }
  const
    { Static parser data structures (parser tables). }
{#IP}
{#>}

  var
    { Dynamic parser data structures }
    STACK:  state_stack;  { the LR(1) state stack }
    SEMSTACK:  array [0..stacksize] of semrecp;  { semantics stack }
    STACKX:  int;  { index of top of stack }

{#<~C -- the following are redundant if typed constants are used }
    { Static parser data structures (parser tables). }
    STATEX:  state_array;    { stack top index }
    MAP:  reduce_array;      { mapping from state to apply numbers }
    POPNO:  pop_array;       { reduce pop size }
    TOKNUM:  token_array;    { token list }
    TOSTATE:  tostate_array;  { read, look states }
    STK_STATE:  ss_array;
    STK_TOSTATE: ss_array;
{#<D -- these are for parser stack dumps. }
    PRODX:  reduce_array;    { prod index into ... }
    PRODS:  prod_array;      { token number, index into ... }
    INSYM:  insym_array;
{#> -- end if for debugging. }
{#> -- end if for typed constants. }

{#<D -- debugging (these cannot be typed constants.) }
    { These guys are for printing tokens in parser stack dumps. }
    TOKX:  tokx_array;       { token index, index into ... }
    TOKCHAR:  tokchar_array;  { token characters }
{#> -- end if for debugging. }

    { Lexical and token data }
    LINE:  string[linelen];  { source line }
    LX:  int;                { index of next character in LINE }
    ERRPOS: int;             { current token position in LINE }
    PROMPT_LEN:int;          { length of prompt string }
    CH:  char;               { next character from input file }
    TOKEN:  int;             { Next token in input list }
    LSEMP:  semrecp;         { current semantics assoc. with token }
    TOKENX:  int;            { index into TOKARY, LSEMPARY }
    TOKARY:  array [0..1] of int;  { token queue }
    LSEMPARY:  array [0..1] of semrecp;
    ERRSYM:  symbol;        { special symbol reserved for errors }
    { The next table can be omitted if real numbers are not used. }
    PWR10_2:  array [0..8] of real;  { Binary powers of ten. }

    { Symbol table data }
    SYMTAB: array [0..hlimit] of symtabp;
    STRTAB: packed array [0..strtablen] of char;
    STRTABX: int;

    SFILE, RFILE: text;      { source, report files }
    SFILENAME, RFILENAME: string80;  { source, report file name }
    TFILE: file of int;      { sometimes used for table inits }

    ERRORS: int;
    DEBUG: int;              { >0 turns on some tracing }

{ GENERAL UTILITIES }

  {*********************}
  function RESP(MSG: string80):  char;
    { print a message and return a single character response. }
    var CH: char;
  begin
    write(msg);
    read(kbd, ch);
    writeln(ch);
    resp := ch
  end;

  {*********************}
  function YESRESP (MSG: string80): boolean;
    { query with a Y or N reply }
    var CH: char;
  begin
    ch := resp(msg);
    yesresp := (ch='y') or (ch='Y');
  end;

  {******************}
  procedure MORE(MSG: string80);
    { print the string, and let the user type
      any character to proceed. }
    var FOO:  char;
  begin
    foo := resp(msg)
  end;

  {******************}
  procedure REPORT_ERR(MSG: string80);
  begin
    if errpos+prompt_len>1 then
      write(rfile, ' ':errpos+prompt_len-1);
    writeln(rfile, '^');  { mark error point }
    writeln(rfile, 'ERROR: ', msg);
    errors := errors+1;
  end;

  {*******************}
  procedure ABORT(MSG: string80);
  begin
    report_err(msg);
    while true do more('FATAL -- PLEASE ABORT:')
  end;

  {******************}
  procedure ERROR(MSG: string80);
  begin
    report_err(msg);
    if errors>maxerrors then abort('Error limit exceeded');
    more('Type any character to continue:')
  end;

  {*****************}
  function UPSHIFT(CH: char): char;
  begin
    if (ch>='a') and (ch<='z') then
      upshift := chr(ord(ch) - ord('a') + ord('A'))
    else
      upshift := ch
  end;

  {$I skelsyms.pas}

{#<D -- debugging utilities. }
  {$I skeldbug.pas}

{#> -- end debugging stuff. }
{ LEXICAL ANALYZER }

  {*******************}
  procedure GETLINE;
    { read the next source line, when nextch exhausts
      the current one. }

    {.............}
    procedure GENEOF;
    begin
      line := chr(eofch);
      lx := 1
    end;

    {............}
    procedure GRABLINE;
    begin
      readln(sfile, line);
      writeln(rfile, line);
      lx := 1
    end;

  begin { getline }
    if sfilename='' then begin
      { prompt if from the console file }
      write('> ');
      grabline;
      if line = 'EOF' then geneof
      end
    else if eof(sfile) then
      geneof
    else
      grabline;
{#<E -- the line ending gets treated differently here. }
    { The appended blank allows a reduction containing <EOL> to take
      place before reading another line.  This behavior is essential
      for interactive systems, and makes no difference in batch. }
    line := line+chr(eolch)+' '
{#: -- case where <EOL> is not significant. }
    { The appended eol character ensures that tokens are broken over
      line endings; they would otherwise be invisible to the scanner.
      eolch allows the string scanner to distinguish ends of lines. }
    line := line+chr(eolch)
{#> -- end of eol business. }
  end;

  {*******************}
  procedure NEXTCH;
    { gets next character from line }
  begin
    if lx > length(line) then
      getline;
    ch := line[lx];
    { don't move past an eof mark }
    if ch <> chr(eofch) then lx := lx+1
  end;

{#<~E -- Pick a blank skipper, depending on appearance of <eol> }
  {********************}
  procedure SKIPBLANKS;  { when <eol> has NOT appeared }
    { This considers left brace as an open comment and right brace
      as a close-comment; comments may run over multiple lines. }
  begin
    repeat
      while ch = ' ' do nextch;
      if ch='{' then begin  { open a comment }
        while (ch <> '}') and (ch <> chr(eofch)) do nextch;
        if ch=chr(eofch) then
          error('unclosed comment')
        else
          nextch
      end
    until ch <> ' '
  end;

{#: -- the second choice}
  {********************}
  procedure SKIPBLANKS;  { when <eol> HAS appeared }
    { This version of skipblanks treats everything from OC to the
      end of a line as a comment. }
    const OC= ';';
  begin
    while ch=' ' do nextch;
    if ch=oc then while ch<>chr(eolch) do nextch
  end;

{#> -- end of the selection}
  {********************}
  procedure PUTSTRCH(CH: char);
  begin
    if strtabx>strtablen then
      abort('String table overflow ... please abort');
    strtab[strtabx] := ch;
    strtabx := strtabx+1;
  end;

  {******************}
  procedure PUTSTR(STR: string80);
    var SX: int;
  begin
    for sx := 1 to length(str) do putstrch(str[sx]);
    putstrch(chr(eos));
  end;

  {****************}
  procedure GET_SYMBOL;
    var SX: int;
        SYM: symbol;
        STP: symtabp;
  begin
    fillchar(sym, maxtoklen, ' ');
    sx := 1;
    { keep snarfing alphanumeric characters.  up to the first
      maxtoklen of them will be put in the symbol spelling. }
    while ((ch>='a') and (ch<='z')) or
          ((ch>='A') and (ch<='Z')) or
          ((ch>='0') and (ch<='9')) or
          (ch='_') do begin
      if sx <= maxtoklen then
        sym[sx] := upshift(ch);
      sx := sx+1;
      nextch;
    end;
    stp := makesym(sym, user, 0);  { the default level is 0 }
    with lsemp^ do begin
      if stp^.symt=reserved then begin
        { a reserved keyword }
        semt := other;
        token := stp^.tokval;
      end
      else begin
        semt := ident;
        symp := stp;
        token := ident_tokx;
      end
    end
  end;

  {$I skelnum.pas}   { Number scanning }

  {*****************}
  procedure GET_STRING;
    { Scans a string, putting it into the string table, and setting
      up the semantic record for it correctly.  Removing the "and
      (ch <> chr(eolch))" clause in the WHILE loop below will allow
      strings to run over the end of a line by storing embedded
      eolch's.  However, this could have unpleasant consequences for
      languages with <eol> in the grammar.  See the comments at the
      end of getline. }
    var END_OF_STRING:  boolean;
  begin
    nextch;  { get past the first quote mark }
    lsemp^.semt := strng;
    lsemp^.stx := strtabx;
    repeat
      while (ch <> chr(eofch)) and (ch <> chr(eolch))
            and (ch <> string_quote) do begin
        putstrch(ch);
        nextch
      end;
      end_of_string := true;
      { peek ahead a bit to see if there's a doubled quote }
      if ch = string_quote then begin
        nextch;
        if ch = string_quote then begin
          end_of_string := false;
          putstrch(ch);
          nextch
        end
      end
      else if (ch = chr(eofch)) or (ch = chr(eolch)) then begin
        error('unterminated string')
      end
    until end_of_string;
    putstrch(chr(eos));
    token := str_tokx;
  end;

  {********************}
  procedure GET_TOKEN;
    { Pascal-style lexical analyzer -- sets TOKEN to token number }
  begin
    lsemp^.semt := other;  { default case }
    skipblanks;
    errpos:=lx-1;
    case ch of
      'a'..'z', 'A'..'Z': get_symbol;
      '0'..'9':           get_number;
      string_quote:       get_string;
{#<D -- if debugging, invoke idebug on a bang (or other char). }
      '!':  begin
              idebug;
              nextch;
              get_token
            end;
{#>}
{#G   special symbol cases go here }
      ELSE  begin
              if ch=chr(eofch) then
                token := stop_tokx
              else if ch=chr(eolch) then begin
                nextch;
{#<E            end-of-line token dealt with here }
                token := eol_tokx  { accept an end-of-line token }
{#:}
                get_token  { go find another (significant) character }
{#>}
              end
              else begin
                error('illegal character');
                nextch;
                get_token  { try again }
              end
            end { case alternatives }
    end { case }
  end { get_token };

  {*******************}
  procedure NEXT_TOKEN;
  begin
    if tokenx>1 then begin
      tokenx := 1;
      get_token;  { goes into token, lsemp }
      tokary[1] := token;
      lsempary[1] := lsemp;
    end
    else begin
      { is in tokary }
      token := tokary[tokenx];
      lsemp := lsempary[tokenx];
    end
  end;

  {*****************}
  procedure TOKENREAD;
  begin
    tokenx := tokenx+1;
  end;

  { LR(1) PARSER procedures }

  {*********************}
  procedure APPLY(PFLAG, PRODLEN: int; TSEMP: semrecp);
  begin
{#A -- create an APPLY body }
  end;

  {******************}
  procedure INIT_SEM;
    { Semantics initialization -- called before any productions
      are applied. }
  begin
    writeln(rfile, 'Semantics initialized.')
  end;

  {******************}
  procedure END_SEM;
    { Semantics conclusion -- called after the GOAL
      production is applied. }
  begin
    writeln(rfile, 'Semantics concluded.')
  end;

  {****************}
  function ERROR_RECOVERY(var MSTACK: state_stack;
                          var MSTACKX: int; MCSTATE: int): int;
    label 99, 100;
    var STACK: state_stack;  { local copy of stack }
        STACKX,              { local stack pointer }
        CSTATE,              { local state }
        JSTX,                { temporary stack limit }
        RX, TL: int;         { index into TOKNUM table }

    {...............}
    procedure COPY_STACK;
      var STX: int;
    begin
      if (jstx<0) or (jstx>mstackx) then abort('ERROR RECOVERY BUG');
      for stx := 0 to jstx do
        stack[stx] := mstack[stx];
      stackx := jstx;
      if jstx=mstackx then
        cstate := mcstate
      else
        cstate := mstack[jstx+1];
    end;

    {...............}
    procedure PUSHREAD(CSTATE: int);
      { adjusts the state stack }
    begin
      stackx := stackx+1;
      if stackx>stacksize then
        abort('stack overflow');
      stack[stackx] := cstate;
    end;

    {...............}
    function TRIAL_PARSE: boolean;
      { parses from current read state through the inserted and the
        error token; if successful, returns TRUE. }
      label 99;
      var RX: int;
    begin
      trial_parse := true;  { until proven otherwise }
      while cstate<>0 do begin
        if cstate < readstate then begin
          { a reduce state }
{#<D      dump if debugging enabled. }
          if debug > 3 then stk_dump('E*Reduce', stack,
                                     stackx, cstate);
{#>       end conditional. }
          if popno[cstate]=0 then begin
            { empty production }
            pushread(stk_state[statex[cstate]]);
            cstate := stk_tostate[statex[cstate]];
          end
          else begin
            { non-empty production }
            stackx := stackx - popno[cstate] + 1;
            rx := statex[cstate];   { compute the GOTO state }
            cstate := stack[stackx];
            while (stk_state[rx]<>cstate) and
                  (stk_state[rx]<>0) do rx := rx+1;
            cstate := stk_tostate[rx];
          end
        end
        else if cstate < lookstate then begin
          { a read state }
          next_token;  { need a token now }
{#<D      dump if debugging enabled. }
          if debug > 3 then stk_dump('E*Read', stack, stackx, cstate);
{#>       end conditional. }
          rx := statex[cstate];
          while (toknum[rx]<>0) and
                (toknum[rx]<>token) do rx := rx+1;
          if toknum[rx]=0 then begin
            { failure }
            trial_parse := false;
            goto 99;
          end
          else begin
            { did read something }
            pushread(cstate);
            cstate := tostate[rx];
            tokenread;  { scan the token }
            if tokenx>1 then goto 99 { successful }
          end
        end
        else begin
          { lookahead state }
          next_token;  { need a token now }
{#<D      dump if debugging enabled. }
          if debug > 3 then stk_dump('E*Look', stack, stackx, cstate);
{#>       end conditional. }
          rx := statex[cstate];
          while (toknum[rx]<>0) and
                (toknum[rx]<>token) do rx := rx+1;
          cstate := tostate[rx];
        end
      end;
    99:
    end;

    {.................}
    procedure INCR_ERRSYM;
      { Note that this procedure assumes ASCII. }
    begin
      if errsym[6]='Z' then begin
        errsym[5] := succ(errsym[5]);
        errsym[6] := 'A';
      end
      else
        errsym[6] := succ(errsym[6]);
    end;

    {.................}
    procedure MAKE_DEFAULT(TOKX: int; SEMP: semrecp);
      { creates a default token data structure }
      var SYM: symbol;
    begin
      with semp^ do begin
        case tokx of
          int_tokx:
            begin
              semt := fixed;
              numval := 1;
            end;
          real_tokx:
            begin
              semt := float;
              rval := 1.0;
            end;
          ident_tokx:
            begin
              semt := ident;
              symp := makesym(errsym, symerr, 0);
              incr_errsym;
            end;
          str_tokx:
            begin
              semt := strng;
              stx := 0;  { default string at origin }
            end;
          ELSE
            semt := other;
        end { case tokx }
      end
    end;

  begin  { ERROR_RECOVERY }
    if debug > 3 then writeln(rfile, 'Going into ERROR RECOVERY');
    while true do begin
      jstx := mstackx;
      while jstx>=0 do begin
        copy_stack;
        rx := statex[cstate];
        while toknum[rx]<>0 do begin
          { scan through legal next tokens }
          if debug > 3 then writeln(rfile, '...starting trial parse');
          tokary[0] := toknum[rx];  { the insertion }
          tokenx := 0;
          if trial_parse then goto 99;  { it clicked! }
          rx := rx+1;
          if toknum[rx]<>0 then
            copy_stack;
        end;
        jstx := jstx-1;  { reduce stack }
      end;
      if token=stop_tokx then begin
        { empty stack, no more tokens }
        cstate := 0;  { halt state }
        tokenx := 2;
        jstx := 0;  { bottom of stack }
        goto 100;
      end;
{#<D}
      if debug > 3 then begin
        write(rfile, '...dropping token ');
        tl := wrtok(tokary[1]);
        writeln(rfile);
      end;
{#>}
      tokenx := 2;
      next_token;
{#<D}
      if debug > 3 then begin
        write(rfile, 'New token ');
        tl := wrtok(token);
        writeln(rfile);
      end
{#>}
    end;
  99:  { found a solution }
    copy_stack;
{#<D}
    if debug > 3 then begin
      write(rfile, 'insertion of ');
      tl := wrtok(tokary[0]);
      writeln(rfile, ' succeeded');
    end;
{#>}
    make_default(tokary[0], lsempary[0]);
    tokenx := 0;  { forces a `real' rescan of the insertion }
    if jstx<mstackx then
      cstate := stack[jstx+1]
    else
      cstate := mcstate;  { cstate returned }
  100:
    error_recovery := cstate;
    mstackx := jstx;
    if debug > 3 then writeln(rfile, 'Ending error recovery');
  end;

  {****************}
  procedure PARSER;
    { Carries out a complete parse, until
      the halt state is seen -- same as empty stack}
    var CSTATE, RX: int;
        TSEMP: semrecp;

    {...............}
    procedure PUSHREAD(CSTATE: int; SEMP: semrecp);
      { do the push part of a readstate. }
    begin
      stackx := stackx+1;
      if stackx>stacksize then
        abort('stack overflow');
      semstack[stackx]^ := semp^;
      stack[stackx] := cstate;
    end;

  begin
    cstate := start_state;
    stackx := -1;
    new(tsemp);
    tsemp^.semt := other;
    pushread(stk_state_1, tsemp);
    while cstate<>0 do begin
      if cstate < readstate then begin
        { a reduce state }
{#<D    dump if debugging enabled. }
        if debug > 0 then stk_dump('Reduce', stack, stackx, cstate);
{#>     end conditional. }
        if map[cstate] <> 0 then
          { the semantics action }
          apply(map[cstate], popno[cstate], tsemp);
        if popno[cstate]=0 then begin
          { empty production }
          pushread(stk_state[statex[cstate]], tsemp);
          cstate := stk_tostate[statex[cstate]];
        end
        else begin
          { non-empty production:
            semantics is preserved on a unit production A --> w,
            where |w| = 1, unless something is in TSEMP.  Note that
            if w is nonterminal, the production may be bypassed. }
          stackx := stackx - popno[cstate] + 1;
          if popno[cstate]=1 then begin
            if tsemp^.semt<>other then
              semstack[stackx]^ := tsemp^;
          end
          else
            semstack[stackx]^ := tsemp^;
          { compute the GOTO state }
          rx := statex[cstate];
          cstate := stack[stackx];
          while (stk_state[rx]<>cstate) and (stk_state[rx]<>0) do
            rx := rx+1;
          cstate := stk_tostate[rx];
        end;
        tsemp^.semt := other;
      end
      else if cstate < lookstate then begin
        { a read state }
        next_token;  { need next token now }
{#<D    dump if debugging enabled. }
        if debug > 2 then stk_dump('Read', stack, stackx, cstate);
{#>     end conditional. }
        rx := statex[cstate];
        while (toknum[rx]<>0) and (toknum[rx]<>token) do
          rx := rx+1;
        if toknum[rx]=0 then begin
          error('syntax error');
          cstate := error_recovery(stack, stackx, cstate);
        end
        else begin
          pushread(cstate, lsemp);
          cstate := tostate[rx];
          tokenread;  { token has been scanned }
        end
      end
      else begin
        { lookahead state }
        next_token;  { need another token now }
{#<D    dump if debugging enabled. }
        if debug > 2 then stk_dump('Look', stack, stackx, cstate);
{#>     end conditional. }
        rx := statex[cstate];
        while (toknum[rx]<>0) and (toknum[rx]<>token) do
          rx := rx+1;
        cstate := tostate[rx];
      end
    end;
    end_sem;
  end;

  { PARSE INITIALIZATION }

  {*****************}
  procedure INITTABLES;
    var SX: int;

{#<F import the table file reading function if needed. }
       {$I skelrtbl.pas}
{#<D   debugging wanted, too?
         {$I skeldtbl.pas}
{#>    end debugging }
{#:  else include the auxiliary functions needed by inline inits. }
    {................}
    procedure PUTSYM(STR: string80; TV: int);
      var SYMP: symtabp;
          TSYM: symbol;
          I: int;
    begin
      fillchar(tsym, maxtoklen, ' ');
      for i:=1 to length(str) do
        tsym[i]:=str[i];
      symp:=makesym(tsym, reserved, -1);
      symp^.tokval:=tv;
    end;

{#<D   also need to init debugging tables? }
    {................}
    procedure PUTTOK(PRINTVAL: string80;  TOKNUM, START: int);
      { this procedure is used to initialize the token tables.
        toknum is the number of the token to be initialized, and
        start is where it should start in the tokchar array. }
      var OFFSET:  int;
    begin
      tokx[toknum] := start;
      for offset := 0 to length(printval)-1 do
        tokchar[start+offset] := printval[offset+1];
      tokchar[start+length(printval)] := chr(0)
    end;
{#>    end puttok insertion. }
{#>  end table file conditional. }

    {................}
    procedure INIT_PARSER_TABLES;
      { initialize the parser tables }
    begin
{#<F  read from a table file? }
{#T     insert table file name in next line. }
        assign(tfile, '#');
        reset(tfile);
        read_header;
        read_table_file;
{#<D    take debugging info from the table file? }
          read_debugging_tables;
{#>     end if. }
        close(tfile)
{#:   not a table file; do the necessary inline inits }
{#IS    inline symbol table inits. }
{#<A    assignment style inits? }
{#IP      do the parser tables inline. }
{#>     end assignment inits. }
{#<D    debugging? }
{#IT      do the token tables inline. }
{#>     end debugging }
{#>   end of initialization style selection. }
    end { init_parser_tables };

  begin { inittables }
    pwr10_2[0] := 1E1;  {10^(2^0)}
    pwr10_2[1] := 1E2;  {10^(2^1)}
    pwr10_2[2] := 1E4;
    pwr10_2[3] := 1E8;
    pwr10_2[4] := 1E16;
    pwr10_2[5] := 1E32;
    errsym := 'ERR#AA         ';
    new(lsempary[0]);
    lsempary[0]^.semt := other;
    new(lsempary[1]);
    lsempary[1]^.semt := other;
    lsemp := lsempary[1];
    strtabx := 0;
    putstr('ERROR');  { default error string }
    tokenx := 2;  { no token queue }
    for sx := 0 to hlimit do
      symtab[sx] := nil;  { initialize symbol table }
    for sx := 0 to stacksize do begin
      new(semstack[sx]);
      semstack[sx]^.semt := other;
    end;
    init_parser_tables;
    init_sem;
    line := '';  { fake a new line }
    lx := 1;
    errpos:=1;
    nextch;  { fetch the first character, forcing a line read }
  end;

  {$I-}
  {*****************}
  procedure OPENFILES;
    { opens source and listing files. }
    var SUCCESS:  boolean;
  begin
    { first, get the source file }
    repeat
      write('What source file? ');
      readln(sfilename);
      if sfilename = '' then begin
        prompt_len:=2;
        assign(sfile, 'con:')
        end
      else begin
        prompt_len:=0;
        assign(sfile, sfilename);
        end;
      reset(sfile);
      success := (ioresult = 0);
      if not success then
        writeln('file doesn''t exist; try again')
    until success;
    { now, get the report file }
    repeat
      write('What report file? ');
      readln(rfilename);
      if rfilename = '' then
        rfilename := 'con:';
      success := true;
      assign(rfile, rfilename);
      if rfilename[length(rfilename)] <> ':' then begin
        reset(rfile);
        success := (ioresult <> 0);
        close(rfile);
        if not success then begin
          success := yesresp('..already exists, purge it? ');
          if success then erase(rfile)
        end
      end
    until success;
    rewrite(rfile)
  end;
  {$I+}

begin
{#P -- put the program name here, too. }
  writeln('# [an LALR(1) parser vs. 1-Mar-85]');
  writeln;
  errors := 0;
  debug := 0;
  openfiles;
  inittables;
  parser;  { does it all }
  close(sfile);
  close(rfile)
end.