{ Copyright (C) 1986 by QCAD Systems Incorporated, All Rights Reserved }

program TUPROG(input, output);

  { TUSKEL:

       A simple Compiler for Turbo }

  const
    VERSION_STRING= 'version 1.0';
    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 }
    CR = 13;          { carriage return }
    MAXSTRCHARS = 1000;  { maximum string space/procedure }
    MAXERRORS = 20;   { maximum errors before aborting }
    HASHSIZE = 167;    { hash table size -- prime number! }
    HLIMIT = 166;      { limit in hash table (hashsize minus one) }
    MAXTOKLEN = 30;   { length of a token or symbol }
    MERR_COUNT= 4;    {minimum tokens to scan before reporting errors
                        again}

    IDENT_TOKLEN = 15;  { maximum user identifier length }
    MAXRPLEN = 7;    { length of longest production right part }
    TERM_TOKS = 25;   { number of terminal tokens }
    NTERM_TOKS = 9;  { number of nonterminal tokens }
    ALL_TOKS = 34;    { term_toks + nterm_toks }
    IDENT_TOKX = 12;  { token number of <identifier> }
    INT_TOKX = 13;    { token number of <integer> }
    REAL_TOKX = 14;   { token number of <real> }
    STR_TOKX = 16;    { token number of <string> }
    STOP_TOKX = 15;   { token number of stopsign (end-of-file) }
    GOAL_TOKX = 30;   { token number of goal }
    EOL_TOKX = 11;    { token number of end-of-line }
    READSTATE = 26;   { first READ state }
    LOOKSTATE = 63;   { first LOOK state }
    MAXSTATE = 73;    { largest state number }
    REDUCELEN = 25;   { number of productions }
    RLTOKENS = 100;
    SSTOKENS = 31;
    PRODTOKS = 110;
    TOKCHARS = 189;
    START_STATE = 26;  { initial state }
    STK_STATE_1 = 26;  { state initially pushed on stack }

  type
    INT = -32767..32767;
    STRING1= string[1];
    STRING7 = string[7];
    STRING8 = string[8];
    STRING9 = string[9];
    STRING15 = string[15];
    STRING31 = string[31];
    STRING80 = string[80];
    LONGSTRING = string[255];
    TOKRANGE = 1..term_toks;

   {$I tudecls}

  type
    SYMTABLE= array [0..hlimit] of symtabp;
    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;

  const
    { Static parser data structures (parser tables). }
    STATEX:  state_array = (
      { 1  : }  0, 0, 5, 5, 0, 6, 6, 0, 9, 
      { 10 : }  11, 16, 11, 11, 17, 0, 18, 27, 9, 18, 
      { 20 : }  18, 27, 30, 11, 31, 11, 0, 3, 8, 10, 
      { 30 : }  3, 12, 14, 3, 16, 3, 3, 3, 3, 3, 
      { 40 : }  3, 20, 23, 26, 28, 3, 3, 3, 36, 45, 
      { 50 : }  49, 53, 28, 28, 55, 28, 0, 57, 59, 62, 
      { 60 : }  65, 67, 70, 71, 73, 75, 78, 81, 83, 86, 
      { 70 : }  89, 92, 95, 98);
    MAP:  reduce_array = (
      { 1  : }  0, 0, 0, 0, 11, 10, 4, 8, 7, 
      { 10 : }  3, 13, 16, 9, 0, 0, 0, 5, 15, 1, 
      { 20 : }  14, 6, 0, 12, 0, 2);
    POPNO:  pop_array = (
      { 1  : }  1, 1, 2, 3, 3, 3, 3, 4, 7, 
      { 10 : }  3, 3, 4, 6, 1, 1, 1, 1, 2, 3, 
      { 20 : }  3, 3, 1, 1, 0, 3);
    STK_STATE:  ss_array = (
      { 0  : }  35, 36, 37, 38, 0, 0, 37, 38, 0, 56, 
      { 10 : }  0, 48, 52, 53, 55, 0, 0, 0, 40, 33, 
      { 20 : }  27, 30, 39, 45, 46, 47, 0, 33, 40, 0, 
      { 30 : }  0, 62);
    STK_TOSTATE:  ss_array = (
      { 0  : }  6, 7, 68, 69, 65, 63, 68, 69, 65, 32, 
      { 10 : }  29, 51, 12, 54, 13, 9, 48, 0, 66, 66, 
      { 20 : }  66, 34, 70, 49, 50, 73, 72, 41, 42, 67, 
      { 30 : }  65, 48);
    TOKNUM:  token_array = (
      { 0  : }  21, 24, 0, 1, 12, 13, 16, 0, 12, 0, 
      { 10 : }  9, 0, 1, 0, 9, 0, 2, 4, 6, 0, 
      { 20 : }  2, 5, 0, 2, 5, 0, 9, 0, 1, 12, 
      { 30 : }  13, 16, 17, 22, 25, 0, 1, 12, 13, 16, 
      { 40 : }  17, 20, 22, 25, 0, 4, 6, 18, 0, 4, 
      { 50 : }  6, 23, 0, 9, 0, 19, 0, 1, 0, 3, 
      { 60 : }  7, 0, 4, 6, 0, 5, 0, 1, 8, 0, 
      { 70 : }  0, 15, 0, 1, 0, 3, 7, 0, 4, 6, 
      { 80 : }  0, 9, 0, 3, 7, 0, 3, 7, 0, 4, 
      { 90 : }  6, 0, 1, 8, 0, 9, 19, 0, 9, 19, 
      { 100: }  0);
    TOSTATE:  tostate_array = (
      { 0  : }  28, 27, 0, 30, 64, 2, 1, 0, 31, 0, 
      { 10 : }  3, 0, 40, 0, 4, 0, 5, 37, 38, 0, 
      { 20 : }  8, 39, 0, 43, 39, 0, 44, 0, 30, 71, 
      { 30 : }  2, 1, 24, 46, 45, 0, 30, 71, 2, 1, 
      { 40 : }  24, 10, 46, 45, 0, 37, 38, 52, 0, 37, 
      { 50 : }  38, 53, 0, 11, 0, 55, 0, 33, 0, 35, 
      { 60 : }  36, 0, 37, 38, 0, 39, 0, 33, 47, 0, 
      { 70 : }  0, 14, 56, 57, 15, 58, 58, 16, 59, 59, 
      { 80 : }  17, 18, 60, 58, 58, 19, 58, 58, 20, 59, 
      { 90 : }  59, 21, 61, 61, 22, 23, 23, 59, 25, 25, 
      { 100: }  59);
    INSYM:  insym_array = (
      { 1  : }  16, 13, 9, 9, 2, 31, 31, 2, 32, 
      { 10 : }  20, 9, 32, 32, 28, 12, 31, 26, 27, 31, 
      { 20 : }  31, 26, 12, 26, 17, 26, 30, 24, 21, 29, 
      { 30 : }  1, 12, 29, 1, 26, 3, 7, 4, 6, 5, 
      { 40 : }  1, 27, 27, 2, 9, 25, 22, 8, 33, 26, 
      { 50 : }  26, 32, 18, 23, 32, 19, 28, 12, 31, 26, 
      { 60 : }  27, 12, 17, 0);
    PRODX:  reduce_array = (
      { 1  : }  1, 4, 7, 11, 16, 21, 26, 31, 37, 
      { 10 : }  46, 51, 56, 62, 70, 73, 76, 79, 82, 86, 
      { 20 : }  91, 96, 73, 101, 104, 106);
    PRODS:  prod_array = (
      { 1  : }  31, 16, 0, 31, 13, 0, 28, 29, 9, 
      { 10 : }  0, 28, 28, 29, 9, 0, 31, 1, 26, 2, 
      { 20 : }  0, 34, 34, 3, 31, 0, 34, 34, 7, 31, 
      { 30 : }  0, 31, 12, 1, 27, 2, 0, 29, 21, 12, 
      { 40 : }  1, 27, 2, 9, 32, 0, 32, 17, 33, 20, 
      { 50 : }  0, 33, 33, 32, 9, 0, 32, 25, 26, 18, 
      { 60 : }  32, 0, 32, 22, 26, 23, 32, 19, 32, 0, 
      { 70 : }  30, 28, 0, 31, 12, 0, 26, 34, 0, 27, 
      { 80 : }  26, 0, 29, 24, 27, 0, 26, 26, 4, 34, 
      { 90 : }  0, 26, 26, 6, 34, 0, 27, 27, 5, 26, 
      { 100: }  0, 32, 26, 0, 33, 0, 32, 12, 8, 26, 
      { 110: }  0);
   {Flag constants}
    ADDOPR= 1;
    ASSIGN= 2;
    BLOCK= 3;
    DIVOPR= 4;
    EXPRLIST1= 5;
    EXPRLIST2= 6;
    FDECL= 7;
    FUNCP= 8;
    IFTHEN= 9;
    MPYOPR= 10;
    PAREN= 11;
    SEXPR= 12;
    STLIST2= 13;
    SUBOPR= 14;
    VDECL= 15;
    WHILEDO= 16;

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


    { These guys are for printing tokens in parser stack dumps. }
    TOKX:  tokx_array;       { token index, index into ... }
    TOKCHAR:  tokchar_array;  { token characters }

    { Lexical and token data }
    LINE:  longstring;       { source line }
    LX:  int;                { index of next character in LINE }
    ERRPOS: int;             { current token position in LINE }
    PROMPT: string8;         { prompt string }
    PROMPTLEN: int;          { front-end length for error purposes }
    IS_CONSOLE: boolean;     { TRUE if input from console }
    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: symtable;

    { String table space }
    STRTAB: packed array [0..maxstrchars] of char;
    STRX: integer;   {next available character slot in STRTAB}

    SFILE, RFILE: text;      { source, report files }

    ERR_COUNT,
    ERRORS: int;
    DEBUG: int;              { >0 turns on some tracing }
    TRACE: boolean;

    SFILENAME, RFILENAME: string80;  { file names }

  function NEW_SEM (SEMTYP: semtype): semrecp; forward;
  procedure IDEBUG; forward;

  {$I tuutils}

  {$I tufiles}

  {******************}
  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 err_count=0 then begin
      if errpos+promptlen>1 then
        write(rfile, ' ':errpos+promptlen-1);
      writeln(rfile, '^');  { mark error point }
      writeln(rfile, msg);
      end
    end;

  {*******************}
  procedure ABORT(MSG: string80);
  begin
    report_err(concat('FATAL ERROR: ', msg));
    writeln('... aborting');
    halt;
    end;

  {******************}
  procedure ERROR(MSG: string80);
  begin
    if err_count=0 then begin
      report_err(concat('ERROR: ', msg));
      errors:=errors+1;
      if errors>maxerrors then begin
        err_count:=0;
        abort('Error limit exceeded');
        end
      else
      if (rfilename=default_rfile) then idebug;
      end
    end;

  {*******************}
  procedure WARN(MSG: string80);
  begin
    report_err(concat('WARNING: ', msg));
    end;

  {$I tusyms}

  {********************}
  procedure SYMERROR(SYM: symbol; MSG: string80);
  begin
    error(concat(sym, concat(': ', msg)));
    end;

  {$I tudbug}

