home *** CD-ROM | disk | FTP | other *** search
/ The Education Master 1994 (4th Edition) / EDUCATIONS_MASTER_4TH_EDITION.bin / files / progscal / tinypasc / tuprog.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-17  |  28.5 KB  |  972 lines
  1. { Copyright (C) 1986 by QCAD Systems Incorporated, All Rights Reserved }
  2.  
  3. program TUPROG(input, output);
  4.  
  5.   { TUSKEL:
  6.  
  7.        A simple Compiler for Turbo }
  8.  
  9.   const
  10.     VERSION_STRING= 'version 1.0';
  11.     STACKSIZE = 60;   { maximum size of LR(1) parser stack }
  12.     EOS = 0;          { marks end of line in LINE }
  13.     EOFCH = 26;       { reader end-of-file character }
  14.     EOLCH = 12;       { end of line character }
  15.     CR = 13;          { carriage return }
  16.     MAXSTRCHARS = 1000;  { maximum string space/procedure }
  17.     MAXERRORS = 20;   { maximum errors before aborting }
  18.     HASHSIZE = 167;    { hash table size -- prime number! }
  19.     HLIMIT = 166;      { limit in hash table (hashsize minus one) }
  20.     MAXTOKLEN = 30;   { length of a token or symbol }
  21.     MERR_COUNT= 4;    {minimum tokens to scan before reporting errors
  22.                         again}
  23.  
  24.     IDENT_TOKLEN = 15;  { maximum user identifier length }
  25.     MAXRPLEN = 7;    { length of longest production right part }
  26.     TERM_TOKS = 25;   { number of terminal tokens }
  27.     NTERM_TOKS = 9;  { number of nonterminal tokens }
  28.     ALL_TOKS = 34;    { term_toks + nterm_toks }
  29.     IDENT_TOKX = 12;  { token number of <identifier> }
  30.     INT_TOKX = 13;    { token number of <integer> }
  31.     REAL_TOKX = 14;   { token number of <real> }
  32.     STR_TOKX = 16;    { token number of <string> }
  33.     STOP_TOKX = 15;   { token number of stopsign (end-of-file) }
  34.     GOAL_TOKX = 30;   { token number of goal }
  35.     EOL_TOKX = 11;    { token number of end-of-line }
  36.     READSTATE = 26;   { first READ state }
  37.     LOOKSTATE = 63;   { first LOOK state }
  38.     MAXSTATE = 73;    { largest state number }
  39.     REDUCELEN = 25;   { number of productions }
  40.     RLTOKENS = 100;
  41.     SSTOKENS = 31;
  42.     PRODTOKS = 110;
  43.     TOKCHARS = 189;
  44.     START_STATE = 26;  { initial state }
  45.     STK_STATE_1 = 26;  { state initially pushed on stack }
  46.  
  47.   type
  48.     INT = -32767..32767;
  49.     STRING1= string[1];
  50.     STRING7 = string[7];
  51.     STRING8 = string[8];
  52.     STRING9 = string[9];
  53.     STRING15 = string[15];
  54.     STRING31 = string[31];
  55.     STRING80 = string[80];
  56.     LONGSTRING = string[255];
  57.     TOKRANGE = 1..term_toks;
  58.  
  59.    {$I tudecls}
  60.  
  61.   type
  62.     SYMTABLE= array [0..hlimit] of symtabp;
  63.     STATE_STACK = array [0..stacksize] of int;
  64.     { Types for parser tables.  NB:  These type names are used by
  65.       the typed constant generation. }
  66.     STATE_ARRAY = array [1..maxstate] of int;
  67.     REDUCE_ARRAY = array [1..reducelen] of int;
  68.     POP_ARRAY = array [1..reducelen] of byte;
  69.     TOKEN_ARRAY = array [0..rltokens] of byte;
  70.     TOSTATE_ARRAY = array [0..rltokens] of int;
  71.     SS_ARRAY = array [0..sstokens] of int;
  72.     PROD_ARRAY = array [1..prodtoks] of byte;
  73.     TOKX_ARRAY = array [1..all_toks] of int;
  74.     TOKCHAR_ARRAY = array [1..tokchars] of char;
  75.     INSYM_ARRAY = array [1..lookstate] of int;
  76.  
  77.   const
  78.     { Static parser data structures (parser tables). }
  79.     STATEX:  state_array = (
  80.       { 1  : }  0, 0, 5, 5, 0, 6, 6, 0, 9, 
  81.       { 10 : }  11, 16, 11, 11, 17, 0, 18, 27, 9, 18, 
  82.       { 20 : }  18, 27, 30, 11, 31, 11, 0, 3, 8, 10, 
  83.       { 30 : }  3, 12, 14, 3, 16, 3, 3, 3, 3, 3, 
  84.       { 40 : }  3, 20, 23, 26, 28, 3, 3, 3, 36, 45, 
  85.       { 50 : }  49, 53, 28, 28, 55, 28, 0, 57, 59, 62, 
  86.       { 60 : }  65, 67, 70, 71, 73, 75, 78, 81, 83, 86, 
  87.       { 70 : }  89, 92, 95, 98);
  88.     MAP:  reduce_array = (
  89.       { 1  : }  0, 0, 0, 0, 11, 10, 4, 8, 7, 
  90.       { 10 : }  3, 13, 16, 9, 0, 0, 0, 5, 15, 1, 
  91.       { 20 : }  14, 6, 0, 12, 0, 2);
  92.     POPNO:  pop_array = (
  93.       { 1  : }  1, 1, 2, 3, 3, 3, 3, 4, 7, 
  94.       { 10 : }  3, 3, 4, 6, 1, 1, 1, 1, 2, 3, 
  95.       { 20 : }  3, 3, 1, 1, 0, 3);
  96.     STK_STATE:  ss_array = (
  97.       { 0  : }  35, 36, 37, 38, 0, 0, 37, 38, 0, 56, 
  98.       { 10 : }  0, 48, 52, 53, 55, 0, 0, 0, 40, 33, 
  99.       { 20 : }  27, 30, 39, 45, 46, 47, 0, 33, 40, 0, 
  100.       { 30 : }  0, 62);
  101.     STK_TOSTATE:  ss_array = (
  102.       { 0  : }  6, 7, 68, 69, 65, 63, 68, 69, 65, 32, 
  103.       { 10 : }  29, 51, 12, 54, 13, 9, 48, 0, 66, 66, 
  104.       { 20 : }  66, 34, 70, 49, 50, 73, 72, 41, 42, 67, 
  105.       { 30 : }  65, 48);
  106.     TOKNUM:  token_array = (
  107.       { 0  : }  21, 24, 0, 1, 12, 13, 16, 0, 12, 0, 
  108.       { 10 : }  9, 0, 1, 0, 9, 0, 2, 4, 6, 0, 
  109.       { 20 : }  2, 5, 0, 2, 5, 0, 9, 0, 1, 12, 
  110.       { 30 : }  13, 16, 17, 22, 25, 0, 1, 12, 13, 16, 
  111.       { 40 : }  17, 20, 22, 25, 0, 4, 6, 18, 0, 4, 
  112.       { 50 : }  6, 23, 0, 9, 0, 19, 0, 1, 0, 3, 
  113.       { 60 : }  7, 0, 4, 6, 0, 5, 0, 1, 8, 0, 
  114.       { 70 : }  0, 15, 0, 1, 0, 3, 7, 0, 4, 6, 
  115.       { 80 : }  0, 9, 0, 3, 7, 0, 3, 7, 0, 4, 
  116.       { 90 : }  6, 0, 1, 8, 0, 9, 19, 0, 9, 19, 
  117.       { 100: }  0);
  118.     TOSTATE:  tostate_array = (
  119.       { 0  : }  28, 27, 0, 30, 64, 2, 1, 0, 31, 0, 
  120.       { 10 : }  3, 0, 40, 0, 4, 0, 5, 37, 38, 0, 
  121.       { 20 : }  8, 39, 0, 43, 39, 0, 44, 0, 30, 71, 
  122.       { 30 : }  2, 1, 24, 46, 45, 0, 30, 71, 2, 1, 
  123.       { 40 : }  24, 10, 46, 45, 0, 37, 38, 52, 0, 37, 
  124.       { 50 : }  38, 53, 0, 11, 0, 55, 0, 33, 0, 35, 
  125.       { 60 : }  36, 0, 37, 38, 0, 39, 0, 33, 47, 0, 
  126.       { 70 : }  0, 14, 56, 57, 15, 58, 58, 16, 59, 59, 
  127.       { 80 : }  17, 18, 60, 58, 58, 19, 58, 58, 20, 59, 
  128.       { 90 : }  59, 21, 61, 61, 22, 23, 23, 59, 25, 25, 
  129.       { 100: }  59);
  130.     INSYM:  insym_array = (
  131.       { 1  : }  16, 13, 9, 9, 2, 31, 31, 2, 32, 
  132.       { 10 : }  20, 9, 32, 32, 28, 12, 31, 26, 27, 31, 
  133.       { 20 : }  31, 26, 12, 26, 17, 26, 30, 24, 21, 29, 
  134.       { 30 : }  1, 12, 29, 1, 26, 3, 7, 4, 6, 5, 
  135.       { 40 : }  1, 27, 27, 2, 9, 25, 22, 8, 33, 26, 
  136.       { 50 : }  26, 32, 18, 23, 32, 19, 28, 12, 31, 26, 
  137.       { 60 : }  27, 12, 17, 0);
  138.     PRODX:  reduce_array = (
  139.       { 1  : }  1, 4, 7, 11, 16, 21, 26, 31, 37, 
  140.       { 10 : }  46, 51, 56, 62, 70, 73, 76, 79, 82, 86, 
  141.       { 20 : }  91, 96, 73, 101, 104, 106);
  142.     PRODS:  prod_array = (
  143.       { 1  : }  31, 16, 0, 31, 13, 0, 28, 29, 9, 
  144.       { 10 : }  0, 28, 28, 29, 9, 0, 31, 1, 26, 2, 
  145.       { 20 : }  0, 34, 34, 3, 31, 0, 34, 34, 7, 31, 
  146.       { 30 : }  0, 31, 12, 1, 27, 2, 0, 29, 21, 12, 
  147.       { 40 : }  1, 27, 2, 9, 32, 0, 32, 17, 33, 20, 
  148.       { 50 : }  0, 33, 33, 32, 9, 0, 32, 25, 26, 18, 
  149.       { 60 : }  32, 0, 32, 22, 26, 23, 32, 19, 32, 0, 
  150.       { 70 : }  30, 28, 0, 31, 12, 0, 26, 34, 0, 27, 
  151.       { 80 : }  26, 0, 29, 24, 27, 0, 26, 26, 4, 34, 
  152.       { 90 : }  0, 26, 26, 6, 34, 0, 27, 27, 5, 26, 
  153.       { 100: }  0, 32, 26, 0, 33, 0, 32, 12, 8, 26, 
  154.       { 110: }  0);
  155.    {Flag constants}
  156.     ADDOPR= 1;
  157.     ASSIGN= 2;
  158.     BLOCK= 3;
  159.     DIVOPR= 4;
  160.     EXPRLIST1= 5;
  161.     EXPRLIST2= 6;
  162.     FDECL= 7;
  163.     FUNCP= 8;
  164.     IFTHEN= 9;
  165.     MPYOPR= 10;
  166.     PAREN= 11;
  167.     SEXPR= 12;
  168.     STLIST2= 13;
  169.     SUBOPR= 14;
  170.     VDECL= 15;
  171.     WHILEDO= 16;
  172.  
  173.   var
  174.     { Dynamic parser data structures }
  175.     STACK:  state_stack;  { the LR(1) state stack }
  176.     SEM:  array [0..stacksize] of semrecp;  { semantics stack }
  177.     TOS:  int;  { index of top of stack }
  178.  
  179.  
  180.     { These guys are for printing tokens in parser stack dumps. }
  181.     TOKX:  tokx_array;       { token index, index into ... }
  182.     TOKCHAR:  tokchar_array;  { token characters }
  183.  
  184.     { Lexical and token data }
  185.     LINE:  longstring;       { source line }
  186.     LX:  int;                { index of next character in LINE }
  187.     ERRPOS: int;             { current token position in LINE }
  188.     PROMPT: string8;         { prompt string }
  189.     PROMPTLEN: int;          { front-end length for error purposes }
  190.     IS_CONSOLE: boolean;     { TRUE if input from console }
  191.     CH:  char;               { next character from input file }
  192.     TOKEN:  int;             { Next token in input list }
  193.     LSEMP:  semrecp;         { current semantics assoc. with token }
  194.     TOKENX:  int;            { index into TOKARY, LSEMPARY }
  195.     TOKARY:  array [0..1] of int;  { token queue }
  196.     LSEMPARY:  array [0..1] of semrecp;
  197.     ERRSYM:  symbol;        { special symbol reserved for errors }
  198.     { The next table can be omitted if real numbers are not used. }
  199.     PWR10_2:  array [0..8] of real;  { Binary powers of ten. }
  200.  
  201.     { Symbol table data }
  202.     SYMTAB: symtable;
  203.  
  204.     { String table space }
  205.     STRTAB: packed array [0..maxstrchars] of char;
  206.     STRX: integer;   {next available character slot in STRTAB}
  207.  
  208.     SFILE, RFILE: text;      { source, report files }
  209.  
  210.     ERR_COUNT,
  211.     ERRORS: int;
  212.     DEBUG: int;              { >0 turns on some tracing }
  213.     TRACE: boolean;
  214.  
  215.     SFILENAME, RFILENAME: string80;  { file names }
  216.  
  217.   function NEW_SEM (SEMTYP: semtype): semrecp; forward;
  218.   procedure IDEBUG; forward;
  219.  
  220.   {$I tuutils}
  221.  
  222.   {$I tufiles}
  223.  
  224.   {******************}
  225.   procedure MORE(MSG: string80);
  226.     { print the string, and let the user type
  227.       any character to proceed. }
  228.     var FOO:  char;
  229.   begin
  230.     foo := resp(msg)
  231.     end;
  232.  
  233.   {******************}
  234.   procedure REPORT_ERR(MSG: string80);
  235.   begin
  236.     if err_count=0 then begin
  237.       if errpos+promptlen>1 then
  238.         write(rfile, ' ':errpos+promptlen-1);
  239.       writeln(rfile, '^');  { mark error point }
  240.       writeln(rfile, msg);
  241.       end
  242.     end;
  243.  
  244.   {*******************}
  245.   procedure ABORT(MSG: string80);
  246.   begin
  247.     report_err(concat('FATAL ERROR: ', msg));
  248.     writeln('... aborting');
  249.     halt;
  250.     end;
  251.  
  252.   {******************}
  253.   procedure ERROR(MSG: string80);
  254.   begin
  255.     if err_count=0 then begin
  256.       report_err(concat('ERROR: ', msg));
  257.       errors:=errors+1;
  258.       if errors>maxerrors then begin
  259.         err_count:=0;
  260.         abort('Error limit exceeded');
  261.         end
  262.       else
  263.       if (rfilename=default_rfile) then idebug;
  264.       end
  265.     end;
  266.  
  267.   {*******************}
  268.   procedure WARN(MSG: string80);
  269.   begin
  270.     report_err(concat('WARNING: ', msg));
  271.     end;
  272.  
  273.   {$I tusyms}
  274.  
  275.   {********************}
  276.   procedure SYMERROR(SYM: symbol; MSG: string80);
  277.   begin
  278.     error(concat(sym, concat(': ', msg)));
  279.     end;
  280.  
  281.   {$I tudbug}
  282.  
  283. { LEXICAL ANALYZER }
  284.  
  285.   {*******************}
  286.   procedure GETLINE;
  287.     { read the next source line, when nextch exhausts
  288.       the current one. }
  289.  
  290.     {.............}
  291.     procedure GENEOF;
  292.     begin
  293.       line := chr(eofch);
  294.       lx := 1
  295.     end;
  296.  
  297.     {............}
  298.     procedure GRABLINE;
  299.     begin
  300.       readln(sfile, line);
  301.       writeln(rfile, ' ; ', line);
  302.       lx := 1
  303.     end;
  304.  
  305.   begin { getline }
  306.     if is_console then begin
  307.       { prompt if from the console file }
  308.       write(prompt);
  309.       grabline;
  310.       if line = 'EOF' then geneof
  311.       end
  312.     else if eof(sfile) then
  313.       geneof
  314.     else
  315.       grabline;
  316.     { The appended eol character ensures that tokens are broken over
  317.       line endings; they would otherwise be invisible to the scanner.
  318.       eolch allows the string scanner to distinguish ends of lines. }
  319.     line := concat(line, '  ');
  320.     line[length(line)-1]:=chr(eolch);
  321.   end;
  322.  
  323.   {*******************}
  324.   procedure NEXTCH;
  325.     { gets next character from line }
  326.   begin
  327.     if lx > length(line) then
  328.       getline;
  329.     ch := line[lx];
  330.     { don't move past an eof mark }
  331.     if ch <> chr(eofch) then lx := lx+1
  332.   end;
  333.  
  334.   {********************}
  335.   function PEEKCH: char;
  336.   begin
  337.     if lx>length(line) then peekch:=chr(eolch)
  338.     else
  339.     peekch:=line[lx];
  340.     end;
  341.  
  342.   {********************}
  343.   procedure SKIPBLANKS;
  344.     label 1;
  345.  
  346.     {..................}
  347.     function END_COMMENT: boolean;
  348.     begin
  349.       if ch=chr(eofch) then begin
  350.         error('unclosed comment at file end');
  351.         end_comment:=true;
  352.         end
  353.       else
  354.       end_comment:=(ch='}');
  355.       end;
  356.  
  357.   begin  {comments open on { and close on close-brace }
  358.     1:
  359.     while ch=' ' do nextch;
  360.     if (ch='{') then begin
  361.       while not(end_comment) do nextch;
  362.       nextch;
  363.       goto 1;
  364.       end
  365.     end;
  366.  
  367.   {***********************}
  368.   procedure GET_SYMBOL;
  369.       {collects Pascal-style identifiers,
  370.           stuffed into symbol table under IDENT tag}
  371.     var SYM: symbol;
  372.         STP: symtabp;
  373.   begin
  374.     sym:='';
  375.     { Keep snarfing alphanumeric characters.  Up to the first
  376.       maxtoklen of them will be put in the symbol spelling. }
  377.     while ch in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do begin
  378.       if length(sym) <= maxtoklen then begin
  379.         sym:=concat(sym, ' ');
  380.         sym[length(sym)] := upcase(ch);
  381.         end;
  382.       nextch;
  383.       end;
  384.     stp := makesym(symtab, sym, user, 0);  { the default level is 0 }
  385.     if (stp^.symt=reserved) then
  386.     token:=stp^.tokval
  387.     else begin
  388.       lsemp:=new_sem(ident);
  389.       with lsemp^ do begin
  390.         symp := stp;
  391.         token := ident_tokx;
  392.         end
  393.       end
  394.     end;
  395.  
  396.   {************************}
  397.   procedure GET_NUMBER;
  398.     var V: integer;
  399.   begin
  400.     v:=0;
  401.     while ch in ['0'..'9'] do begin
  402.       v:=10*v + ord(ch) - ord('0');
  403.       nextch;
  404.       end;
  405.     token:= int_tokx;
  406.     lsemp:=new_sem(fixed);
  407.     lsemp^.numval:=v;
  408.     end;
  409.  
  410.   {***********************}
  411.   procedure GET_STRING;
  412.     label 1, 99;
  413.   
  414.     {..................}
  415.     procedure PUTCH(CH: char);
  416.     begin
  417.       if strx<maxstrchars then begin
  418.         strtab[strx]:=ch;
  419.         strx:=strx+1;
  420.         end
  421.       else
  422.       if strx=maxstrchars then begin
  423.         error('too many string characters');
  424.         strtab[maxstrchars]:=chr(0);
  425.         strx:=strx+1;
  426.         end
  427.       end;
  428.         
  429.   begin
  430.     lsemp:=new_sem(strng);
  431.     lsemp^.stx:=strx;
  432.     1:
  433.     nextch;  {get over first quote mark}
  434.     while ch<>'''' do begin
  435.       if ch=chr(eolch) then begin
  436.         error('string runs over end of line');
  437.         goto 99;
  438.         end;
  439.       putch(ch);
  440.       nextch;
  441.       end;
  442.     nextch;  {get over last quote mark}
  443.     if ch='''' then begin  {repeated quote mark}
  444.       putch(ch);
  445.       goto 1;   {continue grabbing characters}
  446.       end;
  447.     99:
  448.     putch(chr(0));
  449.     token:=str_tokx;
  450.     end;
  451.     
  452.   {********************}
  453.   procedure GET_TOKEN;
  454.     { Pascal-style lexical analyzer -- sets TOKEN to token number }
  455.   begin
  456.     lsemp:= nil;  { default case }
  457.     skipblanks;
  458.     errpos:=lx-1;
  459.     case ch of
  460.       'a'..'z', 'A'..'Z': get_symbol;
  461.       '0'..'9': get_number;
  462.       '''': get_string;
  463.       '!':  begin
  464.               idebug;
  465.               nextch;
  466.               get_token
  467.             end;
  468.       '(':  begin
  469.               nextch;
  470.               token := 1  { '(' }
  471.             end  { '(' character case };
  472.       ')':  begin
  473.               nextch;
  474.               token := 2  { ')' }
  475.             end  { ')' character case };
  476.       '*':  begin
  477.               nextch;
  478.               token := 3  { '*' }
  479.             end  { '*' character case };
  480.       '+':  begin
  481.               nextch;
  482.               token := 4  { '+' }
  483.             end  { '+' character case };
  484.       ',':  begin
  485.               nextch;
  486.               token := 5  { ',' }
  487.             end  { ',' character case };
  488.       '-':  begin
  489.               nextch;
  490.               token := 6  { '-' }
  491.             end  { '-' character case };
  492.       '/':  begin
  493.               nextch;
  494.               token := 7  { '/' }
  495.             end  { '/' character case };
  496.       ':':  begin
  497.               nextch;
  498.               if ch = '=' then
  499.                 begin
  500.                   nextch;
  501.                   token := 8  { ':=' }
  502.                 end
  503.               else 
  504.                 begin
  505.                   error('Illegal character');
  506.                   nextch;
  507.                   get_token;
  508.                 end
  509.             end  { ':' character case };
  510.       ';':  begin
  511.               nextch;
  512.               token := 9  { ';' }
  513.             end  { ';' character case };
  514.       ELSE  begin
  515.         if ch=chr(eofch) then
  516.           token := stop_tokx
  517.         else if ch=chr(eolch) then begin
  518.           nextch;
  519.           get_token  { go find another (significant) character }
  520.           end
  521.         else begin
  522.           error('invalid character');
  523.           nextch;
  524.           get_token;
  525.           end
  526.         end { case alternatives }
  527.       end; { case }
  528.     if err_count>0 then err_count:=err_count-1;
  529.     end { get_token };
  530.  
  531.   {*******************}
  532.   procedure NEXT_TOKEN;
  533.   begin
  534.     if tokenx>1 then begin
  535.       tokenx := 1;
  536.       get_token;  { goes into token, lsemp }
  537.       tokary[1] := token;
  538.       lsempary[1] := lsemp;
  539.       end
  540.     else begin
  541.       { is in tokary }
  542.       token := tokary[tokenx];
  543.       lsemp := lsempary[tokenx];
  544.       end
  545.     end;
  546.  
  547.   {*****************}
  548.   procedure TOKENREAD;
  549.   begin
  550.     tokenx := tokenx+1;
  551.     end;
  552.  
  553.   {$I tusems}
  554.  
  555.   { LR(1) PARSER procedures }
  556.  
  557.   {****************}
  558.   function ERROR_RECOVERY(var MSTACK: state_stack;
  559.                           var MSTACKX: int; MCSTATE: int): int;
  560.     label 99, 100;
  561.     var STACK: state_stack;  { local copy of stack }
  562.         TOS,              { local stack pointer }
  563.         CSTATE,              { local state }
  564.         JSTX,                { temporary stack limit }
  565.         RX, TL: int;         { index into TOKNUM table }
  566.  
  567.     {...............}
  568.     procedure COPY_STACK;
  569.       var STX: int;
  570.     begin
  571.       if (jstx<0) or (jstx>mstackx) then abort('ERROR RECOVERY BUG');
  572.       for stx := 0 to jstx do
  573.         stack[stx] := mstack[stx];
  574.       tos := jstx;
  575.       if jstx=mstackx then
  576.         cstate := mcstate
  577.       else
  578.         cstate := mstack[jstx+1];
  579.     end;
  580.  
  581.     {...............}
  582.     procedure PUSHREAD(CSTATE: int);
  583.       { adjusts the state stack }
  584.     begin
  585.       tos := tos+1;
  586.       if tos>stacksize then
  587.         abort('stack overflow');
  588.       stack[tos] := cstate;
  589.     end;
  590.  
  591.     {...............}
  592.     function TRIAL_PARSE: boolean;
  593.       { parses from current read state through the inserted and the
  594.         error token; if successful, returns TRUE. }
  595.       label 99;
  596.       var RX: int;
  597.     begin
  598.       trial_parse := true;  { until proven otherwise }
  599.       while cstate<>0 do begin
  600.         if cstate < readstate then begin
  601.           { a reduce state }
  602.           if debug > 3 then stk_dump('E*Reduce', stack,
  603.                                      tos, cstate);
  604.           if popno[cstate]=0 then begin
  605.             { empty production }
  606.             pushread(stk_state[statex[cstate]]);
  607.             cstate := stk_tostate[statex[cstate]];
  608.           end
  609.           else begin
  610.             { non-empty production }
  611.             tos := tos - popno[cstate] + 1;
  612.             rx := statex[cstate];   { compute the GOTO state }
  613.             cstate := stack[tos];
  614.             while (stk_state[rx]<>cstate) and
  615.                   (stk_state[rx]<>0) do rx := rx+1;
  616.             cstate := stk_tostate[rx];
  617.           end
  618.         end
  619.         else if cstate < lookstate then begin
  620.           { a read state }
  621.           next_token;  { need a token now }
  622.           if debug > 3 then stk_dump('E*Read', stack, tos, cstate);
  623.           rx := statex[cstate];
  624.           while (toknum[rx]<>0) and
  625.                 (toknum[rx]<>token) do rx := rx+1;
  626.           if toknum[rx]=0 then begin
  627.             { failure }
  628.             trial_parse := false;
  629.             goto 99;
  630.           end
  631.           else begin
  632.             { did read something }
  633.             pushread(cstate);
  634.             cstate := tostate[rx];
  635.             tokenread;  { scan the token }
  636.             if tokenx>1 then goto 99 { successful }
  637.           end
  638.         end
  639.         else begin
  640.           { lookahead state }
  641.           next_token;  { need a token now }
  642.           if debug > 3 then stk_dump('E*Look', stack, tos, cstate);
  643.           rx := statex[cstate];
  644.           while (toknum[rx]<>0) and
  645.                 (toknum[rx]<>token) do rx := rx+1;
  646.           cstate := tostate[rx];
  647.         end
  648.       end;
  649.     99:
  650.     end;
  651.  
  652.     {.................}
  653.     procedure INCR_ERRSYM;
  654.       { Note that this procedure assumes ASCII. }
  655.     begin
  656.       if errsym[6]='Z' then begin
  657.         errsym[5] := succ(errsym[5]);
  658.         errsym[6] := 'A';
  659.       end
  660.       else
  661.         errsym[6] := succ(errsym[6]);
  662.     end;
  663.  
  664.     {.................}
  665.     procedure MAKE_DEFAULT(TOKX: int; var SEMP: semrecp);
  666.       { creates a default token data structure }
  667.       var SYM: symbol; TSYMP: symtabp;
  668.     begin
  669.       case tokx of
  670.         ident_tokx: begin
  671.           tsymp := makesym(symtab, errsym, symerr, 0);
  672.           semp:=new_sem(ident);
  673.           with semp^ do begin
  674.             symp:=tsymp;
  675.             incr_errsym;
  676.             end
  677.           end;
  678.         int_tokx: begin 
  679.           semp:=new_sem(fixed);
  680.           semp^.numval:=1;
  681.           end;
  682.         ELSE
  683.           semp:=nil;
  684.       end { case tokx }
  685.     end;
  686.  
  687.   begin  { ERROR_RECOVERY }
  688.     if debug > 3 then writeln(rfile, 'Going into ERROR RECOVERY');
  689.     while true do begin
  690.       jstx := mstackx;
  691.       while jstx>=0 do begin
  692.         copy_stack;
  693.         rx := statex[cstate];
  694.         while toknum[rx]<>0 do begin
  695.           { scan through legal next tokens }
  696.           if debug > 3 then writeln(rfile, '...starting trial parse');
  697.           tokary[0] := toknum[rx];  { the insertion }
  698.           tokenx := 0;
  699.           if trial_parse then goto 99;  { it clicked! }
  700.           rx := rx+1;
  701.           if toknum[rx]<>0 then
  702.             copy_stack;
  703.         end;
  704.         jstx := jstx-1;  { reduce stack }
  705.       end;
  706.       if token=stop_tokx then begin
  707.         { empty stack, no more tokens }
  708.         cstate := 0;  { halt state }
  709.         tokenx := 2;
  710.         jstx := 0;  { bottom of stack }
  711.         goto 100;
  712.       end;
  713.       if debug > 3 then begin
  714.         write(rfile, '...dropping token ');
  715.         tl := wrtok(tokary[1]);
  716.         writeln(rfile);
  717.       end;
  718.       tokenx := 2;
  719.       next_token;
  720.       if debug > 3 then begin
  721.         write(rfile, 'New token ');
  722.         tl := wrtok(token);
  723.         writeln(rfile);
  724.       end
  725.     end;
  726.   99:  { found a solution }
  727.     copy_stack;
  728.     if debug > 3 then begin
  729.       write(rfile, 'insertion of ');
  730.       tl := wrtok(tokary[0]);
  731.       writeln(rfile, ' succeeded');
  732.     end;
  733.     make_default(tokary[0], lsempary[0]);
  734.     tokenx := 0;  { forces a `real' rescan of the insertion }
  735.     if jstx<mstackx then
  736.       cstate := stack[jstx+1]
  737.     else
  738.       cstate := mcstate;  { cstate returned }
  739.   100:
  740.     error_recovery := cstate;
  741.     mstackx := jstx;
  742.     if debug > 3 then writeln(rfile, 'Ending error recovery');
  743.   end;
  744.  
  745.   {****************}
  746.   procedure PARSER;
  747.     { Carries out a complete parse, until
  748.       the halt state is seen -- same as empty stack}
  749.     var CSTATE, RX: int;
  750.         TSEMP: semrecp;
  751.  
  752.     {...............}
  753.     procedure PUSHREAD(CSTATE: int; SEMP: semrecp);
  754.       { do the push part of a readstate. }
  755.     begin
  756.       tos := tos+1;
  757.       if tos>stacksize then
  758.         abort('stack overflow');
  759.       sem[tos] := semp;
  760.       stack[tos] := cstate;
  761.     end;
  762.  
  763.   begin
  764.     cstate := start_state;
  765.     tos := -1;
  766.     pushread(stk_state_1, nil);
  767.     while cstate<>0 do begin
  768.       tsemp:=nil;
  769.       if cstate < readstate then begin
  770.         { a reduce state }
  771.         if debug > 0 then stk_dump('Reduce', stack, tos, cstate);
  772.         if map[cstate] <> 0 then
  773.           { the semantics action }
  774.           apply(map[cstate], tsemp);
  775.         if popno[cstate]=0 then begin
  776.           { empty production }
  777.           pushread(stk_state[statex[cstate]], tsemp);
  778.           cstate := stk_tostate[statex[cstate]];
  779.         end
  780.         else begin
  781.           { non-empty production:
  782.             semantics is preserved on a unit production A --> w,
  783.             where |w| = 1, unless something is in TSEMP.  Note that
  784.             if w is nonterminal, the production may be bypassed. }
  785.           tos := tos - popno[cstate] + 1;
  786.           if (tsemp<>nil) or (popno[cstate]<>1) then
  787.             sem[tos] := tsemp;
  788.           { compute the GOTO state }
  789.           rx := statex[cstate];
  790.           cstate := stack[tos];
  791.           while (stk_state[rx]<>cstate) and (stk_state[rx]<>0) do
  792.             rx := rx+1;
  793.           cstate := stk_tostate[rx];
  794.         end
  795.       end
  796.       else if cstate < lookstate then begin
  797.         { a read state }
  798.         next_token;  { need next token now }
  799.         if debug > 2 then stk_dump('Read', stack, tos, cstate);
  800.         rx := statex[cstate];
  801.         while (toknum[rx]<>0) and (toknum[rx]<>token) do
  802.           rx := rx+1;
  803.         if toknum[rx]=0 then begin
  804.           error('syntax error');
  805.           cstate := error_recovery(stack, tos, cstate);
  806.           err_count:=merr_count;
  807.         end
  808.         else begin
  809.           pushread(cstate, lsemp);
  810.           cstate := tostate[rx];
  811.           tokenread;  { token has been scanned }
  812.         end
  813.       end
  814.       else begin
  815.         { lookahead state }
  816.         next_token;  { need another token now }
  817.         if debug > 2 then stk_dump('Look', stack, tos, cstate);
  818.         rx := statex[cstate];
  819.         while (toknum[rx]<>0) and (toknum[rx]<>token) do
  820.           rx := rx+1;
  821.         cstate := tostate[rx];
  822.       end
  823.     end;
  824.     end_sem;
  825.   end;
  826.  
  827.   { PARSE INITIALIZATION }
  828.  
  829.   {*****************}
  830.   procedure INITTABLES;
  831.     var SX: int;
  832.         CODE_SYMP: symtabp;
  833.  
  834.     {................}
  835.     procedure PUTSYM(TSYM: symbol; TV: int);
  836.       var SYMP: symtabp;
  837.           I: int;
  838.     begin
  839.       symp:=makesym(symtab, tsym, reserved, -1);
  840.       symp^.tokval:=tv;
  841.     end;
  842.  
  843.     {................}
  844.     procedure PUTTOK(PRINTVAL: string80;  TOKNUM, START: int);
  845.       { this procedure is used to initialize the token tables.
  846.         toknum is the number of the token to be initialized, and
  847.         start is where it should start in the tokchar array. }
  848.       var OFFSET:  int;
  849.     begin
  850.       tokx[toknum] := start;
  851.       for offset := 0 to length(printval)-1 do
  852.         tokchar[start+offset] := printval[offset+1];
  853.       tokchar[start+length(printval)] := chr(0)
  854.     end;
  855.  
  856.     {................}
  857.     procedure INIT_PARSER_TABLES;
  858.       { initialize the parser tables }
  859.     begin
  860.       { initialize keywords in the symbol table. }
  861.       putsym('BEGIN', 17);
  862.       putsym('DO', 18);
  863.       putsym('ELSE', 19);
  864.       putsym('END', 20);
  865.       putsym('FUNCTION', 21);
  866.       putsym('IF', 22);
  867.       putsym('THEN', 23);
  868.       putsym('VAR', 24);
  869.       putsym('WHILE', 25);
  870.       { initialize the token tables. }
  871.       puttok('(', 1, 1);
  872.       puttok(')', 2, 3);
  873.       puttok('*', 3, 5);
  874.       puttok('+', 4, 7);
  875.       puttok(',', 5, 9);
  876.       puttok('-', 6, 11);
  877.       puttok('/', 7, 13);
  878.       puttok(':=', 8, 15);
  879.       puttok(';', 9, 18);
  880.       puttok('<empty>', 10, 20);
  881.       puttok('<eol>', 11, 28);
  882.       puttok('<identifier>', 12, 34);
  883.       puttok('<integer>', 13, 47);
  884.       puttok('<real>', 14, 57);
  885.       puttok('<stop>', 15, 64);
  886.       puttok('<string>', 16, 71);
  887.       puttok('BEGIN', 17, 80);
  888.       puttok('DO', 18, 86);
  889.       puttok('ELSE', 19, 89);
  890.       puttok('END', 20, 94);
  891.       puttok('FUNCTION', 21, 98);
  892.       puttok('IF', 22, 107);
  893.       puttok('THEN', 23, 110);
  894.       puttok('VAR', 24, 115);
  895.       puttok('WHILE', 25, 119);
  896.       puttok('Expr', 26, 125);
  897.       puttok('ExprList', 27, 130);
  898.       puttok('FDeclList', 28, 139);
  899.       puttok('FuncDecl', 29, 149);
  900.       puttok('Goal', 30, 158);
  901.       puttok('Primary', 31, 163);
  902.       puttok('Stmt', 32, 171);
  903.       puttok('StmtList', 33, 176);
  904.       puttok('Term', 34, 185);
  905.     end { init_parser_tables };
  906.  
  907.   begin { inittables }
  908.     pwr10_2[0] := 1E1;  {10^(2^0)}
  909.     pwr10_2[1] := 1E2;  {10^(2^1)}
  910.     pwr10_2[2] := 1E4;
  911.     pwr10_2[3] := 1E8;
  912.     pwr10_2[4] := 1E16;
  913.     pwr10_2[5] := 1E32;
  914.     lsempary[0]:=nil;
  915.     lsempary[1]:=nil;
  916.     lsemp := nil;
  917.     tokenx := 2;  { no token queue }
  918.     for sx := 0 to hlimit do begin
  919.       symtab[sx] := nil;  { initialize symbol tables }
  920.       end;
  921.     for sx := 0 to stacksize do begin
  922.       sem[sx]:=nil;
  923.     end;
  924.     init_parser_tables;
  925.     init_sem;
  926.     errsym:='ERR#AA';
  927.     strx:=0;
  928.     line := '';  { fake a new line }
  929.     lx := 1;
  930.     errpos:=1;
  931.     err_count:=0;
  932.     nextch;  { fetch the first character, forcing a line read }
  933.   end;
  934.  
  935.   {**********************}
  936.   function OPENFILES: boolean;
  937.   begin
  938.     openfiles:=false;
  939.     write('Source file? ');
  940.     readln(sfilename);
  941.     prompt:='';
  942.     promptlen:=3;  {length of ` ; '}
  943.     if sfilename='' then begin
  944.       prompt:='> ';
  945.       sfilename:=default_sfile;
  946.       is_console:=true;
  947.       promptlen:=promptlen+2;
  948.       end
  949.     else is_console:=false;
  950.     if openfile(sfile, sfilename, false) then begin
  951.       write('Target file? ');
  952.       readln(rfilename);
  953.       if rfilename='' then rfilename:=default_rfile;
  954.       openfiles:=openfile(rfile, rfilename, true);
  955.       end
  956.     end;
  957.     
  958. begin
  959.   writeln('Tiny Pascal Compiler, ', version_string);
  960.   writeln;
  961.   errors := 0;
  962.   debug := 0;
  963.   trace := false;
  964.   if openfiles then begin
  965.     inittables;
  966.     parser;  { does it all }
  967.     closefiles;
  968.     end
  969.   end.
  970.  
  971.  
  972.