  (*$p**************************************************************************)
  (*                                                                           *)
  (*                          File: MISC.TEXT                                  *)
  (*                                                                           *)
  (*              (C) Copyright 1981 Silicon Valley Software, Inc.             *)
  (*                            1983, 1984 Apple Computer, Inc.                *)
  (*                                                                           *)
  (*                            All rights reserved.               11-Jun-82   *)
  (*                                                                           *)
  (* 3-31-83 Enter: fixed nil ptr in $SETC tree                                *)
  (* 5-06-83 Nextch: output up to 150 chars/line in listing file               *)
  (* 5-11-83 Pflist,implpflist: error on procs declared forward twice          *)
  (* 5-11-83 Pflist,implpflist: error on forw-declared procs without a body    *)
  (* 5-11-83 Getbounds: return bounds for strings                              *)
  (* 5-26-83 Comment: Don't process include files while skipping text          *)
  (* 5-26-83 Comment: 'alreadyskipping' bool prevents recursive calls to scan  *)
  (* 5-27-83 Comment: add overflow checking switch $OV+                        *)
  (* 5-27-83 Implpflist:Check for missing end after methods ... {end;}         *)
  (* 5-31-83 Forwsearch: new routine for reporting forw procs w/o bodies       *)
  (* 6-13-83 Nextch: speed up output of listing line                           *)
  (* 6-16-83 Init_heap: new proc to reduce heapsize between executions         *)
  (* 6-17-83 Implpflist:Generate error for creation outside method block       *)
  (* 6-17-83 Prog: delete METHOD from list of legal syms following decl section*)
  (* 6-28-83 Hexconstant: make all $xxxx words, $xxxxxxxx longints             *)
  (* 7-15-83 Error: conditional around Killexec                                *)
  (* 8-28-83 Hexconstant: issue a warning on value change (inhouse version only*)
  (* 8-28-83 Warning: a new procedure for warnings                             *)
  (* 8-30-83 Previousfile: fix so file stack doesn't underflow                 *)
  (* 9-07-83 Fillinbuf: check ioresults after reads                            *)
  (*10-10-83 Comptypes: restrict Class compat to Super:=Sub but not Sub:=Super *)
  (*10-10-83 Eqtypes: change so classes = only if A=B and B=A (commutative)    *)
  (*10-11-83 Addatsigns: init superclass method table pointer at (m.t.-4)      *)
  (*10-25-83 Comment: add $F options for controlling forward declarations      *)
  (*10-25-83 Pflist,implpflist: report missing fwd procs only if Forwchkflag   *)
  (*11-18-83 Eqtypes: undo previous change (now sub=super but not super=sub)   *)
  (*12-14-83 SearchClasses: searches for methods up superclass chain           *)
  (*12-14-83 AddAtSigns: correction to 10-11-83 to setup ptr to superclass     *)
  (*12-14-83 SearchAll: uses SearchClasses for WITH'ed methods                 *)
  (*12-14-83 CallUsedUnits, InitUnit: added for unit initialization            *)
  (*12-14-83 Prog: changed for unit and class initialization                   *)
  (*12-20-83 Third parameter added to Dump to control external name casing     *)
  (*12-27-83 AddAtSigns replaced with AddMethodInfo for extensible classes     *)
  (*12-27-83 Various changes for extensible classes                            *)
  (*01-01-84 ImplPFList: CREATION syntax changed to simple BEGIN/END block     *)
  (*01-05-84 CompFormals: new function added to compare formal param lists     *)
  (*01-20-84 Constant: completely redone to support constant expressions       *)
  (*01-21-84 Various places changed to support arbitrary declaration order     *)
  (*01-31-84 New optimization stuff                                            *)
  (*02-06-84 HasBody and related changes for INLINE code                       *)
  (*03-06-84 Additions for prog. communications to the editor and code gen.    *)
  (*03-06-84 Scan: allow (. and .) to be scanned as [ and ] respectively       *)
  (*03-29-84 HasBody: allow C external procs                                   *)
  (*04-29-84 FatalOutputError: added to check for code file write errors       *)
  (*****************************************************************************)
  {[j=0/0/80!,@=10,i=1]}

  {$S SCAN}

  {*[[[ Begin UCSD Dependent I/O Code ]]]*}

  FUNCTION OpenNewFile{Filename: SUStr; FileType: InputFileTypes): boolean};

    VAR
      i: Integer;
      DontCare: Boolean;

    BEGIN {OpenNewFile}
      OpenNewFile := False;

      {Remember all relevant information about current sourcefile}

      IF TopOfOpenFileStack <> 0 THEN
        WITH OpenFileStack[TopOfOpenFileStack] DO
          BEGIN
          NextChToRead := InbufP;
          LastValidByte := InbufLastValidByte;
          NumValidBlocks := InbufNumValidBlocks;
          SrcEolSource := EolSource;
          {Save the contents of the input buffer.  If previously stacked file
           has saved buffer then invalidate it (there is only one save buffer)}
          IF TopOfOpenFileStack > 1 THEN
            OpenFileStack[TopOfOpenFileStack - 1].BufSaved := False;
          BufSaved := True;
          SaveInbufP^ := Inbuf;
          pCurL := pCurLine; CurLine[0] := Chr(pCurLine); CurL := CurLine;
          PrevL := PrevLine;
          LineNbr := LineNumber; PrevLnbr := PrevLn;
          LPrinted := LinePrinted;
          ErrIdx := ErrIndex;
          i := 1;
          WHILE i <= ErrIndex DO
            BEGIN
            ErrLst[i] := ErrList[i]; i := i+1;
            END;
          ErrIndex := 0;
          END;

      {Push file on OpenFileStack}

      IF TopOfOpenFileStack = MAXFILES THEN
        Error(304)
      ELSE
        BEGIN
        TopOfOpenFileStack := TopOfOpenFileStack + 1;

        {Source and Include files must be .TEXT files.}
        {'Uses' files may end in .OBJ.               }
        {File-open error fatal except in 'Uses' case.}

        IF (FileType = INCLUDED) OR (FileType = SOURCE) THEN
          SUAddExtension(@Filename, '.TEXT', SUMaxStrLeng, DontCare);

        {$I-}
        Reset(OpenFileStack[TopOfOpenFileStack].SrcFile, Filename);
        {$I+}

        IF IOResult > 0 THEN
          BEGIN
          IF (FileType = INCLUDED) OR (FileType = SOURCE) THEN
            BEGIN {exit with IORESULT > 0!!}
            TopOfOpenFileStack := TopOfOpenFileStack - 1;
            Exit(OpenNewFile);
            END
          ELSE {filetype = used}
            Filename := Concat(Filename, '.OBJ');

          {$I-}
          Reset(OpenFileStack[TopOfOpenFileStack].SrcFile, Filename);
          {$I+}

          IF IOResult > 0 THEN
            BEGIN {filetype = used} {exit with IORESULT > 0!!}
            TopOfOpenFileStack := TopOfOpenFileStack - 1;
            Exit(OpenNewFile);
            END;
          END;

        OpenNewFile := True;

        WITH OpenFileStack[TopOfOpenFileStack] DO
          BEGIN
          LastRelBlkRead := 2 - InbufBLockSize; {next read will start at block 2}
          NextChToRead := 0;
          FName := Filename;
          EolSource := True;
          BufSaved := False;
          InbufLastValidByte := InbufByteSize - 1;
          InbufP := InbufByteSize;
          LinePrinted := True;
          LineNumber := 0;
          END;
        END;
    END; {OpenNewFile}

  PROCEDURE PreviousFile;

    VAR
      i, j: Integer;

    BEGIN {PreviousFile}
      IF TopOfOpenFileStack > 1 THEN
        BEGIN
        Close(OpenFileStack[TopOfOpenFileStack].SrcFile);
        TopOfOpenFileStack := TopOfOpenFileStack - 1;
        WITH OpenFileStack[TopOfOpenFileStack] DO
          BEGIN {during this pop, merge current errors with pushed errors}
          IF (ErrIdx + ErrIndex) > MaxErrs THEN
            BEGIN {cut back the current error list}
            ErrIndex := MaxErrs - ErrIdx;
            ErrList[ErrIndex].Nbr := 352; {too many errors}
            ErrList[ErrIndex].Name := '        ';
            END;
          j := ErrIndex;
          ErrIndex := ErrIdx + ErrIndex;
          i := ErrIndex;
          WHILE j > 0 DO
            BEGIN
            ErrList[i] := ErrList[j]; i := i - 1; j := j - 1;
            END;
          i := 1;
          WHILE i <= ErrIdx DO
            BEGIN
            ErrList[i] := ErrLst[i]; i := i+1;
            END;
          LinePrinted := LPrinted;
          LineNumber := LineNbr; PrevLn := PrevLnbr;
          pCurLine := pCurL; CurLine := CurL;
          PrevLine := PrevL;
          InbufP := NextChToRead;
          InbufLastValidByte := LastValidByte;
          InbufNumValidBlocks := NumValidBlocks;
          EolSource := SrcEolSource;
          IF BufSaved THEN
            Inbuf := SaveInbufP^
          ELSE IF BlockRead(SrcFile, Inbuf, InbufNumValidBlocks,
                  LastRelBlkRead) <> InbufNumValidBlocks THEN
            BEGIN {Fatal error in rereading previously read block-group Replaced
                   halt with global goto}
            Error(406);
            GOTO 999;
            END;
          END;
        END;
    END; {PreviousFile}

  PROCEDURE FilePos{var block,byte: integer};

    BEGIN {FilePos - return current position in input file}
      Block := OpenFileStack[TopOfOpenFileStack].LastRelBlkRead + InbufP DIV 512;
      Byte := InbufP MOD 512;
    END; {FilePos}

  PROCEDURE FileSeek{block: integer};

    BEGIN {FileSeek - set up so that next fillinbuf will read from the specified
           block of the file.}
      WITH OpenFileStack[TopOfOpenFileStack] DO
        LastRelBlkRead := Block - InbufBLockSize;
      InbufLastValidByte := InbufByteSize;
      InbufP := InbufByteSize;
    END; {FileSeek}

  PROCEDURE NextPg;

    BEGIN {NextPg}
      IF pAbortFlag THEN
        BEGIN
        KillExec; Aborted := True;
        GOTO 999;
        END;
      InbufP := (InbufP DIV 1024) * 1024 + 1024; {advance to next UCSD textpage}
      IF InbufP > InbufLastValidByte THEN FillInbuf;
    END; {NextPg}

  PROCEDURE FillInbuf;

    LABEL 1;

    VAR
      i: Integer;
      Dummy: Boolean;

    BEGIN {FillInbuf - read next group of input text pages into input buffer. Note
           - it is very important to set inbufLastValidByte to InbufBYteSize when
           moving to a different file. Otherwise it's a flag that the previous
           read read to EOF, and Fillinbuf will give up.}
    1:
      IF InbufLastValidByte < InbufByteSize - 1 THEN
        InbufLastValidByte := 0 {previous read got all the blocks}
      ELSE
        BEGIN
        InbufNumValidBlocks := BlockRead(OpenFileStack[TopOfOpenFileStack].SrcFile
                                         , Inbuf, InbufBLockSize,
                                         OpenFileStack[TopOfOpenFileStack].
                                         LastRelBlkRead + InbufBLockSize);
        InbufLastValidByte := 512 * InbufNumValidBlocks - 1;
        i := IOResult;
        IF i > 0 THEN
          BEGIN
          Dummy := IOError(i, '*** FATAL I/O ERROR ***');
          Error(406);
          GOTO 999; {exits compiler}
          END;
        END;

      IF InbufLastValidByte <= 0 THEN {Top of stack read failed}
        IF TopOfOpenFileStack = 1 THEN {EOF}
          BEGIN
          InbufP := 0; Inbuf[0] := Chr(3);
          IF EofLn < 0 THEN
            BEGIN {capture last line in case of errors}
            EofLn := TotalLines; EofLine := PrevLine;
            END;
          END
        ELSE
          BEGIN
          PreviousFile;
          {Block just reread might have just hit last <CR> before it was pushed
           onto the stack.}
          IF InbufP > InbufLastValidByte THEN GOTO 1;
          IF Inbuf[InbufP] = Chr(0) THEN NextPg;
          END
      ELSE
        BEGIN {Top of stack read succeeded}
        OpenFileStack[TopOfOpenFileStack].LastRelBlkRead := OpenFileStack[
                                                            TopOfOpenFileStack].
                                                            LastRelBlkRead +
                                                            InbufBLockSize;
        InbufP := 0;
        END;
    END; {FillInbuf}

  {*[[[ End UCSD Dependent I/O Code ]]]*}

  PROCEDURE ListLine{VAR TotalLines: LongInt};

    VAR
      LineImage: SUStr;
      T: String[10];

    BEGIN {ListLine}
      IF CondStack[CondTos] >= MATCHELSE THEN
        BEGIN {line is being conditionally skipped}
        Left := ' '; Right := ' '; ProcLev := ' ';
        END;

      CurLine[0] := Chr(pCurLine);
      T := PutIntP(TotalLines, 5)^;
      LineImage := Concat(T, PutIntP(LineNumber, 8)^, '      ', CurLine);
      IF TopOfOpenFileStack>1 THEN
        LineImage[8] := Chr(Ord('0') + Ord(TopOfOpenFileStack - 1));
      LineImage[15] := Left;
      LineImage[16] := Right;
      LineImage[18] := ProcLev;

      PutLineP(ListingFCBP, @LineImage);

      TotalLines := TotalLines + 1;
      LinePrinted := True;

      IF pAbortFlag THEN
        BEGIN
        KillExec; Aborted := True;
        GOTO 999;
        END;
    END; {ListLine}

  PROCEDURE ListErrors;

    VAR
      i, j, LastPos, FirstPos, ErrIdx: Integer;
      Overflow, GotResponse: Boolean;
      Ch: Char;
      LineStr, ColStr: String[10];
      Msg, NextMsg, FirstMsg: SUStr;

    PROCEDURE SetupForEditor;                                                  {!03-06-84}

      VAR
        i: Integer;
        Ok: Boolean;

      BEGIN {SetupForEditor - set up communication info for the Editor}
        Ok := True;
        PCReWrite(PCText, 'For Editor');
        i := Pos(' *** ', FirstMsg);
        IF i > 4 THEN Delete(FirstMsg, 1, i + 4);
        i := Length(FirstMsg);
        IF i < 95 THEN
          BEGIN {fake out the editor}
          REPEAT
            i := i + 1; FirstMsg[i] := ' ';
          UNTIL i >= 95;
          FirstMsg[0] := Chr(95);
          END;
        Ok := PCPutLine(FirstMsg);
        IF Ok THEN
          BEGIN
          Ok := PCPutLine(OpenFileStack[TopOfOpenFileStack].FName);
          IF Ok THEN
            BEGIN
            i := FirstPos;
            WHILE (i > 0) AND (CurLine[i] IN ['A'..'Z', 'a'..'z', '_', '%', '0'..'9']) DO
              i := i - 1;
            LineStr := PutIntP(LineNumber, 1)^;
            ColStr := PutIntP(FirstPos + 1, 1)^;
            Ok := PCPutLine(Concat(LineStr, ' ', PutIntP(i + 1, 1)^, ' ', LineStr,
                                   ' ', ColStr));
            END;
          END;
        Ok := Ok AND PCClose(False, 'For Editor');
        IF Ok THEN
          PCSetRunCmd(Ecmd)
        ELSE
          WriteLn(SUBell, 'Unable to set up communication to the Editor.');
        Aborted := True;
      END; {SetupForEditor}

    PROCEDURE GetErrText(MsgNbr: Integer; ErrMsg: SUStrP);

      VAR
        TempStr: String[80];
        IOStatus, MsgIdx, BlockN, CurPos: Integer;
        Overflow, EndMsg: Boolean;
        TheBlock: RECORD
                    CASE Integer OF
                      0:
                        (Ch: PACKED ARRAY [0..511] OF Char);
                      1:
                        (I: ARRAY [0..255] OF Integer);
                  END;

      FUNCTION GetBlock(N: Integer): Integer;

        VAR
          K: Integer;

        BEGIN {GetBlock}
          K := BlockRead(MsgFile, TheBlock.I[0], 1, N);

          IF (IoResult > 0) OR (K <> 1) THEN
            BEGIN
            TempStr := ' Bad block read on error message file "PasErrs.Err".';
            SUConcat(ErrMsg, @TempStr);
            Exit(GetErrText);
            END;

          GetBlock := N;
        END; {GetBlock}

      FUNCTION GetMsgIdx: Integer;

        VAR
          J, CurIdx, NumErrs: Integer;

        BEGIN {GetMsgIdx}
          BlockN := GetBlock(0);
          NumErrs := TheBlock.I[0]; {first entry has number of errors}
          CurIdx := 2;
          J := 1;

          WHILE J <= NumErrs DO
            BEGIN
            IF CurIdx > 255 THEN
              BEGIN
              BlockN := GetBlock(BlockN + 1);
              CurIdx := 0;
              END;

            IF TheBlock.I[CurIdx] = MsgNbr THEN
              BEGIN {found msg}
              GetMsgIdx := TheBlock.I[CurIdx + 1];
              Exit(GetMsgIdx);
              END;

            CurIdx := CurIdx + 2; {each entry consists of two integers}
            J := J + 1;
            END; {while}

          Exit(GetErrText);
        END; {GetMsgIdx}

      BEGIN {GetErrText}
        ErrMsg^ := Concat('*** Error ', PutIntP(MsgNbr, 3)^, ' ***');

        IF NOT MsgFileOpen THEN
          BEGIN {open the msg file and get nbr of errors in it}
          SUSysReset(@MsgFile, 'PASERRS.ERR', IOStatus);
          IF IOStatus > 0 THEN
            BEGIN
            TempStr := ' Error message file "PasErrs.Err" not available.';
            SUConcat(ErrMsg, @TempStr);
            Exit(GetErrText);
            END;

          MsgFileOpen := True;
          END; {msg file is open until end of compilation}

        EndMsg := False;
        MsgIdx := GetMsgIdx;
        SUAddCh(ErrMsg, ' ', SUMaxStrLeng, Overflow);
        BlockN := GetBlock(MsgIdx DIV 512);
        CurPos := MsgIdx MOD 512;

        REPEAT
          IF CurPos > 511 THEN
            BEGIN
            BlockN := GetBlock(BlockN + 1);
            CurPos := 0;
            END;

          IF Ord(TheBlock.Ch[CurPos]) = 0 THEN
            EndMsg := True
          ELSE
            BEGIN
            SUAddCh(ErrMsg, TheBlock.Ch[CurPos], SUMaxStrLeng, Overflow);
            IF Overflow THEN EndMsg := True;
            CurPos := CurPos + 1;
            END;
        UNTIL EndMsg;
      END; {GetErrText}

    PROCEDURE Show(VAR Msg: SUStr);

       BEGIN {Show}
         IF ErrFileOpen THEN WriteLn(ErrFile, Msg);
         IF Listing THEN PutLineP(ListingFCBP, @Msg);
         IF NOT ConsListing THEN WriteLn(Msg);
       END; {Show}

     PROCEDURE Point(Pos: Integer);

       BEGIN {Point}
         IF ErrFileOpen THEN WriteLn(ErrFile, '?': 5 + Pos);
         IF Listing THEN
           BEGIN
           PutStrS(ListingFCBP, '?', 19 + Pos); PutcF(ListingFCBP, IONewline);
           END;
         IF NOT ConsListing THEN WriteLn('?': 5 + Pos);
         LastPos := Pos;
       END; {Point}

    BEGIN {ListErrors}
      IF TotalLines = EofLn THEN CurLine := EofLine;

      IF NOT ConsListing THEN
        BEGIN
        IF PrevLn <> 0 THEN WriteLn(PrevLn: 4, ' ', PrevLine);
        IF TotalLines <> LastErrLn THEN
          WriteLn(LineNumber: 4, ' ', CurLine);
        END;

      IF ErrFileOpen THEN
        BEGIN
        IF PrevLn <> 0 THEN WriteLn(ErrFile, PrevLn: 4, ' ', PrevLine);
        IF TotalLines <> LastErrLn THEN
          WriteLn(ErrFile, LineNumber: 4, ' ', CurLine);
        END;

      LastErrLn := TotalLines;

      ErrIdx := ErrIndex;
      ErrIndex := 0; {in case we go to 999, and for next line}

      FOR i := 1 TO ErrIdx DO
        WITH ErrList[i] DO
          BEGIN
          IF pAbortFlag THEN
            BEGIN
            Aborted := True;
            GOTO 999;
            END;

          GetErrText(Nbr, @Msg);

          IF Name <> '        ' THEN
            BEGIN
            SUAddCh(@Msg, ' ', SUMaxStrLeng, Overflow);
            FOR j := 1 TO ALFALEN DO
              SUAddCh(@Msg, Name[j], SUMaxStrLeng, Overflow);
            SUTrimBlanks(@Msg);
            END;

          SUAddCh(@Msg, '.', SUMaxStrLeng, Overflow);

          IF i = 1 THEN
            BEGIN
            Point(Pos); NextMsg := Msg; FirstMsg := Msg; FirstPos := Pos;
            END
          ELSE IF (Msg = NextMsg) AND (Pos <> LastPos) THEN
            Point(Pos)
          ELSE IF (Msg <> NextMsg) AND (Pos = LastPos) THEN
            BEGIN
            Show(NextMsg); NextMsg := Msg;
            END
          ELSE IF (Msg <> NextMsg) AND (Pos <> LastPos) THEN
            BEGIN
            Show(NextMsg); NextMsg := Msg; Point(Pos);
            END;
          END; {with, for}

      Show(NextMsg);

      Msg := Concat('*** File ', OpenFileStack[TopOfOpenFileStack].FName,
                    ' ***');
      IF Listing THEN PutLineP(ListingFCBP, @Msg);
      IF NOT ConsListing THEN WriteLn(Msg);
      IF ErrFileOpen THEN WriteLn(ErrFile, Msg);

      IF NOT (Listing OR ErrFileOpen) THEN
        IF CallEditor THEN                                                     {!03-06-84 start}
          BEGIN
          SetupForEditor;
          GOTO 999;
          END
        ELSE
          BEGIN
          Write('Type SPACE to continue, CLEAR to exit, E to call Editor.');
          REPEAT
            SUGetCh(Ch);
            GotResponse := Ch IN [' ', SUCr, SUEsc, 'e', 'E'];
            IF NOT GotResponse THEN
              Write(SUBell)
            ELSE
              BEGIN
              WriteLn;
              IF Ch = SUEsc THEN
                BEGIN
                Aborted := True;
                GOTO 999;
                END;
              IF (Ch = 'e') OR (Ch = 'E') THEN
                BEGIN
                SetupForEditor;
                GOTO 999;
                END;
              END;
          UNTIL GotResponse;                                                     {!03-06-84 end}
          END;
    END; {ListErrors}

  {*[[[ Begin UCSD Dependent I/O Code ]]]*}

  PROCEDURE NextCh;

    VAR
      i: Integer;

    BEGIN {NextCh - If the last nextch terminated a line there is a chance that
           the dottext page in inbuf has been fully read}
      IF EolSource THEN
        BEGIN
        EolSource := False;
        CurLine[0] := Chr(pCurLine);
        IF NOT LinePrinted THEN
          BEGIN
          IF Listing THEN
            ListLine(TotalLines)
          ELSE
            TotalLines := TotalLines + 1;
          END;
        IF ErrIndex <> 0 THEN ListErrors;
        PrevLn := LineNumber; PrevLine := CurLine;
        LineNumber := LineNumber + 1;
        Left := '-'; Right := '-'; ProcLev := ' ';
        IF InbufP > InbufLastValidByte THEN FillInbuf;
        IF Inbuf[InbufP] = Chr(0) {NULL} THEN NextPg;
        pCurLine := 0;
        IF Inbuf[InbufP] = Chr(16) {DLE} THEN
          BEGIN
          pCurLine := Ord(Inbuf[InbufP + 1]) - 32;
          IF pCurLine > 150 THEN pCurLine := 150;
          i := 1;
          WHILE i <= pCurLine DO
            BEGIN
            CurLine[i] := ' '; i := i + 1;
            END;
          InbufP := InbufP + 2; {Need to skip blanks at beginning of line}
          END;
        LinePrinted := False;
        END;

      {Pick up the next character in Inbuf}

      Ch := Inbuf[InbufP];
      InbufP := InbufP + 1;

      {If this character is the <CR>, it gets special treatment}

      IF Ch = Chr(13) THEN
        BEGIN {end of line}
        Ch := ' '; EolSource := True;
        END
      ELSE IF pCurLine < 150 THEN
        BEGIN
        pCurLine := pCurLine + 1; CurLine[pCurLine] := Ch;
        END;
    END; {NextCh}

  {*[[[ End UCSD Dependent I/O Code ]]]*}

  PROCEDURE Scan;

    LABEL 1;

    VAR
      i, k: Integer;

    PROCEDURE HexConstant;

      VAR
        k, N: Integer;
        lCh: Char;

      BEGIN {HexConstant}
        IntVal := 0; N := 0; NextCh;
        IF Ch < 'a' THEN
          lCh := Ch
        ELSE
          lCh := Chr(Ord(Ch) - 32);
        WHILE ((lCh >= '0') AND (lCh <= '9')) OR ((lCh >= 'A') AND (lCh <=
              'F')) DO
          BEGIN
          IF IntVal <= 268435455 THEN
            BEGIN
            k := Ord(lCh) - Ord('0');
            IF lCh >= 'A' THEN k := k - 7;
            IntVal := IntVal * 16 + k;
            END
          ELSE
            BEGIN
            Error(12); IntVal := 0;
            END;
          N := N + 1; NextCh;
          IF Ch < 'a' THEN
            lCh := Ch
          ELSE
            lCh := Chr(Ord(Ch) - 32);
          END;
        IF N > 0 THEN
          BEGIN
          Token := ICONSTSY;
          IF N <= 4 THEN {<= 4 digits, make two's complement word}
            IF (IntVal >= 32768) THEN
              IF (IntVal <= 65535) THEN IntVal := IntVal - 65536;
          END
        ELSE
          Token := DOLLARSY;
      END; {HexConstant}

    PROCEDURE UnsignedNumber;

    {$ifc foros}

      VAR
        Digits: fpString; {DecStr} {spring}
        MaxK, k, i: Integer;
        Digital: Boolean;
        Error10: Boolean;

        {$elsec}

      CONST
        DIGITMAX = 20;

      VAR
        Digits: ARRAY [1..DIGITMAX] OF 0..9;
        k, Exp, Scale, i: Integer;
        Negative: Boolean;
        Zero, Ten: Real;
        {$endc}

        {$ifc foros}

      PROCEDURE ConcatCh; {Adds Ch to Digits and reads next Ch.}

        BEGIN {ConcatCh}
          IF k < MaxFpString THEN {DecStrLen} {spring}
            BEGIN
            k := k + 1;
            Digits[k] := Ch;
            END
          ELSE IF NOT Error10 THEN
            BEGIN
            Error10 := True;
            Error(10); {not enough room in buffer}
            END;
          NextCh;
          Digital := ChClass[Ord(Ch)] = DIGITCL;
        END; {ConcatCh}

      {$endc}

      BEGIN {UnsignedNumber}
        {$ifc foros}
        Error10 := False; {Set true when it's been printed}
        Token := ICONSTSY; {Assume integer format until otherwise determined.}
        k := 0; {Start with null string.}
        WHILE Ch = '0' DO NextCh; {ignore leading zeros}
        Digital := ChClass[Ord(Ch)] = DIGITCL; {Initialize digital flag.}
        WHILE Digital DO ConcatCh; {Accumulate digits.}
        IF Ch = '.' THEN
          BEGIN {period detected}
          ConcatCh;
          IF Ch = '.' THEN
            BEGIN {woops - meant :}
            Ch := ':'; DotFlag := True;
            k := k - 1; {Back up}
            END {woops - meant :}
          ELSE IF Ch = ')' THEN
            BEGIN
            Ch := ']'; k := k - 1;
            END
          ELSE
            BEGIN {decimal point detected}
            Token := RCONSTSY;
            IF NOT Digital THEN Error(11);
            WHILE Digital DO ConcatCh; {Accumulate digits after decimal point.}
            END; {decimal point detected}
          END; {period detected}
        IF (Ch = 'E') OR (Ch = 'e') THEN
          BEGIN {explicit exponent}
          ConcatCh;
          Token := RCONSTSY;
          IF (Ch = '+') OR (Ch = '-') THEN ConcatCh; {Accumulate exponent sign.}
          IF NOT Digital THEN Error(13);
          WHILE Digital DO ConcatCh; {Accumulate exponent digits.}
          END; {explicit exponent}
        IF Token = ICONSTSY THEN
          BEGIN {evaluate integer}
          IntVal := 0;
          IF k > 0 THEN
            BEGIN {one or more digits}
            IF k > 10 THEN
              Error(12)
            ELSE
              BEGIN {1 to 10 digits}
              MaxK := k;
              IF MaxK > 9 THEN MaxK := 9;
              IntVal := Ord(Digits[1]) - 48;
              FOR i := 2 TO MaxK DO IntVal := 10 * IntVal + Ord(Digits[i]) - 48;
              IF k = 10 THEN
                BEGIN {handle tenth digit}
                IF (IntVal >= 214748365) OR ((IntVal = 214748364) AND (Digits[i] >
                   '8')) THEN
                  BEGIN
                  Error(12); IntVal := 0;
                  END {Prevent too many error messages}
                ELSE
                  IntVal := IntVal * 10 + Ord(Digits[10]) - 48;
                END; {handle tenth digit}
              END; {1 to 10 digits}
            END; {one of more digits}
          END {evaluate integer}
        ELSE
          BEGIN {evaluate real}
          Digits[0] := Chr(k); {Set length of digits by subterfuge.}
          RealVal := p_f32(Digits); {Str2S(Digits, RealVal);} {spring}
          END; {evaluate real}

        {$elsec}

        Zero := 0;
        Ten := 10;
        Scale := 0;
        Token := ICONSTSY;
        k := 0;
        REPEAT
          k := k + 1;
          Digits[k] := Ord(Ch) - Ord('0');
          NextCh;
        UNTIL (ChClass[Ord(Ch)] <> DIGITCL) OR (k >= DIGITMAX);
        IF ChClass[Ord(Ch)] = DIGITCL THEN
          BEGIN
          Error(10);
          REPEAT
            NextCh;
          UNTIL ChClass[Ord(Ch)] <> DIGITCL;
          END;
        IF Ch = '.' THEN
          BEGIN
          NextCh;
          IF Ch = '.' THEN
            BEGIN
            Ch := ':'; DotFlag := True;
            END
          ELSE
            BEGIN
            Token := RCONSTSY;
            RealVal := Zero;
            FOR i := 1 TO k DO RealVal := RealVal * Ten + Digits[i];
            IF ChClass[Ord(Ch)] <> DIGITCL THEN Error(11);
            WHILE ChClass[Ord(Ch)] = DIGITCL DO
              BEGIN
              RealVal := RealVal * 10 + Ord(Ch) - Ord('0');
              Scale := Scale - 1;
              NextCh;
              END;
            END;
          END; {digits . digits}
        IF (Token = ICONSTSY) AND (Ch <> 'E') AND (Ch <> 'e') THEN
          BEGIN
          IntVal := 0;
          FOR i := 1 TO k DO
            IF (IntVal >= 214748365) OR ((IntVal = 214748364) AND (Digits[i] >
               8)) THEN
              BEGIN
              Error(12); IntVal := 0;
              END {Prevent too many error messages}
            ELSE
              IntVal := IntVal * 10 + Digits[i];
          END;
        IF (Ch = 'E') OR (Ch = 'e') THEN
          BEGIN
          IF Token = ICONSTSY THEN
            BEGIN
            Token := RCONSTSY;
            RealVal := Zero;
            FOR i := 1 TO k DO RealVal := RealVal * Ten + Digits[i];
            END;
          NextCh;
          Negative := False;
          IF Ch = '+' THEN
            NextCh
          ELSE IF Ch = '-' THEN
            BEGIN
            NextCh;
            Negative := True;
            END;
          IF ChClass[Ord(Ch)] <> DIGITCL THEN Error(13);
          Exp := 0;
          WHILE ChClass[Ord(Ch)] = DIGITCL DO
            BEGIN
            Exp := Exp * 10 + Ord(Ch) - Ord('0');
            NextCh;
            END;
          IF Negative THEN Exp := - Exp;
          Scale := Scale + Exp;
          END; {ch = 'E'}
        IF Token = RCONSTSY THEN
          IF Scale < 0 THEN
            FOR i := - 1 DOWNTO Scale DO RealVal := RealVal / Ten
          ELSE
            FOR i := 1 TO Scale DO RealVal := RealVal * Ten;

        {$endc}

      END; {UnsignedNumber}

    PROCEDURE GetString;

      VAR
        lStrVal: StrValType;
        Done: Boolean;
        StrLenModAlfaLen: Integer;
        lIntVal: Integer;

      PROCEDURE Concat;

        BEGIN {Concat}
          IF IntVal = 0 THEN
            lIntVal := Ord(Ch)
          ELSE
            BEGIN
            IF IntVal = 1 THEN
              BEGIN
              New(StrVal);
              lStrVal := StrVal;
              StrVal^.Next := NIL;
              StrVal^.StrPart := '        ';
              StrVal^.StrPart[1] := Chr(lIntVal);
              StrLenModAlfaLen := 1;
              END;
            IF StrLenModAlfaLen = ALFALEN THEN
              BEGIN
              New(lStrVal^.Next);
              lStrVal := lStrVal^.Next;
              lStrVal^.Next := NIL;
              lStrVal^.StrPart := '        ';
              StrLenModAlfaLen := 0;
              END;
            StrLenModAlfaLen := StrLenModAlfaLen + 1;
            lStrVal^.StrPart[StrLenModAlfaLen] := Ch;
            END;
          IntVal := IntVal + 1;
        END; {Concat}

      BEGIN {GetString}
        IntVal := 0;
        Done := False;
        REPEAT
          IF {*[[[ EOLN(sourcefile) ]]]*} EolSource THEN
            Error(14)
          ELSE
            NextCh;
          WHILE Ch <> '''' DO
            BEGIN
            Concat;
            IF {*[[[ EOLN(sourcefile) ]]]*} EolSource THEN
              BEGIN
              Error(14); Ch := ''''
              END
            ELSE
              NextCh;
            END;
          NextCh; {Found first ', is there another}
          IF Ch = '''' THEN
            Concat {Double '}
          ELSE
            Done := True;
        UNTIL Done;
        IF IntVal = 1 THEN
          BEGIN
          IntVal := lIntVal; Token := CCONSTSY;
          END
        ELSE
          Token := SCONSTSY;
      END; {GetString}

    {*[[[ Begin UCSD Dependent I/O Code ]]]*}

    PROCEDURE Comment(TermCh: Char);

      LABEL 1;

      VAR
        EndOfOptions: Boolean;
        OptionCh: Char;
        Filename, Str1, Str2: SUStr;
        InclOptFlag, SameName, Ovflo, AlreadySkipping: Boolean;
        i: Integer;
        TempId: Alfa;

      PROCEDURE GetFileName(BlanksOk: Boolean);

        VAR
          j: Integer;

        PROCEDURE NextFileCh;

          BEGIN {NextFileCh - concatenates ch to the current file name}
            IF j < SUMaxStrLeng THEN
              BEGIN
              IF BlanksOk OR (Ch <> ' ') THEN
                BEGIN
                j := j + 1; Filename[0] := Chr(j); Filename[j] := Ch;
                END;
              END
            ELSE
              Error(351); {File name too long}
            NextCh;
          END; {NextFileCh}

        BEGIN {Getfilename - scans remainder of comment, accumulating a filename.
               Blanks are ignored.}
          j := Length(Filename);
          IF TermCh = '*' THEN
            BEGIN
            NextFileCh;
            WHILE Ch <> '*' DO NextFileCh;
            END
          ELSE
            WHILE Ch <> '}' DO NextFileCh;
          SUTrimBlanks(@Filename);
          EndOfOptions := True;
        END; {GetFileName}

      PROCEDURE Push(s: CondState);

        BEGIN {Push}
          CondTos := CondTos + 1;
          CondStack[CondTos] := s;
        END; {Push}

      PROCEDURE Pop;

        BEGIN {Pop}
          CondTos := CondTos - 1;
        END; {Pop}

      PROCEDURE SetVal(a: Alfa; b: Integer);

        VAR
          tpN, lpN: pN;

        FUNCTION LevelCheck: Boolean;

          BEGIN {LevelCheck}
            IF (Level = 1) OR (( - NumUnits <= Level) AND (Level <= - 1)) THEN
              LevelCheck := True
            ELSE
              BEGIN
              LevelCheck := False;
              Error(260);
              END;
          END; {LevelCheck}

        PROCEDURE Enter(VAR fN: pN);

          BEGIN {Enter}
            IF LevelCheck THEN
              BEGIN
              New(fN);
              WITH fN^ DO
                BEGIN
                Name := a;
                Llink := NIL;
                Rlink := NIL;
                ValueOf.Ivalu := b;
                END;
              END
            ELSE
              fN := NIL;                                                       {!3-31-83ah}
          END; {Enter}

        BEGIN {SetVal}
          lpN := CondRoot;
          IF lpN = NIL THEN
            BEGIN
            Enter(lpN);
            END
          ELSE
            REPEAT
              WITH lpN^ DO
                IF a = Name THEN
                  BEGIN
                  ValueOf.Ivalu := b;
                  lpN := NIL;
                  END
                ELSE IF a < Name THEN
                  IF Llink = NIL THEN
                    BEGIN
                    Enter(tpN); Llink := tpN; lpN := NIL
                    END
                  ELSE
                    lpN := Llink
                ELSE IF Rlink = NIL THEN
                  BEGIN
                  Enter(tpN); Rlink := tpN; lpN := NIL
                  END
                ELSE
                  lpN := Rlink;
            UNTIL lpN = NIL;
        END; {SetVal}

      FUNCTION GetVal(a: Alfa): Integer;

        LABEL 1;

        VAR
          lpN: pN;

        BEGIN {GetVal}
          lpN := CondRoot;
          WHILE lpN <> NIL DO
            WITH lpN^ DO
              IF a = Name THEN
                BEGIN
                GetVal := ValueOf.Ivalu;
                GOTO 1;
                END
              ELSE IF a < Name THEN
                lpN := Llink
              ELSE
                lpN := Rlink;

          Error(261);
          SetVal(a, 0);
          GetVal := 0;
        1:
        END; {GetVal}

      FUNCTION OpExpr: Integer;
        FORWARD;

      FUNCTION OpFactor: Integer;

        BEGIN {OpFactor}
          WHILE NOT (Token IN [IDENTSY, ICONSTSY, NOTSY, LPARENSY, STRINGSY,
                CCONSTSY]) DO
            BEGIN
            Error(262);
            Scan;
            END;
          CASE Token OF
            IDENTSY:  BEGIN
                      OpFactor := GetVal(Ident);
                      Scan;
                      END;
            ICONSTSY, CCONSTSY:
                      BEGIN
                      OpFactor := IntVal;
                      Scan;
                      END;
            STRINGSY: BEGIN
                      Error(262);
                      OpFactor := 0;
                      Scan;
                      END;
            NOTSY:    BEGIN
                      Scan;
                      OpFactor := Ord(NOT (Odd(OpFactor)));
                      END;
            LPARENSY: BEGIN
                      Scan;
                      OpFactor := OpExpr;
                      IF Token <> RPARENSY THEN Error(262);
                      Scan;
                      END;
          END;
        END; {OpFactor}

      FUNCTION OpTerm: Integer;

        VAR
          LeftVal: Integer;
          OldSy: Symbol;

        BEGIN {OpTerm}
          LeftVal := OpFactor;
          WHILE Token IN [STARSY, SLASHSY, DIVSY, MODSY, ANDSY] DO
            BEGIN
            OldSy := Token;
            Scan;
            CASE OldSy OF
              STARSY:   LeftVal := LeftVal * OpFactor;
              SLASHSY, DIVSY:
                        LeftVal := LeftVal DIV OpFactor;
              MODSY:    LeftVal := LeftVal MOD OpFactor;
              ANDSY:    LeftVal := Ord(Odd(LeftVal) AND Odd(OpFactor));
            END;
            END;
          OpTerm := LeftVal;
        END; {OpTerm}

      FUNCTION OpSimpExpr: Integer;

        VAR
          LeftVal: Integer;
          Negate: Boolean;
          OldSy: Symbol;

        BEGIN {OpSimpExpr}
          Negate := False;
          IF Token IN [PLUSSY, MINUSSY, ORSY] THEN
            BEGIN
            Negate := Token = MINUSSY;
            IF Token = ORSY THEN Error(262);
            Scan;
            END;
          LeftVal := OpTerm;
          IF Negate THEN LeftVal := - LeftVal;
          WHILE Token IN [PLUSSY, MINUSSY, ORSY] DO
            BEGIN
            OldSy := Token;
            Scan;
            CASE OldSy OF
              PLUSSY:   LeftVal := LeftVal + OpTerm;
              MINUSSY:  LeftVal := LeftVal - OpTerm;
              ORSY:     LeftVal := Ord(Odd(LeftVal) OR Odd(OpTerm));
            END;
            END;
          OpSimpExpr := LeftVal;
        END; {OpSimpExpr}

      FUNCTION OpExpr{: integer};

        VAR
          LeftVal: Integer;
          OldSy: Symbol;

        BEGIN {OpExpr}
          LeftVal := OpSimpExpr;
          IF Token IN [LTSY, LESY, GESY, GTSY, NESY, EQSY, INSY] THEN
            BEGIN
            OldSy := Token;
            Scan;
            CASE OldSy OF
              LTSY:     LeftVal := Ord(LeftVal < OpSimpExpr);
              LESY:     LeftVal := Ord(LeftVal <= OpSimpExpr);
              GESY:     LeftVal := Ord(LeftVal >= OpSimpExpr);
              GTSY:     LeftVal := Ord(LeftVal > OpSimpExpr);
              NESY:     LeftVal := Ord(LeftVal <> OpSimpExpr);
              EQSY:     LeftVal := Ord(LeftVal = OpSimpExpr);
              INSY:     Error(262);
            END;
            END;
          OpExpr := LeftVal;
        END; {OpExpr}

      FUNCTION EvalExpr: Integer;

        BEGIN {EvalExpr}
          ParsingOption := True;
          Scan;
          EvalExpr := OpExpr;
          ParsingOption := False;
        END; {EvalExpr}

      PROCEDURE ScanForCond;

        VAR
          i, j: Integer;
          ChkSign: Boolean;
          A: Alfa;

        PROCEDURE SetupOp(OCh: Char);

          BEGIN {SetupOp}
            OptionCh := OCh; {so scan2end will work in the case where comment is
                              entered with token equal to RBRACKSY. This is a
                              quick patch solution, there may be a better one for
                              the maintainer of the compiler to find.}
            IF Token = RBRACKSY THEN Token := LBRACECL;
          END; {SetupOp}

        BEGIN {ScanForCond}
          A := '        ';
          A[1] := OptionCh;
          i := 1;
          j := Length(Filename);
          ChkSign := OptionCh IN ['A', 'O']; {asm, ov, opt}
          WHILE (Ch <> TermCh) AND (Ch <> ' ') AND NOT (ChkSign AND ((Ch = '-') OR
                (Ch = '+'))) DO
            BEGIN
            IF j < SUMaxStrLeng THEN
              BEGIN
              j := j + 1; Filename[0] := Chr(j); Filename[j] := Ch;
              END;
            IF i < ALFALEN THEN
              BEGIN
              i := i + 1;
              IF (Ch >= 'a') AND (Ch <= 'z') THEN
                A[i] := Chr(Ord(Ch) - 32)
              ELSE
                A[i] := Ch;
              END;
            NextCh;
            END;
          IF A = 'IFC     ' THEN
            SetupOp('1')
          ELSE IF A = 'ELSEC   ' THEN
            SetupOp('2')
          ELSE IF A = 'ENDC    ' THEN
            SetupOp('3')
          ELSE IF A = 'SETC    ' THEN
            SetupOp('4')
          ELSE IF A = 'OV      ' THEN
            SetupOp('5')
          ELSE IF A = 'OPT     ' THEN
            SetUpOp('6')
          ELSE IF A = 'ASM     ' THEN SetUpOp('7');
          IF Ch = TermCh THEN EndOfOptions := True;
        END; {ScanForCond}

      PROCEDURE Scan2End;

        VAR
          Done: Boolean;

        BEGIN {Scan2End}
          Done := False;
          REPEAT
            WHILE Token <> RBRACKSY DO Scan;
            IF TermCh = RBrackChar THEN
              Done := True
            ELSE
              Scan;
          UNTIL Done;
          ParsingOption := False;                                             {! bh 4/30/82}
        END; {Scan2End}

      BEGIN {Comment}
        InclOptFlag := False;
        AlreadySkipping := (CondStack[CondTos] >= MATCHELSE);
        NextCh;
        IF Ch = '$' THEN
          BEGIN {Options, including prining for character after options}
          EndOfOptions := False;
          REPEAT
            NextCh;
            IF (Ch >= 'a') AND (Ch <= 'z') THEN Ch := Chr(Ord(Ch) - 32);
            IF Ch IN ['%', 'A', 'C', 'D', 'E', 'F', 'H', 'I', 'L', 'M', 'O', 'P',
                      'R', 'S', 'U', 'X'] THEN
              BEGIN
              OptionCh := Ch;
              NextCh;

              Filename[0] := Chr(0);
              IF (OptionCh IN ['A', 'E', 'I', 'O', 'S']) AND (NOT (Ch IN [' ',
                 '+', '-'])) THEN
                ScanForCond;

              {if skipping text then invalidate all but IFC, ELSEC, ENDC
               metacomments}
              IF (CondStack[CondTos] >= MATCHELSE) THEN
                IF (NOT (OptionCh IN ['1'..'3']))
                   (*AND ((ch{should be optionch} <> 'I') OR
                         (ch in ['+','-']))                                     5-26-83 AH*)
                   THEN
                  OptionCh := ' ';

              CASE OptionCh OF                                                 {!}{[@=5]}
                '%': IF Ch = '+' THEN
                       ChClass[Ord('%')] := LETCL
                     ELSE IF Ch = '-' THEN
                       ChClass[Ord('%')] := ERRSY
                     ELSE
                       EndOfOptions := True;
                'A': IF Ch IN ['+', '-'] THEN
                       SaveA2D3 := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'C': IF Ch IN ['+', '-'] THEN
                       CodeFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'D': IF Ch IN ['+', '-'] THEN
                       DbugFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'E': IF Ch IN ['+', '-'] THEN
                       CallEditor := Ch = '+'
                     ELSE
                       BEGIN
                       IF ErrFileOpen THEN Close(ErrFile, Lock);
                       IF Ch <> TermCh THEN GetFileName(True);
                       SUAddExtension(@Filename, '.TEXT', SUMaxStrLeng, Ovflo);
                       Rewrite(ErrFile, Filename);
                       IF IOResult <= 0 THEN
                         BEGIN
                         ErrFileOpen := True; ErrFName := Filename;
                         END
                       ELSE
                         BEGIN
                         ErrFileOpen := False; Error(411);
                         END;
                       END;
                'F': IF Ch IN ['+', '-'] THEN                                  {!10-25-83}
                       BEGIN
                       ForwChkFlag := Ch = '+';
                       NextCh;
                       IF Ch IN ['+', '-'] THEN
                         RodFlag := Ch = '+' {in honor of Rod Perkins}
                       ELSE
                         EndOfOptions := True;
                       END;
                'H': IF Ch IN ['+', '-'] THEN                                  {!C}
                       HandleCheck := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'I': BEGIN
                     IF Ch IN ['+', '-'] THEN
                       IOFlag := Ch = '+'
                     ELSE
                       BEGIN
                       IF InterFlag THEN Error(305);
                       IF Ch <> TermCh THEN GetFileName(True);

                       {Don't actually do file include until comment}
                       {fully scanned to prevent comment tail from }
                       {being scanned on EOF of the include file.  }

                       InclOptFlag := True;
                       END;
                     END;
                'L': IF NOT ListingOk THEN
                       EndOfOptions := True
                     ELSE IF Ch IN ['+', '-'] THEN
                       Listing := (Ch = '+') AND ListOpen
                     ELSE
                       BEGIN
                       GetFileName(True); SameName := False;
                       IF ListOpen THEN
                         BEGIN
                         Str1 := Filename; SUUpStr(@Str1); SUTrimBlanks(@Str1);
                         SUAddExtension(@Str1, '.TEXT', SUMaxStrLeng, Ovflo);
                         Str2 := ListingFCBP^.Filename; SUUpStr(@Str2);
                         IF Str1 = Str2 THEN
                           SameName := True
                         ELSE
                           BEGIN
                           Closef(ListingFCBP, IOLock); Listing := False;
                           END;
                         END;
                       IF NOT SameName THEN
                         Listing := OpenF(Filename, ListingFCBP, IOWrite, ListingBufrP) <= 0;
                       IF Listing THEN
                         BEGIN
                         ConsListing := (ListingFCBP^.DevType = IOConsDev);
                         NewListFile := (ListingFCBP^.DevType = IOBlkDev) AND
                                        AsmListOk AND NOT SameName;
                         LastLine := 0;
                         END
                       ELSE
                         Error(410);
                       ListOpen := Listing;
                       Pass2Listing := Listing AND NewListFile AND AsmListOk;
                       END;
                'M': IF Ch IN ['+', '-'] THEN
                       MacFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'P': BEGIN
                     IF Listing THEN
                        IF NOT ConsListing THEN PutcF(ListingFCBP, Chr(12));
                     EndOfOptions := True;
                     END;
                'R': IF Ch IN ['+', '-'] THEN
                       RangeFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                'S': IF Ch IN ['+', '-'] THEN
                       SwapFlag := Ch = '+'
                     ELSE
                       BEGIN
                       IF Ch <> TermCh THEN GetFileName(False);
                       FOR i := 1 TO 8 DO
                         IF i <= Length(Filename) THEN
                           SegName[i] := Filename[i]
                         ELSE
                           SegName[i] := ' ';
                       END;
                'U': {$ifc IULIB}
                     IF Ch IN ['+', '-'] THEN
                       SearchLibrary := Ch = '+'
                     ELSE
                     {$endc}
                       BEGIN
                       GetFileName(True);
                       IF NOT Using THEN UFname := Filename;
                       END;
                'X': IF Ch IN ['+', '-'] THEN
                       StkXFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                '1': BEGIN {IFC}
                     IF CondTos < MaxCondDepth - 1 THEN
                       BEGIN {bh 4/30/82, was matchend before}
                       IF CondStack[CondTos] >= MATCHELSE THEN
                         BEGIN {set things up so all source will be skipped for
                                this nested conditional}
                         ParsingOption := True; {bh 4/30/82}
                         Push(MATCHEND); Push(MATCHELSE);
                         END
                       ELSE
                         BEGIN
                         IF Odd(EvalExpr) THEN
                           BEGIN {the condition was true so include source till
                                  you find an else or an end. if the else is
                                  found first, skip the source after the else
                                  till you find the end after it.}
                           Push(MATCHEND); Push(LOOKELSE);
                           END
                         ELSE
                           BEGIN {the condition was false so skip source till you
                                  find an else or an end. if the else is found
                                  first, include the source after the else till
                                  you find the end after it.}
                           Push(LOOKEND); Push(MATCHELSE);
                           END;
                         END;
                       END
                     ELSE
                       BEGIN
                       Error(263);
                       i := EvalExpr; {trash rest of option}
                       END;
                     Scan2End;
                     GOTO 1;
                     END; {IFC}
                '2': {ELSEC}
                     IF NOT (CondStack[CondTos] IN [LOOKELSE, MATCHELSE]) THEN
                       Error(264)
                     ELSE
                       Pop;
                '3': {ENDC}
                     IF NOT (CondStack[CondTos] IN [LOOKELSE, MATCHELSE, LOOKEND,
                        MATCHEND]) THEN
                       Error(265)
                     ELSE
                       BEGIN
                       IF CondStack[CondTos] IN [LOOKELSE, MATCHELSE] THEN Pop;
                       Pop;
                       END;
                '4': BEGIN {SETC}
                     REPEAT
                       ParsingOption := True;
                       Scan;
                       IF Token <> IDENTSY THEN Error(266);
                       TempId := Ident;
                       Scan;
                       IF (Token <> ASSIGNSY) AND (Token <> EQSY) THEN
                         Error(266)
                       ELSE
                         SetVal(TempId, EvalExpr);
                     UNTIL Token <> COMMASY;
                     Scan2End;
                     GOTO 1;
                     END; {SETC}
                '5': IF Ch IN ['+', '-'] THEN
                       OflowFlag := Ch = '+'
                     ELSE
                       EndOfOptions := True;
                '6': IF Ch IN ['+', '-'] THEN
                       BEGIN {OPT}
                       OptFlag := Ch = '+'; OptLimFlag := True;
                       NextCh;
                       IF Ch IN ['+', '-'] THEN
                         OptLimFlag := Ch = '-'
                       ELSE
                         EndOfOptions := True;
                       END {OPT}
                     ELSE
                       EndOfOptions := True;
                '7': IF Ch IN ['+', '-'] THEN
                       BEGIN {ASM}
                       ShowAsmCode := Ch = '+';
                       NewAsmStatus := True;
                       END {ASM}
                     ELSE
                       EndOfOptions := True;
              END; {case}

              IF NOT EndOfOptions THEN
                BEGIN
                NextCh; EndOfOptions := Ch <> ',';
                END;
              END
            ELSE {ch not in [...]}
              EndOfOptions := True;
          UNTIL EndOfOptions;
          END;

        IF TermCh = '*' THEN
          REPEAT
            WHILE (Ch <> '*') AND (Ch <> Chr(3)) DO NextCh;
            IF Ch <> Chr(3) THEN NextCh;
          UNTIL (Ch = ')') OR (Ch = Chr(3))
        ELSE
          WHILE (Ch <> '}') AND (Ch <> Chr(3)) DO NextCh;

        IF Ch = Chr(3) THEN
          BEGIN
          LineNumber := LineNumber - 1; PrevLn := 0;
          Error(18);
          GOTO 999;
          END;

        IF InclOptFlag THEN
          BEGIN {Process include file here}
          IF Inbuf[InbufP] = Chr(13) {Attempt to flush out current line} THEN
            BEGIN
            NextCh;
            IF Listing THEN
              ListLine(TotalLines)
            ELSE
              TotalLines := TotalLines + 1;
            LinePrinted := True; LineNumber := LineNumber + 1; EolSource := False;
            END;

          IF OpenNewFile(Filename, INCLUDED) THEN
            BEGIN
            FillInbuf; {Get a buffer full of include file}
            NextCh;
            WITH OpenFileStack[TopOfOpenFileStack - 1] DO
              BEGIN
              PrevLn := PrevLnbr; PrevLine := PrevL;
              END;
            END
          ELSE
            BEGIN {OpenNewFile failed}
            IF IOResult > 0 THEN
              BEGIN {couldn't open file}
              LineNumber := LineNumber - 1;
              Error(405);
              GOTO 999;
              END; {other errors reported directly by OpenNewFile}
            NextCh;
            END;
          END {IF InclOptFlag}
        ELSE
          NextCh;
      1:
        IF NOT AlreadySkipping THEN
          IF CondStack[CondTos] >= MATCHELSE THEN
            BEGIN {skip text}
            WHILE CondStack[CondTos] >= MATCHELSE DO Scan;
            Exit(Scan);
            END;
      END; {Comment}

    {*[[[ End UCSD Dependent I/O Code ]]]*}

    BEGIN {Scan}
    1:
      WHILE ChClass[Ord(Ch)] = BLANKCL DO {Skip blanks and tabs}
        NextCh;
      CASE ChClass[Ord(Ch)] OF                                                 {!}{[@=10]}
        DIGITCL:  UnsignedNumber;
        DOLLARSY: HexConstant;

        LETCL:    BEGIN
                  k := 0;
                  Ident := '        ';
                  REPEAT
                    IF k < ALFALEN THEN
                      BEGIN
                      IF Ch >= 'a' THEN Ch := Chr(Ord(Ch) - 32);
                      k := k + 1;
                      Ident[k] := Ch;
                      END;
                    NextCh;
                  UNTIL ChClass[Ord(Ch)] < LETCL;
                  Token := IDENTSY;
                  FOR i := LRWnames[k - 1] + 1 TO LRWnames[k] DO
                    IF RWnames[i] = Ident THEN Token := RWsymbol[i];
                  END;

        RPARENSY, COMMASY, SEMISY, UPARROWSY, LBRACKSY, RBRACKSY, PLUSSY, MINUSSY,
        SLASHSY, EQSY, ATSIGNSY:
                  BEGIN
                  Token := ChClass[Ord(Ch)];
                  NextCh;
                  END;

        STARSY:   BEGIN
                  NextCh;
                  IF ParsingOption AND (Ch = ')') THEN
                    BEGIN
                    NextCh;
                    Token := RBRACKSY;
                    RBrackChar := '*';
                    END
                  ELSE
                    Token := STARSY;
                  END;

        LPARENSY: BEGIN
                  NextCh;
                  IF Ch = '*' THEN
                    BEGIN
                    Comment('*');
                    GOTO 1;
                    END
                  ELSE IF Ch = '.' THEN                                        {!03-06-84}
                    BEGIN
                    NextCh; Token := LBRACKSY;
                    END
                  ELSE
                    Token := LPARENSY;
                  END;

        LBRACECL: BEGIN
                  Comment('}');
                  GOTO 1;
                  END;

        LTSY:     BEGIN
                  NextCh;
                  IF Ch = '=' THEN
                    BEGIN
                    NextCh; Token := LESY;
                    END
                  ELSE IF Ch = '>' THEN
                    BEGIN
                    NextCh; Token := NESY;
                    END
                  ELSE
                    Token := LTSY;
                  END;

        GTSY:     BEGIN
                  NextCh;
                  IF Ch = '=' THEN
                    BEGIN
                    NextCh; Token := GESY;
                    END
                  ELSE
                    Token := GTSY;
                  END;

        PERIODSY: BEGIN
                  NextCh;
                  IF Ch = '.' THEN
                    BEGIN
                    NextCh; Token := COLONSY; DotDot := True;
                    END
                  ELSE IF Ch = ')' THEN                                        {!03-06-84}
                    BEGIN
                    NextCh; Token := RBRACKSY;
                    END
                  ELSE
                    Token := PERIODSY;
                  END;

        COLONSY:  BEGIN
                  NextCh;
                  IF Ch = '=' THEN
                    BEGIN
                    NextCh; Token := ASSIGNSY;
                    END
                  ELSE
                    BEGIN
                    Token := COLONSY; DotDot := DotFlag; DotFlag := False;
                    END;
                  END;

        SCONSTSY: GetString;

        EOFSY:    BEGIN
                  EolSource := True; LinePrinted := True; PrevLn := 0;
                  IF Token = EOFSY {Two times is an error} THEN
                    BEGIN
                    IF CondStack[CondTos] = NULL THEN
                      Error(16)
                    ELSE
                      Error(267);
                    NextCh; {force out error message}
                    GOTO 999;
                    END
                  ELSE
                    BEGIN
                    Token := EOFSY; LineNumber := LineNumber - 1;
                    END;
                  END;

        ERRSY:    IF ParsingOption AND (Ch = '}') THEN
                    BEGIN
                    NextCh;
                    Token := RBRACKSY;
                    RBrackChar := '}';
                    END
                  ELSE
                    BEGIN
                    pCurLine := pCurLine + 1; {fake out error postion}
                    Error(15); {Illegal character input}
                    pCurLine := pCurLine - 1;
                    NextCh;
                    GOTO 1;
                    END;
      END; {case}
    END; {Scan}

  {$S }

  FUNCTION ShowProcName{Class: String9; Name: Alfa; Level: Integer): SUStrP};

    VAR
      i: Integer;
      NameStr: String[ALFALEN];

    BEGIN {ShowProcName}
      FOR i := 1 TO ALFALEN DO NameStr[i] := Name[i];
      NameStr[0] := Chr(ALFALEN);
      IF Errors = 0 THEN
        ShowPStr := Concat('[', PutIntP(MemAvail, 6)^, ' words]',
                           Copy(Blanks, 1, (Level - 1) * 3 + 1), Class, NameStr)
      ELSE
        ShowPStr := Concat('{', PutIntP(MemAvail, 6)^, ' words}',
                           Copy(Blanks, 1, (Level - 1) * 3 + 1), Class, NameStr);
      ShowProcName := @ShowPStr;;
    END; {ShowProcName}

  PROCEDURE LeftCheck;

    BEGIN {LeftCheck - increment the left lex display nesting level}
      NestLev := NestLev + 1;
      IF Left = '-' THEN Left := Chr(Ord('0') + NestLev MOD 10);
    END; {LeftCheck}

  PROCEDURE RightCheck;

    BEGIN {RightCheck - decrement the right lex display nesting level}
      Right := Chr(Ord('0') + NestLev MOD 10);
      NestLev := NestLev - 1;
    END; {RightCheck}

  PROCEDURE KillExec;

    VAR
      p: ^Integer;
      {$ifc foros}
      i: Integer;
      Strg: String[255];
      {$endc}

    BEGIN {KillExec - this procedure will stop an exec file}
      {$ifc foros}
      SUStopExec(i);
      IF i > 0 THEN
        BEGIN
        WriteLn('Error number ', i, ' killing OS exec.');
        SUErrText('OSErrs.Err', i, @Strg);
        WriteLn(Strg);
        SUWaitSp;
        END;
      {$elsec}
      p := Pointer($D00 - 122); p^ := 0;
      {$endc}
    END; {KillExec}

  PROCEDURE RecordError(Nbr, Pos: Integer; Name: Alfa);

     BEGIN {RecordError - common routine used by Error and NError}
       KillExec;

       Errors := Errors + 1;
       IF ErrIndex >= MaxErrs THEN
         BEGIN
         ErrList[MaxErrs].Nbr := 352; {too many errors on line}
         ErrList[MaxErrs].Name := '        ';
         END
       ELSE
         BEGIN
         ErrIndex := ErrIndex + 1;
         ErrList[ErrIndex].Nbr := Nbr;
         ErrList[ErrIndex].Name := Name;
         END;
       ErrList[ErrIndex].Pos := Pos;
     END; {RecordError}

  PROCEDURE Error{ErrNum: Integer};

    VAR
      DupErr: Boolean;
      i, P: Integer;

    BEGIN {Error}
      P := pCurLine - Ord(NOT EolSource);
      IF P <= 0 THEN P := 1;

      DupErr := False; i := 1;
      WHILE NOT DupErr AND (i <= ErrIndex) DO
        WITH ErrList[i] DO
          IF (P = Pos) AND (ErrNum = Nbr) THEN
            DupErr := True
          ELSE
            i := i + 1;

      IF NOT DupErr THEN RecordError(ErrNum, P, '        ');
    END; {Error}

  PROCEDURE NError{ErrNum: Integer; ErrName: Alfa};

    VAR
      P: Integer;

    BEGIN {NError}
      P := pCurLine - Ord(NOT EolSource);
      IF P <= 0 THEN P := 1;

      RecordError(ErrNum, P, ErrName);
    END; {NError}

  PROCEDURE FatalOutputError;                                                  {!04-19-84}

    VAR
      IORslt: Integer;
      Dummy: Boolean;

    BEGIN {FatalOutputError - if an output error occurs during the generation of
           the code file, come here to see of we can continue.}
      IORslt := IOResult;
      IF IORslt <= 0 THEN
        Error(407)
      ELSE IF IORslt = 848 THEN
        Error(407)
      ELSE
        BEGIN
        Dummy := IOError(IORslt, '*** FATAL OUTPUT ERROR WRITING I-CODE FILE ***');
        Error(408);
        WHILE NOT EolSource DO NextCh;
        CurLine[0] := Chr(pCurLine);
        IF NOT LinePrinted THEN
          BEGIN
          IF Listing THEN
            ListLine(TotalLines)
          ELSE
            TotalLines := TotalLines + 1;
          END;
        GOTO 999;
        END;
    END; {FatalOutputError}                                                    {!04-19-84}

  FUNCTION FullBytes{fpt: pt): integer};

    VAR
      lMin, lMax: Integer;

    BEGIN {FullBytes}
      IF FpT <> NIL THEN
        WITH FpT^ DO
          IF Bits <> 0 THEN
            FullBytes := Bytes + 1
          ELSE IF (Bytes = 1) AND (Form <= SUBRANGE) THEN
            BEGIN
            GetBounds(FpT, lMin, lMax);
            IF lMin >= 0 THEN
              FullBytes := 2
            ELSE
              FullBytes := 1;
            END
          ELSE
            FullBytes := Bytes
      ELSE
        FullBytes := 2;
    END; {FullBytes}

  FUNCTION CompTypes{fpt1,fpt2: pt): Boolean;};

    LABEL 10;                                                                  {!C}

    VAR
      tPt: pT;

    BEGIN {CompTypes}
      CompTypes := True;
      IF (FpT1 <> NIL) AND (FpT2 <> NIL) THEN
        IF FpT1 <> FpT2 THEN
          IF FpT1^.Form <> FpT2^.Form THEN
            IF FpT1^.Form = SUBRANGE THEN
              CompTypes := CompTypes(FpT1^.RangeOf, FpT2)
            ELSE IF FpT2^.Form = SUBRANGE THEN
              CompTypes := CompTypes(FpT2^.RangeOf, FpT1)
            ELSE IF ((FpT1^.Form = STRINGS) AND (FpT2^.Form = SCONST)) OR (
                    (FpT1^.Form = SCONST) AND (FpT2^.Form = STRINGS)) THEN
              CompTypes := True
            ELSE IF ((FpT1^.Form = CLASSES) AND (FpT2 = NilPtr)) OR ((FpT2^.Form =
                    CLASSES) AND (FpT1 = NilPtr)) THEN
              CompTypes := True
            ELSE
              CompTypes := False
          ELSE
            CASE FpT1^.Form OF                                                 {!}{[@=10]}
              SCALAR, ARRAYS, RECORDS, TAGFIELD, VARIANT, FILES:
                        CompTypes := False;
              SUBRANGE: CompTypes := CompTypes(FpT1^.RangeOf, FpT2^.RangeOf);
              POINTERS: CompTypes := (FpT1 = NilPtr) OR (FpT2 = NilPtr);
              SETS:     CompTypes := CompTypes(FpT1^.SetOf, FpT2^.SetOf);
              SCONST, STRINGS:
                        CompTypes := True;
              CLASSES:  BEGIN {class vars are compatible iff Class1 Super* Class2
                               or Class2 Super* Class1}

                        {changed to Class1 Super* Class2 only}                 {!10-10-83}
                        {note: not commutative!}

                        tPt := FpT2;
                        WHILE tPt <> NIL DO
                          BEGIN
                          IF tPt = FpT1 THEN GOTO 10; {success}
                          tPt := tPt^.SuperClass;
                          END;
                        CompTypes := False;                                    {!2-10-83}

                      10: {break}

                        END;
            END;
    END; {CompTypes}

  FUNCTION EqTypes{fpt1,fpt2: pt): Boolean;};

    BEGIN {EqTypes}
      IF (FpT1^.Form = CLASSES) OR (FpT2^.Form = CLASSES) THEN                 {!10-10-83}
        EqTypes := CompTypes(FpT2, FpT1)                                       {!11-18-83}
      ELSE
        EqTypes := FpT1 = FpT2;
    END; {EqTypes}

  FUNCTION CompFormals{FormArg1, FromArg2: pN; Exact: Boolean): Boolean};      {!01-05-84 start}

    VAR
      Ok: Boolean;

    FUNCTION EqualTypes: Boolean;

       BEGIN {EqualTypes}
         EqualTypes := False;
         IF Exact THEN
           EqualTypes := FormArg1^.IdType = FormArg2^.IdType
         ELSE IF FormArg1^.IdType <> NIL THEN
           IF FormArg2^.IdType <> NIL THEN
             IF FormArg1^.IdType^.Form = FormArg2^.IdType^.Form THEN
               IF FormArg1^.IdType^.Form = CLASSES THEN
                 EqualTypes := CompTypes(FormArg1^.IdType, FormArg2^.IdType)
               ELSE
                 EqualTypes := FormArg1^.IdType = FormArg2^.IdType;
       END; {EqualTypes}

    BEGIN {CompFormals - compares the formal argument lists of two procedure
           declarations.  Returns true if the lists match.  The matching must
           be exact in both the names and types if Exact is true. If Exact is
           false then a class type of FormArg2's list may be a descendent of
           of FormArg1's list. Similarily for a function's return type.}
      Ok := True;
      WHILE (FormArg1 <> NIL) AND (FormArg2 <> NIL) AND Ok DO
        BEGIN
        Ok := False;
        IF FormArg1^.Name = FormArg2^.Name THEN
          IF FormArg1^.Class = FormArg2^.Class THEN
            IF FormArg1^.Class = VARS THEN
              BEGIN
              IF FormArg1^.Vkind = FormArg2^.Vkind THEN Ok := EqualTypes;
              END
            ELSE IF FormArg1^.PFdeclKind = FormArg2^.PFdeclKind THEN
              IF CompFormals(FormArg1^.PFArgList, FormArg2^.PFArgList, Exact) THEN
                IF FormArg1^.Class = PROC THEN
                  Ok := True
                ELSE
                  Ok := EqualTypes;

        FormArg1 := FormArg1^.Next;
        FormArg2 := FormArg2^.Next;
        END; {while}

      IF Ok THEN Ok := (FormArg1 = NIL) AND (FormArg2 = NIL);

      CompFormals := Ok;
    END; {CompFormals}                                                         {!01-05-84 end}

  PROCEDURE GetBounds{fpt: pt; var fmin,fmax: integer};

    BEGIN {GetBounds - Warning: GetBounds will return incorrect bounds on long
           integer types}
      Fmin := 0; Fmax := 0;
      IF FpT <> NIL THEN
        WITH FpT^ DO
          IF Form = SCALAR THEN
            BEGIN
            IF ScalKind = DECLARED THEN
              BEGIN
              IF MaxConst <> NIL THEN Fmax := MaxConst^.ValueOf.Ivalu;         {!03-07-84}
              END
            ELSE IF FpT = CharPtr THEN
              Fmax := 255
            ELSE IF FpT = IntPtr THEN
              BEGIN
              Fmin := - 32767 - 1; Fmax := 32767;
              END;
            END
          ELSE IF Form = SUBRANGE THEN
            BEGIN
            Fmin := Min; Fmax := Max;
            END
          ELSE IF Form IN [STRINGS, SCONST] THEN
            BEGIN
            Fmin := 0; {0 to allow access to string length}
            Fmax := StringLen;
            END;
    END; {GetBounds}

  FUNCTION StringType{fpt: pt): Boolean};

    BEGIN {StringType}
      StringType := False;
      IF FpT <> NIL THEN
        WITH FpT^ DO
          IF (Form = STRINGS) OR (Form = SCONST) THEN
            StringType := True
          ELSE IF Form = ARRAYS THEN
            StringType := (ArrayOf = CharPtr) AND PckdArr;
    END; {StringType}

  PROCEDURE ChToString{VAR fAttr: Attr};

    VAR
      lStrVal: StrValType;

    BEGIN {ChToString}
      New(lStrVal);
      WITH lStrVal^ DO
        BEGIN
        StrPart := '        '; Next := NIL;
        StrPart[1] := Chr(fAttr.TreePtr^.CstValu.Ivalu);
        END;
      WITH fAttr.TreePtr^ DO
        BEGIN
        CstType := Str1Ptr; CstValu.Svalu := lStrVal;
        CstValu.SvaluLen := 1;
        END;
      fAttr.Typtr := Str1Ptr; fAttr.ASize := 2;
    END; {ChToString}

  PROCEDURE UpdateSetConst{fLb, fUb: LongInt; VAR fSetCstPart: pN};

    VAR
      i, j, Lb, ub: Integer;
      lSetVal: SetValType;

    BEGIN {UpdateSetConst}
      IF (fLb < 0) OR (fUb < 0) OR (fLb > 4087) OR (fUb > 4087) THEN
        Error(308)
      ELSE
        BEGIN
        Lb := fLb; ub := fUb;
        IF Lb <= ub THEN
          BEGIN
          IF fSetCstPart = NIL THEN
            BEGIN
            New(fSetCstPart, CSTNODE);
            WITH fSetCstPart^ DO
              BEGIN
              Node := CSTNODE; CstType := NIL;
              CstValu.MaxSetEl := 0; New(CstValu.SetValu);
              CstValu.SetValu^.NextSet := NIL;
              CstValu.SetValu^.SetVal := [];
              END;
            END;
          WITH fSetCstPart^.CstValu DO
            BEGIN
            IF MaxSetEl < ub THEN MaxSetEl := ub;
            lSetVal := SetValu;
            FOR i := 1 TO ub DIV 32 DO
              BEGIN
              IF lSetVal^.NextSet = NIL THEN
                BEGIN
                New(lSetVal^.NextSet);
                lSetVal^.NextSet^.NextSet := NIL;
                lSetVal^.NextSet^.SetVal := [];
                END;
              lSetVal := lSetVal^.NextSet;
              END;
            FOR i := Lb TO ub DO
              BEGIN
              lSetVal := SetValu;
              FOR j := 1 TO i DIV 32 DO lSetVal := lSetVal^.NextSet;
              lSetVal^.SetVal := lSetVal^.SetVal + [i MOD 32];
              END;
            END;
          END;
        END;
    END; {UpdateSetConst}

  {$S CONST}

  PROCEDURE Constant{FSys: SetOfSys; VAR fValu: Valu; VAR FpT: pT};            {!01-20-84start}{[o=100]}

    VAR
      NonStd: Boolean;

    PROCEDURE ConstExpression(Fsys: SetOfSys);

      VAR
        lToken: Symbol;
        lAttr: Attr;
        i, j: Integer;
        Bv: Boolean;
        lSetVal: SetValType;

      PROCEDURE Err(Nbr: Integer);

        BEGIN {Err}
          Error(Nbr);
          gAttr.Typtr := NIL; gAttr.TreePtr := NIL;
        END; {Err}

      PROCEDURE Float(VAR fAttr: Attr);

        BEGIN {Float}
          WITH fAttr, TreePtr^ DO
            BEGIN
            Typtr := RealPtr; CstType := RealPtr;
            CstValu.Rvalu := CstValu.Ivalu;
            END;
        END; {Float}

      PROCEDURE SimpleConstExpression(Fsys: SetOfSys);

        VAR
          lToken: Symbol;
          lAttr: Attr;
          Signed, Negative: Boolean;

        PROCEDURE CompactSet(Result: pN);

          VAR
             MaxEl, CurrMaxEl: Integer;
             lSetVal, LastSetVal: SetValType;
             lpT: pT;

          BEGIN {CompactSet}
            New(lpT, SETS);
            WITH lpT^ DO
              BEGIN
              FType := False; Form := SETS; SetOf := gAttr.Typtr^.SetOf; Bits := 0;
              END;

            gAttr.Typtr := lpT; gAttr.TreePtr := Result;
            Result^.Node := CSTNODE; Result^.CstType := lpT;

            WITH Result^.CstValu DO
              BEGIN
              LastSetVal := NIL;

              IF SetValu <> NIL THEN
                BEGIN
                lSetVal := SetValu;
                CurrMaxEl := - 1;
                REPEAT
                  CurrMaxEl := CurrMaxEl + 32;
                  IF lSetVal^.SetVal <> [] THEN
                    BEGIN
                    LastSetVal := lSetVal; MaxEl := CurrMaxEl;
                    END;
                  lSetVal := lSetVal^.NextSet;
                UNTIL lSetVal = NIL;
                END;

              IF LastSetVal = NIL THEN
                BEGIN
                lpT^.Bytes := 0;
                SetValu := NIL; MaxSetEl := - 1;
                END
              ELSE
                BEGIN
                LastSetVal^.NextSet := NIL;
                CurrMaxEl := 31;
                WHILE NOT (CurrMaxEl IN LastSetVal^.SetVal) DO CurrMaxEl := CurrMaxEl - 1;
                MaxSetEl := MaxEl - (31 - CurrMaxEl);
                WITH lpT^ DO
                  BEGIN
                  Bytes := (MaxSetEl DIV 8) + 1;
                  IF (Bytes > 1) AND Odd(Bytes) THEN Bytes := Bytes + 1;
                  END;
                END;
              END;
          END; {CompactSet}

        PROCEDURE LinkSetVal(Result: pN; VAR PrevSetVal, CurrSetVal: SetValType);

          BEGIN {LinkSetVal}
            New(CurrSetVal);
            IF PrevSetVal = NIL THEN
              Result^.CstValu.SetValu := CurrSetVal
            ELSE
              PrevSetVal^.NextSet := CurrSetVal;
            PrevSetVal := CurrSetVal;
            CurrSetVal^.NextSet := NIL;
          END; {LinkSetVal}

        PROCEDURE SetUnion;

          VAR
            Result: pN;
            Left, Right, PrevSetVal, CurrSetVal: SetValType;

          BEGIN {SetUnion}
            New(Result, CSTNODE);
            Result^.CstValu.SetValu := NIL;
            Left := lAttr.TreePtr^.CstValu.SetValu;
            Right := gAttr.TreePtr^.CstValu.SetValu;
            PrevSetVal := NIL;

            WHILE (Left <> NIL) OR (Right <> NIL) DO
              BEGIN
              LinkSetVal(Result, PrevSetVal, CurrSetVal);
              IF (Left <> NIL) AND (Right <> NIL) THEN
                BEGIN
                CurrSetVal^.SetVal := Left^.SetVal + Right^.SetVal;
                Left := Left^.NextSet; Right := Right^.NextSet;
                END
              ELSE IF Left = NIL THEN
                BEGIN
                CurrSetVal^.SetVal := Right^.SetVal; Right := Right^.NextSet;
                END
              ELSE
                BEGIN
                CurrSetVal^.SetVal := Left^.SetVal; Left := Left^.NextSet;
                END;
              END;

            CompactSet(Result);
          END; {SetUnion}

        PROCEDURE SetDifference;

          VAR
            Result: pN;
            Left, Right, PrevSetVal, CurrSetVal: SetValType;

          BEGIN {SetDifference}
            New(Result, CSTNODE);
            Result^.CstValu.SetValu := NIL;
            Left := lAttr.TreePtr^.CstValu.SetValu;
            Right := gAttr.TreePtr^.CstValu.SetValu;
            PrevSetVal := NIL;

            WHILE Left <> NIL DO
              BEGIN
              LinkSetVal(Result, PrevSetVal, CurrSetVal);
              IF Right <> NIL THEN
                BEGIN
                CurrSetVal^.SetVal := Left^.SetVal - Right^.SetVal;
                Right := Right^.NextSet;
                END
              ELSE
                CurrSetVal^.SetVal := Left^.SetVal;
              Left := Left^.NextSet;
              END;

            CompactSet(Result);
          END; {SetDifference}

        PROCEDURE ConstTerm(Fsys: SetOfSys);

          VAR
            lToken: Symbol;
            lAttr: Attr;

          PROCEDURE SetIntersection;

            VAR
              Result: pN;
              Left, Right, PrevSetVal, CurrSetVal: SetValType;

            BEGIN {SetIntersection}
              New(Result, CSTNODE);
              Result^.CstValu.SetValu := NIL;
              PrevSetVal := NIL;
              Left := lAttr.TreePtr^.CstValu.SetValu;
              Right := gAttr.TreePtr^.CstValu.SetValu;

              WHILE (Left <> NIL) AND (Right <> NIL) DO
                BEGIN
                LinkSetVal(Result, PrevSetVal, CurrSetVal);
                CurrSetVal^.SetVal := Left^.SetVal * Right^.SetVal;
                Left := Left^.NextSet; Right := Right^.NextSet;
                END;

              CompactSet(Result);
            END; {SetIntersection}

          PROCEDURE ConstFactor(Fsys: SetOfSys);

            VAR
              lpN: pN;
              lpT: pT;

            PROCEDURE ConstCall(Fsys: SetOfSys; FpN: pN);

              VAR
                lpN: pN;
                lpT: pT;

              BEGIN {ConstCall}
                NonStd := True;
                IF Token = LPARENSY THEN
                  Scan
                ELSE
                  Error(31);

                WITH FpN^ DO
                  IF PFdeclKind <> STANDARD THEN
                    Err(183)
                  ELSE IF NOT (Key IN [1, 3, 9, 10, 12, 14, 17, 26, 32]) THEN
                    Err(183)
                  ELSE IF Key = 26 THEN
                    BEGIN {SizeOf}
                    gAttr.Typtr := IntPtr;
                    IF Token = IDENTSY THEN
                      BEGIN
                      lpN := SearchAll([VARS, TYPES]); lpT := lpN^.IdType;
                      Scan;
                      New(lpN, CSTNODE);
                      WITH lpN^ DO
                        BEGIN
                        Node := CSTNODE; CstType := IntPtr;
                        IF lpT = NIL THEN
                          CstValu.Ivalu := 0
                        ELSE IF lpT^.Form = CLASSES THEN
                          CstValu.Ivalu := lpT^.SizeInstance
                        ELSE
                          CstValu.Ivalu := FullBytes(lpT);
                        END;
                      gAttr.TreePtr := lpN; gAttr.Typtr := IntPtr;
                      END
                    ELSE
                      Err(29);
                    END {SizeOf}
                  ELSE
                    BEGIN
                    ConstExpression(Fsys + [RPARENSY]);
                    IF gAttr.Typtr <> NIL THEN
                      WITH gAttr DO
                        IF CompTypes(Typtr, IntPtr) THEN
                          CASE Key OF                                          {!} {[@=4]}
                            01: {ABS}
                                TreePtr^.CstValu.Ivalu := Abs(TreePtr^.CstValu.Ivalu);
                            03: {CHR}
                                BEGIN
                                Typtr := CharPtr; TreePtr^.CstType := CharPtr;
                                END;
                            09: {ODD}
                                BEGIN
                                TreePtr^.CstValu.Ivalu := Ord(Odd(TreePtr^.CstValu.Ivalu));
                                Typtr := BoolPtr; TreePtr^.CstType := BoolPtr;
                                END;
                            10, 32: {ORD, ORD4} ;
                            14: {SQR}
                                TreePtr^.CstValu.Ivalu := Sqr(TreePtr^.CstValu.Ivalu);
                            12, 17: {TRUNC, ROUND}
                                Err(122);
                          END
                        ELSE IF CompTypes(Typtr, RealPtr) THEN
                          CASE Key OF
                            01: {ABS}
                                TreePtr^.CstValu.Rvalu := Abs(TreePtr^.CstValu.Rvalu);
                            12: {ROUND}
                                BEGIN
                                TreePtr^.CstValu.Ivalu := Round(TreePtr^.CstValu.Rvalu);
                                Typtr := IntPtr; TreePtr^.CstType := IntPtr;
                                END;
                            14: {SQR}
                                TreePtr^.CstValu.Rvalu := Sqr(TreePtr^.CstValu.Rvalu);
                            17: {TRUNC}
                                BEGIN
                                TreePtr^.CstValu.Ivalu := Trunc(TreePtr^.CstValu.Rvalu);
                                Typtr := IntPtr; TreePtr^.CstType := IntPtr;
                                END;
                            03, 09, 10, 32: {CHR, ODD, ORD, ORD4}
                                Err(122)
                          END
                        ELSE IF (Key = 10) OR (Key = 32) AND (Typtr^.Form <= POINTERS) THEN
                          BEGIN {ORD, ORD4}
                          Typtr := IntPtr; TreePtr^.CstType :=  IntPtr;
                          END
                        ELSE
                          Err(122);
                    END;

                IF Token = RPARENSY THEN
                  Scan
                ELSE
                  Error(32);
              END; {ConstCall}

            PROCEDURE BuildSet;

              VAR
                ExitFlag: Boolean;
                lpN, SetCstPart: pN;
                lpT, SetType: pT;

              BEGIN {BuildSet}
                NonStd := True;

                WITH gAttr DO
                  BEGIN
                  Scan;
                  SetType := NIL; SetCstPart := NIL;

                  IF Token <> RBRACKSY THEN
                    BEGIN
                    ExitFlag := False;

                    REPEAT
                      ConstExpression(Fsys + [COMMASY, COLONSY, RBRACKSY]);
                      IF SetType = NIL THEN
                        SetType := Typtr
                      ELSE IF NOT CompTypes(SetType, Typtr) THEN Error(134);

                      IF Token = COLONSY THEN
                        BEGIN {Double set element}
                        Scan;
                        lpN := TreePtr;
                        ConstExpression(Fsys + [COMMASY, RBRACKSY]);
                        IF SetType = NIL THEN
                          SetType := Typtr
                        ELSE IF NOT CompTypes(SetType, Typtr) THEN Error(134);
                        IF (lpN <> NIL) AND (TreePtr <> NIL) THEN
                          UpdateSetConst(lpN^.CstValu.Ivalu, TreePtr^.CstValu.Ivalu, SetCstPart);
                        END
                      ELSE IF TreePtr <> NIL THEN
                        UpdateSetConst(TreePtr^.CstValu.Ivalu, TreePtr^.CstValu.Ivalu, SetCstPart);

                      IF Token = COMMASY THEN
                        Scan
                      ELSE
                        ExitFlag := True;
                    UNTIL ExitFlag;

                    IF SetType <> NIL THEN
                      IF SetType^.Form > SUBRANGE THEN
                        Error(133)
                      ELSE IF CompTypes(SetType, RealPtr) THEN Error(164);
                    END;

                  New(lpT, SETS);
                  WITH lpT^ DO
                    BEGIN
                    FType := False; Form := SETS;
                    SetOf := SetType; Bits := 0;
                    END;
                  Typtr := lpT;

                  IF SetCstPart = NIL THEN
                    BEGIN
                    New(SetCstPart, CSTNODE);
                    WITH SetCstPart^.CstValu DO
                      BEGIN {kluge to indicate a null constant set}
                      SetValu := NIL; MaxSetEl := - 1; lpT^.Bytes := 0;
                      END;
                    END
                  ELSE
                    WITH lpT^ DO
                      BEGIN
                      Bytes := (SetCstPart^.CstValu.MaxSetEl DIV 8) + 1;
                      IF (Bytes > 1) AND Odd(Bytes) THEN Bytes := Bytes + 1;
                      END;

                  SetCstPart^.CstType := lpT;
                  TreePtr := SetCstPart;

                  IF Token = RBRACKSY THEN
                    Scan
                  ELSE
                    Error(34);
                  END;
              END; {Buildset}

            BEGIN {ConstFactor}
              WITH gAttr DO
                BEGIN
                TreePtr := NIL; Typtr := NIL;
                IF NOT (Token IN FacBegSys) THEN Skip(27, Fsys + FacBegSys);

                REPEAT
                  IF Token IN FacBegSys THEN
                    BEGIN
                    CASE Token OF                                              {!} {[@=10]}
                      IDENTSY:  BEGIN
                                lpN := SearchAll([CONSTS, FUNC]);
                                Scan;
                                IF lpN^.Class = CONSTS THEN
                                  WITH lpN^ DO
                                    BEGIN
                                    Typtr := IdType;
                                    New(TreePtr, CSTNODE);
                                    TreePtr^.Node := CSTNODE;
                                    TreePtr^.CstValu := ValueOf;
                                    TreePtr^.CstType := IdType;
                                    END
                                ELSE {FUNC}
                                  ConstCall(Fsys, lpN);
                                END;

                      ICONSTSY: BEGIN
                                Typtr := IntPtr;
                                New(TreePtr, CSTNODE);
                                WITH TreePtr^ DO
                                  BEGIN
                                  Node := CSTNODE; CstType := Typtr;
                                  CstValu.Ivalu := IntVal;
                                  END;
                                Scan;
                                END;

                      RCONSTSY: BEGIN
                                Typtr := RealPtr;
                                New(TreePtr, CSTNODE);
                                WITH TreePtr^ DO
                                  BEGIN
                                  Node := CSTNODE; CstType := RealPtr;
                                  CstValu.Rvalu := RealVal;
                                  END;
                                Scan;
                                END;

                      CCONSTSY: BEGIN
                                Typtr := CharPtr;
                                New(TreePtr, CSTNODE);
                                WITH TreePtr^ DO
                                  BEGIN
                                  Node := CSTNODE; CstType := CharPtr;
                                  CstValu.Ivalu := IntVal;
                                  END;
                                Scan;
                                END;

                      SCONSTSY: BEGIN
                                IF IntVal > 0 THEN
                                  BEGIN
                                  New(lpT, SCONST);
                                  WITH lpT^ DO
                                    BEGIN
                                    FType := False; Form := SCONST;
                                    StringLen := IntVal; Bits := 0;
                                    Bytes := IntVal;
                                    IF (Bytes <> 1) AND Odd(Bytes) THEN Bytes := Bytes + 1;
                                    END;
                                  END
                                ELSE
                                  lpT := Str0Ptr;
                                Typtr := lpT;
                                New(TreePtr, CSTNODE);
                                WITH TreePtr^ DO
                                  BEGIN
                                  Node := CSTNODE; CstType := lpT;
                                  CstValu.Svalu := StrVal;
                                  CstValu.SvaluLen := IntVal;
                                  END;
                                Scan;
                                END;

                      LPARENSY: BEGIN
                                NonStd := True;
                                Scan;
                                ConstExpression(Fsys + [RPARENSY]);
                                IF Token = RPARENSY THEN
                                  Scan
                                ELSE
                                  Error(32);
                                END;

                      NOTSY:    BEGIN
                                NonStd := True;
                                Scan;
                                ConstFactor(Fsys);
                                IF NOT CompTypes(Typtr, BoolPtr) THEN
                                  Err(132)
                                ELSE IF Typtr <> NIL THEN
                                  TreePtr^.CstValu.Ivalu := 1 - TreePtr^.CstValu.Ivalu;
                                END;

                      NILSY:    Err(181);

                      LBRACKSY: BuildSet;

                      ATSIGNSY: BEGIN
                                Err(182);
                                Scan;
                                IF Token = IDENTSY THEN Scan;
                                END;
                    END;

                    IF NOT (Token IN Fsys) THEN Skip(20, Fsys + FacBegSys);
                    END;
                UNTIL Token IN Fsys;
                END;
            END; {ConstFactor}

          BEGIN {ConstTerm}
            ConstFactor(Fsys + [DIVSY, STARSY, MODSY, ANDSY, SLASHSY]);

            WHILE Token IN [DIVSY, STARSY, MODSY, ANDSY, SLASHSY] DO
              BEGIN
              NonStd := True;
              lAttr := gAttr; lToken := Token;

              Scan;
              ConstFactor(Fsys + [DIVSY, STARSY, MODSY, ANDSY, SLASHSY]);

              IF (lAttr.Typtr <> NIL) AND (gAttr.Typtr <> NIL) THEN
                WITH gAttr DO
                  CASE lToken OF
                    ANDSY:    IF CompTypes(lAttr.Typtr, BoolPtr) AND CompTypes(Typtr, BoolPtr) THEN
                                gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu *
                                                                gAttr.TreePtr^.CstValu.Ivalu
                              ELSE
                                Err(132);

                    DIVSY, MODSY:
                              IF CompTypes(lAttr.Typtr, IntPtr) AND CompTypes(Typtr, IntPtr) THEN
                                IF gAttr.TreePtr^.CstValu.Ivalu <> 0 THEN
                                  IF lToken = DIVSY THEN
                                    gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu DIV
                                                                    gAttr.TreePtr^.CstValu.Ivalu
                                  ELSE
                                    gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu MOD
                                                                    gAttr.TreePtr^.CstValu.Ivalu
                                ELSE
                                  Err(180)
                              ELSE
                                Err(131);

                    SLASHSY:  BEGIN
                              IF CompTypes(lAttr.Typtr, IntPtr) THEN Float(lAttr);
                              IF CompTypes(Typtr, IntPtr) THEN Float(gAttr);
                              IF CompTypes(Typtr, RealPtr) AND CompTypes(lAttr.Typtr, RealPtr) THEN
                                IF gAttr.TreePtr^.CstValu.Rvalu <> 0 THEN
                                  gAttr.TreePtr^.CstValu.Rvalu := lAttr.TreePtr^.CstValu.Rvalu /
                                                                  gAttr.TreePtr^.CstValu.Rvalu
                                ELSE
                                  Err(180)
                              ELSE
                                Err(131);
                              END;

                    STARSY:   IF CompTypes(lAttr.Typtr, IntPtr) AND CompTypes(Typtr, IntPtr) THEN
                                gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu *
                                                                gAttr.TreePtr^.CstValu.Ivalu
                              ELSE
                                BEGIN
                                IF CompTypes(lAttr.Typtr, IntPtr) THEN Float(lAttr);
                                IF CompTypes(Typtr, IntPtr) THEN Float(gAttr);
                                IF CompTypes(lAttr.Typtr, RealPtr) AND CompTypes(Typtr,
                                   RealPtr) THEN
                                  gAttr.TreePtr^.CstValu.Rvalu := lAttr.TreePtr^.CstValu.Rvalu *
                                                                  gAttr.TreePtr^.CstValu.Rvalu
                                ELSE IF CompTypes(Typtr, lAttr.Typtr) AND (Typtr^.Form = SETS) THEN
                                   SetIntersection
                                ELSE
                                  Err(131);
                                END;
                  END;
              END;
          END; {ConstTerm}

        BEGIN {SimpleConstExpression}
          Negative := Token = MINUSSY;
          Signed := (Token = PLUSSY) OR Negative;
          IF Signed THEN Scan;

          ConstTerm(Fsys + [PLUSSY, MINUSSY, ORSY]);

          IF gAttr.Typtr <> NIL THEN
            IF Signed THEN
              IF CompTypes(gAttr.Typtr, IntPtr) THEN
                BEGIN
                IF Negative THEN gAttr.TreePtr^.CstValu.Ivalu := - gAttr.TreePtr^.CstValu.Ivalu;
                END
              ELSE IF CompTypes(gAttr.Typtr, RealPtr) THEN
                BEGIN
                IF Negative THEN gAttr.TreePtr^.CstValu.Rvalu := - gAttr.TreePtr^.CstValu.Rvalu;
                END
              ELSE
                Err(140);

          WHILE Token IN [PLUSSY, MINUSSY, ORSY] DO
            BEGIN
            NonStd := True;
            lToken := Token; lAttr := gAttr;

            Scan;
            ConstTerm(Fsys + [PLUSSY, MINUSSY, ORSY]);

            IF (lAttr.Typtr <> NIL) AND (gAttr.Typtr <> NIL) THEN
              CASE lToken OF
                MINUSSY, PLUSSY:
                          IF CompTypes(lAttr.Typtr, IntPtr) AND CompTypes(gAttr.Typtr, IntPtr) THEN
                            IF lToken = PLUSSY THEN
                              gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu +
                                                              gAttr.TreePtr^.CstValu.Ivalu
                            ELSE
                              gAttr.TreePtr^.CstValu.Ivalu := lAttr.TreePtr^.CstValu.Ivalu -
                                                              gAttr.TreePtr^.CstValu.Ivalu
                          ELSE
                            BEGIN
                            IF CompTypes(lAttr.Typtr, IntPtr) THEN Float(lAttr);
                            IF CompTypes(gAttr.Typtr, IntPtr) THEN Float(gAttr);
                            IF CompTypes(lAttr.Typtr, RealPtr) AND CompTypes(gAttr.Typtr,
                               RealPtr) THEN
                              IF lToken = PLUSSY THEN
                                gAttr.TreePtr^.CstValu.Rvalu := lAttr.TreePtr^.CstValu.Rvalu +
                                                                gAttr.TreePtr^.CstValu.Rvalu
                              ELSE
                                gAttr.TreePtr^.CstValu.Rvalu := lAttr.TreePtr^.CstValu.Rvalu -
                                                                gAttr.TreePtr^.CstValu.Rvalu
                            ELSE IF CompTypes(lAttr.Typtr, gAttr.Typtr) AND (lAttr.Typtr^.Form = SETS) THEN
                              IF lToken = PLUSSY THEN
                                SetUnion
                              ELSE
                                SetDifference
                            ELSE
                              Err(131);
                            END;

                ORSY:     IF CompTypes(lAttr.Typtr, BoolPtr) AND CompTypes(gAttr.Typtr,
                             BoolPtr) THEN
                            IF (lAttr.TreePtr^.CstValu.Ivalu + gAttr.TreePtr^.CstValu.Ivalu) =
                               0 THEN
                              gAttr.TreePtr^.CstValu.Ivalu := Ord(False)
                            ELSE
                              gAttr.TreePtr^.CstValu.Ivalu := Ord(True)
                          ELSE
                            Err(132);
              END;
            END;
        END; {SimpleConstExpression}

      FUNCTION CompInts(Left: Attr; Op: Symbol; Right: Attr): Boolean;

        VAR
          Lvalu, Rvalu: LongInt;

        BEGIN {CompInts}
          Lvalu := Left.TreePtr^.CstValu.Ivalu;
          Rvalu := Right.TreePtr^.CstValu.Ivalu;

          CASE Op OF                                                           {!} {[@=6]}
            LTSY: CompInts := Lvalu < Rvalu;
            GTSY: CompInts := Lvalu > Rvalu;
            LESY: CompInts := Lvalu <= Rvalu;
            GESY: CompInts := Lvalu >= Rvalu;
            EQSY: CompInts := Lvalu = Rvalu;
            NESY: CompInts := Lvalu <> Rvalu;
          END;
        END; {CompInts}

      FUNCTION CompReals(Left: Attr; Op: Symbol; Right: Attr): Boolean;

        VAR
          Lvalu, Rvalu: Real;

        BEGIN {CompReals}
          Lvalu := Left.TreePtr^.CstValu.Rvalu;
          Rvalu := Right.TreePtr^.CstValu.Rvalu;

          CASE Op OF
            LTSY: CompReals := Lvalu < Rvalu;
            GTSY: CompReals := Lvalu > Rvalu;
            LESY: CompReals := Lvalu <= Rvalu;
            GESY: CompReals := Lvalu >= Rvalu;
            EQSY: CompReals := Lvalu = Rvalu;
            NESY: CompReals := Lvalu <> Rvalu;
          END;
        END; {CompReals}

      FUNCTION CompSets(Left: Attr; Op: Symbol; Right: Attr): Boolean;

        VAR
          lBv: Boolean;
          Lmax, Rmax: Integer;
          lSetVal, rSetVal: SetValType;

        BEGIN {CompSets}
          Lmax := Left.TreePtr^.CstValu.MaxSetEl;
          Rmax := Right.TreePtr^.CstValu.MaxSetEl;

          CASE Op OF
            LESY: IF Lmax > Rmax THEN
                    lBv := False
                  ELSE {Lmax <= Rmax}
                    BEGIN
                    lSetVal := Left.TreePtr^.CstValu.SetValu;
                    rSetVal := Right.TreePtr^.CstValu.SetValu;
                    lBv := True;
                    WHILE (lSetVal <> NIL) AND (rSetVal <> NIL) AND lBv DO
                      IF lSetVal^.SetVal <= rSetVal^.SetVal THEN
                        BEGIN
                        lSetVal := lSetVal^.NextSet; rSetVal := rSetVal^.NextSet;
                        END
                      ELSE
                        lBv := False;
                    END;

            GESY: IF Rmax > Lmax THEN
                    lBv := False
                  ELSE {Rmax <= Lmax}
                    BEGIN
                    lSetVal := Left.TreePtr^.CstValu.SetValu;
                    rSetVal := Right.TreePtr^.CstValu.SetValu;
                    lBv := True;
                    WHILE (lSetVal <> NIL) AND (rSetVal <> NIL) AND lBv DO
                      IF lSetVal^.SetVal >= rSetVal^.SetVal THEN
                        BEGIN
                        lSetVal := lSetVal^.NextSet; rSetVal := rSetVal^.NextSet;
                        END
                      ELSE
                        lBv := False;
                    END;

            EQSY: IF Lmax <> Rmax THEN
                    lBv := False
                  ELSE
                    BEGIN
                    lSetVal := Left.TreePtr^.CstValu.SetValu;
                    rSetVal := Right.TreePtr^.CstValu.SetValu;
                    lBv := True;
                    WHILE (lSetVal <> NIL) AND (rSetVal <> NIL) AND lBv DO
                      IF lSetVal^.SetVal = rSetVal^.SetVal THEN
                        BEGIN
                        lSetVal := lSetVal^.NextSet; rSetVal := rSetVal^.NextSet;
                        END
                      ELSE
                        lBv := False;
                    END;

            NESY: lBv := Lmax <> Rmax;
          END;

          CompSets := lBv;
        END; {CompSets}

      FUNCTION CompStrs(Left: Attr; Op: Symbol; Right: Attr): Boolean;

        TYPE
          Str255 = String[255];

        VAR
          LeftStr, RightStr: Str255;

        PROCEDURE Concat(StrValu: Valu; VAR Str: Str255);

          VAR
            i, Len: Integer;

          BEGIN {Concat}
            WITH StrValu DO
              BEGIN
              Str[0] := Chr(SvaluLen);
              Len := 0;
              WHILE Svalu <> NIL DO
                IF Len < 249 THEN
                  BEGIN
                  FOR i := 1 TO ALFALEN DO Str[Len + i] := Svalu^.StrPart[i];
                  Len := Len + ALFALEN;
                  Svalu := Svalu^.Next;
                  END
                ELSE
                  BEGIN
                  FOR i := 1 TO 255 - Len DO Str[Len + i] := Svalu^.StrPart[i];
                  Svalu := NIL; {safety, there should be no more}
                  END;
              END;
          END; {Concat}

        BEGIN {CompStrs}
          Concat(Left.TreePtr^.CstValu, LeftStr);
          Concat(Right.TreePtr^.CstValu, RightStr);

          CASE Op OF
            LTSY: CompStrs := LeftStr < RightStr;
            GTSY: CompStrs := LeftStr > RightStr;
            LESY: CompStrs := LeftStr <= RightStr;
            GESY: CompStrs := LeftStr >= RightStr;
            EQSY: CompStrs := LeftStr = RightStr;
            NESY: CompStrs := LeftStr <> RightStr;
          END;
        END; {CompStrs}

      BEGIN {ConstExpression}
        SimpleConstExpression(Fsys + [LTSY, GTSY, LESY, GESY, EQSY, NESY, INSY]);

        IF Token IN [LTSY, GTSY, LESY, GESY, EQSY, NESY, INSY] THEN
          BEGIN
          NonStd := True;
          lToken := Token; lAttr := gAttr;

          Scan;
          SimpleConstExpression(Fsys);

          IF (lAttr.Typtr <> NIL) AND (gAttr.Typtr <> NIL) THEN
            CASE lToken OF                                                     {!} {[@=10]}
              LTSY, GTSY, LESY, GESY, EQSY, NESY:
                        BEGIN
                        IF NOT CompTypes(lAttr.Typtr, gAttr.Typtr) THEN
                          BEGIN
                          IF CompTypes(lAttr.Typtr, IntPtr) THEN
                            Float(lAttr)
                          ELSE IF CompTypes(gAttr.Typtr, IntPtr) THEN
                            Float(gAttr)
                          ELSE IF (lAttr.Typtr^.Form = SCONST) AND (gAttr.Typtr = CharPtr) THEN
                            ChToString(gAttr)
                          ELSE IF (lAttr.Typtr^.Form = SCONST) AND (gAttr.Typtr = CharPtr) THEN
                            ChToString(lAttr);
                          END;
                        IF CompTypes(lAttr.Typtr, gAttr.Typtr) THEN
                          CASE gAttr.Typtr^.Form OF                            {!} {[@=9]}
                            SCALAR, SUBRANGE:
                                     IF CompTypes(gAttr.Typtr, RealPtr) THEN
                                       Bv := CompReals(lAttr, lToken, gAttr)
                                     ELSE
                                       Bv := CompInts(lAttr, lToken, gAttr);
                            SETS:    IF (lToken = LTSY) OR (lToken = GTSY) THEN
                                       Err(129)
                                     ELSE
                                       Bv := CompSets(lAttr, lToken, gAttr);
                            SCONST:  Bv := CompStrs(lAttr, lToken, gAttr);
                            RECORDS: Err(131);
                            FILES:   Err(130);
                            STRINGS, CLASSES, POINTERS, ARRAYS:
                                     Err(179);
                          END
                        ELSE
                          Err(144);
                        END;
              INSY:     IF gAttr.Typtr^.Form = SETS THEN
                          IF CompTypes(lAttr.Typtr, gAttr.Typtr^.SetOf) THEN
                            BEGIN
                            i := lAttr.TreePtr^.CstValu.Ivalu;
                            IF (i >= 0) AND (i <= gAttr.TreePtr^.CstValu.MaxSetEl) THEN
                              BEGIN
                              lSetVal := gAttr.TreePtr^.CstValu.SetValu;
                              FOR j := 1 TO i DIV 32 DO lSetVal := lSetVal^.NextSet;
                              Bv := (i MOD 32) IN lSetVal^.SetVal;
                              END
                            ELSE
                              Bv := False;
                            END
                          ELSE
                            Err(127)
                        ELSE
                          Err(131);
            END
          ELSE
            gAttr.Typtr := NIL;

          WITH gAttr DO
            IF gAttr.Typtr <> NIL THEN
              BEGIN
              Typtr := BoolPtr;
              New(TreePtr, CSTNODE);
              TreePtr^.Node := CSTNODE;
              TreePtr^.CstType := BoolPtr;
              TreePtr^.CstValu.Ivalu := Ord(Bv);
              END;
          END;
      END; {ConstExpression}

    BEGIN {Constant}
      NonStd := False;
      IF NOT (Token IN ConstBegSys) THEN Skip(24, Fsys + ConstBegSys);
      IF Token IN ConstBegSys THEN
        BEGIN
        ConstExpression(Fsys);
        IF gAttr.Typtr = NIL THEN
          BEGIN
          fValu.Ivalu := 0;
          FpT := IntPtr;
          END
        ELSE
          BEGIN
          fValu := gAttr.TreePtr^.CstValu;
          FpT := gAttr.TreePtr^.CstType;
          END;
        IF NOT (Token IN Fsys) THEN Skip(20, Fsys);
        END
      ELSE
        BEGIN
        fValu.Ivalu := 0;
        FpT := IntPtr;
        END;
    END; {Constant}                                                            {!01-20-84end} {[o=82]}

  {$S }

  PROCEDURE EnterId{fn: pn};

    VAR
      lN, lUnitP: pN;
      DuplId: Boolean;

    BEGIN {EnterId}
      DuplId := False;
      WITH fN^ DO
        BEGIN
        Llink := NIL; Rlink := NIL;
        END;
      IF (Top = 1) AND (UnitList <> NIL) THEN
        BEGIN {search the used units for this guy}                             {!DBG!}
        lUnitP := UnitList;                                                    {!DBG!}
        IF lUnitP^.Ulev = - 1 THEN lUnitP := lUnitP^.Next;                     {!DBG!}
        WHILE (lUnitP <> NIL) AND NOT DuplId DO                                {!DBG!}
          BEGIN                                                                {!DBG!}
          lN := lUnitP;                                                        {!DBG!}
          WHILE (lN <> NIL) AND (NOT DuplId) DO                                {!DBG!}
            WITH lN^ DO                                                        {!DBG!}
              IF Name = fN^.Name THEN                                          {!DBG!}
                DuplId := True                                                 {!DBG!}
              ELSE IF Name < fN^.Name THEN                                     {!DBG!}
                lN := Llink                                                    {!DBG!}
              ELSE                                                             {!DBG!}
                lN := Rlink;                                                   {!DBG!}
          lUnitP := lUnitP^.Next;                                              {!DBG!}
          END;                                                                 {!DBG!}
        END;                                                                   {!DBG!}

      lN := Display[Top].NameTree;
      IF lN = NIL THEN
        Display[Top].NameTree := fN
      ELSE
        REPEAT
          WITH lN^ DO
            IF Name = fN^.Name THEN
              BEGIN
              DuplId := True; lN := Llink;
              END
            ELSE IF Name < fN^.Name THEN
              IF Llink = NIL THEN
                BEGIN
                Llink := fN; lN := NIL;
                END
              ELSE
                lN := Llink
            ELSE IF Rlink = NIL THEN
              BEGIN
              Rlink := fN; lN := NIL;
              END
            ELSE
              lN := Rlink;
        UNTIL lN = NIL;
      IF DuplId THEN Error(100);
    END; {EnterId}

  FUNCTION SearchLocal{ftree: pn): pn};

    VAR
      ExitFlag: Boolean;
      lpN: pN;
      lUnitP: pN;                                                              {!DBG!}

    BEGIN {SearchLocal}
      lpN := FTree; ExitFlag := False;
      IF (FTree = Display[1].NameTree) AND (UnitList <> NIL) THEN
        BEGIN {search the used units FIRST}                                    {!DBG!}
        lUnitP := UnitList;                                                    {!DBG!}
        IF lUnitP^.Ulev = - 1 THEN lUnitP := lUnitP^.Next;                     {!DBG!}
        WHILE (lUnitP <> NIL) AND NOT ExitFlag DO                              {!DBG!}
          BEGIN                                                                {!DBG!}
          lpN := lUnitP;                                                       {!DBG!}
          WHILE (lpN <> NIL) AND NOT ExitFlag DO                               {!DBG!}
            WITH lpN^ DO                                                       {!DBG!}
              IF Name = Ident THEN                                             {!DBG!}
                ExitFlag := True                                               {!DBG!}
              ELSE                                                             {!DBG!}
              IF Name < Ident THEN                                             {!DBG!}
                lpN := Llink                                                   {!DBG!}
              ELSE                                                             {!DBG!}
                lpN := Rlink;                                                  {!DBG!}
          IF NOT ExitFlag THEN lUnitP := lUnitP^.Next;                         {!DBG!}
          END;                                                                 {!DBG!}
        IF NOT ExitFlag THEN lpN := FTree;                                     {!DBG!}
        END;                                                                   {!DBG!}

      WHILE (lpN <> NIL) AND NOT ExitFlag DO
        WITH lpN^ DO
          IF Name = Ident THEN
            ExitFlag := True
          ELSE IF Name < Ident THEN
            lpN := Llink
          ELSE
            lpN := Rlink;
      SearchLocal := lpN;
    END; {SearchLocal}

  FUNCTION SearchClasses{FpT: pT; VAR HigherLevel: Boolean; StartAtSuper:
                         Boolean): pN};                                       {!C 12-14-83}

    VAR
      ExitFlag, First: Boolean;
      lpN: pN;
      lUnitP: pN;

    BEGIN {SearchClasses - a special version of SearchLocal for class methods}
      ExitFlag := False; HigherLevel := StartAtSuper;
      lpN := NIL;

      WHILE (FpT <> NIL) AND NOT ExitFlag DO
        BEGIN {search from current class then up through the superclasses}
        lpN := FpT^.ClFields;
        WHILE (lpN <> NIL) AND NOT ExitFlag DO
          WITH lpN^ DO
            IF Name = Ident THEN
              BEGIN
              ExitFlag := True;
              IF HigherLevel THEN
                IF (Class = PROC) OR (Class = FUNC) THEN
                  IF Name = 'CREATE  ' THEN
                    BEGIN
                    ExitFlag := False; lpN := NIL;
                    END;
              END
            ELSE IF Name < Ident THEN
              lpN := Llink
            ELSE
              lpN := Rlink;
        IF NOT ExitFlag THEN
          BEGIN
          FpT := FpT^.SuperClass;
          HigherLevel := True;
          END;
        END;

      SearchClasses := lpN;
    END; {SearchClasses}

  FUNCTION SearchAll{FClass: NClassSet): pN};

    LABEL 1, 2;

    VAR
      lpN: pN;
      HigherLevel: Boolean;                                                    {!C 12-14-83}
      lDisx: DispRange;
      lUnitP: pN;                                                              {!DBG!}

    BEGIN {SearchAll}
      FOR lDisx := Top DOWNTO 0 DO
        BEGIN                                                                  {!DBG!}
        IF lDisx = 1 THEN                                                      {!DBG!}
          IF UnitList <> NIL THEN                                              {!DBG!}
            BEGIN {search the used units first}                                {!DBG!}
            lUnitP := UnitList;                                                {!DBG!}
            IF lUnitP^.Ulev = - 1 THEN lUnitP := lUnitP^.Next;                 {!DBG!}
            WHILE lUnitP <> NIL DO                                             {!DBG!}
              BEGIN                                                            {!DBG!}
              lpN := lUnitP;                                                   {!DBG!}
              WHILE lpN <> NIL DO                                              {!DBG!}
                WITH lpN^ DO                                                   {!DBG!}
                  IF Name = Ident THEN                                         {!DBG!}
                    IF Class IN fClass THEN                                    {!DBG!}
                      BEGIN                                                    {!DBG!}
                      Disx := lDisx;                                           {!DBG!}
                      GOTO 1;                                                  {!DBG!}
                      END                                                      {!DBG!}
                    ELSE                                                       {!DBG!}
                      BEGIN                                                    {!DBG!}
                      IF PrintErrors THEN Error(101);                          {!DBG!}
                      lpN := Llink;                                            {!DBG!}
                      END                                                      {!DBG!}
                  ELSE IF Name < Ident THEN                                    {!DBG!}
                    lpN := Llink                                               {!DBG!}
                  ELSE                                                         {!DBG!}
                    lpN := Rlink;                                              {!DBG!}
              lUnitP := lUnitP^.Next;                                          {!DBG!}
              END;                                                             {!DBG!}
            END; {searching the used units first}                              {!DBG!}

        WITH Display[lDisx] DO
          BEGIN
          IF Occur = KLASS THEN                                                {!C 12-14-83}
            IF KType <> NIL THEN
              BEGIN {process WITH'ed class record}
              lpN := SearchClasses(KType, HigherLevel, False);
              IF lpN <> NIL THEN
                WITH lpN^ DO
                  IF Class IN fClass THEN
                    BEGIN
                    BEGIN
                    Disx := lDisx;
                    GOTO 1;
                    END;
                    END
                  ELSE IF PrintErrors THEN Error(101); {not right class}
              GOTO 2;
              END; {processing WITH'ed class record}                           {!C 12-14-83}

          lpN := NameTree;
          WHILE lpN <> NIL DO
            WITH lpN^ DO
              IF Name = Ident THEN
                IF Class IN fClass THEN
                  BEGIN
                  Disx := lDisx;
                  GOTO 1;
                  END
                ELSE
                  BEGIN
                  IF PrintErrors THEN Error(101); {not right class}
                  lpN := Llink;
                  END
              ELSE IF Name < Ident THEN
                lpN := Llink
              ELSE
                lpN := Rlink;
          END; {with}
      2:
        END; {for}                                                             {!DBG!}

      {No such identifier of the correct class.  Return a dummy.}

      Disx := 0;
      IF PrintErrors THEN
        BEGIN
        Error(102); {id not declared}
        IF VARS IN fClass THEN
          lpN := uVarPtr
        ELSE IF TYPES IN fClass THEN
          lpN := uTypPtr
        ELSE IF CONSTS IN fClass THEN
          lpN := uCstPtr
        ELSE IF FIELD IN fClass THEN
          lpN := uFldPtr
        ELSE IF PROC IN fClass THEN
          lpN := uPrcPtr
        ELSE
          lpN := uFctPtr;
        END;

    1:
      SearchAll := lpN;
    END; {SearchAll}

  PROCEDURE Skip{errorno: integer; fsys: setofsys};

    BEGIN {Skip}
      IF ErrorNo <> 0 THEN Error(ErrorNo);
      WHILE NOT (Token IN FSys) DO Scan;
    END; {Skip}


  PROCEDURE Out{a: integer};

    BEGIN {Out}
      IF ByteNo >= BuffByteSize THEN
        BEGIN
        IF BlockWrite(ICodeFile, Buff, BuffBlockSize, BlockNo) <>
           BuffBlockSize THEN
          FatalOutputError;
        BlockNo := BlockNo + BuffBlockSize;
        ByteNo := 0;
        END;
      Buff[ByteNo] := Chr(a);
      ByteNo := ByteNo + 1;
    END; {Out}

  PROCEDURE Out2{a: integer};

    VAR
      c: PACKED ARRAY [0..1] OF Char;

    BEGIN {Out2}
      MoveLeft(a, c, 2);
      IF FlipBytes THEN
        BEGIN
        Out(Ord(c[1])); Out(Ord(c[0]));
        END
      ELSE
        BEGIN
        Out(Ord(c[0])); Out(Ord(c[1]));
        END;
    END; {Out2}

  PROCEDURE ForwSearch(FpN: pN);

    BEGIN {ForwSearch - error reporting for forward proc w/o bodies}
      IF FpN <> NIL THEN
        WITH FpN^ DO
          BEGIN
          ForwSearch(Llink);
          IF (Class = PROC) OR (Class = FUNC) THEN
            IF PFdeclKind = DECLARED THEN
              IF PFdecl = FORWDECL THEN
                IF Class = PROC THEN
                  NError(176, Name)
                ELSE
                  NError(177, Name);
          ForwSearch(Rlink);
          END;
    END; {ForwSearch}

  FUNCTION HasBody{FSys: SetOfSys; ProcpN: pN; VAR HeapMark: PBoolean): Boolean}; {!02-06-84 start}

    VAR
      LastWord, CodeWord: InlinePtr;
      InlineWord: Valu;
      lpT: pT;

    BEGIN {HasBody - checks for words FORWARD, EXTERNAL, and INLINE following the
           procedure header.  Return false if not identifer follows the header,
           else true.}
      HasBody := True; {assume there is a proc body, i.e., no identifier}

      IF Token = IDENTSY THEN
        BEGIN
        HasBody := False; {we now assume there is no proc body}

        IF Ident = 'FORWARD ' THEN
          BEGIN
          IF InterFlag OR InUses THEN Error(20);
          IF ProcpN^.PFdecl = DECL THEN
            BEGIN
            ProcpN^.PFdecl := FORWDECL; Forwcount := Forwcount + 1
            END
          ELSE
            Error(175);
          Scan;
          END
        ELSE IF Ident = 'EXTERNAL' THEN
          BEGIN
          IF InterFlag OR InUses THEN Error(20);
          IF ProcpN^.PFdecl = FORWDECL THEN Forwcount := Forwcount - 1;
          ProcpN^.PFdecl := EXTDECL; ProcpN^.RtnNo := - 1;
          IF DebugOpen THEN                                                    {!DBG!}
            WITH Display[Top] DO DumpSyms(ProcBase, NameTree, NIL, ProcpN);    {!DBG!}
          Scan;
          END
        ELSE IF Ident = 'INLINE  ' THEN
          BEGIN
          IF ProcpN^.PFdecl <> DECL THEN
            Error(186)
          ELSE IF NOT (InterFlag OR InUses) THEN Release(HeapMark);
          ProcpN^.PFdecl := INLINEDECL; LastWord := NIL;
          REPEAT
            Scan;
            Constant(FSys + [COMMASY, SEMISY], InlineWord, lpT);
            IF lpT <> NIL THEN
              BEGIN
              IF lpT <> IntPtr THEN
                BEGIN
                Error(185); InlineWord.Ivalu := 0;
                END
              ELSE IF (InlineWord.Ivalu < -32768) OR (InlineWord.Ivalu > 65535) THEN
                BEGIN
                Error(185); InlineWord.Ivalu := 0;
                END;
              New(CodeWord);
              CodeWord^.InlineWord := InlineWord.Ivalu;
              CodeWord^.NextInlineWord := NIL;
              IF LastWord = NIL THEN
                ProcpN^.InlineCode := CodeWord
              ELSE
                LastWord^.NextInlineWord := CodeWord;
              LastWord := CodeWord;
              END; {lpT <> NIL}
          UNTIL Token <> COMMASY;
          IF NOT (InterFlag OR InUses) THEN Mark(HeapMark);
          END
        ELSE IF Ident = 'C       ' THEN                                        {!03-29-84}
          BEGIN
          IF InterFlag OR InUses THEN Error(20);
          IF ProcpN^.PFdecl = FORWDECL THEN
            BEGIN
            Forwcount := Forwcount - 1;
            Error(187);
            END;
          ProcpN^.PFdecl := CDECL; ProcpN^.RtnNo := - 1;
          IF DebugOpen THEN                                                    {!DBG!}
            WITH Display[Top] DO DumpSyms(ProcBase, NameTree, NIL, ProcpN);    {!DBG!}
          Scan;
          END
        ELSE
          BEGIN
          Error(162);
          Scan;
          END;

        IF InterFlag OR InUses THEN
          IF Token = SEMISY THEN
            Scan
          ELSE
            Error(36);
        END; {ident}
    END; {HasBody}                                                             {!02-06-84 end}

  PROCEDURE PFList(FSys: SetOfSys);                                            {!01-21-84}

    VAR
      ExitFlag: Boolean;
      lToken: Symbol;
      HeapMark: PBoolean;
      OldTop: DispRange;
      OldLevel: LevRange;
      ProcpN, OldProc: pN;
      OldForwCount: Integer;

    BEGIN {PFList}
      ExitFlag := False;
      OldLevel := Level; OldTop := Top; OldProc := CurrentProc;
      OldForwCount := Forwcount;

      REPEAT
        IF (Token = PROCSY) OR (Token = FUNCTSY) THEN
          BEGIN
          IF Level>0 THEN
            ProcLev := Chr(Ord('A') + Level - 1)
          ELSE
            ProcLev := 'A';

          lToken := Token;
          Scan;
          Declarations(FSys + [IDENTSY], lToken, ProcpN, HeapMark, NIL);
          CurrentProc := ProcpN;

          IF HasBody(FSys, ProcpN, HeapMark) THEN                              {!02-06-84}
            BEGIN
            IF ProcpN^.PFdecl = FORWDECL THEN
              BEGIN
              ProcpN^.PFdecl := DECL;
              Forwcount := Forwcount - 1;
              END;

            REPEAT                                                             {!01-21-84}
              PFList(FSys);                                                    {!01-21-84}
              IF Token IN IdDecBegSys THEN                                     {!01-21-84}
                 Declarations(FSys, Token, ProcpN, HeapMark, NIL);             {!01-21-84}
            UNTIL NOT (Token IN DecBegSys);                                    {!01-21-84}

            IF Token = BEGINSY THEN
              BEGIN
              LeftCheck;
              IF Level>1 THEN ProcLev := Chr(Ord('A') + Level - 2);
              Scan;
              END
            ELSE
              Error(43);

            REPEAT
              Body(FSys + [CASESY], ProcpN^.Name, ProcStmt);
              IF Token <> SEMISY THEN Skip(20, FSys);
              IF (Errors = 0) AND CodeFlag THEN
                BEGIN
                RegMask.sMask := [];                                           {!OPT!}
                IF OptFlag THEN
                  IF OptLimFlag THEN                                           {!01-31-84}
                    BEGIN
                    Optimize(ProcStmt, ProcpN);
                    BindRegisters(ProcStmt, ProcpN);                           {!OPT!}
                    END
                  ELSE
                    GlobalOptimize(ProcStmt, ProcpN);
                IF DebugOpen OR DebugDebug THEN                                {!DBG!}
                  WITH Display[Top] DO                                         {!DBG!}
                    DumpSyms(ProcBase, NameTree, ProcStmt, ProcpN);            {!DBG!}
                Dump(ProcStmt, ProcpN, False);                                 {!12-20-83}
                END;
            UNTIL (Token = SEMISY) OR (Token IN BlockBegSy);
            END;

          IF Token = SEMISY THEN
            Scan
          ELSE
            Error(36);

          Release(HeapMark); Level := OldLevel;
          Top := OldTop; CurrentProc := OldProc;
          END
        ELSE
          ExitFlag := True;
      UNTIL ExitFlag;

      IF NOT (Token IN [BEGINSY] + IdDecBegSys) THEN Skip(22, FSys);           {!01-21-84}

      IF Forwcount > OldForwCount THEN
        BEGIN
        IF ForwChkFlag THEN
          BEGIN                                                                {!10-25-83}
          ForwSearch(Display[Top].NameTree);
          Forwcount := OldForwCount;
          END;
        END;
    END; {PFList}

  PROCEDURE BodyCount(ThisClass: pT);                                          {!C}

    VAR
      ThisMethod: pN;

    BEGIN {BodyCount - verifies that all methods have a body}
      WITH ThisClass^ DO
        BEGIN {verify that there is a method}
        ThisMethod := ThisClass^.ClFstMethod;
        WHILE ThisMethod <> NIL DO
          WITH ThisMethod^ DO
            BEGIN
            IF PFdecl = FORWMETHDECL THEN NError(805, Name);
            ThisMethod := Next;
            END;
        END;
    END; {BodyCount}                                                           {!C}

  PROCEDURE AddMethodInfo(VAR ProcStmt: pStmt; ThisClass: pT; ClassName: Alfa); {!C 12-27-83}

    VAR
      LineNbr: Integer;
      PrevN, N: LongInt;
      NewStmt, LastStmt: pStmt;
      ThisMethod, iProc: pN;

    BEGIN {AddMethodInfo - This procedure prefixes the creation code with code
           that will be used to build the method tables. The actual initalization
           is done by a runtime interpreter %_class.}
          {The following code is generated:
               Call %_Class('ThisClas', 'SuperCla',
                             MasterPtr,
                             EvenMethods, OddMethods,
                             ClSize);
               Call method(MethodLevel*256+MethodNo);
               ...
               Call %_class;

           where 'ThisClas'   = Alfa type name of current class.
                 'SuperCla'   = Alfa type name of this class's superclass.
                 MasterPtr    = LongInt type ptr to this class's master table.
                 EvenMethods  = Integer type of the nbr of methods in even
                                sublevel added in this class.
                 OddMethods   = Integer type of the nbr of methods in odd
                                sublevel added in this class.
                 method       = Name of a method added in this class.  This may
                                include overrides. The parameter is omitted if it
                                is 1 higher than the call before it.
          }
      IF ProcStmt <> NIL THEN
        LineNbr := ProcStmt^.StmtNumb
      ELSE
        LineNbr := TotalLines;
      New(LastStmt, CALLST);
      WITH LastStmt^ DO
        BEGIN {now call the proc}
        NextStmt := ProcStmt; ProcStmt := LastStmt;
        StmtOp := CALLST; StmtNumb := LineNbr;
        ProcpN := KlassPtr; {declared by initialization}
        New(pArgList, BINNODE);
        WITH pArgList^ DO
          BEGIN {1st arg - type Alfa}
          Node := BINNODE; BinOp := 0; BinSubOp := 0;
          New(LeftArg, CSTNODE);
          WITH LeftArg^ DO
            BEGIN
            Node := CSTNODE;
            CstValu.SvaluLen := 8;
            New(CstValu.Svalu);
            CstValu.Svalu^.StrPart := ClassName;
            CstValu.Svalu^.Next := NIL;
            New(CstType, SCONST);
            WITH CstType^ DO
              BEGIN
              FType := False; Form := SCONST; Bits := 0; Bytes := 8;
              StringLen := 8;
              END;
            END;
          New(RightArg, BINNODE);
          WITH RightArg^ DO
            BEGIN {2nd arg}
            Node := BINNODE; BinOp := 0; BinSubOp := 0;
            New(LeftArg, CSTNODE);
            WITH LeftArg^ DO
              BEGIN
              Node := CSTNODE;
              CstValu.SvaluLen := 8;
              New(CstValu.Svalu);
              IF ThisClass^.SuperClass = NIL THEN
                CstValu.Svalu^.StrPart := 'NIL     '
              ELSE IF ThisClass^.SuperClass^.ItsId = NIL THEN
                CstValu.Svalu^.StrPart := 'NIL     '
              ELSE
                CstValu.Svalu^.StrPart := ThisClass^.SuperClass^.ItsId^.Name;
              CstValu.Svalu^.Next := NIL;
              New(CstType, SCONST);
              WITH CstType^ DO
                BEGIN
                FType := False; Form := SCONST; Bits := 0; Bytes := 8;
                StringLen := 8;
                END;
              END;
            New(RightArg, BINNODE);
            WITH RightArg^ DO
              BEGIN {3rd arg}
              Node := BINNODE; BinOp := 0; BinSubOp := 0;
              New(LeftArg, IDENTNODE, VARS);
              WITH LeftArg^ DO
                BEGIN
                IdType := LIntPtr;
                Node := IDENTNODE; Class := VARS; Vkind := DRCT;
                IsSELF := False; InRegister := - 1;
                Vlev := ThisClass^.MethodLev;
                Voff := ThisClass^.MethodOff;
                END;
              New(RightArg, BINNODE);
              WITH RightArg^ DO
                BEGIN {4th arg}
                Node := BINNODE; BinOp := 0; BinSubOp := 0; RightArg := NIL;
                New(LeftArg, CSTNODE);
                WITH LeftArg^ DO
                  BEGIN
                  Node := CSTNODE; CstType := IntPtr;
                  CstValu.Ivalu := ThisClass^.LastEvenMethod;
                  END;
                New(RightArg, BINNODE);
                WITH RightArg^ DO
                  BEGIN {5th arg}
                  Node := BINNODE; BinOp := 0; BinSubOp := 0; RightArg := NIL;
                  New(LeftArg, CSTNODE);
                  WITH LeftArg^ DO
                    BEGIN
                    Node := CSTNODE; CstType := IntPtr;
                    CstValu.Ivalu := ThisClass^.LastOddMethod;
                    END;
                  New(RightArg, BINNODE);
                  WITH RightArg^ DO
                    BEGIN {6th arg}
                    Node := BINNODE; BinOp := 0; BinSubOp := 0; RightArg := NIL;
                    New(LeftArg, CSTNODE);
                    WITH LeftArg^ DO
                      BEGIN
                      Node := CSTNODE; CstType := IntPtr;
                      CstValu.Ivalu := ThisClass^.SizeInstance;
                      END;
                    END; {6th arg}
                  END; {5th arg}
                END; {4th arg}
              END; {3rd arg}
            END; {2nd arg}
          END; {1st arg}
        END; {calling proc}

      ThisMethod := ThisClass^.ClFstMethod;
      PrevN := ThisClass^.ClassLevel * 256 {+ 0} ;

      WHILE ThisMethod <> NIL DO
        BEGIN
        IF ThisMethod^.MethodNo <> 0 {CREATE} THEN
          IF ThisMethods^.RtnNo <> 0 {ABSTRACT} THEN
            BEGIN
            N := ThisMethod^.MethodLevel * 256 + ThisMethod^.MethodNo;
            New(iProc, IDENTNODE, PROC, DECLARED);
            WITH iProc^ DO
              BEGIN
              Name := ThisMethod^.Name;
              Node := IDENTNODE; Class := PROC;
              PFdeclKind := DECLARED; PFdecl := DECL;
              IdType := NIL; Next := NIL; Lc := 0;
              PFlev := ThisMethod^.PFlev;
              RtnNo := ThisMethod^.RtnNo;
              IF (PrevN + 1) = N THEN
                BEGIN
                PFargList := NIL; ParmBytes := 0;
                END
              ELSE
                BEGIN
                ParmBytes := 10;
                New(PFargList, IDENTNODE, VARS);
                WITH PFargList^ DO
                  BEGIN
                  Node := IDENTNODE; Class := VARS; Vkind := DRCT;
                  IdType := IntPtr; IsSELF := False; InRegister := - 1;
                  Next := NIL;
                  Vlev := 2; Voff := 8;
                  END;
                END;
              END;

            New(NewStmt, CALLST);
            WITH NewStmt^ DO
              BEGIN
              StmtNumb := LineNbr; StmtOp := CALLST; ProcpN := iProc;
              IF iProc^.PFargList=NIL THEN
                pArgList := NIL
              ELSE
                BEGIN
                New(pArgList, BINNODE);
                WITH pArgList^ DO
                  BEGIN
                  Node := BINNODE; BinOp := 0; BinSubOp := 0; RightArg := NIL;
                  New(LeftArg, CSTNODE);
                  WITH LeftArg^ DO
                    BEGIN
                    Node := CSTNODE; CstType := IntPtr;
                    CstValu.Ivalu := N;
                    END;
                  END;
                END;
              NextStmt := LastStmt^.NextStmt;
              LastStmt^.NextStmt := NewStmt;
              END;

            LastStmt := NewStmt;
            PrevN := N;
            END;

        ThisMethod := ThisMethod^.Next;
        END; {while}

      New(NewStmt, CALLST);
      WITH NewStmt^ DO
        BEGIN
        NextStmt := LastStmt^.NextStmt;
        LastStmt^.NextStmt := NewStmt;
        StmtNumb := LineNbr; StmtOp := CALLST; pArgList := NIL;
        New(ProcpN, IDENTNODE, PROC, DECLARED);
        WITH ProcpN^ DO
          BEGIN
          Name := '%_CLASS ';
          Node := IDENTNODE; Class := PROC;
          PFdeclKind := DECLARED; PFdecl := DECL;
          IdType := NIL; Next := NIL; PFargList := NIL;
          ParmBytes := 0; Lc := 0;
          PFlev := 1; RtnNo := - 1;
          END;
        END;
    END; {AddMethodInfo}                                                       {!C 12-27-83}

  PROCEDURE ImplPFList(FSys: SetOfSys);

    VAR
      SawMethods, ExitFlag, b: Boolean;
      lToken: Symbol;
      HeapMark: PBoolean;
      OldTop: DispRange;
      OldLevel: LevRange;
      lpN, ProcpN, OldProc: pN;
      InitProc: Alfa;                                                          {!12-27-83}
      OldForwCount, i: Integer;
      SaveClass: String9;

    BEGIN {ImplPFList - A special PFList that is called in the implementation part
           of a unit to compile the implementation of the methods. It accepts
           procedures mixed with method declarations.}
      OldLevel := Level; OldTop := Top; OldProc := CurrentProc;
      OldForwCount := Forwcount;
      ExitFlag := False;
      SawMethods := False;
      ThisClass := NIL;
      InitProc := 'No Name!';
      CurrClass := '';

      REPEAT
        IF Token = METHSY THEN
          BEGIN
          IF SawMethods THEN {forgot to end methods section}
            BEGIN
            Error(44);
            IF ThisClass <> NIL THEN
              BEGIN
              BodyCount(ThisClass);
              ThisClass^.WasDeclared := True;
              END;
            Level := OldLevel;
            Top := OldTop;
            CurrentProc := OldProc;
            ThisClass := NIL; InitProc := 'No Name!'; CurrClass := '';
            SawMethods := False;
            END;

          Scan;
          IF Token = OFSY THEN
            Scan
          ELSE
            Error(800);

          InitProc := 'No Name!'; CurrClass := '';                              {!12-27-83}

          IF Token = IDENTSY THEN
            BEGIN
            lpN := SearchLocal(Display[Top].NameTree);
            IF lpN = NIL THEN
              Error(101)
            ELSE
              WITH lpN^ DO
                BEGIN
                IF (Class <> TYPES) OR (IdType = NIL) THEN
                  Error(101)
                ELSE IF IdType^.Form <> CLASSES THEN
                  Error(101)
                ELSE
                  BEGIN
                  ThisClass := IdType;
                  LocProcNo := LocProcNo + 1;
                  IF ThisClass^.ItsId <> NIL THEN
                    InitProc := ThisClass^.ItsId^.Name                         {!12-27-83}
                  ELSE
                    InitProc := lpN^.Name;                                     {!12-27-83}
                  i := 1; b := True;
                  WHILE b DO
                    BEGIN
                    CurrClass[i] := Name[i];
                    i := i+1;
                    IF i>8 THEN
                      b := False
                    ELSE IF Name[i] = ' ' THEN b := False;
                    END;
                  CurrClass[i] := '.';
                  CurrClass[0] := Chr(i);
                  END;
                END;
            Scan;
            IF Token = SEMISY THEN Scan;
            END;

          IF ThisClass <> NIL THEN IF ThisClass^.WasDeclared THEN Error(101);
          SawMethods := True;
          END
        ELSE IF (Token = PROCSY) OR (Token = FUNCTSY) THEN
          BEGIN
          lToken := Token;
          IF Level>0 THEN
            ProcLev := Chr(Ord('A') + Level - 1)
          ELSE
            ProcLev := 'A';

          Scan;
          IF Token = IDENTSY THEN                                              {!01-06-84}
            IF Ident = InitProc THEN
              BEGIN
              Scan;
              IF Token = PERIODSY THEN
                Scan
              ELSE
                Error(51);
              END;                                                             {!01-06-84}

          Declarations(FSys + [IDENTSY], lToken, ProcpN, HeapMark, ThisClass);
          CurrentProc := ProcpN;

          IF HasBody(FSys, ProcpN, HeapMark) THEN                              {!02-06-84}
            BEGIN
            IF ProcpN^.PFdecl = FORWMETHDECL THEN
              ProcpN^.PFdecl := METHDECL
            ELSE IF ProcpN^.PFdecl = FORWDECL THEN
              BEGIN
              ProcpN^.PFdecl := DECL;
              Forwcount := Forwcount - 1;
              END;

            SaveClass := CurrClass; CurrClass := '';
            REPEAT                                                             {!01-21-84}
              PFList(FSys);                                                    {!01-21-84}
              IF Token IN IdDecBegSys THEN                                     {!01-21-84}
                 Declarations(FSys, Token, ProcpN, HeapMark, ThisClass);       {!01-21-84}
            UNTIL NOT (Token IN DecBegSys);                                    {!01-21-84}
            CurrClass := SaveClass;

            IF Token = BEGINSY THEN
              BEGIN
              LeftCheck;
              IF Level>1 THEN ProcLev := Chr(Ord('A') + Level - 2);
              Scan;
              END
            ELSE
              Error(43);

            REPEAT
              Body(FSys + [CASESY], ProcpN^.Name, ProcStmt);
              IF Token <> SEMISY THEN Skip(20, FSys);
              IF (Errors = 0) AND CodeFlag THEN
                BEGIN
                RegMask.sMask := [];                                           {!OPT!}
                IF OptFlag THEN
                  IF OptLimFlag THEN                                           {!01-31-84}
                    BEGIN
                    Optimize(ProcStmt, ProcpN);
                    BindRegisters(ProcStmt, ProcpN);                           {!OPT!}
                    END
                  ELSE
                    GlobalOptimize(ProcStmt, ProcpN);
                IF DebugOpen OR DebugDebug THEN                                {!DBG!}
                  WITH Display[Top] DO                                         {!DBG!}
                    DumpSyms(ProcBase, NameTree, ProcStmt, ProcpN);            {!DBG!}
                IF (ProcpN^.PFdecl = METHDECL) AND (ProcpN^.Name =
                   'CREATE  ') THEN                                            {!C 12-27-83}
                  BEGIN {Kluge CREATE so that it is known to the outside world as
                         its class name. We do this by "tricking" dump, but when
                         we are done tricking it, put things back as they were so
                         that we know elsewhere what we are talking about!}
                  ProcpN^.Name := InitProc; {hopefully the class name}
                  Dump(ProcStmt, ProcpN, False);
                  ProcpN^.Name := 'CREATE  '; {back the way it was}
                  END
                ELSE
                  Dump(ProcStmt, ProcpN, False);                               {!12-20-83}
                END;
            UNTIL (Token = SEMISY) OR (Token IN BlockBegSy);
            END;

          IF Token = SEMISY THEN
            Scan
          ELSE
            Error(36);

          Release(HeapMark);
          Level := OldLevel;
          Top := OldTop;
          CurrentProc := OldProc;
          END
        ELSE IF (Token = BEGINSY) OR ((Token = ENDSY) AND SawMethods) THEN     {!01-01-84}
          BEGIN
          IF NOT SawMethods THEN Error(20);
          SawMethods := False;
          lToken := Token;
          Declarations(FSys + [IDENTSY], lToken, ProcpN, HeapMark, ThisClass); {!12-27-83}

          IF lToken = BEGINSY THEN
            BEGIN
            IF Level>1 THEN ProcLev := Chr(Ord('A') + Level - 2);
            LeftCheck;
            END;

          Scan;                                                                {!01-01-84}

          IF ThisClass <> NIL THEN ThisClass^.CrProc := ProcpN;                {!12-27-83}
          CurrentProc := ProcpN;

          IF lToken = BEGINSY THEN
            Body(AllBegSys, ProcpN^.Name, ProcStmt)                            {!12-27-83}
          ELSE
            BEGIN
            ProcStmt := NIL;
            IF NOT ConsListing OR NOT Listing THEN
              WriteLn(ShowProcName(CurrClass, ProcpN^.Name, 2)^);
            END;

          IF ThisClass <> NIL THEN
            BEGIN
            BodyCount(ThisClass);
            ThisClass^.WasDeclared := True;
            END;

          IF (Errors = 0) AND CodeFlag THEN
            BEGIN
            AddMethodInfo(ProcStmt, ThisClass, InitProc);                      {!12-27-83}
            IF OptFlag THEN
              IF OptLimFlag THEN                                               {!01-31-84}
                Optimize(ProcStmt, ProcpN)
              ELSE
                GlobalOptimize(ProcStmt, ProcpN);
            RegMask.sMask := [];                                               {!OPT!}
            Dump(ProcStmt, ProcpN, False);                                     {!12-27-83}
            END;

          IF Token = SEMISY THEN
            Scan
          ELSE
            Error(36);

          Release(HeapMark);
          Level := OldLevel;
          Top := OldTop; CurrentProc := OldProc;
          ThisClass := NIL; InitProc := 'No Name!'; CurrClass := '';
          END
        ELSE
          ExitFlag := True;
      UNTIL ExitFlag;

      IF NOT (Token IN [ENDSY] + IdDecBegSys) THEN Skip(22, FSys);             {!01-21-84}

      IF Forwcount > OldForwCount THEN
        BEGIN
        IF ForwChkFlag THEN
          BEGIN                                                                {!10-25-83}
          ForwSearch(Display[Top].NameTree);
          Forwcount := OldForwCount;
          END;
        END;
    END; {ImplPflist}

  PROCEDURE ClassCount;                                                        {!C}

    VAR
      ThisClass: pT;

    BEGIN {ClassCount - this procedure verifies that all classes defined in this
           unit had a method section.}
      ThisClass := NilClassPtr^.TotalOrder;
      WHILE ThisClass <> NIL DO
        WITH ThisClass^ DO
          BEGIN
          IF NOT WasDeclared THEN
            IF ItsId <> NIL THEN NError(806, ItsId^.Name);
          ThisClass := TotalOrder;
          END;
    END; {ClassCount}                                                          {!C}

  PROCEDURE CallUsedUnits(VAR ProcStmt, LastStmt: pStmt);                      {!C 12-14-83}

    VAR
      i, LineNbr: Integer;
      lUnitP: pN;
      NewStmt: pStmt;

    BEGIN {CallUsedUnits - generates calls to all units which have appeared in a
           USES statement}
      IF ProcStmt <> NIL THEN
        LineNbr := ProcStmt^.StmtNumb
      ELSE
        LineNbr := TotalLines;
      IF NOT InUnit THEN
        BEGIN
        New(NewStmt, CALLST);
        WITH NewStmt^ DO
          BEGIN
          NextStmt := ProcStmt; ProcStmt := NewStmt;
          IF LastStmt=NIL THEN LastStmt := NewStmt;
          StmtNumb := LineNbr; StmtOp := CALLST; pArgList := NIL;
          New(ProcpN, IDENTNODE, PROC, DECLARED);
          WITH ProcpN^ DO
            BEGIN
            Name := '%_PGM2  ';
            Class := PROC; Node := IDENTNODE;
            IdType := NIL; Next := NIL; ParmBytes := 0; Lc := 0;
            PFdeclKind := DECLARED; PFdecl := DECL;
            PFargList := NIL; PFlev := 1; RtnNo := - 1;
            END;
          END;
        END;

      lUnitP := UnitList; {chain is in reverse order of USES}

      WHILE lUnitP <> NIL DO
        BEGIN
        IF lUnitP^.HasClasses THEN
          BEGIN
          New(NewStmt, CALLST);
          WITH NewStmt^ DO
            BEGIN
            NextStmt := ProcStmt; ProcStmt := NewStmt;
            IF LastStmt=NIL THEN LastStmt := NewStmt;
            StmtNumb := LineNbr; StmtOp := CALLST; pArgList := NIL;
            New(ProcpN, IDENTNODE, PROC, DECLARED);
            WITH ProcpN^ DO
              BEGIN
              Name := lUnitP^.Name;
              FOR i := 1 TO ALFALEN DO {make name lower case for this special
                                        proc}
                IF Name[i] >= 'A' THEN
                  IF Name[i] <= 'Z' THEN Name[i] := Chr(Ord(Name[i]) + 32);
              Class := PROC; Node := IDENTNODE;
              IdType := NIL; Next := NIL;
              PFdeclKind := DECLARED; PFdecl := DECL;
              PFargList := NIL; ParmBytes := 0; Lc := 0;
              PFlev := 1; RtnNo := - 1;
              END;
            END;
          END;

        lUnitP := lUnitP^.Next;
        END; {while}

      New(NewStmt, CALLST);
      WITH NewStmt^ DO
        BEGIN
        NextStmt := ProcStmt; ProcStmt := NewStmt;
        IF LastStmt=NIL THEN LastStmt := NewStmt;
        StmtNumb := LineNbr; StmtOp := CALLST; pArgList := NIL;
        New(ProcpN, IDENTNODE, PROC, DECLARED);
        WITH ProcpN^ DO
          BEGIN
          IF InUnit THEN
            Name := '%_UNIT  '
          ELSE
            Name := '%_PGM1  ';
          Class := PROC; Node := IDENTNODE;
          IdType := NIL; Next := NIL; ParmBytes := 0; Lc := 0;
          PFdeclKind := DECLARED; PFdecl := DECL;
          PFargList := NIL; PFlev := 1; RtnNo := - 1;
          END;
        END;
    END; {CallUsedUnits}                                                       {!C 12-14-83}

  PROCEDURE InitClasses(VAR ProcStmt, LastStmt: pStmt);                        {!C 12-14-83}

    VAR
      LineNbr: Integer;
      NewStmt: pStmt;
      CurClass: pT;

    BEGIN {InitClasses - generates calls to all the class initialization
           procedures. Calls are generated in topsort order of the subclass tree,
           starting at the topmost superclass.}
      IF ProcStmt <> NIL THEN
        LineNbr := ProcStmt^.StmtNumb
      ELSE
        LineNbr := TotalLines;
      LastStmt := NIL;
      CurClass := NilClassPtr^.TotalOrder;                                     {!C 12-14-83}

      WHILE CurClass <> NIL DO
        BEGIN
        IF CurClass^.NeedsInit THEN
          IF CurClass^.ItsId <> NIL THEN
            IF CurClass^.CrProc <> NIL THEN
              BEGIN
              New(NewStmt, CALLST);
              WITH NewStmt^ DO
                BEGIN
                StmtNumb := LineNbr;
                StmtOp := CALLST;
                ProcpN := CurClass^.CrProc;
                ProcpN^.PFdecl := DECL; {treat as regular call}
                pArgList := NIL;
                END;

              IF LastStmt = NIL THEN
                BEGIN
                NewStmt^.NextStmt := ProcStmt;
                ProcStmt := NewStmt;
                END
              ELSE
                BEGIN
                NewStmt^.NextStmt := LastStmt^.NextStmt;
                LastStmt^.NextStmt := NewStmt;
                END;
              LastStmt := NewStmt;
              END;

        CurClass := CurClass^.TotalOrder;
        END; {while}
    END; {InitClasses}

  PROCEDURE InitUnit(FpN: pN);                                                 {!C 12-14-83}

    VAR
      i: Integer;
      HeapMark: PBoolean;
      OldTop: DispRange;
      OldLevel: LevRange;
      OldProc, UnitpN: pN;
      lStmt, LastStmt: pStmt;

    BEGIN {InitUnit - if a unit is being compiled this proc is called. InitUnit
           generates an extra procedure which will be called by any compilation
           that USES the unit. The generated proc in-turn calls all units which
           the current compilation USES. It also calles the creation procs of all
           classes explicitly declared (i.e., not from USES) in this
           compilation.}
      OldLevel := Level; OldTop := Top; OldProc := CurrentProc;
      IF NOT ConsListing OR NOT Listing THEN
        WriteLn(ShowProcName('', FpN^.Name, 2)^,
                '  Unit Initialization in Segment "', SegName, '"');

      Declarations([], BEGINSY, UnitpN, HeapMark, NIL);
      WITH UnitpN^ DO
        BEGIN
        Name := FpN^.Name;
        FOR i := 1 TO ALFALEN DO {make name lower case for this special proc}
          IF Name[i] >= 'A' THEN
            IF Name[i] <= 'Z' THEN Name[i] := Chr(Ord(Name[i]) + 32);
        RtnNo := -1; {force this proc to be know to the outside world}
        PFdecl := DECL; {known as a garden-variety procedure}
        END;

      ProcStmt := NIL;
      IF ClassesToInit OR UnitsToInit THEN
        BEGIN
        InitClasses(ProcStmt, LastStmt);
        CallUsedUnits(ProcStmt, LastStmt);
        END;

      New(lStmt, LABEDST);
      WITH lStmt^ DO
        BEGIN
        NextStmt := NIL; StmtOp := LABEDST;
        StLab := Display[Level].ExitLabel; LabStmt := NIL;
        END;

      IF ProcStmt = NIL THEN
        BEGIN
        ProcStmt := lStmt; lStmt^.StmtNumb := TotalLines;
        END
      ELSE
        BEGIN
        LastStmt^.NextStmt := lStmt; lStmt^.StmtNumb := LastStmt^.StmtNumb;
        END;
      RegMask.sMask := [];
      Dump(ProcStmt, UnitpN, True);
      Release(HeapMark);
      Level := OldLevel; Top := OldTop; CurrentProc := OldProc;
    END; {InitUnit}                                                            {!C 12-14-83}

  PROCEDURE UnitText(FpN: pN);                                                 {!01-21-84}

    VAR
      fBlock, NumBlocks, i, BlocksUsed: Integer;
      BufStart: Integer; {block # of first block in input buffer}
      LastBufPageStart: Integer; {block # of beginning of last (full) textpage in
                                  input buffer}
      PageStart: Integer;
      LastBlock: Boolean;

    PROCEDURE ZeroLast(LastGoodByte: Integer);

      VAR
        i, LastOnPage: Integer;

      BEGIN {ZeroLast}
        LastOnPage := (LastGoodByte DIV 1024) * 1024 + 1023;
        WHILE (LastGoodByte < LastOnPage) AND (Inbuf[LastGoodByte] <> Chr(13) {
                CR, the EOL character} ) DO
          LastGoodByte := LastGoodByte + 1;
        FOR i := LastGoodByte + 1 TO LastOnPage DO Inbuf[i] := Chr(0);
      END; {zeroLast}

    BEGIN {UnitText - Copy interface source}
      IF Errors = 0 THEN
        BEGIN
        IF ByteNo > 0 THEN
          BEGIN {flush current contents of code buffer}
          BlocksUsed := (ByteNo - 1) DIV 512 + 1;
          IF BlockWrite(ICodeFile, Buff, BlocksUsed, BlockNo) <> BlocksUsed THEN
            FatalOutputError;
          BlockNo := BlockNo + BlocksUsed; ByteNo := 0;
          END;
        fBlock := BlockNo;

        {Copy text block(s) into codefile}
        {Caution, this blasts the filestack mechanism}

        WITH OpenFileStack[TopOfOpenFileStack] DO
          IF FName <> IntFName THEN
            BEGIN
            Close(SrcFile);
            Reset(SrcFile, IntFName);
            IF IOResult > 0 THEN Error(406);
            InbufNumValidBlocks := 0;
            END;
        BufStart := OpenFileStack[TopOfOpenFileStack].LastRelBlkRead;
        LastBufPageStart := BufStart + InbufNumValidBlocks - 2;
        IF (InbufNumValidBlocks = 0) OR (BufStart > FirstUBlock) OR
           (LastBufPageStart < FirstUBlock) OR (Inbuf[0] = Chr(3)) THEN
          BEGIN
          FileSeek(FirstUBlock);
          FillInbuf;
          IF Inbuf[0] = Chr(3) THEN Error(406); {fillinbuf set EOF because it
                                                 couldn't read from file}
          BufStart := OpenFileStack[TopOfOpenFileStack].LastRelBlkRead;
          LastBufPageStart := BufStart + InbufNumValidBlocks - 2;
          END;

        {Point inbufp to beginning of interface in the buffer}
        InbufP := 512 * (FirstUBlock - BufStart) + FirstUByte;
        PageStart := (InbufP DIV 1024) * 1024;

        {Move the data to the beginning of the buffer}
        IF PageStart > 1023 THEN
          BEGIN
          FOR i := PageStart TO InbufLastValidByte DO
            Inbuf[i - PageStart] := Inbuf[i];
          InbufP := InbufP - PageStart;
          InbufNumValidBlocks := InbufNumValidBlocks - (FirstUBlock - BufStart);
          BufStart := FirstUBlock;
          END;

        {Move the data on the first page to the beginning of the page}
        FOR i := InbufP TO 1023 DO Inbuf[i - InbufP] := Inbuf[i];

        {Set 1st byte to indicate whether this unit needs init call}
        IF ClassesToInit OR UnitsToInit THEN Inbuf[0] := Chr(Ord(Inbuf[0]) + 128);

        {Zero the rest of the first page}
        FOR i := 1024 - InbufP TO 1023 DO Inbuf[i] := Chr(0);

       {Write out the interface text, zeroing the unused portion of the last page}
        LastBlock := False;
        REPEAT
          IF LastBufPageStart >= LastUBlock THEN
            BEGIN
            ZeroLast(512 * (LastUBlock - BufStart) + LastUByte);
            InbufNumValidBlocks := LastUBlock - BufStart + 2;
            LastBlock := True;
            END;
          IF BlockWrite(ICodeFile, Inbuf, InbufNumValidBlocks, BlockNo) <>
             InbufNumValidBlocks THEN
            FatalOutputError;
          BlockNo := BlockNo + InbufNumValidBlocks;
          IF NOT LastBlock THEN
            BEGIN
            FillInbuf;
            IF Inbuf[0] = Chr(3) THEN Error(406); {FillInbuf set EOF because it
                                                   couldn't read from file}
            BufStart := OpenFileStack[TopOfOpenFileStack].LastRelBlkRead;
            LastBufPageStart := BufStart + InbufNumValidBlocks - 2;
            END;
        UNTIL LastBlock;

        {Put address and size of text into first record in object file}

        IF BlockRead(ICodeFile, Buff, 1, 0) <> 1 THEN Error(401);
        NumBlocks := BlockNo - fBlock;
        Buff[10] := Chr(fBlock DIV 128);
        Buff[11] := Chr((fBlock * 2) MOD 256);
        Buff[14] := Chr(NumBlocks DIV 128);
        Buff[15] := Chr((NumBlocks * 2) MOD 256);
        Buff[17] := Chr(FpN^.ULc DIV 256);                                     {!01-21-84}
        Buff[18] := Chr(FpN^.ULc MOD 256);                                     {!01-21-84}
        IF BlockWrite(ICodeFile, Buff, 1, 0) <> 1 THEN FatalOutputError;
        ByteNo := 0;
        END;
    END; {UnitText}

  PROCEDURE Prog;

    VAR
      lpN: pN;                                                                 {!C 12-14-83}
      lLc: Integer;                                                            {!C 12-14-83}
      LastStmt: pStmt;                                                         {!C 12-14-83}
      HeapP: PBoolean;                                                         {!DBG!}

    BEGIN {Prog}
      IF (Token <> PROGRAMSY) AND (Token <> UNITSY) THEN
        Skip(41, [PROGRAMSY, UNITSY]);

      IF Token = PROGRAMSY THEN
        BEGIN
        Scan;

        New(lpN, IDENTNODE, PROC, DECLARED);
        WITH lpN^ DO
          BEGIN
          Node := IDENTNODE; Class := PROC; PFdeclKind := DECLARED;
          RtnNo := - 1;
          PFlev := 0; PFdecl := DECL; Lc := 0; ParmBytes := 0;
          Next := NIL;
          PFargList := NIL; Llink := NIL; Rlink := NIL; IdType := NIL;
          END;

        IF Token = IDENTSY THEN
          BEGIN
          lpN^.Name := Ident; ProgName := Ident; Scan;
          IF (Token <> LPARENSY) AND (Token <> SEMISY) THEN
            Skip(23, AllBegSys - [CASESY] + [SEMISY, LPARENSY]);

          IF Token = LPARENSY THEN
            BEGIN
            REPEAT
              Scan;
              IF Token = IDENTSY THEN
                Scan
              ELSE
                Error(29);
              IF (Token <> RPARENSY) AND (Token <> COMMASY) THEN
                Skip(20, AllBegSys - [CASESY] + [COMMASY, RPARENSY, USESSY]);
            UNTIL Token <> COMMASY;

            IF Token = RPARENSY THEN
              Scan
            ELSE
              Error(32);
            END;

          IF Token = SEMISY THEN
            Scan
          ELSE
            Error(36);
          END
        ELSE
          BEGIN
          lpN^.Name := 'No name!';
          Skip(29, AllBegSys - [CASESY] + [USESSY]);
          END;

        REPEAT
          Declarations(AllBegSys - [CASESY, METHSY] + [USESSY], PROGRAMSY,     {!6-17-83}
                       lpN, HeapMark, NIL);
          CurrentProc := lpN;

          REPEAT                                                               {!01-21-84}
            PFList(AllBegSys - [CASESY, METHSY]);                              {!01-21-84}
            IF Token IN IdDecBegSys THEN                                       {!01-21-84}
               Declarations(AllBegSys - [CASESY, METHSY], Token, lpN,          {!01-21-84}
                            HeapMark, NIL);                                    {!01-21-84}
          UNTIL NOT (Token IN DecBegSys);                                      {!01-21-84}

          IF Token = BEGINSY THEN
            BEGIN
            LeftCheck; Scan;
            END
          ELSE
            Error(43);

          REPEAT
            Body(AllBegSys, lpN^.Name, ProcStmt);
            IF Token <> PERIODSY THEN Skip(51, AllBegSys - [CASESY]);
            SegName := '        ';
            IF (Errors = 0) AND CodeFlag THEN
              BEGIN
              IF OptFlag THEN
                IF OptLimFlag THEN                                             {!01-31-84}
                  Optimize(ProcStmt, lpN)
                ELSE
                  GlobalOptimize(ProcStmt, lpN);
              IF DebugOpen OR DebugDebug THEN                                  {!DBG!}
                WITH Display[Top] DO DumpSyms(ProcBase, NameTree, ProcStmt, lpN);{!DBG!}
              RegMask.sMask := [];                                             {!OPT!}

              IF UnitsToInit THEN                                              {!C 12-14-83}
                BEGIN {explicit $CLASSES directives in source}                 {!C 12-14-83}
                CallUsedUnits(ProcStmt, LastStmt);                             {!C 12-14-83}
                Dump(ProcStmt, lpN, True);                                     {!C 12-14-83}
                END                                                            {!C 12-14-83}
              ELSE                                                             {!C 12-14-83}
                Dump(ProcStmt, lpN, False);                                    {!12-20-83}
              END;
          UNTIL (Token = PERIODSY) OR (Token IN BlockBegSy);
        UNTIL Token = PERIODSY;

        IF CondStack[CondTos] <> NULL THEN Error(267);
        {For host programs, dump level 0 symbols, if any}                      {!DBG!}
        Release(Display[1].ProcBase);                                          {!DBG!}
        Top := 0;                                                              {!DBG!}
        IF (Errors = 0) AND CodeFlag AND (DebugOpened OR DebugDebug) THEN      {!DBG!}
          BEGIN                                                                {!DBG!}
          WITH Display[0] DO DumpSyms(ProcBase, NameTree, NIL, NIL);           {!DBG!}
          DbgOut2(0);                                                          {!DBG!}
          END;                                                                 {!DBG!}

        Scan;
        Out(255 {ENDCODE} );
        END
      ELSE {UNIT}
        BEGIN
        Scan;
        InUnit := True;
        NumUnits := 1; Level := - 1;

        New(lpN, IDENTNODE, UNITS);
        WITH lpN^ DO
          BEGIN
          Node := IDENTNODE; Class := UNITS; Ulev := - 1; ULc := 0;
          Llink := NIL; Rlink := NIL; Next := NIL; IdType := NIL;
          Ukind := REGUNIT;                                                    {!IU!}
          HasClasses := False;                                                 {!12-20-83}
          END;
        UnitList := lpN;

        IF Token = IDENTSY THEN
          BEGIN
          lpN^.Name := Ident; ProgName := Ident; Scan;
          END
        ELSE
          BEGIN
          lpN^.Name := 'No name!';
          Skip(29, AllBegSys - [CASESY] + [SEMISY, INTRINSY, USESSY, INTERSY,
               IMPLESY]);                                                      {!IU!}
          END;

        IntFName := OpenFileStack[TopOfOpenFileStack].FName;
        FirstUBlock := OpenFileStack[TopOfOpenFileStack].LastRelBlkRead + 2 *
                       (InbufP DIV 1024);
        FirstUByte := InbufP MOD 1024;

        IF Token = SEMISY THEN
          Scan
        ELSE
          Error(36);

        IF Token = INTERSY THEN
          Scan                                                                 {!IU!}
        ELSE IF Token <> INTRINSY THEN Error(53);                              {!IU!}

        Declarations(AllBegSys - [CASESY], UNITSY, lpN, HeapMark, NIL);

        IF Errors = 0 THEN Dump(NIL, lpN, False);                              {!12-20-83}

        REPEAT                                                                 {!01-21-84}
          ImplPFList(AllBegSys - [CASESY]);                                    {!01-21-84}
          IF Token IN IdDecBegSys THEN                                         {!01-21-84}
            Declarations(AllBegSys - [CASESY] + [ENDSY], Token, lpN,           {!01-21-84}
                         HeapMark, NIL);                                       {!01-21-84}
        UNTIL NOT (Token IN DecBegSys + [METHSY]);                             {!01-21-84}

        ClassCount;                                                            {!C}

        IF Forwcount <> 0 THEN
          BEGIN
          IF ForwChkFlag THEN
            BEGIN                                                              {!10-25-83}
            ForwSearch(Display[Top].NameTree);
            Forwcount := 0;
            END;
          END;

        IF Token = ENDSY THEN
          Scan
        ELSE
          Error(44);

        IF Token <> PERIODSY THEN Error(51);

        IF ClassesToInit OR UnitsToInit THEN InitUnit(lpN);                    {!C 12-14-83}

        IF CondStack[CondTos] <> NULL THEN Error(267);
        IF Errors = 0 THEN                                                     {!DBG!}
          IF DebugOpen OR DebugDebug THEN                                      {!DBG!}
            BEGIN                                                              {!DBG!}
            WITH Display[Top] DO DumpSyms(ProcBase, NameTree, NIL, lpN);       {!DBG!}
            {Don't dump level 0 symbols for UNITS}                             {!DBG!}
            DbgOut2(0);                                                        {!DBG!}
            END;                                                               {!DBG!}

        Scan;
        Out(255 {ENDCODE} );
        UnitText(lpN);                                                         {!01-21-84}
        END;
    END; {Prog}

  {$S OPT1}

  PROCEDURE LoadOPt1;

    BEGIN {LoadOPt1} {$R OPTIMIZE}
      Prog;
    END; {LoadOPt1}

  {$S OPT2}

  PROCEDURE LoadOPt2;

    BEGIN {LoadOPt2} {$R GLOBALOPTIMIZE}
      Prog;
    END; {LoadOPt2}

  {$S DUMP}

  PROCEDURE LoadDump;

    BEGIN {LoadDump} {$R DUMP}
      IF OptFlag THEN
        IF OptLimFlag THEN
          LoadOPt1
        ELSE
          LoadOpt2
      ELSE
        Prog;
    END; {LoadDump}

  {$S DEBUG}                                                                   {!DBG!}

  PROCEDURE LoadDebug;                                                         {!DBG!}

    BEGIN {LoadDebug} {$R DUMPSYMS}                                            {!DBG!}
      LoadDump;                                                                {!DBG!}
    END; {LoadDebug}                                                           {!DBG!}

  {$S DECL}

  PROCEDURE LoadDecl;

    BEGIN {LoadDecl} {$R DECLARATIONS}
      LoadDebug;                                                               {!DBG!}
    END; {LoadDecl}

  {$S BODY2}

  PROCEDURE LoadBdy2;

    BEGIN {LoadBdy2} {$R BODY2}
      LoadDecl;
    END; {LoadBdy2}

  {$S BODY1}

  PROCEDURE LoadBdy1;

    BEGIN {LoadBdy1} {$R BODY1}
      LoadBdy2;
    END; {LoadBdy1}

  {$S CONST}

  PROCEDURE LoadConst;

    BEGIN {LoadConst} {$R CONST}
      LoadBdy1;
    END; {LoadConst}

  {$S }

  PROCEDURE Finalize;

    VAR
      i, BlocksUsed: Integer;

    PROCEDURE Summarize;

      VAR
        Line: String[80];

      BEGIN {Summarize}
        IF Aborted THEN
          Line := 'Compilation aborted - '
        ELSE
          Line := 'Compilation complete - ';

        IF Errors = 0 THEN
          Line := Concat(Line, 'no error')
        ELSE
          Line := Concat(Line, PutIntP(Errors, 0)^, ' error');

        IF Errors <> 1 THEN
          Line := Concat(Line, 's found.  ')
        ELSE
          Line := Concat(Line, ' found.  ');

        Line := Concat(Line, PutIntP(TotalLines - 1, 0)^, ' lines.');

        IF Listing THEN
          BEGIN
          PutcF(ListingFCBP, IONewline); PutLineP(ListingFCBP, @Line);
          END;

        IF NOT ConsListing THEN
          BEGIN
          WriteLn; WriteLn(Line);
          END;

        IF ErrFileOpen THEN
          BEGIN
          WriteLn(ErrFile); WriteLn(ErrFile, Line);
          END;
      END; {Summarize}

    PROCEDURE ChainToEdOrGen;                                                  {!03-06-84}

      VAR
        i: Integer;
        Ok: Boolean;
        Msg: SUStr;

      BEGIN {ChainToEdOrGen}
        IF Errors = 0 THEN
          BEGIN {no errors, if allowed call, setup to auto load the code generator}
          IF CallGen THEN
            BEGIN
            PCReWrite(PCText, 'For Code Gen');
            Ok := PCPutLine(ICodeName);
            IF Ok THEN Ok := PCPutLine(ObjName);
            IF Ok THEN Ok := PCPutLine('$I+');
            IF Ok THEN IF AsmOnly THEN Ok := PCPutLine('$ASM ONLY');
            IF Ok THEN IF AsmProc THEN Ok := PCPutLine('$ASM PROC');
            IF Ok THEN IF SaveA2D3 THEN Ok := PCPutLine('$A+');
            IF Ok THEN IF MacFlag THEN Ok := PCPutLine('$M+');
            Ok := Ok AND PCClose(False, 'For Code Gen');
            IF Ok THEN
              PCSetRunCmd(Gcmd)
            ELSE
              BEGIN
              KillExec;
              WriteLn;
              WriteLn(SuBell, 'Cannot communicate with the Code Generator.');
              END;
            END;
          END {auto load}
        ELSE IF ErrFileOpen AND CallEditor THEN
          BEGIN {errors, if allowed prepare to pass error log file to the editor}
          PCReWrite(PCText, 'For Editor');
          For i := 1 TO ALFALEN DO Msg[i] := ProgName[i];
          Msg[0] := Chr(ALFALEN);
          Msg := Concat('Errors in ', Msg);
          i := Length(Msg);
          IF i < 95 THEN
            BEGIN {fake out the editor}
            REPEAT
              i := i + 1; Msg[i] := ' ';
            UNTIL i >= 95;
            Msg[0] := Chr(95);
            END;
          Ok := PCPutLine(Msg);
          IF Ok THEN
            BEGIN
            Ok := PCPutLine(ErrFName);
            IF Ok THEN Ok := PCPutLine('* 1 1 1 1');
            END;
          Ok := Ok AND PCClose(False, 'For Editor');
          IF Ok THEN
            PCSetRunCmd(Ecmd)
          ELSE
            BEGIN
            KillExec;
            WriteLn(SUBell, 'Unable to set up communication to the Editor.');
            END;
          END; {passing error log info to editor}
      END; {ChainToEdOrGen}

    BEGIN {Finalize}
      IF CodeOpened THEN
        BEGIN
        IF (ByteNo > 0) AND (Errors = 0) THEN
          BEGIN
          BlocksUsed := (ByteNo - 1) DIV 512 + 1;
          IF BlockWrite(ICodeFile, Buff, BlocksUsed, BlockNo) <> BlocksUsed THEN
            FatalOutputError;
          END;
        IF Errors = 0 THEN
          Close(ICodeFile, Lock)
        ELSE
          Close(ICodeFile, PURGE);
        CodeOpened := False;
        END;

      Summarize;

      IF NOT Aborted THEN ChainToEdOrGen;                                      {!03-06-84}

      IF ListOpen THEN CloseF(ListingFCBP, IOLock);

      IF MsgFileOpen THEN Close(MsgFile);

      IF ErrFileOpen THEN
        BEGIN
        Close(ErrFile, Lock); ErrFileOpen := False;
        END;

      FOR i := TopOfOpenFileStack DOWNTO 1 DO Close(OpenFileStack[i].SrcFile);

      IF DebugOpen THEN                                                        {!DBG!}
        BEGIN                                                                  {!DBG!}
        IF DbgIdx > 0 THEN                                                     {!DBG!}
          BEGIN                                                                {!DBG!}
          FOR i := DbgIdx TO 511 DO DbgBuf[i] := Chr(0);                       {!DBG!}
          IF BlockWrite(DebugFile, DbgBuf, 1, DbgBlkNum) <> 1 THEN             {!DBG!}
            Error(420);                                                        {!DBG!}
          END;                                                                 {!DBG!}
        IF Errors = 0 THEN                                                     {!DBG!}
          Close(DebugFile, LOCK)                                               {!DBG!}
        ELSE                                                                   {!DBG!}
          Close(DebugFile, PURGE);                                             {!DBG!}
        DebugOpen := False;                                                    {!DBG!}
        END;                                                                   {!DBG!}
                                                                               {!DBG!}
      IF DebugDebug THEN                                                       {!DBG!}
        BEGIN                                                                  {!DBG!}
        Close(Debugging, Lock); DebugDebug := False;                           {!DBG!}
        END;                                                                   {!DBG!}

      EndIO;
      SUDone;
    END; {Finalize}

  {$S SCAN}

  PROCEDURE CallProg;

    BEGIN {CallProg}
      Scan;
      IF SwapFlag THEN
        Prog
      ELSE
        LoadConst;
      IF Token <> EOFSY THEN Error(17);
    END; {CallProg}