{ 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 is_console then begin
      { prompt if from the console file }
      write(prompt);
      grabline;
      if line = 'EOF' then geneof
      end
    else if eof(sfile) then
      geneof
    else
      grabline;
    { 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 := concat(line, '  ');
    line[length(line)-1]:=chr(eolch);
  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;

  {********************}
  function PEEKCH: char;
  begin
    if lx>length(line) then peekch:=chr(eolch)
    else
    peekch:=line[lx];
    end;

  {********************}
  procedure SKIPBLANKS;
    label 1;

    {..................}
    function END_COMMENT: boolean;
    begin
      if ch=chr(eofch) then begin
        error('unclosed comment at file end');
        end_comment:=true;
        end
      else
      end_comment:=(ch='}');
      end;

  begin  {comments open on { and close on close-brace }
    1:
    while ch=' ' do nextch;
    if (ch='{') then begin
      while not(end_comment) do nextch;
      nextch;
      goto 1;
      end
    end;

  {***********************}
  procedure GET_SYMBOL;
      {collects Pascal-style identifiers,
          stuffed into symbol table under IDENT tag}
    var SYM: symbol;
        STP: symtabp;
  begin
    sym:='';
    { Keep snarfing alphanumeric characters.  Up to the first
      maxtoklen of them will be put in the symbol spelling. }
    while ch in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do begin
      if length(sym) <= maxtoklen then begin
        sym:=concat(sym, ' ');
        sym[length(sym)] := upcase(ch);
        end;
      nextch;
      end;
    stp := makesym(symtab, sym, user, 0);  { the default level is 0 }
    if (stp^.symt=reserved) then
    token:=stp^.tokval
    else begin
      lsemp:=new_sem(ident);
      with lsemp^ do begin
        symp := stp;
        token := ident_tokx;
        end
      end
    end;

  {************************}
  procedure GET_NUMBER;
    var V: integer;
  begin
    v:=0;
    while ch in ['0'..'9'] do begin
      v:=10*v + ord(ch) - ord('0');
      nextch;
      end;
    token:= int_tokx;
    lsemp:=new_sem(fixed);
    lsemp^.numval:=v;
    end;

  {***********************}
  procedure GET_STRING;
    label 1, 99;
  
    {..................}
    procedure PUTCH(CH: char);
    begin
      if strx<maxstrchars then begin
        strtab[strx]:=ch;
        strx:=strx+1;
        end
      else
      if strx=maxstrchars then begin
        error('too many string characters');
        strtab[maxstrchars]:=chr(0);
        strx:=strx+1;
        end
      end;
        
  begin
    lsemp:=new_sem(strng);
    lsemp^.stx:=strx;
    1:
    nextch;  {get over first quote mark}
    while ch<>'''' do begin
      if ch=chr(eolch) then begin
        error('string runs over end of line');
        goto 99;
        end;
      putch(ch);
      nextch;
      end;
    nextch;  {get over last quote mark}
    if ch='''' then begin  {repeated quote mark}
      putch(ch);
      goto 1;   {continue grabbing characters}
      end;
    99:
    putch(chr(0));
    token:=str_tokx;
    end;
    
  {********************}
  procedure GET_TOKEN;
    { Pascal-style lexical analyzer -- sets TOKEN to token number }
  begin
    lsemp:= nil;  { default case }
    skipblanks;
    errpos:=lx-1;
    case ch of
      'a'..'z', 'A'..'Z': get_symbol;
      '0'..'9': get_number;
      '''': get_string;
      '!':  begin
              idebug;
              nextch;
              get_token
            end;
      '(':  begin
              nextch;
              token := 1  { '(' }
            end  { '(' character case };
      ')':  begin
              nextch;
              token := 2  { ')' }
            end  { ')' character case };
      '*':  begin
              nextch;
              token := 3  { '*' }
            end  { '*' character case };
      '+':  begin
              nextch;
              token := 4  { '+' }
            end  { '+' character case };
      ',':  begin
              nextch;
              token := 5  { ',' }
            end  { ',' character case };
      '-':  begin
              nextch;
              token := 6  { '-' }
            end  { '-' character case };
      '/':  begin
              nextch;
              token := 7  { '/' }
            end  { '/' character case };
      ':':  begin
              nextch;
              if ch = '=' then
                begin
                  nextch;
                  token := 8  { ':=' }
                end
              else 
                begin
                  error('Illegal character');
                  nextch;
                  get_token;
                end
            end  { ':' character case };
      ';':  begin
              nextch;
              token := 9  { ';' }
            end  { ';' character case };
      ELSE  begin
        if ch=chr(eofch) then
          token := stop_tokx
        else if ch=chr(eolch) then begin
          nextch;
          get_token  { go find another (significant) character }
          end
        else begin
          error('invalid character');
          nextch;
          get_token;
          end
        end { case alternatives }
      end; { case }
    if err_count>0 then err_count:=err_count-1;
    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;

  {$I tusems}

  { LR(1) PARSER procedures }

  {****************}
  function ERROR_RECOVERY(var MSTACK: state_stack;
                          var MSTACKX: int; MCSTATE: int): int;
    label 99, 100;
    var STACK: state_stack;  { local copy of stack }
        TOS,              { 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];
      tos := jstx;
      if jstx=mstackx then
        cstate := mcstate
      else
        cstate := mstack[jstx+1];
    end;

    {...............}
    procedure PUSHREAD(CSTATE: int);
      { adjusts the state stack }
    begin
      tos := tos+1;
      if tos>stacksize then
        abort('stack overflow');
      stack[tos] := 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 }
          if debug > 3 then stk_dump('E*Reduce', stack,
                                     tos, cstate);
          if popno[cstate]=0 then begin
            { empty production }
            pushread(stk_state[statex[cstate]]);
            cstate := stk_tostate[statex[cstate]];
          end
          else begin
            { non-empty production }
            tos := tos - popno[cstate] + 1;
            rx := statex[cstate];   { compute the GOTO state }
            cstate := stack[tos];
            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 }
          if debug > 3 then stk_dump('E*Read', stack, tos, cstate);
          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 }
          if debug > 3 then stk_dump('E*Look', stack, tos, cstate);
          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; var SEMP: semrecp);
      { creates a default token data structure }
      var SYM: symbol; TSYMP: symtabp;
    begin
      case tokx of
        ident_tokx: begin
          tsymp := makesym(symtab, errsym, symerr, 0);
          semp:=new_sem(ident);
          with semp^ do begin
            symp:=tsymp;
            incr_errsym;
            end
          end;
        int_tokx: begin 
          semp:=new_sem(fixed);
          semp^.numval:=1;
          end;
        ELSE
          semp:=nil;
      end { case tokx }
    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;
      if debug > 3 then begin
        write(rfile, '...dropping token ');
        tl := wrtok(tokary[1]);
        writeln(rfile);
      end;
      tokenx := 2;
      next_token;
      if debug > 3 then begin
        write(rfile, 'New token ');
        tl := wrtok(token);
        writeln(rfile);
      end
    end;
  99:  { found a solution }
    copy_stack;
    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
      tos := tos+1;
      if tos>stacksize then
        abort('stack overflow');
      sem[tos] := semp;
      stack[tos] := cstate;
    end;

  begin
    cstate := start_state;
    tos := -1;
    pushread(stk_state_1, nil);
    while cstate<>0 do begin
      tsemp:=nil;
      if cstate < readstate then begin
        { a reduce state }
        if debug > 0 then stk_dump('Reduce', stack, tos, cstate);
        if map[cstate] <> 0 then
          { the semantics action }
          apply(map[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. }
          tos := tos - popno[cstate] + 1;
          if (tsemp<>nil) or (popno[cstate]<>1) then
            sem[tos] := tsemp;
          { compute the GOTO state }
          rx := statex[cstate];
          cstate := stack[tos];
          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 next token now }
        if debug > 2 then stk_dump('Read', stack, tos, cstate);
        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, tos, cstate);
          err_count:=merr_count;
        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 }
        if debug > 2 then stk_dump('Look', stack, tos, cstate);
        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;
        CODE_SYMP: symtabp;

    {................}
    procedure PUTSYM(TSYM: symbol; TV: int);
      var SYMP: symtabp;
          I: int;
    begin
      symp:=makesym(symtab, tsym, reserved, -1);
      symp^.tokval:=tv;
    end;

    {................}
    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;

    {................}
    procedure INIT_PARSER_TABLES;
      { initialize the parser tables }
    begin
      { initialize keywords in the symbol table. }
      putsym('BEGIN', 17);
      putsym('DO', 18);
      putsym('ELSE', 19);
      putsym('END', 20);
      putsym('FUNCTION', 21);
      putsym('IF', 22);
      putsym('THEN', 23);
      putsym('VAR', 24);
      putsym('WHILE', 25);
      { initialize the token tables. }
      puttok('(', 1, 1);
      puttok(')', 2, 3);
      puttok('*', 3, 5);
      puttok('+', 4, 7);
      puttok(',', 5, 9);
      puttok('-', 6, 11);
      puttok('/', 7, 13);
      puttok(':=', 8, 15);
      puttok(';', 9, 18);
      puttok('<empty>', 10, 20);
      puttok('<eol>', 11, 28);
      puttok('<identifier>', 12, 34);
      puttok('<integer>', 13, 47);
      puttok('<real>', 14, 57);
      puttok('<stop>', 15, 64);
      puttok('<string>', 16, 71);
      puttok('BEGIN', 17, 80);
      puttok('DO', 18, 86);
      puttok('ELSE', 19, 89);
      puttok('END', 20, 94);
      puttok('FUNCTION', 21, 98);
      puttok('IF', 22, 107);
      puttok('THEN', 23, 110);
      puttok('VAR', 24, 115);
      puttok('WHILE', 25, 119);
      puttok('Expr', 26, 125);
      puttok('ExprList', 27, 130);
      puttok('FDeclList', 28, 139);
      puttok('FuncDecl', 29, 149);
      puttok('Goal', 30, 158);
      puttok('Primary', 31, 163);
      puttok('Stmt', 32, 171);
      puttok('StmtList', 33, 176);
      puttok('Term', 34, 185);
    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;
    lsempary[0]:=nil;
    lsempary[1]:=nil;
    lsemp := nil;
    tokenx := 2;  { no token queue }
    for sx := 0 to hlimit do begin
      symtab[sx] := nil;  { initialize symbol tables }
      end;
    for sx := 0 to stacksize do begin
      sem[sx]:=nil;
    end;
    init_parser_tables;
    init_sem;
    errsym:='ERR#AA';
    strx:=0;
    line := '';  { fake a new line }
    lx := 1;
    errpos:=1;
    err_count:=0;
    nextch;  { fetch the first character, forcing a line read }
  end;

  {**********************}
  function OPENFILES: boolean;
  begin
    openfiles:=false;
    write('Source file? ');
    readln(sfilename);
    prompt:='';
    promptlen:=3;  {length of ` ; '}
    if sfilename='' then begin
      prompt:='> ';
      sfilename:=default_sfile;
      is_console:=true;
      promptlen:=promptlen+2;
      end
    else is_console:=false;
    if openfile(sfile, sfilename, false) then begin
      write('Target file? ');
      readln(rfilename);
      if rfilename='' then rfilename:=default_rfile;
      openfiles:=openfile(rfile, rfilename, true);
      end
    end;
    
begin
  writeln('Tiny Pascal Compiler, ', version_string);
  writeln;
  errors := 0;
  debug := 0;
  trace := false;
  if openfiles then begin
    inittables;
    parser;  { does it all }
    closefiles;
    end
  end.