program compiler(input,output,SourceFile,ListFile,CodeFile);

const
      number_of_ssym = 10; { number of single-character tokens }
      ORD_TAB        = 9; { ascii TAB character }

      MAXSYM = 520; { maximum number of entries in the symbol table }
      MAXDISPLAYDEPTH = 20; { maximum nesting of procedures }
      FAKENIL = -1; { since we're faking the pointer }
      MAXERRCOUNT = 10; { most errors reported for one line }

{ some target machine constants }
      BITSETSIZE        = 31; { number of elements - 1 in BITSET type }

      INTEGER_ALIGN     = 2;  { even bytes only }
      CHAR_ALIGN        = 1;  { any byte alignment }
      REAL_ALIGN        = 2;
      BOOLEAN_ALIGN     = 1;
      CARDINAL_ALIGN    = 2;
      BITSET_ALIGN      = 2;
      POINTER_ALIGN     = 2;

      INTEGER_SIZE      = 4;  { take up four bytes }
      CHAR_SIZE         = 1;  { take up one byte }
      REAL_SIZE         = 8;  { take up eight bytes }
      BOOLEAN_SIZE      = 1;
      CARDINAL_SIZE     = 4;
      BITSET_SIZE       = 4;
      POINTER_SIZE      = 4;

      BOOLTRUEVAL  = 1;       { constants which represent the boolean }
      BOOLFALSEVAL = 0;       { values in the target machine.         }

type
     IDstring = string[32];   { used for holding names of IDs }
     string80 = string[80];   { used for holding string literals }
     string5  = string[5];
     StringPTR = ^string80;

     { types of tokens }
     Tokens    = (IntConst, RealConst, CharConst, StringConst, MulOp, AddOp,
                  UnaryOp, RelOp, ID, comma, semicolon, colon, period,
                  ellipsis, stroke, uparrow, Lparen, Rparen,
                  Lbracket, Rbracket, Lbrace, Rbrace,
                  ANDsym, DIVsym, MODsym, NOTsym, ORsym, NILsym,
                  IMPLEMsym, IMPORTsym, EXPORTsym, DEFINsym, MODULEsym,
                  QUALIFsym,
                  IFsym, THENsym, ELSEsym, ELSIFsym, BEGINsym, ENDsym,
                  CASEsym, OFsym, WHILEsym, DOsym, FORsym, TOsym,
                  REPEATsym, UNTILsym, LOOPsym, EXITsym,
                  ASSIGNsym, RECORDsym, ARRAYsym, PROGRAMsym, PROCEDUREsym,
                  POINTERsym, SETsym, CONSTsym, VARsym, TYPEsym, EOFtoken,
                  nosym);

     setoftokens = SET OF Tokens;

     { binary operators except relational operators }
     MulType = (times, divide, divv, modd, andd);
     AddType = (plus, minus, orr);

     { relational operators }
     RelType    = (relEQ, relNEQ, relLT, relLE, relGT, relGE);

     { unary operators }
     UnaryType  = (nott, negate);

     bitsettype = packed array[0..BITSETSIZE] of boolean;

     TokenType = record
                   case token : tokens of
                      IntConst    : (Ival : integer);
                      RealConst   : (Rval : real);
                      CharConst   : (Cval : char);
                      StringConst : (Sval : StringPTR);
                      MulOp       : (MultOp : MulType);
                      AddOp       : (AdddOp : AddType);
                      UnaryOp     : (UnOp : UnaryType);
                      RelOp       : (Rop : RelType);
                      ID          : (Name : IDstring);
                   end; { TokenType }

     constkind = (constINT, constCARD, constREAL, constCHAR,
                  constSTR, constBITSET);
     structkind = (Basic, Enumerated, Range, Sett, Arrayy, Recordd, Pointr);
     entkind = (Constt, Varr, Enum, Typee, Field, UProc, UFunc,
                StdProc, StdFunc, unknown);

     entryPTR  = -1..MAXSYM;
     const_entryPTR = ^const_entry;
     var_entryPTR = ^var_entry;
     enum_entryPTR = ^enum_entry;
     structPTR = ^struct;

     { A structure can be pointed to from many places.  The owner bit is set
       true on the node which is responsible for the DISPOSE-ing of the
       structure. }
     struct_entryPTR = record
                           PTR : structPTR;
                         owner : boolean;
                       end;

     const_entry = record
                      case const_kind : constkind of
                          constINT : ( Ival : integer );
                         constCARD : ( Cardval : integer );
                         constREAL : ( Rval : real );
                         constCHAR : ( Cval : char );
                          constSTR : ( Sval : stringPTR );
                       constBITSET : ( bits : bitsettype);
                   end; { record const_entry }

     var_entry   = record
                      adr : integer; { abs address of rel offset from SP }
                      vstruct : struct_entryPTR; { pointer to variable's structure }
                      linkfield : var_entryPTR; { for grouping's sake }
                   end; { record var_entry }

     enum_entry   = record
                       enumclass : struct_entryPTR;{ pointer to containing structure }
                       enumval : integer;          { ordinal value }
                    end; { record enum_entry }

           struct = record
                      size : integer;  { size of structure }
                      align : integer; { alignment of first element }
                      case form : structkind of
                             Basic : (basicptr : structPTR);
                            Pointr : (ptrtype : struct_entryPTR);
                        Enumerated : (lastelem : enum_entryPTR);
                             Range : (rangetype : struct_entryPTR;
                                      min, max : integer);
                              Sett : (settype : struct_entryPTR);
                            Arrayy : (indextype : struct_entryPTR;
                                      contenttype : struct_entryPTR);
                           Recordd : ( { none } );
                    end; { record struct }


     { types for expression compilation }
     attrtype  = (cnstant, enumer, variable, expr);
     varaccess = (direct, indirect, indexed);

     { for allocation of temporary locations }
     address = integer; { contains the stack displacement }

     attributes = record
                     ttype : structPTR;
                     loc : address;  { offset of expression value }
                     temp : boolean; { true if a temp result }
                     case kind : attrtype of
                        cnstant : (val : const_entryPTR);
                         enumer : (enumval : integer);
                           expr : ();
                       variable : (case access : varaccess of
                                      direct : (lexlevel : integer);
                                    indirect : (baseptr : address);
                                     indexed : ()               )
                  end; { record attributes }


     tempheapptr = ^tempheap;
     tempheap = record
                   adr : integer;
                   ptr : tempheapptr;
                end;

     { for Icode labels }
     labeltype = -1..100000000; { -1 .. MAXINT blows up PASSEM }

     { types for lexical analysis }
     ch_class_type = (letter, digit, space, endofline, endoffile, other);
     ch_type = record
                  class : ch_class_type;
                  val : char;
               end; { ch_type record }


{ GLOBAL VARS }

var
    { the list of reserved symbols }
    ReservedWords : array[ANDsym..TYPEsym] of string[14];

    { files }
    SourceFile,ListFile,CodeFile : text;

    { Contains symbol information }
    ST : array [0..MAXSYM] of
            record
               IDname : IDstring;         { name of ID; '' means empty }
               nestingdepth : integer;    { level of proc nesting }
               backlink : entryPTR;       { ptr to last var on same level }
               case entry_type : entkind of
                  Constt : (constptr : const_entryPTR;
                            constype : structPTR);       { CONST ids }
                    Varr : (varptr : var_entryPTR);      { VAR ids }
                   Typee : (typptr : struct_entryPTR);   { TYPE ids }
                    Enum : (enumptr : enum_entryPTR);    { enumerated ids }
                   Field : (fieldptr : var_entryPTR;     { record fields }
                            recptr : structPTR);         { ^ to declaring rec }
                   UProc : ( { none } );
                   UFunc : ( { none } );
                 StdProc : ( { none } );
                 StdFunc : ( { none } );
                 unknown : ( { none } );
            end; { ST }

    { these variables hold the sets of synchronizing tokens for error recovery }
    constbegtoks, typedelimtoks, typebegtoks, blockbegtoks, factorbegtoks,
      stmtbegtoks, specifytoks : setoftokens;

    { The display is the information specific to a certain lexical level
      which must be maintained as we return down to a lexical level. }

    display : array [0..MAXDISPLAYDEPTH] of record
                 lastlink : entryPTR;  { most recent ST declaration }
                 first : array [1..8] of tempheapptr; { list of temps }
                 vvloc : integer;      { stack offset }
                 looplabel : labeltype; { label of most recent loop }
              end; { display }

    { vloc is used a lot so it is efficent to keep vloc out here }
    vloc : integer;

    { level of nesting of scope rules }
    NestLevel : integer;

    { this var is the Icode label counter }
    ILabel : labeltype;

    { these pointers will be useful for determining variable types }
    BITSET_, BOOLEAN_, CARDINAL_, CHAR_, INTEGER_, PROC_, REAL_, STRING_,
    POINTER_   : structPTR;

    { this global variable holds the attributes of the expression currently
      being compiled. }
    gattr : attributes;

    { the list of single character symbols and token equivalents }
    ssym_names : array[1..number_of_ssym] of char;
    ssym_token : array[1..number_of_ssym] of Tokens;

    { the next two vars are used as a 1-deep token queue }
    StoredToken : TokenType;   { token on queue }
    TokenIsWaiting : boolean;  { queue depth (empty or not) }

    { the next vars are used to hold the current line of info }
    currentline : string[132];
    lineptr     : 1..133;
    linelength  : integer;
    linenumber  : integer;
    CharWaiting : boolean; { use to remember if one char has been put back }
    StoredChar  : ch_type;

    { err_list holds all the errors that have occurred on a given line }
    err_list : record
                  ErrCount : 0..MAXERRCOUNT;
                  ErrNum   : array [1..MAXERRCOUNT] of integer;
                  ErrPos   : array [1..MAXERRCOUNT] of integer;
               end;


    { this is a global token holder }
    tok : TokenType;
{ lexical routines }
{$BOX

  This procedure initializes all the static global variables used by
  the compiler.

$EBOX}

procedure InitLex;

begin

   { create the reserved word list }
   ReservedWords[ANDsym]        := 'AND';
   ReservedWords[DIVsym]        := 'DIV';
   ReservedWords[MODsym]        := 'MOD';
   ReservedWords[NOTsym]        := 'NOT';
   ReservedWords[ORsym]         := 'OR';
   ReservedWords[NILsym]        := 'NIL';

   ReservedWords[IMPLEMsym]     := 'IMPLEMENTATION';
   ReservedWords[IMPORTsym]     := 'IMPORT';
   ReservedWords[EXPORTsym]     := 'EXPORT';
   ReservedWords[DEFINsym]      := 'DEFINITION';
   ReservedWords[MODULEsym]     := 'MODULE';
   ReservedWords[QUALIFsym]     := 'QUALIFIED';

   ReservedWords[IFsym]         := 'IF';
   ReservedWords[THENsym]       := 'THEN';
   ReservedWords[ELSEsym]       := 'ELSE';
   ReservedWords[BEGINsym]      := 'BEGIN';
   ReservedWords[ENDsym]        := 'END';
   ReservedWords[CASEsym]       := 'CASE';
   ReservedWords[OFsym]         := 'OF';
   ReservedWords[WHILEsym]      := 'WHILE';
   ReservedWords[DOsym]         := 'DO';
   ReservedWords[FORsym]        := 'FOR';
   ReservedWords[TOsym]         := 'TO';
   ReservedWords[REPEATsym]     := 'REPEAT';
   ReservedWords[UNTILsym]      := 'UNTIL';
   ReservedWords[LOOPsym]       := 'LOOP';
   ReservedWords[EXITsym]       := 'EXIT';
   ReservedWords[ASSIGNsym]     := ':=';
   ReservedWords[RECORDsym]     := 'RECORD';
   ReservedWords[ARRAYsym]      := 'ARRAY';
   ReservedWords[PROGRAMsym]    := 'PROGRAM';
   ReservedWords[PROCEDUREsym]  := 'PROCEDURE';
   ReservedWords[POINTERsym]    := 'POINTER';
   ReservedWords[SETsym]        := 'SET';
   ReservedWords[CONSTsym]      := 'CONST';
   ReservedWords[VARsym]        := 'VAR';
   ReservedWords[TYPEsym]       := 'TYPE';

   { intialize the list of single character tokens }
   ssym_names[1]  := ',';   ssym_token[1]  := comma;
   ssym_names[2]  := ';';   ssym_token[2]  := semicolon;
   ssym_names[3]  := '|';   ssym_token[3]  := stroke;
   ssym_names[4]  := '^';   ssym_token[4]  := uparrow;
   ssym_names[5]  := '[';   ssym_token[5]  := Lbracket;
   ssym_names[6]  := ']';   ssym_token[6]  := Rbracket;
   ssym_names[7]  := '{';   ssym_token[7]  := Lbrace;
   ssym_names[8]  := '}';   ssym_token[8]  := Rbrace;
   ssym_names[9]  := '(';   ssym_token[9]  := Lparen;
   ssym_names[10] := ')';   ssym_token[10] := Rparen;

   { counter of the number of lines read from the source file }
   linenumber := 0;

   { no chars have been read in yet }
   CharWaiting := FALSE;

end; { InitGlobals }

{$EJECT}
{$BOX

  This procedure prompts the user for the program name (without extension)
  and then attempts to open the source, list, and code files.  The program
  will abort if any of these files fail to open.

  The manditory extensions are:
     xxx.SOURCE    --- (source code file)
     xxx.LIST      --- (compiler listing file)
     xxx.ICODE     --- (intermediate code file)

$EBOX}

procedure OpenFiles(var InputFile, ListFile, CodeFile : text);

var InFileName, ListFileName, CodeFileName : string[20];
    dummy : boolean;
    Errcode : integer;
    NameLength : 0..20;

begin

   writeln;
   writeln('Mini-Mod compiler');

   { get the generic name of the files }
   format(output,'*');
   writeln(output,'Name of source file>');
   readln(input,InFileName);

   { add manditory extensions }
   NameLength := length(InFileName);
   ListFileName := InFileName;
   ListFileName[NameLength+1..NameLength+6] := '.LIST';
   CodeFileName := InFileName;
   CodeFileName[NameLength+1..NameLength+7] := '.ICODE';
   InFileName[NameLength+1..NameLength+8] := '.SOURCE';

   { open the source file }
   Open(InputFile,InFileName,ReadOnlyAccess,FALSE,FALSE,saf,dummy);
   GetErrorCode(InputFile,ErrCode);
   If ErrCode <> 0 then begin
      writeln('Could not open the source file');
      stopprogram(1);
   end;

   { open the list file}
   Open(ListFile,ListFileName,ReadOnlyAccess,FALSE,TRUE,saf,dummy);
   GetErrorCode(ListFile,ErrCode);
   If ErrCode <> 0 then begin
      writeln('Could not open the list file');
      stopprogram(1);
   end;
   ReWrite(ListFile);   { empty the list file if it already existed }

   { open the code file}
   Open(CodeFile,CodeFileName,ReadOnlyAccess,FALSE,TRUE,saf,dummy);
   GetErrorCode(CodeFile,ErrCode);
   If ErrCode <> 0 then begin
      writeln('Could not open the code file');
      stopprogram(1);
   end;
   ReWrite(CodeFile);  { empty the code file if it already existed }

end; { procedure OpenFiles }

{$EJECT}
{$BOX

  This procedure will attempt to close the file passed to it.
  If the file does not close properly then an error message is printed
  and the program aborts.

$EBOX}

procedure CloseFile(var FileToClose : text);

var Errcode : integer;

begin

   Close(FileToClose,FALSE); { close it, don't destroy it }
   GetErrorCode(FileToClose,Errcode);
   If (Errcode <> 0) then begin
      writeln('Error in closing a file');
      STOPPROGRAM(1); { indicate abnormal termination }
   end;

end; { procedure CloseFile }

{$EJECT}
{$BOX

  This procedure is used to 'reattach' a token.  It will be called
  when the parser has pulled off one more token than it needs.

$EBOX}

procedure ReturnToken(Token : TokenType);

begin

   If TokenIsWaiting then begin
      writeln('COMPILER ERROR: tried to return two tokens');
      STOPPROGRAM(1);
      end
   else begin
      TokenIsWaiting := TRUE;
      StoredToken := Token;
   end;

end; { procedure ReturnToken }

{$EJECT}
{$BOX

  This procedure will read the next line of the source file and store it
  in a global variable.  It will establish the line length and reset the
  character-of-line pointer.  Also, leading spaces are skipped.

$EBOX}

procedure GetCurrentLine;

begin

   readln(SourceFile,currentline);  { read next line }
   linelength := length(currentline); { remember its length }
   linenumber := linenumber + 1; { line # of source file }

   { skip leading spaces }
   lineptr := 1; { pointer to next character to read }
   if (linelength > 1) then
      while (lineptr < linelength) and (currentline[lineptr] = ' ') do
         lineptr := lineptr + 1;

   { empty out the list of errors for the line being parsed }
   err_list.ErrCount := 0;

end; { procedure GetCurrentLine }

{$EJECT}
{$BOX

  This procedure will send the current line to the list file.  It will
  later on also append the error list accumulated by that line.

$EBOX}

procedure ListCurrentLine;

var i,j : integer;

begin

   { print out the line that was read in most recently }
   writeln(ListFile,linenumber:5,' : ',currentline);

   { now print the list of accumulated errors }
   for j := 1 to err_list.ErrCount do begin
      for i := 1 to err_list.ErrPos[j]+6 do write(ListFile,' ');
      writeln(ListFile,'^',err_list.ErrNum[j]:1);
      end;

end; { procedure ListCurrentLine }


{$EJECT}
{$BOX

  This procedure collects the errors reported during the compilation of one
  line.  If MAXERRCOUNT or more errors occur on one line, the last error
  reported will be 255, "further error reporting suppressed."

$EBOX}

procedure ReportError(err : integer);

begin
   with err_list do
      If (ErrCount = MAXERRCOUNT) then begin
         ErrNum[MAXERRCOUNT] := 255;
         ErrPos[MAXERRCOUNT] := ErrPos[MAXERRCOUNT-1] + 1;
         end
      else begin
         ErrCount := ErrCount + 1;
         ErrNum[ErrCount] := err;
         ErrPos[ErrCount] := lineptr; { current char in line }
         end;
end; { procedure ReportError }

{$EJECT}
{$BOX

  This procedure scans the input stream and assembles the next token.

$EBOX}

procedure GetNextToken(var NextToken : TokenType);

var
    TryAgain : boolean;
    ch : ch_type;

   {======================================================================}

   procedure UnGetCh;

   { this procedure 'ungets' one character from the current line }

   begin
      If (CharWaiting) then begin
           writeln('COMPILER ERROR: UnGot more than one char');
           STOPPROGRAM(1);
           end
      else begin StoredChar := ch; charwaiting := TRUE; end;
   end; { procedure UnGetCh }

   {======================================================================}

   procedure GetCh;

   { All characters read by the compiler will come from GetCh,
     i.e., this should be the only window to the source file.
     Other routines rely on the fact that ch.val will be a space
     if it ch.class isn't a letter, digit, or other.            }

   begin
      If CharWaiting then begin ch := StoredChar; CharWaiting := FALSE; end
      else begin
         { if we have consumed the entire line, read the next }
         If (lineptr > linelength) then begin
            ListCurrentLine;
            If EOF(SourceFile) then begin
               { if we have consumed all the input then return endoffile status }
               ch.class := endoffile;
               ch.val := ' ';
               end
            else begin
               GetCurrentLine;  { read in next line }
               ch.class := endofline;
               ch.val := ' ';
               end;
            end
         else begin { classify the next letter }
            ch.val := currentline[lineptr];  { read next character }
            lineptr := lineptr + 1;
            if (ch.val >= '0') and (ch.val <= '9') then ch.class := digit
            else if ((ch.val >= 'A') and (ch.val <= 'Z'))
                 or ((ch.val >= 'a') and (ch.val <= 'z')) then ch.class := letter
            else if (ch.val = ' ') or (ORD(ch.val) = ORD_TAB) then ch.class := space
            else ch.class := other;
         end;
      end;
   end; { procedure GetCh }

   {======================================================================}

   procedure TokenizeID;

   var reserved : tokens;  { used to search the reserved word list }
       IDname : IDstring;

   begin

      IDname := '';
      repeat
         IDname[length(IDname)+1] := ch.val;
         GetCh;
      until (ch.class <> letter) and (ch.class <> digit);
      UnGetCh; { return last character }

      { first assume it isn't a reserved word }
      NextToken.token := ID;
      NextToken.Name := IDname;

      for reserved := ANDsym to TYPEsym do
         if (ReservedWords[reserved] = IDname) then
            NextToken.token := reserved;

      case NextToken.token of
         ANDsym : begin NextToken.token := MulOp;
                        NextToken.MultOp := andd; end;
          ORsym : begin NextToken.token := AddOp;
                        NextToken.AdddOp := orr; end;
         DIVsym : begin NextToken.token := MulOp;
                        NextToken.MultOp := divv; end;
         MODsym : begin NextToken.token := MulOp;
                        NextToken.MultOp := modd; end;
         NOTsym : begin NextToken.token := UnaryOp;
                        NextToken.UnOp := nott; end;
         otherwise { nothing }
      end; { case }

   end; { procedure TokinizeID }

   {======================================================================}

   procedure ConvertInt(digit : IDstring; base : integer; var result : integer);

   { This procedure accepts a string of digits and converts them to an integer
     assuming the numbers are in base 'base'.  Numbers that are too large
     will be caught. }

   var i, digval : integer;

   begin

      result := 0;
      for i := 1 to length(digit) do begin

         if (digit[i] >= '0') and (digit[i] <= '9') then
            digval := ORD(digit[i]) - ORD('0')
         else if (digit[i] >= 'A') and (digit[i] <= 'Z') then
            digval := ORD(digit[i]) - ORD('A')
         else if (digit[i] >= 'a') and (digit[i] <= 'z') then
            digval := ORD(digit[i]) - ORD('a')
         else digval := 100; { too big }

         if (digval >= base) then ReportError(3 { bad digit} )
         else if (result > ((MAXINT - digval) div base)) then begin
            ReportError(4 { int too big });
            result := 0; { otherwise an error would result for each extra digit }
            end
         else result := base*result + digval;

      end; { for }

   end; { procedure ConvertInt }

   {======================================================================}

   procedure TokenizeNum;

   { This procedure is entered after a digit has been spotted.  The value
     returned may be an integer, a real, or even a character.  We have to
     accumulate all the digits until we start converting. }

   var digits : IDstring;
       intval : integer;     { used for accumulating numbers }
       Rval : real;          { used for forming a real constant }
       Power : integer;      { used for scaling real number }
       i : integer;          { index for looping }
       FabToken : TokenType; { in the event of something like 0..100 }

   begin

      digits := '';
      intval := 0;
      repeat
         digits[length(digits)+1] := ch.val;
         GetCh;
      until (ch.class <> letter) and (ch.class <> digit);
      UnGetCh; { put back last letter that GetCh got }

      If (digits[length(digits)] = 'H') then begin
         { It is a hex constant.  Convert base 16 }
         ConvertInt(digits[1..length(digits)-1],16,intval);
         NextToken.token := IntConst;
         NextToken.Ival  := intval;
         end
      else if (digits[length(digits)] = 'B') then begin
         { It is an octal constant.  Convert base 8 }
         ConvertInt(digits[1..length(digits)-1],8,intval);
         NextToken.token := IntConst;
         NextToken.Ival  := intval;
         end
      else if (digits[length(digits)] = 'C') then begin
         { it is an char constant expressed as an octal number }
         ConvertInt(digits[1..length(digits)-1],8,intval);
         if (intval > 255) then ReportError(5 { constant too large })
         else begin
            NextToken.token := CharConst;
            NextToken.Cval  := CHR(intval);
            end
         end
      else if (ch.val <> '.') then begin { it is a decimal integer }
         ConvertInt(digits[1..length(digits)],10,intval);
         NextToken.token := IntConst;
         NextToken.Ival  := intval;
         end
      else begin { it may be a range, e.g. '1..16' }
         GetCh; { get first period back }
         GetCh; { get char following period }
         if (ch.class <> digit) then begin
            { we've swallowed two characters.  Since only one can go back...}
            FabToken.token := ellipsis; ReturnToken(FabToken);
            ConvertInt(digits[1..length(digits)],10,intval);
            NextToken.token := IntConst;
            NextToken.Ival  := intval;
            end
         else begin { it is a horrible real number }
            Rval := 0;
            for i := 1 to length(digits) do
               if (digits[i] >= '0') and (digits[i] <= '9') then
                  Rval := 10.0 * Rval + (ORD(digits[i]) - ORD('0'))
               else ReportError(6 { bad decimal digit });
            Power := 1;
            { the first digit to the right of . was already read in }
            While (ch.class = digit) do begin
               Rval := 10.0 * Rval + (ORD(ch.val) - ORD('0'));
               Power := Power * 10;
               GetCh;
               end; { while }
            Rval := Rval / Power; { normalize the fractional part }
            { insert code for exponents here! }
            UnGetCh; { return last non-digit }
            NextToken.token := RealConst;  { indicate token type }
            NextToken.Rval  := Rval;       { pass back value }
         end;
      end;

   end; { procedure TokenizeNum }

   {======================================================================}

   procedure TokenizeString;

   { This procedure builds a constant string which is terminated by the
     same kind of quote used to open it.  It is an error if there is an
     endofline before the quote gets closed.  Any strings with length one
     are returned as type char. }

   var startquote : char;
       conststr : string80;
       strPTR : stringPTR;
       done : boolean;

   begin

      startquote := ch.val;  { will be a " or a ' }
      conststr := '';
      done := FALSE;
      repeat
         GetCh;
         If (ch.class = endoffile) or (ch.class = endofline) then begin
            done := TRUE;
            ReportError(2 { quote not closed });
            end
         else if (ch.val = startquote) then done := TRUE
         else conststr[length(conststr)+1] := ch.val;
      until done;
      if (length(conststr) = 1) then begin { return a char constant }
         NextToken.token := CharConst;
         NextToken.Cval := conststr;
         end
      else begin { return a string }
         NextToken.token := StringConst;  { say token is of string type }
         NEW(strPTR); { allocate space for string }
         strPTR^ := conststr;
         NextToken.Sval  := strPTR;
         end;

   end; { procedure TokenizeString }

   {======================================================================}

   procedure ProcessComment;

   { This procedure eats up input until a the comment terminator is found.
     Comments nest.  It is assumed that the first leading comment has been
     read in already. }

   var lastch : char;
       depth : integer;   { depth of comment nesting }

   begin
      depth := 1; GetCh;
      repeat
         lastch := ch.val; GetCh;
         if (lastch = '(') and (ch.val = '*') then depth := depth + 1;
         if (lastch = '*') and (ch.val = ')') then depth := depth - 1;
      until (depth = 0);
   end; { procedure ProcessComment }

   {======================================================================}

   procedure ProcessOther;

   { this procedure attempt to find a symbol for one of the 'other' type
     tokens. }

   var i : 1..number_of_ssym;  { loop index }
       match : boolean;

   begin
      { first try single-character tokens }
      match := FALSE;
      for i := 1 to number_of_ssym do
         if (ch.val = ssym_names[i]) then
            begin match := TRUE; NextToken.token := ssym_token[i]; end;

      if not match then
         if (ch.val = '.') then begin  { see if it is . or .. }
            GetCh;
            If (ch.val = '.') then NextToken.token := ellipsis
            else begin UnGetCh; NextToken.token := period; end
            end
         else if (ch.val = ':') then begin
            GetCh;
            If (ch.val = '=') then NextToken.token := ASSIGNsym
            else begin UnGetCh; NextToken.token := colon; end
            end
         else if (ch.val = '<') then begin
            GetCh; NextToken.token := RelOp;
            If (ch.val = '=') then NextToken.Rop := relLE
            else If (ch.val = '>') then NextToken.Rop := relNEQ
            else begin UnGetCh; NextToken.Rop := relLT; end
            end
         else if (ch.val = '>') then begin
            GetCh; NextToken.token := RelOp;
            If (ch.val = '=') then NextToken.Rop := relGE
            else begin UnGetCh; NextToken.Rop := relGT; end
            end
         else if (ch.class = endoffile) then NextToken.token := EOFtoken
         else case ch.val of
            '=' : begin NextToken.token  := RelOp;
                        NextToken.ROp    := relEQ; end;
            '#' : begin NextToken.token  := RelOp;
                        NextToken.Rop    := relNEQ; end;
            '+' : begin NextToken.token  := AddOp;
                        NextToken.AdddOp := plus; end;
            '-' : begin NextToken.token  := AddOp;
                        NextToken.AdddOp := minus; end;
            '*' : begin NextToken.token  := MulOp;
                        NextToken.MultOp := times; end;
            '/' : begin NextToken.token  := MulOp;
                        NextToken.MultOp := divide; end;
        otherwise begin
                     ReportError(1 { unexpected symbol});
                     NextToken.token := nosym;
                  end;

         end; { case }

   end; { procedure ProcessOther }

   {======================================================================}

begin  { procedure GetNextToken }

   repeat
      TryAgain := FALSE; { used in case the next input item is not returnable }
                         { i.e., a comment, end of line, etc. }
      { skip any leading spaces }
      Repeat GetCh until (ch.class <> space);
      case ch.class of
         letter : TokenizeID;
          digit : TokenizeNum;
          other : if (ch.val = '''') or (ch.val = '"') then TokenizeString
                  else if (ch.val = '(') then begin { see if it's a comment }
                     GetCh;
                     if (ch.class = other) and (ch.val = '*') then begin
                        ProcessComment;
                        TryAgain := TRUE;
                        end
                     else begin
                        UnGetCh; { put back character after the ( }
                        NextToken.token := Lparen;
                        end;
                  end
                  else ProcessOther;
      endofline : TryAgain := TRUE;
      endoffile : NextToken.token := EOFtoken;
      end; { case }

   until not TryAgain;

end; { procedure GetNextToken }


{$EJECT}
{$BOX

  This procedure will return the 'next' token from the input stream.
  If the parser has returned a token then send the token back to the
  parser, otherwise return the actual next token.

$EBOX}

procedure FetchToken;

begin

   If TokenIsWaiting then begin
      { a token has been put back so use it first }
      Tok := StoredToken;
      TokenIsWaiting := FALSE;
      end
   else
      { there is no stored token so get the next token }
      GetNextToken(tok);

end; { procedure FetchToken }


{$EJECT}
{$BOX

  This procedure prints out the contents of the token passed to it to the
  list file.

$EBOX}

procedure PrintToken(tok : TokenType);
begin
   case tok.token of
      IntConst : write(ListFile,'INTEGER:',tok.Ival);
      RealConst : write(ListFile,'REAL:',tok.Rval);
      CharConst : write(ListFile,'CHAR:',tok.Cval);
      StringConst : begin { return string to heap }
                       write(ListFile,'STRING:',tok.Sval^);
                       Dispose(tok.Sval);
                    end;
      MulOp : case tok.MultOp of
                   times : write(ListFile,'*');
                   divide : write(ListFile,'/');
                   modd : write(ListFile,'MOD');
                   divv : write(ListFile,'DIV');
                   andd : write(ListFile,'AND');
                 end;
      AddOp : case tok.AdddOp of
                   plus : write(ListFile,'+');
                   minus : write(ListFile,'-');
                   orr : write(ListFile,'OR');
                 end;
       UnaryOp : case tok.UnOp of
                   nott : write(ListFile,'NOT');
                   negate : write(ListFile,'-');
                 end;
      RelOp : case tok.ROp of
                   relEQ : write(ListFile,'=');
                   relNEQ : write(ListFile,'<>');
                   relLT : write(ListFile,'<');
                   relLE : write(ListFile,'<=');
                   relGE : write(ListFile,'>=');
                   relGT : write(ListFile,'>');
              end; { case }
      ID : write(ListFile,'ID:',tok.Name);
      comma : write(ListFile,',');
      semicolon : write(ListFile,';');
      colon : write(ListFile,':');
      period : write(ListFile,'.');
      ellipsis : write(ListFile,'..');
      Lparen : write(ListFile,'(');
      Rparen : write(ListFile,')');
      Lbracket : write(ListFile,'[');
      Rbracket : write(ListFile,']');
      Lbrace : write(ListFile,'{');
      Rbrace : write(ListFile,'}');
      IFsym..TYPEsym : write(ListFile,ReservedWords[tok.token]);
      EOFtoken : write(ListFile,'END OF FILE');
   otherwise write(ListFile,'OTHER');
   end; { case }
end; { procedure PrintToken }
{ symbol table routines }

{$BOX
  This function takes a string and and hashes it into an integer in
  in the range of 0..MAXSYM as a result.
  This algorithm appears on page 436, "Compilers," Aho, Sethi, and Ullman
  with slight modifications.
$EBOX}

function HashID(ID : IDstring) : integer;

CONST TwoTo20 = 1048576;        { Hex #001000000 }
      TwoTo24 = 16777216;       { Hex #010000000 }

var i, hashval : integer;

begin
   hashval := 0;
   for i := 1 to length(ID) do begin
      hashval := 16 * hashval + ORD(ID[i]);
      if (hashval >= TwoTo24) then
         hashval := (hashval + (hashval div Twoto20)) mod TwoTo24;
   end; { for }
   HashID := hashval mod (MAXSYM+1); { to produce 0..MAXSYM }
end; { function HashID }


{$BOX
  This procedure searches the ID table to find an ID matching param ID located
  at the 'depth' level of scoping.  If the entry is found a pointer to it is
  returned in both entry and loc.  If the entry isn't found, entry is returned
  with NIL and loc is returned with a pointer an empty slot.
$EBOX}

procedure ThisLevel(ID : IDstring; depth : integer;
                    var entry, loc : entryPTR);

var start, scan : entryPTR;
    name : IDstring;

begin

   { hash the name to get the starting point for the search }
   start := HashID(ID);

   If (ST[start].IDname = '') then
      begin entry := FAKENIL; loc := start; end

   else if (ST[start].IDname = ID) and
           (ST[start].entry_type <> field) and
           (ST[start].nestingdepth = depth) then
      begin entry := start; loc := start; end

   else begin { search the symbol table in a circular, sequential fashion }
      scan := start;
      repeat
         if (scan = MAXSYM) then scan := 0 else scan := scan + 1;
         name := ST[scan].IDname;
      until (name = ID) and
            (ST[scan].nestingdepth = depth) and
            (ST[scan].entry_type <> field)
            or (name = '') or (scan = start);

      if (scan = start) then begin { we've checked everything }
         writeln('COMPILER ERROR: symbol table too small');
         STOPPROGRAM(1); end
      else if (name = '') then { found empty slot first }
         begin entry := FAKENIL; loc := scan; end
      else { found matching ID }
         begin entry := scan; loc := entry; end
    end; { search }

end; { procedure ThisLevel }


{$BOX
  This procedure is for the purpose of entering ID field names into the
  symbol table.  This routine is similar to ThisLevel but matching an
  ID also requires that the structure pointer field must be matched.
  This is because two field IDs may have the same ID and the same scoping
  level but are declared in two different records.
$EBOX}

procedure FindFieldID(ID : IDstring; depth : integer; recptr : structPTR;
                      var entry, loc : entryPTR);

var start, scan : entryPTR;
    name : IDstring;

begin

   { hash the name to get the starting point for the search }
   start := HashID(ID);

   If (ST[start].IDname = '') then
      begin entry := FAKENIL; loc := start; end

   else if (ST[start].IDname = ID) and
           (ST[start].entry_type = field) and
           (ST[start].nestingdepth = depth) and
           (ST[start].recptr = recptr) then
      begin entry := start; loc := start; end

   else begin { search the symbol table in a circular, sequential fashion }
      scan := start;
      repeat
         if (scan = MAXSYM) then scan := 0 else scan := scan + 1;
         name := ST[scan].IDname;
      until (name = ID) and
            (ST[scan].nestingdepth = depth) and
            (ST[scan].entry_type = field) and
            (ST[scan].recptr = recptr)
            or (name = '') or (scan = start);

      if (scan = start) then begin { we've checked everything }
         writeln('COMPILER ERROR: symbol table too small');
         STOPPROGRAM(1); end
      else if (name = '') then { found empty slot first }
         begin entry := FAKENIL; loc := scan; end
      else { found matching ID }
         begin entry := scan; loc := entry; end
    end; { search }

end; { procedure FindFieldID }


{$BOX
  This procedure searches the ID table for the ID matching param 'ID' starting
  at the current level.  If that name isn't found then it searches for the
  name at the next lower level.  If the name is found, a pointer to its
  table entry is returned in both entry and loc.  If the name isn't found,
  entry is returned as NIL and loc is returned with a pointer to the empty
  slot where the ID belongs.
$EBOX}

procedure FindID(ID : IDstring; var entry, loc : entryPTR);

var nest : integer;     { for descending through scope levels }
    TopSlot : entryPTR; { hash slot if it isn't in the table anywhere }

begin
   nest := NestLevel;
   ThisLevel(ID,nest,entry,TopSlot); { see if it exists on top level }
   loc := TopSlot;
   while (entry = FAKENIL) and (nest > 0) do begin
      nest := nest - 1;
      ThisLevel(ID,nest,entry,loc);  { see if it exists on this level }
      end;
   If (entry = FAKENIL) then loc := TopSlot;
end; { procedure FindID }


{$BOX
  This procedure accepts an ID name, the type of entry, and the scoping
  level of the ID.  "entry" returns with the location of where the info
  was inserted, or the location of the original ID if the ID was already
  defined (error condition).
$EBOX}

procedure EnterID(ID : IDstring; ET : entkind;
                  nestdepth : integer; var entry : entryPTR);
var entptr1, entptr2 : entryPTR;
begin
   ThisLevel(ID, nestdepth, entptr1, entptr2);
   IF (entptr1 <> FAKENIL) then
      ReportError(8) { var declared twice }
   else begin
      ST[entptr2].IDname := ID;
      ST[entptr2].entry_type := ET;
      ST[entptr2].nestingdepth := nestdepth;
      ST[entptr2].backlink := display[nestdepth].lastlink;
      display[nestdepth].lastlink := entptr2;
      end;
   entry := entptr2; { return loc of ID or of existing ID }
end; { EnterID }


{$BOX
  This procedure is like EnterID but enters only field IDs into the symbol
  table.  It also uses FindFieldID to find the place to insert the name.
$EBOX}

procedure EnterFieldID(ID : IDstring; recptr : structPTR;
                       nestdepth : integer; var entry : entryPTR);
var entptr1, entptr2 : entryPTR;
begin
   FindFieldID(ID, nestdepth, recptr, entptr1, entptr2);
   IF (entptr1 <> FAKENIL) then
      ReportError(9)  { var declared twice }
   else begin
      ST[entptr2].IDname := ID;
      ST[entptr2].entry_type := Field;
      ST[entptr2].nestingdepth := nestdepth;
      ST[entptr2].backlink := display[nestdepth].lastlink;
      ST[entptr2].recptr := recptr;
      display[nestdepth].lastlink := entptr2;
      end;
   entry := entptr2; { return loc of ID or of existing ID }
end; { EnterFieldID }


{$BOX
  Initialize the symbol table with standard types
$EBOX}

procedure InitSymbolTable;

var i : integer;
    dummy, BITSETeptr, BOOLEANeptr, CARDINALeptr, CHAReptr,
                       INTeptr, PROCeptr, REALeptr :  entryPTR;

begin

   { clean out the lowest part of the display }
   with display[0] do begin
      lastlink := FAKENIL;
      vvloc := 0; { no vars should be made at this level, but do it anyway }
   end; { with }

   NestLevel := 0;
   ILabel := 0;     { unique label generator }


   { make all symbol table entries empty }
   For i := 0 to MAXSYM do
      ST[i].IDname := '';

   { enter standard names into symbol table at level 0 scope }
   EnterID('ABS',       StdFunc,  0,  dummy);
   EnterID('BITSET',    Typee,    0,  BITSETeptr);
   EnterID('BOOLEAN',   Typee,    0,  BOOLEANeptr);
   EnterID('CAP',       StdFunc,  0,  dummy);
   EnterID('CARDINAL',  Typee,    0,  CARDINALeptr);
   EnterID('CHAR',      Typee,    0,  CHAReptr);
   EnterID('CHR',       StdFunc,  0,  dummy);
   EnterID('DEC',       StdProc,  0,  dummy);
   EnterID('DISPOSE',   StdProc,  0,  dummy);
   EnterID('EXCL',      StdProc,  0,  dummy);
   EnterID('FLOAT',     StdFunc,  0,  dummy);
   EnterID('HALT',      StdProc,  0,  dummy);
   EnterID('HIGH',      StdFunc,  0,  dummy);
   EnterID('INC',       StdProc,  0,  dummy);
   EnterID('INCL',      StdProc,  0,  dummy);
   EnterID('INTEGER',   Typee,    0,  INTeptr);
   EnterID('NEW',       StdProc,  0,  dummy);
   EnterID('ODD',       StdFunc,  0,  dummy);
   EnterID('ORD',       StdFunc,  0,  dummy);
   EnterID('PROC',      Typee,    0,  PROCeptr);
   EnterID('REAL',      Typee,    0,  REALeptr);
   EnterID('TRUNC',     StdFunc,  0,  dummy);
   EnterID('VAL',       StdFunc,  0,  dummy);

   { set up "constant" pointer to make it handy to compare standard types }
   NEW(BITSET_,Basic);
   NEW(BOOLEAN_,Basic);
   NEW(CARDINAL_,Basic);
   NEW(CHAR_,Basic);
   NEW(INTEGER_,Basic);
   NEW(PROC_,Basic);
   NEW(REAL_,Basic);
   NEW(STRING_, Basic);
   NEW(POINTER_, Basic);

   BITSET_^.form   := Basic;   BITSET_^.basicptr := BITSET_;
   BOOLEAN_^.form  := Basic;  BOOLEAN_^.basicptr := BOOLEAN_;
   CARDINAL_^.form := Basic; CARDINAL_^.basicptr := CARDINAL_;
   CHAR_^.form     := Basic;     CHAR_^.basicptr := CHAR_;
   INTEGER_^.form  := Basic;  INTEGER_^.basicptr := INTEGER_;
   PROC_^.form     := Basic;     PROC_^.basicptr := PROC_;
   REAL_^.form     := Basic;     REAL_^.basicptr := REAL_;
   STRING_^.form   := Basic;   STRING_^.basicptr := STRING_;
   POINTER_^.form  := Basic;   POINTER_^.basicptr:= POINTER_;

   BITSET_^.size   := BITSET_SIZE;     BITSET_^.align   := BITSET_ALIGN;
   BOOLEAN_^.size  := BOOLEAN_SIZE;    BOOLEAN_^.align  := BOOLEAN_ALIGN;
   CHAR_^.size     := CHAR_SIZE;       CHAR_^.align     := CHAR_ALIGN;
   CARDINAL_^.size := CARDINAL_SIZE;   CARDINAL_^.align := CARDINAL_ALIGN;
   INTEGER_^.size  := INTEGER_SIZE;    INTEGER_^.align  := INTEGER_ALIGN;
   REAL_^.size     := REAL_SIZE;       REAL_^.align     := REAL_ALIGN;
   POINTER_^.size  := POINTER_SIZE;    POINTER_^.align  := POINTER_ALIGN;

   ST[BITSETeptr].typptr.PTR     := BITSET_;
   ST[BITSETeptr].typptr.owner   := TRUE;
   ST[BOOLEANeptr].typptr.PTR    := BOOLEAN_;
   ST[BOOLEANeptr].typptr.owner  := TRUE;
   ST[CARDINALeptr].typptr.PTR   := CARDINAL_;
   ST[CARDINALeptr].typptr.owner := TRUE;
   ST[CHAReptr].typptr.PTR       := CHAR_;
   ST[CHAReptr].typptr.owner     := TRUE;
   ST[INTeptr].typptr.PTR        := INTEGER_;
   ST[INTeptr].typptr.owner      := TRUE;
   ST[PROCeptr].typptr.PTR       := PROC_;
   ST[PROCeptr].typptr.owner     := TRUE;
   ST[REALeptr].typptr.PTR       := REAL_;
   ST[REALeptr].typptr.owner     := TRUE;

end; { procedure InitSymbolTable }
procedure InitSets;

{$BOX
  The purpose of this procedure is to initialize the sets of synchronizing
  tokens, which are kept in global variables.
$EBOX}

begin

   constbegtoks  := [IntConst, RealConst, CharConst, StringConst, ID, LBrace];
   typedelimtoks := [POINTERsym, ARRAYsym, RECORDsym, SETsym, LParen,
                     LBracket, ID];
   typebegtoks   := typedelimtoks + constbegtoks;
   blockbegtoks  := [CONSTsym, TYPEsym, VARsym, PROCEDUREsym, BEGINsym];
   factorbegtoks := [IntConst, RealConst, CharConst, StringConst, ID, LBrace,
                     LParen, NOTsym];
   stmtbegtoks   := [semicolon, ID, FORsym, WHILEsym, REPEATsym, CASEsym,
                     IFsym, BEGINsym, LOOPsym, EXITsym];
   specifytoks   := [period, LBracket, uparrow];

end; { procedure InitSets }
procedure UpLexLevel;

{$BOX
  This procedure is called when a new procedure or function is first
  entered.  It does the necessary changes to the global variables to
  start a new scoping level.
$EBOX}

var i : integer;

begin

   If (NestLevel = MAXDISPLAYDEPTH) then begin
      ReportError(112); STOPPROGRAM(1); end;

   { remember current var loc counter before reseting global vloc }
   display[NestLevel].vvloc := vloc;
   vloc := 0;

   NestLevel := NestLevel + 1;
   with display[NestLevel] do begin
      lastlink := FAKENIL; { empty list of declarations }
      looplabel := -1;     { most recent loop exit label }
      for i := 1 to 8 do first[i] := NIL; { empty temp lists }
   end; { with }

end; { procedure UpLexLevel }
procedure ScanTheFile;
{ this procedure reads the source file token by token and echos those
  tokens by type and value to the list file.  Any IDs which are scanned
  are put in the symbol table at scoping level 1. }
var dummy : entryPTR;
begin

   UpLexLevel; { insert IDs at one level above standard IDs }
   repeat
      FetchToken;
      PrintToken(tok); writeln;
      If (tok.token = ID) then
         EnterID(tok.Name,Varr,NestLevel,dummy);
   until (tok.token = EOFtoken);

end; { procedure ScanTheFile }
procedure MatchSym(Token : tokens);

{$BOX
  This procedure reports an error if the current token isn't what is expected.
  In either case it then reads in the next token.
$EBOX}

var TTok : TokenType;
begin

   If (tok.token <> Token) then begin
      ReportError(999 { not expected });
      TTok.token := Token;
      write(ListFile,'EXPECTED '''); PrintToken(TTok);
      write(ListFile,''', RECEIVED '''); PrintToken(Tok); writeln(ListFile,'''');
      end;
   FetchToken;

end; { procedure Matchsym }
procedure Skip(tokset : setoftokens);

{$BOX
  This procedure is called after an error has been detected.  Its purpose
  is to flush input symbols until either end-of-file is detected or a
  token which is a member of the passed set is found.  The token on exit
  will be the EOFtoken or a member of the passed set.
$EBOX}

begin

   while (tok.token <> EOFtoken) and not (tok.token IN tokset) do
      FetchToken;

end; { procedure Skip }
procedure align(var address : integer; alignment : integer);

{$BOX
  The pupose of this procedure is to advance the address parameter so
  it is boundary aligned with the alignment factor.
$EBOX}

var am : integer;

begin
   if (address > 0) then begin
      am := address mod alignment;
      if (am > 0) then
         address := address + (alignment - am);
   end;
end; { procedure align }
procedure alloctemp(var attr : attributes; strct : structPTR);

{$BOX
  This procedure is something like a heap manager.  As intermediate code
  is generated, a call is made to this routine to get a stack displacement
  for a temporary of a given type.  Subsequent calls to dealltemp will
  deallocate the space when the scope of the temporary is over.  In this
  way a memory location can be recycled as long as it is the proper size;
  e.g., a real and a bitset could use the same location at different times.
  This routine, as well as dealltemp, are dependent on the size of of the
  various objects.
  This routine assumes that objects of the same size will have the same
  alignment.
$EBOX}

var ptr : tempheapptr;

begin
   with display[NestLevel] do begin
      { get pointer to first temporary at this level of this size }
      if (strct <> NIL) then begin
         ptr := first[strct^.size];
         if (ptr <> NIL) then begin
            first[strct^.size] := ptr^.ptr;
            with attr do begin
               loc := ptr^.adr;
               ttype := strct;
               temp := TRUE;
               kind := variable;
               access := direct;
               end;
            DISPOSE(ptr);
            end
         else begin
            align(vloc,strct^.align);
            with attr do begin
               loc := vloc;
               ttype := strct;
               temp := TRUE;
               kind := variable;
               access := direct;
               end;
            vloc := vloc + strct^.size;
            end;
      end;
   end; { with }
end; { procedure alloctemp }


procedure dealloctemp(adr : address; strct : structPTR);

var temp : tempheapptr;

begin
   with display[NestLevel] do begin
      NEW(temp);
      temp^.ptr := first[strct^.size];
      temp^.adr := adr;
      first[strct^.size] := temp;
   end; { with }
end; { procedure dealloctemp }


procedure Unalloc(attr : attributes);
{ This procedure returns the arg to the temp list if it is a temp }
begin
   if attr.temp then dealloctemp(attr.loc,attr.ttype);
end; { procedure Unalloc }
{ code generators }

procedure GenType(ttype : structPTR);
begin
   if      (ttype = INTEGER_)  then write(CodeFile,'I')
   else if (ttype = CARDINAL_) then write(CodeFile,'C')
   else if (ttype = CHAR_)     then write(CodeFile,'CH')
   else if (ttype = REAL_)     then write(CodeFile,'R')
   else if (ttype = BITSET_)   then write(CodeFile,'BS')
   else if (ttype = BOOLEAN_)  then write(CodeFile,'B')
   else                             write(CodeFile,'?');
end; { GenType }

procedure GenCode1(Mnem : string5; num1, num2 : integer);
begin
   writeln(CodeFile,Mnem,'  ',num1:1,'  ',num2:1);
end; { GenCode1 }

procedure GenCode1t(Mnem : string5; num1, num2 : integer; ttype : structPTR);
begin
   write(CodeFile,Mnem); GenType(ttype);
   writeln(CodeFile,'  ',num1:1,'  ',num2:1);
end; { GenCode1 }

procedure GenCode2(Mnem : string5; num : integer);
begin
   writeln(CodeFile,Mnem,'  ',num:1);
end; { GenCode2 }

procedure GenCode2t(Mnem : string5; num : integer; ttype : structPTR);
begin
   write(CodeFile,Mnem); GenType(ttype);
   writeln(CodeFile,'  ',num:1);
end; { GenCode2 }

procedure GenCode3(Mnem : string5; num1 : integer;  num2 : real);
begin
   writeln(CodeFile,Mnem,'  ',num1:1,'  ',num2);
end; { GenCode3 }

procedure GenCode4(Mnem : string5; num1 : integer;  bits : bitsettype);
var i : 0..BITSETSIZE;
begin
   write(CodeFile,Mnem,'  ',num1:1,')');
   for i := 0 to BITSETSIZE do
      if bits[i] then write(CodeFile,i:1,',');
   writeln(CodeFile,')');
end; { GenCode4 }

procedure GenCode5(Mnem : string5; num1, num2, num3 : integer);
begin
   writeln(CodeFile,Mnem,'  ',num1:1,'  ',num2:1,'  ',num3:1);
end; { GenCode1 }

procedure GenCode5t(Mnem : string5; num1,num2,num3 : integer; ttype : structPTR);
begin
   write(CodeFile,Mnem); GenType(ttype);
   writeln(CodeFile,'  ',num1:1,'  ',num2:1,'  ',num3:1);
end; { GenCode1 }

procedure GenLabel(val : labeltype);
begin
   writeln(CodeFile,'L  ',val:1);
end; { procedure GenLabel }

{$BOX
  This procedure generates jumping code based on the value of the boolean
  variable in attr.  The resulting code will to to Tbranch if the var is
  true;otherwise it will go to Fbranch.
$EBOX}

procedure GenTestBool(attr : attributes; Tbranch, Fbranch : labeltype);

{ This procedure generates jumping code for boolean evaluation if the
  "expression" really turns out to be just a variable. }

var temp : attributes;

begin
   if (attr.kind = variable) then begin
      alloctemp(temp,BOOLEAN_);
      GenCode1('LD#B',temp.loc,BOOLFALSEVAL);
      GenCode1('CPB',temp.loc,gattr.loc);
      GenCode2('JEQ',Fbranch);
      GenCode2('JUN',Tbranch);
   end;
end; { procedure GenTestBool }

procedure GenComment(mess : string80);
begin
   writeln(CodeFile,'*',mess);
end; { procedure GenComment }
procedure MakeLabel(var lval : labeltype);

{$BOX
  This procedure is called each time a code generating routine wants
  another unique label.  A unique label is made by incrementing the
  global variable ILabel, which is initially 0 and never decremented.
$EBOX}

begin
   lval := ILabel;
   ILabel := ILabel + 1;
end; { procedure MakeLabel }
procedure BuildBitSet(cp : const_entryPTR; sync : setoftokens);

{$BOX
    The purpose of this procedure is to scan bitset declarations and
    to return a pointer to the resulting constant.  The syntax is
         {<card1>,<card2>, ... }
$EBOX}

var buildset : bitsettype;  { for constructing bitset constants }
    i : 0..BITSETSIZE;

begin

   { make a list of constants used }
   for i := 0 to BITSETSIZE do buildset[i] := FALSE;

   repeat
       FetchToken; { swallow brace or comma }
       If (tok.token = IntConst) then begin
          If (tok.Ival > BITSETSIZE) then ReportError(102)
          else if (buildset[tok.Ival]) then ReportError(103)
          else buildset[tok.Ival] := TRUE;
          FetchToken; end;
   until (tok.token <> comma);

   If (tok.token <> RBrace) then
      begin ReportError(104); Skip(sync); end
   else begin
      NEW(cp,constBITSET);
      cp^.const_kind := constBITSET; cp^.bits := buildset;
      FetchToken;
   end;

end; { procedure BuildBitSet }
function constant(sync : setoftokens) : const_entryPTR;

{$BOX
  The purpose of this procedure is to read in the next token and verify that
  it is a constant type : an INT, a REAL, a CHAR, a STRing, or a BITSET.
  The resulting constant is then stored in a constant record and a pointer
  to that record is returned.
$EBOX}

var cp : const_entryPTR;    { ptr to result }

begin

   If not (tok.token IN constbegtoks) then
      begin ReportError(42); Skip(sync + constbegtoks); end;

   If (tok.token = LBrace) then begin { BITSET constant }
      BuildBitSet(cp,sync);
   end

   else case tok.token of
      IntConst : begin NEW(cp,constINT);
                       FetchToken;
                       cp^.const_kind := constINT;
                       cp^.Ival := tok.Ival; end;
     RealConst : begin NEW(cp,constREAL);
                       FetchToken;
                       cp^.const_kind := constREAL;
                       cp^.Rval := tok.Rval; end;
     CharConst : begin NEW(cp,constCHAR);
                       FetchToken;
                       cp^.const_kind := constCHAR;
                       cp^.Cval := tok.Cval; end;
   StringConst : begin NEW(cp,constSTR);
                       FetchToken;
                       cp^.const_kind := constSTR;
                       cp^.Sval := tok.Sval; end;
     otherwise begin
                  ReportError(10);
                  Skip(sync);
                  cp := NIL;
               end;

   end; { case }

   constant := cp;  { value returned by function }

end; { procedure constant }
procedure comp_range(var rs : struct_entryPTR);

{$BOX
  This procedure returns a pointer to a struct record which contains the
  range and type of the subrange.  It is assumed that tok holds the
  left bracket on entry.
$EBOX}

var eptr1, eptr2, eptr3 : entryPTR;

begin

   MatchSym(LBracket);
   NEW(rs.PTR,Range); rs.PTR^.form := Range; rs.owner := TRUE;
   rs.PTR^.size := CARDINAL_SIZE;   { default }
   rs.PTR^.align := CARDINAL_ALIGN; { default }

   If (tok.token = IntConst) then begin { cardinal or integer subrange }
      rs.PTR^.min := tok.Ival; { lower boundary }
      FetchToken; MatchSym(ellipsis); { dot dot }
      If (tok.token <> IntConst) then ReportError(86);
      rs.PTR^.max := tok.Ival; { upper boundary }
      rs.PTR^.rangetype.PTR := INTEGER_; { what it's a subrange of }
      rs.PTR^.rangetype.owner := FALSE;
      end

   else if (tok.token = CharConst) then begin { character subrange }
      rs.PTR^.size := CHAR_SIZE;
      rs.PTR^.align := CHAR_ALIGN;
      rs.PTR^.min := ORD(tok.Cval); { lower boundary }
      FetchToken; MatchSym(ellipsis); { dot dot }
      If (tok.token <> CharConst) then ReportError(86);
      rs.PTR^.max := ORD(tok.Cval); { upper boundary }
      rs.PTR^.rangetype.PTR := CHAR_; { what it's a subrange of }
      rs.PTR^.rangetype.owner := FALSE;
      end

   else if (tok.token = ID) then begin { subrange of enumerated type }
      FindID(tok.name,eptr1, eptr2);
      If (eptr1 = FAKENIL) then ReportError(88)
      else if (ST[eptr1].entry_type <> Enum) then ReportError(89)
      else rs.PTR^.min := ST[eptr1].enumptr^.enumval; { lower boundary }
      FetchToken; MatchSym(ellipsis); { dot dot }
      If (tok.token <> ID) then ReportError(86)
      else begin
         FindID(tok.name,eptr3, eptr2);
         If (eptr3 = FAKENIL) then ReportError(88)
         else if (ST[eptr3].entry_type <> Enum) then ReportError(89)
         else rs.PTR^.max := ST[eptr3].enumptr^.enumval; { upper boundary }
         rs.PTR^.rangetype := ST[eptr3].enumptr^.enumclass;
         If (ST[eptr3].enumptr^.enumclass <>
             ST[eptr1].enumptr^.enumclass) then ReportError(85);
         end;
      end;

   If (rs.PTR^.min > rs.PTR^.max) then ReportError(87);
   FetchToken; MatchSym(RBracket);

end; { procedure comp_range }
procedure comp_Arrayrange(var ARs : struct_entryPTR);

{$BOX
  This procedure will return a pointer to a range structure.  It accepts
  range declarations like "[min..max]" or like "rangetype".
$EBOX}

var eptr1, eptr2 : entryPTR;

begin

   ARs.PTR := NIL;
   If (tok.token = LBracket) then comp_range(ARs)
   else if (tok.token = ID) then begin
      FindID(tok.name,eptr1,eptr2); FetchToken;
      If (eptr1 = FAKENIL) then ReportError(75)
      else if (ST[eptr1].entry_type <> Typee) then ReportError(76)
      else if (ST[eptr1].typptr.PTR^.form <> Range) then ReportError(77)
      else begin ARs.PTR := ST[eptr1].typptr.PTR; ARs.owner := FALSE; end
      end
   else ReportError(78);

end; { procedure comp_Arrayrange }
function TagCompat(tok : tokentype; select : structPTR) : boolean;

{$BOX
  This purpose of this funtion is to determine if the tag passed in tok
  is compatible with the tag selector passed in select.
$EBOX}

var eptr1,eptr2 : entryPTR;

begin
   TagCompat := FALSE; { default }
   case tok.token of
         ID : begin
              FindID(tok.name,eptr1,eptr2);
              if (eptr1 <> FAKENIL) then
                 if (ST[eptr1].entry_type = Enum) then
                    if (ST[eptr1].enumptr <> NIL) then
                       if (ST[eptr1].enumptr^.enumclass.PTR = Select) then
                          TagCompat := TRUE;
              end; { ID }

   IntConst : with Select^ do begin
                 If (form = Basic) then
                    if (basicptr = INTEGER_) then TagCompat := TRUE
                    else if (basicptr = CARDINAL_) and
                            (tok.Ival > 0) then TagCompat := TRUE;
                 If (form = Range) then
                    if (rangetype.PTR <> NIL) then
                       if (rangetype.PTR^.form = Basic) then
                          if (rangetype.PTR^.basicptr = INTEGER_) then begin
                             if (tok.Ival >= min) and (tok.Ival <= max)
                                then TagCompat := TRUE;
                             end;
                          if (rangetype.PTR^.basicptr = CARDINAL_) then
                             if (tok.Ival >= min) and (tok.Ival <= max)
                                then TagCompat := TRUE;
              end; { IntConst }

  CharConst : with Select^ do begin
              If (form = Basic) then
                 if (basicptr = CHAR_) then TagCompat := TRUE;
              If (form = Range) then
                 if (rangetype.PTR <> NIL) then
                    if (rangetype.PTR^.form = Basic) and
                       (rangetype.PTR^.basicptr = CHAR_) then
                       if (ORD(tok.Cval) >= min) and (ORD(tok.Cval) <= max)
                          then TagCompat := TRUE;
              end { CharConst }
   end; { case }
end; { function TagCompat }
function rangemin(sptr : structPTR) : integer;

{$BOX
  This function returns an integer which is equal to the minimum value
  of the range pointed to by the sptr.
$EBOX}

begin
   if (sptr = NIL) then rangemin := 0
                   else rangemin := sptr^.min;
end; { function rangemin }



{$BOX
  This function returns an integer which is equal to the maximum value
  of the range pointed to by the sptr.
$EBOX}

function rangemax(sptr : structPTR) : integer;

begin
   if (sptr = NIL) then rangemax := 0
                   else rangemax := sptr^.max;
end; { function rangemax }


{$BOX
  This function returns an integer which is equal to the size of the
  structure pointed to by the sptr.
$EBOX}

function structsize(sptr : structPTR) : integer;

begin
   if (sptr = NIL) then structsize := 0
                   else structsize := sptr^.size;
end; { function structsize }


{$BOX
  This function returns an integer which is equal to the alignment of the
  structure pointed to by the sptr.
$EBOX}

function structalign(sptr : structPTR) : integer;

begin
   if (sptr = NIL) then structalign := 1
                   else structalign := sptr^.align;
end; { function structalign }
procedure gettype(var ttype : struct_entryPTR; sync : setoftokens);

{$BOX
  This procedure compiles type definitions.  It builds a tree and returns a
  pointer to the head of that tree. If the type already exists then the
  pointer to that type is returned (such as for ... : INTEGER) and the
  owner bit in ttype is set false.
  Syntax recognized:
            <existingTYPEid>
         |  (<enumID1> [, <enumID2>, ...] )
         |  ARRAY <range1> [,<range2>, ...] OF <type>
         |  SET OF <subrangetype>
         |  POINTER TO <type>
         |  RECORD [recordbody] END
$EBOX}

   {------------------------------------------------------------------}

   procedure fieldVARlist(rptr : structPTR; var offset : integer;
                          FirstOne : boolean; sync : setoftokens);

{$BOX
     This procedure scans a list of IDs seperated by commas.  Rptr is the
     pointer to the record that declared the field.  After scanning the list
     each member's structure pointer is set to their structure pointer.  Only
     the last name in the list will be the owner of their structure type.
     If this is the first field being declared by the record then FirstOne
     is true and we enter the record alignment based on that of the field.
     On entry the first ID should be in tok.
     The syntax this procedure recognizes is:
         <vname1> [,<vname2>] [...] : <type>
$EBOX}

   var
       eptr : entryPTR;
       fieldptr, fieldptr2 : var_entryPTR;
       strctptr : struct_entryPTR;
       ssize : integer;  { size of var structure }
       salign : integer; { alignment of var structure }

   begin

      while (tok.token = ID) do begin { make a list of vars }

         EnterFieldID(tok.name,rptr,NestLevel,eptr);
         NEW(fieldptr); ST[eptr].fieldptr := fieldptr;
         fieldptr^.linkfield := NIL; { indicates first var of list }

         FetchToken; { comma or a colon }
         while (tok.token = comma) do begin
            FetchToken; { get next name on list }
            if (tok.token <> ID) then
               begin ReportError(92); Skip(sync + [colon]); end
            else begin
               EnterFieldID(tok.name,rptr,NestLevel,eptr);
               NEW(fieldptr2); ST[eptr].fieldptr := fieldptr2;
               fieldptr2^.linkfield := fieldptr; { make a list }
               fieldptr := fieldptr2; { remember for next time around }
               FetchToken; { fetch comma or colon }
            end;
         end; { while }

         If (tok.token <> colon) then
            begin ReportError(47); Skip(sync + [ID]); end
         else begin
            MatchSym(colon);
            { find out what type the vars in the list are }
            gettype(strctptr,sync);
            ssize := structsize(strctptr.PTR);  { size of each element }
            salign := structalign(strctptr.PTR);{ alignment of each element }
            if FirstOne then { first element(s) declared }
               rptr^.align := salign;
            fieldptr^.vstruct := strctptr;
            align(offset, salign);
            fieldptr^.adr := offset;   { offset of field within record }
            offset := offset + ssize;

            strctptr.owner := FALSE; { make sure there is only one owner }
            fieldptr := fieldptr^.linkfield;
            while (fieldptr <> NIL) do begin
               align(offset, salign);
               fieldptr^.adr := offset;   { offset of field within record }
               offset := offset + ssize;
               fieldptr^.vstruct := strctptr;
               fieldptr := fieldptr^.linkfield;
            end;
         end; { if not : }

      end; { while }

   end; { procedure fieldVARlist }

   {------------------------------------------------------------------}

   procedure variantrecord(rptr : structPTR; var offset : integer;
                           FirstOne : boolean; sync : setoftokens);

{$BOX
     This procedure processes the variant parts of a record declaration.
     rptr is the pointer to the record declaring this variant part.
     If this is the first field being declared by the record then FirstOne
     is true and we make the alignment of the record that of its first field.
     It is assumed that the CASE keyword is in tok on entry.
     The syntax this procedure recognizes is
                CASE <discrim> : <rangetype> OF

            [    <rangetag1> : <varlist1> : <varlisttype1>
                          [[ ; <varlist2> : <varlisttype2>] ... ]
            [ |  <rangetag2> : <varlist3> : <varlisttype3>
                          [[ ; <varlist4> : <varlisttype4>] ... ]

                END
$EBOX}

   var distype : struct_entryPTR;  { discriminator type }
       fieldptr, fieldptr2 : var_entryPTR;
       eptr1, eptr2 : entryPTR;
       salign : integer; { alignment of element }
       beginoffset : integer; { offset at start of variant part }
       maxoffset : integer;   { biggest variant element }

   begin
      MatchSym(CASEsym);  { get disriminator name }
      If (tok.token <> ID) then
         begin ReportError(13); Skip(sync); end

      else begin
         EnterFieldID(tok.name,rptr,NestLevel,eptr1);
         NEW(fieldptr); ST[eptr1].fieldptr := fieldptr;
         FetchToken; MatchSym(colon);
         gettype(distype,sync+ [OFsym]);
         ST[eptr1].fieldptr^.vstruct := distype;
         salign := structalign(distype.PTR); { alignment of discriptor }
         if FirstOne then { first element declared }
            rptr^.align := salign;
         align(offset, salign);
         fieldptr^.adr := offset;
         offset := offset + structsize(distype.PTR);
         MatchSym(OFsym);
         maxoffset := offset;
         beginoffset := offset; { where the variant part starts }
         if (distype.PTR <> NIL) then
            if not (distype.PTR^.form in [basic,enumerated,range,sett]) then
               begin ReportError(17); Skip(sync); end

            else begin
               while (tok.token in [IntConst,CharConst,ID]) do begin
                  while (tok.token in [IntConst,CharConst,ID]) do begin
                     if not TagCompat(tok,distype.PTR) then ReportError(21);
                     FetchToken; { comma or colon }
                     if (tok.token = comma) then FetchToken;
                  end; { while }
                  if (tok.token <> colon) then ReportError(22)
                  else FetchToken; { swallow colon }
                  offset := beginoffset; { each clause starts at same point }
                  { enter FALSE for because case selector was first }
                  fieldVARlist(rptr,offset,FALSE,sync+[ENDsym]);
                  if (tok.token = semicolon) then FetchToken;
                  if (tok.token = stroke) then FetchToken;
                  { the size of a CASE is the size of its largest variant }
                  if (offset > maxoffset) then maxoffset := offset;
               end; { while }
               MatchSym(ENDsym);
               offset := maxoffset;
            end;

      end;
   end; { procedure variantrecord }

   {------------------------------------------------------------------}

var strctptr, newptr : struct_entryPTR;
    eptr1, eptr2 : entryPTR;
    ord_count : integer;   { values to assign to enumerated types }
    enumerptr : enum_entryPTR;
    elements : integer;    { # of elements in array }
    fieldoffset : integer; { displacement of field within record }
    firsttime : boolean;   { to mark first field of record }

begin

   ttype.owner := TRUE; { default }
   ttype.PTR := NIL;    { in case of errors }

   If not (tok.token IN typedelimtoks) then begin
      ReportError(43);
      Skip(sync + typedelimtoks);
      end;

   If (tok.token IN typedelimtoks) then begin
      { declared or standard type; form is ... <existingtypeID> }
      if (tok.token = ID) then begin
         FindID(tok.name, eptr1, eptr2);
         if (eptr1 = FAKENIL) then begin
                  ReportError(81); { undefined type }
                  Skip(sync);
                  FetchToken; end
         else if (ST[eptr1].entry_type = Typee) then begin
            ttype.PTR := ST[eptr1].typptr.PTR; { point to type structure }
            ttype.owner := FALSE; { mark that this is not the originator }
            FetchToken; end
         else begin ReportError(71); Skip(sync); end

      end { declared or predefined type }

      { enumerated type declaration; form is (<enum1>,<enum2>,...) }
      else if (tok.token = LParen) then begin
         NEW(strctptr.PTR,Enumerated); strctptr.PTR^.form := Enumerated;
         ttype.PTR := strctptr.PTR;
         ttype.PTR^.size := CARDINAL_SIZE;
         ttype.PTR^.align := CARDINAL_ALIGN;
         ord_count := 0;
         repeat
            FetchToken; { get element name }
            If (tok.token <> ID) then ReportError(83)
            else begin  { get first member of set }
               EnterID(tok.name,Enum,NestLevel,eptr1);
               NEW(enumerptr); ST[eptr1].enumptr := enumerptr;
               enumerptr^.enumval := ord_count; ord_count := ord_count + 1;
               enumerptr^.enumclass := strctptr; { tell element set id }
               FetchToken;
               end;
         until (tok.token <> comma);
         MatchSym(RParen); strctptr.PTR^.lastelem := enumerptr;
      end { enumerated type }

      { array type declaration; form is ARRAY <arrayrange> OF <type> }
      else if (tok.token = ARRAYsym) then begin
         elements := 1;
         NEW(strctptr.PTR,Arrayy); strctptr.PTR^.form := Arrayy;
         ttype.PTR := strctptr.PTR; ttype.owner := TRUE; FetchToken;
         comp_Arrayrange(strctptr.PTR^.indextype);
         elements := elements * (rangemax(strctptr.PTR^.indextype.PTR)
                                 - rangemin(strctptr.PTR^.indextype.PTR) + 1);
         newptr := strctptr;  { in case we pass over loop }
         while (tok.token = comma) do begin
            FetchToken;
            NEW(newptr.PTR,Arrayy); newptr.PTR^.form := Arrayy;
            newptr.owner := TRUE;
            strctptr.PTR^.contenttype := newptr;
            comp_Arrayrange(newptr.PTR^.indextype);
            elements := elements * (rangemax(newptr.PTR^.indextype.PTR)
                                    - rangemin(newptr.PTR^.indextype.PTR) + 1);
            end; { while }

         if (tok.token = OFsym) then begin
            FetchToken; { swallow OF }
            gettype(newptr.PTR^.contenttype,sync);
            strctptr.PTR^.size := elements *
                                  structsize(newptr.PTR^.contenttype.PTR);
            strctptr.PTR^.align := structalign(newptr.PTR^.contenttype.PTR);
            end
         else begin
            ReportError(49);
            Skip(sync);
            end;
      end { ARRAY type }

      { SET type declaration; form is ... SET OF <subrangetype> }
      else if (tok.token = SETsym) then begin
         FetchToken; MatchSym(OFsym);
         NEW(ttype.PTR,Sett); ttype.PTR^.form := Sett;
         ttype.PTR^.size := BITSET_SIZE;
         ttype.PTR^.align := BITSET_ALIGN;
         ttype.PTR^.settype.PTR := NIL;
         gettype(strctptr,sync);
         if (strctptr.PTR <> NIL) then
            with strctptr.PTR^ do
               if (form = Enumerated) then
                  if (lastelem <> NIL) then
                     if (lastelem^.enumval > BITSETSIZE) then ReportError(104)
                     else ttype.PTR^.settype := strctptr
                   else { lastelem was NIL }
               else if (form = Range) then
                  if (rangetype.PTR <> NIL) then
                     if (min < 0) or (max > BITSETSIZE) then ReportError(105)
                     else ttype.PTR^.settype := strctptr
                  else { rangetype was NIL }
               else begin
                  ReportError(106); Skip(sync); end;
      end { SET type }

      { POINTER type; form is ... POINTER TO <type> }
      else if (tok.token = POINTERsym) then begin
         FetchToken;
         MatchSym(TOsym);
         NEW(ttype.PTR,Pointr);
         ttype.PTR^.form := Pointr;
         ttype.PTR^.size := POINTER_SIZE;
         ttype.PTR^.align := POINTER_ALIGN;
         gettype(ttype.PTR^.ptrtype,sync);
      end { POINTER type }

      { RECORD type; form is ... too complicated to show here }
      else if (tok.token = RECORDsym) then begin
         fieldoffset := 0;
         firsttime := TRUE; { let first field set the alignment of the record }
         FetchToken; { swallow RECORD symbol }
         NEW(ttype.PTR,Recordd); ttype.PTR^.form := Recordd;
         while (tok.token = ID) or (tok.token = CASEsym) do begin
            if (tok.token = ID) then { invariant field }
               fieldVARlist(ttype.PTR,fieldoffset,firsttime,sync+[ENDsym])
            else { variant record }
               variantrecord(ttype.PTR,fieldoffset,firsttime,sync+[ENDsym]);
            If (tok.token = semicolon) then FetchToken;
            firsttime := FALSE;
            end; { while }
         If (tok.token = ENDsym) then begin
            ttype.PTR^.size := fieldoffset; { size of record structure }
            FetchToken; end { swallow ENDsym }
         else begin
            ReportError(52); Skip(sync); end;
      end { RECORD type }

      { must be a subrange }
      else if (tok.token = LBracket) then begin
         comp_range(ttype);
      end; { subrange }

   end; { if IN typedelimtoks }

end; { procedure gettype }
procedure compCONST;

{$BOX
  This procedure compiles CONST declarations.  It is assumed that the word
  'CONST' is currently in tok on entry.
$EBOX}

var eptr : entryPTR;
    cp : const_entryPTR;

begin

   FetchToken;
   If (tok.token <> ID) then
      begin ReportError(11); Skip(blockbegtoks + [ID]); end;
   while (tok.token = ID) do begin
      EnterID(tok.name,Constt,NestLevel,eptr);
      FetchToken;
      if (tok.token <> RelOp) or (tok.ROp <> relEQ) then
         begin ReportError(12); Skip(blockbegtoks + [ID]); end
      else begin
         FetchToken;
         cp := constant(constbegtoks + [semicolon]);
         ST[eptr].constptr := cp;
         ST[eptr].constype := NIL;
         if (cp <> NIL) then
            case cp^.const_kind of
               constINT : ST[eptr].constype := INTEGER_;
              constCARD : ST[eptr].constype := CARDINAL_;
              constREAL : ST[eptr].constype := REAL_;
              constCHAR : ST[eptr].constype := CHAR_;
            constBITSET : ST[eptr].constype := BITSET_;
               constSTR : ST[eptr].constype := STRING_;
            end; { case }
         MatchSym(semicolon);
         end;
   end; { while }

end; { procedure compCONST }
procedure compVAR;

{$BOX
  This procedure compiles VAR statements.  It is assumed that 'VAR' was the
  last thing read into tok.
$EBOX}

var
    eptr : entryPTR;
    varptr, varptr2 : var_entryPTR;
    strctptr : struct_entryPTR;
    vsize : integer;  { size of var structure }
    valign : integer; { alignment of var structure }

begin

   FetchToken;
   If (tok.token <> ID) then ReportError(90) else begin
      while (tok.token = ID) do begin { make a list of vars }

         EnterID(tok.name,Varr,NestLevel,eptr);
         NEW(varptr); ST[eptr].varptr := varptr;
         varptr^.linkfield := NIL; { indicates first var of list }

         FetchToken; { comma or a colon }
         while (tok.token = comma) do begin
            FetchToken; { get next name on list }
            if (tok.token <> ID) then ReportError(92)
            else begin
               EnterID(tok.name,Varr,NestLevel,eptr);
               NEW(varptr2); ST[eptr].varptr := varptr2;
               varptr2^.linkfield := varptr; { make a list }
               varptr := varptr2; { remember for next time around }
            end;
            FetchToken; { fetch comma or colon }
         end; { while }

         MatchSym(colon);
         gettype(strctptr,typedelimtoks); { find out the type of the vars }
         vsize := structsize(strctptr.PTR);  { size of each element }
         valign := structalign(strctptr.PTR);{ alignment of each element }
         varptr^.vstruct := strctptr;
         strctptr.owner := FALSE; { make sure there is only one owner }
         align(vloc,valign);    { allocate space for variable }
         varptr^.adr := vloc;
         vloc := vloc + vsize;

         varptr := varptr^.linkfield;
         while (varptr <> NIL) do begin
            align(vloc,valign);    { allocate space for variable }
            varptr^.adr := vloc;
            vloc := vloc + vsize;
            varptr^.vstruct := strctptr;
            varptr := varptr^.linkfield;
         end; { while }

         MatchSym(semicolon);
      end; { while }
   end; { if }

end; { procedure compVAR }
procedure compTYPE;

{$BOX
  This procedure compiles TYPE statements.  It is assumed that "TYPE" is the
  token currently in tok.
$EBOX}

var eptr : entryPTR;
    strctptr : struct_entryPTR;
    Newname : IDstring;   { name of type being defined }

begin

   FetchToken;
   If (tok.token <> ID) then ReportError(13)
   else while (tok.token = ID) do begin
      Newname := tok.name; FetchToken;
      If (tok.token <> RelOp) or (tok.Rop <> relEQ) then ReportError(20);
      FetchToken;
      gettype(strctptr,typedelimtoks); { get a pointer to structure tree }
      { must enter after searching for type otherwise "TYPE me=me" is OK }
      EnterID(Newname,Typee,NestLevel,eptr);
      ST[eptr].typptr :=strctptr;
      MatchSym(semicolon);
   end; { while }

end; { procedure compTYPE }
{ expression compiling routines }

{$BOX
  The purpose of this procedure is to finish off compiling some part
  of an expression that is still hanging around.
$EBOX}

procedure makedirect;

var newattr : attributes;

begin  with gattr do begin

   if (ttype <> NIL) then begin
     case kind of
        cnstant : begin
             if (val <> NIL) then
                case val^.const_kind of
                      constINT : begin
                                    alloctemp(newattr,INTEGER_);
                                    GenCode1('LD#I',newattr.loc,val^.Ival);
                                 end;
                     constCARD : begin
                                    alloctemp(newattr,CARDINAL_);
                                    GenCode1('LD#C',newattr.loc,val^.Cardval);
                                 end;
                     constCHAR : begin
                                    alloctemp(newattr,CHAR_);
                                    GenCode1('LD#CH',newattr.loc,ORD(val^.Cval));
                                 end;
                     constREAL : begin
                                    alloctemp(newattr,REAL_);
                                    GenCode3('LD#R',newattr.loc,val^.Rval);
                                 end;
                      constSTR : begin
                                    GenCode1('STR?',-1,-1);
                                 end;
                   constBITSET : begin
                                    alloctemp(newattr,BITSET_);
                                    GenCode4('LD#BS',newattr.loc,val^.bits);
                                 end;
                      end; { case }
                      gattr := newattr;
                      gattr.kind := expr;
                   end; { cnstant }

         enumer : begin
                    alloctemp(newattr,CARDINAL_);
                    GenCode1('LD#C',newattr.loc,enumval);
                    gattr.loc := newattr.loc;
                    gattr.temp := TRUE;
                  end; { enumer }

       variable : begin
                     case access of
                        direct : { nothing to do } ;

                      indirect : if (ttype <> NIL) then begin
                             if (ttype^.size <= 8) then
                                alloctemp(newattr,ttype);
                                GenCode5t('LD@',newattr.loc,baseptr,loc,ttype);
                             gattr.loc := newattr.loc;
                             gattr.temp := TRUE;
                             end;

                       indexed : { none }

                     end; { case }
                  end; { variable }

           expr : { nothing to do }

      end; { case }
   end;

   end; { with gattr }
end; { procedure makedirect }


{$BOX
  The purpose of this routine is to guarantee that the location pointed to
  can be stored to.  In other words, the location should be a temp so we
  don't clobber a variable.
$EBOX}

procedure changeable(var attr : attributes);

var newloc : attributes;

begin
   with attr do
      if not temp then
         if (ttype <> NIL) then begin
            alloctemp(newloc,ttype);
            GenCode1t('LD',newloc.loc,loc,ttype);
            attr := newloc;
            kind := expr;
         end;
end; { procedure changeable }


procedure ConvertToInt(var attr : attributes);

{$BOX
  The procedure turns the cardinal attr into an integer.
$EBOX}

var newloc : attributes;

begin
   alloctemp(newloc,INTEGER_);
   GenCode1('CTOI',newloc.loc,attr.loc);
   Unalloc(attr);
   attr := newloc;
end; { procedure ConvertToInt }


{$BOX
  The purpose of this routine is to convert any CARDINAL to an INTEGER
  it the two should appear in a mixed-mode expression.
$EBOX}

procedure MakeCompat(var attr1, attr2 : attributes);

var newattr : attributes;

begin

   if (attr1.ttype = INTEGER_) and (attr2.ttype = CARDINAL_) then
      ConvertToInt(attr2);
   if (attr2.ttype = INTEGER_) and (attr1.ttype = CARDINAL_) then
      ConvertToInt(attr1);

end; { MakeCompat }


{$BOX
  The purpose of this procedure is to turn whatever attr is into a
  cardinal.  This is for the purpose of array indexing.
$EBOX}

procedure ConvertToCard(var attr : attributes);

var newloc : attributes;

begin

   if (attr.ttype <> CARDINAL_) then begin

      alloctemp(newloc,CARDINAL_);

      if (attr.ttype = INTEGER_) then
         GenCode1('ITOC',newloc.loc,attr.loc)
      else if (attr.ttype = CHAR_) then
         GenCode1('CHTOC',newloc.loc,attr.loc)
      else if (attr.ttype = BOOLEAN_) then
         GenCode1('BTOC',newloc.loc,attr.loc);

      Unalloc(attr);
      attr := newloc;

   end; { if cardinal }

end; { procedure ConvertToCard }


procedure Expression(Tbranch, Fbranch : labeltype; sync : setoftokens); forward;

{$BOX
  This procedure is entered with a pointer to a symbol (eptr).  The input
  is scanned to see if the identifier is further specified in one or more
  of these ways:
     <ID>                        simple variable
     <ID> . <fieldname>          field reference
     <ID> ^                      pointer reference
     <ID> [<subscriptlist>]      array reference
$EBOX}

procedure Specify(Tbranch, Fbranch : labeltype; eptr : entryPTR;
                  sync : setoftokens);

var eptr1, eptr2 : entryPTR;
    arraybase, indextotal : address;
    indexattr,newattr : attributes;
    arraypath : structPTR;
    firstindex : boolean;
    subindex : structPTR;
    constantoffset : integer;  { accumulates the minrange displacement
                                 in subscript calculations. }
begin
   gattr.ttype := NIL; { default }
   if (eptr <> FAKENIL) then
      with ST[eptr] do begin
         case entry_type of

               Varr : If (varptr <> NIL) then
                         with gattr do begin
                            kind := variable;
                            ttype := varptr^.vstruct.PTR;
                            access := direct;
                            loc := varptr^.adr;
                            temp := FALSE;
                         end; { with }

               Enum : If (enumptr <> NIL) then
                         with gattr do begin
                            kind := enumer;
                            ttype := enumptr^.enumclass.PTR;
                            enumval := enumptr^.enumval;
                            temp := FALSE;
                         end;

              Field : begin
                         { not needed until WITH statements are accepted }
                         ReportError(103);
                      end;

             otherwise begin
                ReportError(52);
                Skip(sync); end;

         end; { case }
      end; { with }

   If not (tok.token IN (sync + specifytoks)) then
      begin ReportError(57); Skip(sync + specifytoks); end;

   while (tok.token IN specifytoks) do begin
      if (gattr.ttype = NIL) or (gattr.kind <> variable) then
         ReportError(104)
      else case tok.token of

        period : begin
                 FetchToken;
                 if (gattr.ttype^.form <> Recordd) then
                    begin ReportError(105); Skip(sync + specifytoks); end
                    else begin
                       If (tok.token <> ID) then
                          begin ReportError(106); Skip(sync + specifytoks); end
                          else begin
                             FindFieldID(tok.name,NestLevel,gattr.ttype,eptr1,eptr2);
                             if (eptr1 = FAKENIL) then begin
                                ReportError(107); Skip(sync+specifytoks);end
                             else begin
                                FetchToken; { swallow field specifier }
                                if (ST[eptr1].fieldptr <> NIL) then begin
                                   gattr.ttype := ST[eptr1].fieldptr^.vstruct.PTR;
                                   gattr.loc := gattr.loc + ST[eptr1].fieldptr^.adr;
                                   end;
                             end;
                          end;
                    end;
                 end; { period : }

       uparrow : begin
                    FetchToken; { swallow ^ }
                    if (gattr.ttype^.form <> Pointr) then
                       begin ReportError(108); Skip(sync+specifytoks); end
                    else begin
                       makedirect;
                       with gattr do begin
                          kind := variable;
                          ttype := ttype^.ptrtype.PTR;
                          access := indirect;
                          baseptr := loc;
                          loc := 0;       { displacement }
                       end;
                    end;
                 end; { uparrow : }

      LBracket : begin

                   if (gattr.ttype^.form <> Arrayy) then begin
                      ReportError(108); Skip(sync+specifytoks);
                      FetchToken; end

                   else begin { compile the array reference }
                    makedirect;
                    arraybase := gattr.loc; arraypath := gattr.ttype;
                    constantoffset := 0; firstindex := TRUE;

                    repeat
                      FetchToken; { swallow [ or , }
                      if (arraypath <> NIL) then
                         subindex := arraypath^.indextype.PTR;
                      if (not firstindex) and (subindex <> NIL) then begin
                         GenCode1('SCALE',indextotal,
                                  subindex^.max-subindex^.min+1);
                         constantoffset := constantoffset *
                                  (subindex^.max-subindex^.min+1);
                         end;
                      Expression(Tbranch, Fbranch,
                                 sync+specifytoks+[comma,RBracket]);
                      makedirect;
                      if (subindex <> NIL) then begin
                        if (gattr.ttype <> subindex^.rangetype.PTR) then
                           begin ReportError(109);
                           Skip(sync+specifytoks+[comma,RBracket]); end
                        else begin
                           makedirect;
                           ConvertToCard(gattr);
                           if firstindex then begin
                              firstindex := FALSE;
                              Changeable(gattr);
                              indexattr := gattr;
                              indextotal := gattr.loc;
                              end
                           else begin
                              GenCode1('ADDC',indextotal,gattr.loc);
                              Unalloc(gattr);
                           end;

                           constantoffset := constantoffset + subindex^.min;
                           arraypath := arraypath^.contenttype.PTR;

                        end;
                     end; { subindex <> NIL }
                    until (tok.token <> comma);

                    if (constantoffset <> 0) then
                       GenCode1('DECC',indextotal,constantoffset);
                    if (arraypath <> NIL) then
                       GenCode1('SCALE',indextotal,arraypath^.size);

                    alloctemp(newattr,POINTER_);
                    GenCode5('INDX',newattr.loc,indextotal,arraybase);
                    with gattr do begin
                       ttype := arraypath;
                       loc := 0;
                       temp := FALSE;
                       kind := variable;
                       access := indirect;
                       baseptr := newattr.loc;
                       end; { with }
                    Unalloc(indexattr);

                    if (tok.token = RBracket) then FetchToken
                       else ReportError(110);
                   end;
                 end; { LBracket : }

      end; { case tok.token }
   end; { while }

end; { procedure Specify }


{$BOX

  The purpose of this procedure is to compile factors, i.e. this grammar:
        <Number>
     |  <string>
     |  <set>
     |  ( <expression> )
     |  NOT <factor>

$EBOX}

procedure Factor(Tbranch, Fbranch : labeltype; sync : setoftokens);

var eptr1, eptr2 : entryPTR;

begin
   if not (tok.token IN factorbegtoks) then
      begin ReportError(61); Skip(sync + factorbegtoks);
         gattr.ttype := NIL; end;

   while (tok.token IN factorbegtoks) do begin { normally executed just once }
      case tok.token of

         IntConst, RealConst, CharConst, StringConst :
            with gattr do begin
               kind := cnstant;
               NEW(val);
               case tok.token of
                     IntConst : begin
                                   val^.const_kind := constINT;
                                   val^.Ival := tok.Ival;
                                   ttype := INTEGER_;
                                end;
                    RealConst : begin
                                   val^.const_kind := constREAL;
                                   val^.Rval := tok.Rval;
                                   ttype := REAL_;
                                end;
                    CharConst : begin
                                   val^.const_kind := constCHAR;
                                   val^.Cval := tok.Cval;
                                   ttype := CHAR_;
                                end;
                  StringConst : begin
                                   val^.const_kind := constSTR;
                                   val^.Sval := tok.Sval;
                                   ttype := STRING_;
                                end;
               end; { case }
               FetchToken; { swallow constant }
            end; { with }

               ID : begin
                       FindID(tok.name,eptr1,eptr2);
                       FetchToken; { swallow ID }
                       If (eptr1 = FAKENIL) then
                          begin ReportError(111); Skip(sync); end
                       else if (ST[eptr1].entry_type = Constt) then
                             with gattr do begin
                                kind := cnstant;
                                ttype := ST[eptr1].constype;
                                val := ST[eptr1].constptr;
                             end { Constt }

                          else begin
                             Specify(Tbranch,Fbranch,eptr1,sync);
                             if (gattr.ttype <> NIL) then
                                if (gattr.ttype^.form = Range) then
                                   gattr.ttype := gattr.ttype^.rangetype.PTR;
                          end;
                    end;

           LBrace : begin { BITSET }
                       gattr.kind := expr;
                       gattr.ttype := BITSET_;
                       BuildBitSet(gattr.val,sync);
                       with gattr do begin
                          kind := cnstant;
                          ttype := BITSET_;
                       end; { with }
                    end;

           LParen : begin
                      FetchToken; { swallow LParen }
                      Expression(Tbranch, Fbranch, sync + [Rparen]);
                      if (tok.token = Rparen) then FetchToken
                         else begin ReportError(62); Skip(sync); end;
                    end;

           NOTsym : begin
                       FetchToken; { swallow NOT }
                       Factor(Fbranch, Tbranch, sync); makedirect;
                       if (gattr.ttype <> BOOLEAN_) then ReportError(113);
                       GenTestBool(gattr,Tbranch,Fbranch);
                    end;

      end; { case }
   end; { while }

end; { procedure Factor }


{$BOX
  The purpose of this procedure is to compile terms, i.e. the syntax
      <factor>  |  <term> <multop> <factor>
   where <multop> is AND | * | / | DIV | MOD
$EBOX}

procedure Term(Tbranch, Fbranch : labeltype; sync : setoftokens);

var lattr, swap : attributes;  { attributes of left hand side }
    op : MulType;
    newattr : address;
    ANDwasused : boolean;
    L1 : labeltype;

begin
   ANDwasused := false;
   MakeLabel(L1);
   Factor(Tbranch, Fbranch, sync+[MulOp]);
   lattr := gattr;
   if (tok.token = MulOp) then
      begin makedirect; lattr := gattr; end;

   while (tok.token = MulOp) do begin
      op := tok.MultOp; FetchToken;
      Factor(L1, Fbranch, sync+[MulOp]); makedirect;


         if (gattr.ttype <> NIL) and (lattr.ttype <> NIL) then begin
            { Cardinals convert to integer in mixed-mode }
            MakeCompat(lattr,gattr);

            case op of
               times : begin
                          { try to store the result in a temporary }
                          if gattr.temp and not lattr.temp then begin
                             swap := gattr; gattr := lattr; lattr := swap; end;

                          if (gattr.ttype = lattr.ttype) then
                             if (gattr.ttype = INTEGER_) or
                             (gattr.ttype = CARDINAL_) or
                             (gattr.ttype = REAL_) then begin
                                Changeable(lattr);
                                GenCode1t('MUL',lattr.loc,gattr.loc,gattr.ttype);
                                Unalloc(gattr);
                                end
                             else ReportError(116)
                          else ReportError(117);

                       end; { * }

              divide : begin
                          if (gattr.ttype = REAL_) and (lattr.ttype = REAL_) then begin
                             { real / real --> real }
                             Changeable(lattr);
                             GenCode1('DIVR',lattr.loc,gattr.loc);
                             Unalloc(gattr);
                             end
                          else ReportError(118);
                       end; { / }

                modd : begin
                          if (gattr.ttype = lattr.ttype) and
                             ((gattr.ttype = INTEGER_) or
                              (gattr.ttype = CARDINAL_)) then begin
                              Changeable(lattr);
                              GenCode1t('MOD',lattr.loc,gattr.loc,gattr.ttype);
                              Unalloc(gattr);
                              end
                           else ReportError(120);
                       end; { modd }

                divv : begin
                          if (gattr.ttype = lattr.ttype) and
                             ((gattr.ttype = INTEGER_) or
                              (gattr.ttype = CARDINAL_)) then begin
                              Changeable(lattr);
                              GenCode1t('DIV',lattr.loc,gattr.loc,gattr.ttype);
                              Unalloc(gattr);
                              end
                           else ReportError(121);
                       end; { divv }

                andd : begin
                          FetchToken; { swallow AND }
                          if not ANDwasused then begin
                             if (lattr.ttype <> BOOLEAN_) then
                                ReportError(149);
                             GenTestBool(lattr,L1,Fbranch);
                             end
                          else begin
                             GenLabel(L1); MakeLabel(L1);
                             if (gattr.ttype <> BOOLEAN_) then
                                ReportError(148);
                             GenTestBool(gattr,L1,Fbranch);
                             end;
                          lattr.ttype := BOOLEAN_;
                          lattr.kind := expr;
                          ANDwasused := TRUE;
                       end; { andd }

             end; { case }
          end; { <> NIL and <> NIL }

   end; { while }

   if ANDwasused then begin
      GenLabel(L1);
      GenCode2('JUN',Tbranch);
      end;

   gattr := lattr; { result }

end; { procedure term }


{$BOX
  The purpose of this procedure is to compile the following syntax:
     [ + | - ] <term> [ <addop> <term> ]*
  where <addop> is + | - | OR.
$EBOX}

procedure SimpleExpression(Tbranch, Fbranch : labeltype; sync : setoftokens);

var lattr, swap : attributes;  { attributes of left hand side }
    op : AddType;
    exprsign : plus..minus;
    newattr : attributes;
    ORwasused : boolean;
    L1 : labeltype;

begin

   ORwasused := false;
   { look for optional leading sign }
   exprsign := plus;
   If (tok.token = AddOp) and
      ((tok.AdddOp = plus) or (tok.AdddOp = minus)) then begin
      exprsign := tok.adddop; FetchToken; end;

   MakeLabel(L1);
   Term(Tbranch,Fbranch,sync+[AddOp]);

   { leading minus? }
   if (exprsign = minus) then begin
      makedirect;
      if (gattr.ttype = INTEGER_) then begin
         Changeable(gattr);
         GenCode2('NEGI',gattr.loc);
         end
      else if (gattr.ttype = CARDINAL_) then begin { must be to integer }
         alloctemp(newattr,INTEGER_);
         GenCode1('CTOI',newattr.loc,gattr.loc);
         Unalloc(gattr);
         GenCode2('NEGI',gattr.loc);
         gattr := newattr;
         end
      else if (gattr.ttype = REAL_) then begin
         Changeable(gattr);
         GenCode2('NEGR',gattr.loc);
         end
      else ReportError(124);
   end;

   lattr := gattr;
   if (tok.token = AddOp) then
      begin makedirect; lattr := gattr; end;

   while (tok.token = AddOp) do begin
      op := tok.AdddOp; FetchToken;
      Term(Tbranch, L1, sync+[AddOp]); makedirect;

      if (gattr.ttype <> NIL) and (lattr.ttype <> NIL) then begin
         { Cardinals convert to integer in mixed-mode }
         MakeCompat(lattr,gattr);

         case op of
             plus : begin
                       { try to store the result in a temporary }
                       if gattr.temp and not lattr.temp then begin
                          swap := gattr; gattr := lattr; lattr := swap; end;

                       if (gattr.ttype = lattr.ttype) then
                          if (gattr.ttype = INTEGER_) or
                             (gattr.ttype = CARDINAL_) or
                             (gattr.ttype = BITSET_) or
                             (gattr.ttype = REAL_) then begin
                             Changeable(lattr);
                             GenCode1t('ADD',lattr.loc,gattr.loc,gattr.ttype);
                             Unalloc(gattr);
                             end
                          else ReportError(125)
                       else ReportError(124);
                    end; { plus }

            minus : begin
                       if (gattr.ttype = lattr.ttype) then
                          if (gattr.ttype = INTEGER_) or
                             (gattr.ttype = CARDINAL_) or
                             (gattr.ttype = BITSET_) or
                             (gattr.ttype = REAL_) then begin
                             Changeable(lattr);
                             GenCode1t('SUB',lattr.loc,gattr.loc,gattr.ttype);
                             Unalloc(gattr);
                             end
                          else ReportError(127)
                       else ReportError(128);
                    end; { minus }

              orr : begin
                       FetchToken; { swallow OR }
                       if not ORwasused then begin
                          if (lattr.ttype <> BOOLEAN_) then
                             ReportError(147);
                          GenTestBool(lattr,Tbranch,L1);
                          end
                       else begin
                          GenLabel(L1); MakeLabel(L1);
                          if (gattr.ttype <> BOOLEAN_) then
                             ReportError(150);
                          GenTestBool(gattr,Tbranch,L1);
                          end;
                       lattr.ttype := BOOLEAN_;
                       lattr.kind := expr;
                       ORwasused := TRUE;
                    end; { orr }

         end; { case }
      end; { <> NIL <> NIL }

      if ORwasused then begin
         GenLabel(L1);
         GenCode2('JUN',Fbranch);
      end;

   end; { while }

   gattr := lattr; { result }

end; { procedure SimpleExpression }


{$BOX
  The purpose of this procedure is to compile the following syntax:
      <simpleexpr> [ <relop> <simpleexpr> ]
  where <relop> is  #  |  <>  |  <=  |  >=  |  <  |  >  |  =
$EBOX}

procedure Expression{(Tbranch, Fbranch : labeltype; sync : setoftokens)};

var op : RelType; { relation joining two simple expressions }
    lattr : attributes; { attributes of left hand side }

begin

   SimpleExpression(Tbranch, Fbranch, sync + [RelOp]);

   If (tok.token = RelOp) then begin
      makedirect; lattr := gattr;
      op := tok.Rop; FetchToken;
      SimpleExpression(Tbranch, Fbranch, sync); makedirect;
      { Cardinals convert to integer in mixed-mode }
      MakeCompat(lattr,gattr);

      if (lattr.ttype = BOOLEAN_) then
         if (gattr.ttype = BOOLEAN_) then begin
            GenCode1('CPB',lattr.loc,gattr.loc);
            if not (op in [relEQ, relNEQ]) then ReportError(134);
         end
         else ReportError(135)

      else if (lattr.ttype = gattr.ttype) then
            GenCode1t('CP',lattr.loc,gattr.loc,gattr.ttype)
         else ReportError(136);

      case op of
          relEQ  : GenCode2('JNE',Fbranch);
          relNEQ : GenCode2('JEQ',Fbranch);
          relGT  : GenCode2('JLE',Fbranch);
          relLT  : GenCode2('JGE',Fbranch);
          relLE  : GenCode2('JGT',Fbranch);
          relGE  : GenCode2('JLT',Fbranch);
      end; { case }
      GenCode2('JUN',Tbranch);

      Unalloc(gattr);
      Unalloc(lattr);

      with gattr do begin
         ttype := BOOLEAN_;
         kind := expr;
      end;

   end; { if tok.token = relop }

end; { procedure Expression }


{$BOX
  The purpose of this subroutine is to compile an expression and to make
  sure that has a boolean result.
$EBOX}

procedure BooleanExpression(Tbranch, Fbranch : labeltype; sync : setoftokens);
begin
   Expression(Tbranch, Fbranch, sync); makedirect;
   If (gattr.ttype <> BOOLEAN_) then ReportError(151);
end; { procedure BooleanExpression }
procedure compStmtlist(sync, terminator : setoftokens);

{$BOX
  This procedure compiles any number of statements until an
  symbol in the set parameter 'terminator' is found.
$EBOX}


procedure compStmt(sync : setoftokens);

{$BOX
  This procedure compiles one line, which should be a statement.
$EBOX}
procedure compIF(sync : setoftokens);


{$BOX
  This procedure compiles the following grammar:
       IF <booleanexpression> THEN
          <stmtlist>
    [[ ELSIF <booleanexpression> THEN
             <stmtlist> ] ... ]
     [ ELSE <stmtlist> ]
$EBOX}

var L1, L2, L3 : labeltype;

begin
   FetchToken; { swallow IF }

   MakeLabel(L1); MakeLabel(L2); MakeLabel(L3);
   BooleanExpression(L1, L2, sync + [THENsym]); { true, false branches }
   if (tok.token = THENsym) then begin
      FetchToken; { swallow THEN }
      GenLabel(L1); { then portion }
      compStmtlist(sync, [ELSIFsym, ELSEsym, ENDsym]);
      GenCode2('JUN',L3);
      end
   else begin
      ReportError(147); Skip(sync+[ELSIFsym,ELSEsym,ENDsym]); end;

   while (tok.token = ELSIFsym) do begin { ELSIF portion }
      FetchToken; { swallow ELSIF }
      GenLabel(L2); MakeLabel(L1); MakeLabel(L2);
      BooleanExpression(L1, L2, sync + [THENsym]); { true, false branches }
      if (tok.token = THENsym) then begin
         FetchToken; { swallow THEN }
         GenLabel(L1); { then portion }
         compStmtlist(sync, [ELSIFsym, ELSEsym, ENDsym]);
         GenCode2('JUN',L3);
         end
      else begin
         ReportError(147); Skip(sync+[ELSIFsym,ELSEsym,ENDsym]); end;
      end; { ELSIF portion }

   if (tok.token = ELSEsym) then begin { ELSE portion }
      FetchToken; { swallow ELSE }
      GenLabel(L2);
      compStmtlist(sync, [ENDsym]);
      end; { ELSE portion }

   GenLabel(L3); { fall-through label when all tests fail }

   if (tok.token = ENDsym) then FetchToken { swallow END }
     else begin ReportError(148); Skip(sync); end;

end; { procedure compIF }
procedure compWHILE(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     WHILE <booleanexpression> DO <stmtlist> END
$EBOX}

var L1, L2 : labeltype;

begin
   FetchToken; { swallow WHILE token }

   MakeLabel(L1); MakeLabel(L2); Genlabel(L1);
   BooleanExpression(L1, L2, sync + [DOsym]); { true, false branches }

   if (tok.token = DOsym) then begin
      FetchToken; { swallow DO }
      compStmtlist(sync,[ENDsym]);
      if (tok.token = ENDsym) then FetchToken; { swallow END }
      GenCode2('JUN',L1);
      GenLabel(L2);
      end
   else begin
      ReportError(147); Skip(sync); end;

end; { procedure compWHILE }
procedure compREPEAT(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     REPEAT <stmtlist> UNTIL <booleanexpression>
$EBOX}

var L1, L2 : labeltype;

begin
   FetchToken; { swallow REPEAT token }

   MakeLabel(L1); GenLabel(L1);
   compStmtlist(sync, [UNTILsym]);
   if (tok.token = UNTILsym) then begin
      FetchToken; { swallow UNTIL }
      MakeLabel(L2);
      BooleanExpression(L1, L2, sync); { true, false branches }
      GenLabel(L2);
      end
   else begin
      ReportError(146); Skip(sync); end;

end; { procedure compREPEAT }
procedure compBEGIN(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     BEGIN <stmtlist> END
$EBOX}

begin
   FetchToken; { skip the BEGIN }

   compStmtlist(sync, [ENDsym]);
   if (tok.token = ENDsym) then FetchToken; { swallow END }

end; { procedure compBEGIN }
procedure compFOR(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     FOR <identifier> := <expression> TO <expression> [ BY <expression> ]
         DO <stmtlist> END
$EBOX}

begin
end; { procedure compFOR }
procedure compLOOP(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
  LOOP <stmt> END
$EBOX}

var L1, L2, previousexit : labeltype;

begin
   FetchToken; { swallow LOOP }

   { establish this label as new "closest" exit for EXIT statements }
   MakeLabel(L1); MakeLabel(L2);
   with display[NestLevel] do begin
      previousexit := looplabel;
      looplabel := L2;
      end; { with }

   GenLabel(L1);                   {  <label> }
   compStmtlist(sync,[ENDsym]);    {  ...  }
   GenCode2('JUN',L1);           {  Jump to <label> }
   GenLabel(L2);
   if (tok.token = ENDsym) then
      FetchToken; { swallow END }

   { reestablish previous "closest" exit for EXIT statements }
   display[NestLevel].looplabel := previousexit;

end; { procedure compLOOP }
procedure compEXIT(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     EXIT
  The exit statement will terminate the most recent LOOP statement.
$EBOX}

begin
   FetchToken; { swallow EXIT }

   with display[NestLevel] do

      if (looplabel = -1) then begin
         ReportError(146); Skip(sync); end
      else begin
         GenCode2('JUN',looplabel);
      end;

end; { procedure compEXIT }
procedure compCASE(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
     CASE <expression> OF <caselabellist> : <stmtlist>
                      [ | <caselabellist> : <stmtlist> ]*
                        [ [|] ELSE <stmtlist> ]
     END
$EBOX}

begin
end; { procedure compCASE }
procedure compAssignment(sync : setoftokens);

{$BOX
  This procedure compiles the following grammar:
  <designator> := <expression>
$EBOX}

var eptr1, eptr2 : entryPTR;
    lattr : attributes;
    L1, L2 : labeltype;
    temp : attributes;

begin
   FindID(tok.name,eptr1,eptr2);
   If (eptr1 = FAKENIL) then ReportError(154)
   else
     if not (ST[eptr1].entry_type in [Varr, Field]) then
        ReportError(155);
   FetchToken; { swallow id }
   Specify(-1,-1,eptr1,sync + [ASSIGNsym]);
   If (tok.token <> ASSIGNsym) then ReportError(156);
   Fetchtoken; { swallow := }
   lattr := gattr; { remember what we're assigning to }
   if (lattr.ttype = BOOLEAN_) then begin
      MakeLabel(L1); MakeLabel(L2);
      BooleanExpression(L1,L2,sync); makedirect;

      if (gattr.kind = variable) then  { a simple copy }
         if (lattr.access = direct) then
            GenCode1('LDB',lattr.loc,gattr.loc)
         else
            GenCode5('ST@B',lattr.baseptr,gattr.loc,lattr.loc)

      else begin
         GenTestBool(gattr,L1,L2);
         GenLabel(L1);
         if (lattr.access = direct) then
            GenCode1('LD#B',lattr.loc,BOOLTRUEVAL)
         else begin
            alloctemp(temp,BOOLEAN_);
            GenCode1('LD#B',temp.loc,BOOLTRUEVAL);
            GenCode5('ST@B',lattr.baseptr,temp.loc,lattr.loc);
            end;
         MakeLabel(L1); GenCode2('JUN',L1);
         GenLabel(L2);
         if (lattr.access = direct) then
            GenCode1('LD#B',lattr.loc,BOOLFALSEVAL)
         else begin
            alloctemp(temp,BOOLEAN_);
            GenCode1('LD#B',temp.loc,BOOLTRUEVAL);
            GenCode5('ST@B',lattr.baseptr,temp.loc,lattr.loc);
            end;
         GenLabel(L1);
         end; { bool := bool expression }
      end { BOOLEAN }

   else begin
      Expression(-1,-1,sync+[ASSIGNsym]); makedirect;
      if (lattr.ttype = CARDINAL_) and (gattr.ttype = INTEGER_) then
         ConvertToCard(gattr);
      if (lattr.ttype = INTEGER_) and (gattr.ttype = CARDINAL_) then
         ConvertToInt(gattr);

      if (lattr.ttype = gattr.ttype) and (lattr.ttype <> NIL) then
         if (lattr.ttype^.form = Basic) then
            if (lattr.access = direct) then
               GenCode1t('LD',lattr.loc,gattr.loc,gattr.ttype)
            else
               GenCode5t('ST@',lattr.baseptr,gattr.loc,lattr.loc,gattr.ttype)
         else { copy a structure, e.g. an array or a field }
            GenComment('can''t copy structures yet')
      else ReportError(157);
   end;
end; { procedure compAssignment }
      { compStmt }
begin

   case tok.token of
        semicolon : Fetchtoken; { swallow semicolon }
            IFsym : compIF(stmtbegtoks+sync);
         WHILEsym : compWHILE(stmtbegtoks+sync);
        REPEATsym : compREPEAT(stmtbegtoks+sync);
         BEGINsym : compBEGIN(stmtbegtoks+sync);
           FORsym : compFOR(stmtbegtoks+sync);
               ID : compAssignment(stmtbegtoks+sync);
          LOOPsym : compLOOP(stmtbegtoks+sync);
          EXITsym : compEXIT(stmtbegtoks+sync);
          CASEsym : compCASE(stmtbegtoks+sync);
   otherwise { null statement }
   end; { case }

end; { procedure compStmt }
      { compStmtlist }
begin

   { list must have at least one statement }
   If (tok.token in stmtbegtoks) then
      compStmt(sync + stmtbegtoks + terminator)
   else ReportError(153);

   while (tok.token in stmtbegtoks) do begin
      MatchSym(semicolon); { stmts are seperated by a semicolon }
      while (tok.token = semicolon) do FetchToken;
      compStmt(sync + stmtbegtoks + terminator);
      end;

   if not (tok.token IN terminator) then begin
      ReportError(144);
      Skip(sync+terminator);
      end;

end; { procedure Stmtlist }
procedure CompileThatSucker;

var progstart : boolean;
    progname : IDstring;

begin

   UpLexLevel;
   FetchToken;  { read in the first token of the program }
   MatchSym(PROGRAMsym);
   If (tok.token <> ID) then ReportError(14)
   else progname := tok.name;
   FetchToken;
   MatchSym(semicolon);

   while (tok.token <> BEGINsym) do
      case tok.token of
         CONSTsym : compCONST;
         VARsym :  compVAR;
         TYPEsym : compTYPE;
         EOFtoken : begin
             writeln('Unexpected end of file');
             STOPPROGRAM(1);
             end;
         otherwise begin ReportError(15); FetchToken; Skip(blockbegtoks); end;
         end; { case }

   FetchToken; { get first token after BEGIN }
   compStmtlist([ENDsym], [ENDsym]);

   { now deal with then end of the program }
   MatchSym(ENDsym);
   If (tok.token <> ID) then ReportError(16)
   else if (progname <> tok.name) then ReportError(17);
   FetchToken; MatchSym(period);
   If (tok.token <> EOFtoken) then ReportError(18);

   { read any remaining text so the last line gets printed out }
   while (tok.token <> EOFtoken) do FetchToken;

end; { procedure CompileThatSucker }
procedure PrintOutTable;

var tab : integer;  { for formatting purposes }
    i : integer;
    eptr : entryPTR;

procedure indent(i:integer); begin tab := tab + i; end;
procedure undent(i:integer); begin tab := tab - i; end;

procedure TabOver;
var i : integer;
begin for i := 1 to tab do write(ListFile,' '); end;

procedure printbasictype(ptr : structPTR);
begin
        if (ptr = INTEGER_)  then writeln(ListFile,'INTEGER')
   else if (ptr = REAL_)     then writeln(ListFile,'REAL')
   else if (ptr = CHAR_)     then writeln(ListFile,'CHAR')
   else if (ptr = CARDINAL_) then writeln(ListFile,'CARDINAL')
   else if (ptr = BOOLEAN_)  then writeln(ListFile,'BOOLEAN')
   else if (ptr = BITSET_)   then writeln(ListFile,'BITSET')
   else if (ptr = PROC_)     then writeln(ListFile,'PROC')
   else if (ptr = NIL)       then writeln(ListFile,'NIL basic type pointer')
   else                           writeln(ListFile,'unknown basic type');
end; { procedure printbasictype }

procedure printconstt(cptr : const_entryPTR);
var i : 0..BITSETSIZE;
begin
   if (cptr = NIL) then writeln(ListFile,'NIL const pointer')
   else case cptr^.const_kind of
        constINT : writeln(ListFile,'constant INT, val=',cptr^.Ival:1);
       constREAL : writeln(ListFile,'constant REAL, val=',cptr^.Rval);
       constCHAR : writeln(ListFile,'constant CHAR, val=''',cptr^.Cval,'''');
        constSTR : writeln(ListFile,'constant STR, val=''',cptr^.Sval^,'''');
     constBITSET : begin
                      writeln(ListFile,'constant BITSET');
                      write(ListFile,'      value = {');
                      for i := 0 to BITSETSIZE do
                         if (cptr^.bits[i]) then write(ListFile,i:1,',');
                      writeln(ListFile,'}');
                   end;
       otherwise   writeln(ListFile,'unknown constant type');
   end; { case }
end; { procedure printconstt }

procedure printstruct(sptr : struct_entryPTR);
begin
   If (sptr.PTR = NIL) then writeln(ListFile,'NIL struct pointer')
   else begin
      If NOT (sptr.owner) and (sptr.PTR^.form <> Basic) then begin
         write(ListFile,'renaming of '); indent(13); end;
      case sptr.PTR^.form of
            Basic : begin
                       printbasictype(sptr.PTR^.basicptr);
                    end;
           Pointr : begin
                       write(ListFile,'POINTER TO ');
                       indent(12); printstruct(sptr.PTR^.ptrtype);
                    end;
       Enumerated : begin
                       write(ListFile,'enumeration, ');
                       If (sptr.PTR^.lastelem = NIL) then
                          writeln(ListFile,'NIL end pointer')
                       else
                          writeln(ListFile,' MaxOrd=',sptr.PTR^.lastelem^.enumval:1);
                    end;
            Range : begin
                       write(ListFile,'subrange of ');
                       indent(13); printstruct(sptr.PTR^.rangetype); undent(13);
                       TabOver; writeln(ListFile,'MinOrd=',sptr.PTR^.min:1,
                                              ' MaxOrd=',sptr.PTR^.max:1);
                    end;
             Sett : begin
                       write(ListFile,'set of ');
                       indent(8); printstruct(sptr.PTR^.settype); undent(8);
                    end;
           Arrayy : begin
                       write(ListFile,'ARRAY : ');
                       indent(9); printstruct(sptr.PTR^.indextype); undent(9);
                       TabOver; write(ListFile,' OF ');
                       indent(5); printstruct(sptr.PTR^.contenttype); undent(5);
                    end;
          Recordd : writeln(ListFile,'RECORD #',ORD(sptr.PTR));

        Otherwise writeln('unknown struct type');
      end; { case }
   end;
end; { procedure printstruct }

procedure printvarr(vptr : var_entryPTR);
begin
   if (vptr = NIL) then writeln(ListFile,'NIL var entry pointer')
   else begin
      write(ListFile,'var of ');
      indent(8); printstruct(vptr^.vstruct); undent(8);
      writeln(ListFile,' addr =',vptr^.adr);
   end;
end; { procedure printvarr }

procedure printenum(eptr : enum_entryPTR);
begin
   If (eptr = NIL) then writeln(ListFile,'NIL enum pointer')
   else writeln(ListFile,'enumerated, ORD=',eptr^.enumval:1);
end; { procedure printenum }

procedure printTypee(tptr : struct_entryPTR);
begin
   if (tptr.PTR = NIL) then writeln(ListFile,'NIL type pointer')
   else begin
      printstruct(tptr);
      writeln(ListFile,'align =',tptr.PTR^.align:1,'  size =',tptr.PTR^.size:1);
      end;
end; { procedure printTypee }


procedure printField(fptr : var_entryPTR; rptr : structPTR);
begin
   write(ListFile,'record field ');
   indent(14); printVarr(fptr); undent(14);
   TabOver;
   if (rptr = NIL) then writeln(ListFile,'NIL recptr')
                   else writeln(ListFile,'record #',ORD(rptr));
end; { procedure printField }


procedure printTableEntry(eptr : entryPTR);
var hash : integer;
begin
   if (eptr = FAKENIL) then writeln(ListFile,'NIL table entry pointer')
   else with ST[eptr] do begin
      writeln(ListFile,'NAME: ',IDname,', scope level: ',nestingdepth:1);
      hash := HashID(ST[eptr].IDname);
      writeln(ListFile,'entry #',eptr:1,', hash distance=',(eptr-hash):1);
      write(ListFile,'Structure:'); indent(11);
      case entry_type of
         Constt : printconstt(constptr);
           Varr : printvarr(varptr);
          Typee : printtypee(typptr);
           Enum : printenum(enumptr);
          Field : printfield(fieldptr, recptr);
       otherwise  writeln('unknown table entry type');
      end; { case }
   end; { else with }
end; { procedure printTableEntry }


begin

{
   writeln(ListFile);
   writeln(ListFile,'HASH TABLE IN ORDER');
   for i := 0 to MAXSYM do
      if ST[i].IDname <> '' then
          writeln(ListFile,i:3,' : ',ST[i].IDname:35,
                  '  level=', ST[i].nestingdepth:2);
}

   writeln(ListFile);
   writeln(ListFile,'HASH TABLE BY LINK POINTERS');
   for i := MAXDISPLAYDEPTH downto 1 do
      if (display[i].lastlink <> FAKENIL) then begin
         writeln(ListFile,'---- display[',i:1,'] ----');
         eptr := display[i].lastlink;
         while (eptr <> FAKENIL) do begin
            writeln(ListFile); { blank line }
            tab := 5; { start near left column }
            printTableEntry(eptr);
            eptr := ST[eptr].backlink;
            end; { while }
         end; { if }

end; { procedure PrintOutTable }
{ main program }
{$BOX

  Main program

$EBOX}

var eptr1, eptr2 : entryPTR;
    IDname : IDstring;

begin

   InitLex;    { initialize variables in Lex module }
   InitSymbolTable;
   InitSets;
   OpenFiles(SourceFile,ListFile,CodeFile);
   GetCurrentLine; { read in the first line of the program }

   CompileThatSucker;

{  PrintOutTable;  }

   CloseFile(SourceFile);
   CloseFile(ListFile);
   CloseFile(CodeFile);

end. { compiler }