  (*$p**************************************************************************)
  (*                                                                           *)
  (*                          File: CODE.1.TEXT                                *)
  (*                                                                           *)
  (*              (C) Copyright 1981 Silicon Valley Software, Inc.             *)
  (*                            1983, 1984 Apple Computer, Inc.                *)
  (*                                                                           *)
  (*                            All rights reserved.               18-Jul-82   *)
  (*                                                                           *)
  (* 09-23-83 Getreg: SaveA2D3 stuff to monitor use of A2, D3                  *)
  (* 02-02-84 CodError: added call to SUErrText to show error message text     *)
  (*****************************************************************************)
  {[j=0/0/80!,i=1]}
  {$S }

  PROCEDURE KillExec;

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

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

  PROCEDURE CodError(N: Integer);

    VAR
      Loc: LongInt;
      WhatUserTyped: PromptState;
      Msg: SUStr;

    BEGIN
      KillExec;
      SUErrText('PasErrs.Err', N, @Msg);
      Errors := Errors + 1;
      WriteLn;
      WriteLn(SUBell, '*** Within ', UserPNam, ' (Error ', N: 1, '): ', Msg,
              ' ***');
      GetObjPtr(OutFile, Loc);
      WriteLn('IC = ', Ic: 1, ', IN = ', InBlock: 1, ':', InByte: 1, ', OUT = ',
              (Loc DIV 512): 1, ':', (Loc MOD 512): 1);
      SUWaitEscOrSp(WhatUserTyped);
      IF WhatUserTyped = SUEscape THEN
        BEGIN
        Aborted := True;
        GOTO 999;
        END;
      WriteLn; FirstOnCons := False;
    END; {CodError}

  {S MakeList}

  PROCEDURE VerifyId(OrigId: Alfa8; VAR UsableId: AlfaStr);

    VAR
      i: Integer;
      Ch: Char;

    FUNCTION IsOpcode(VAR Id: Alfa8): Boolean;

      VAR
        p: pOpcode;

      BEGIN {IsOpcode - checks to see if an id is an Assembler opcode}
        IF AsmOnly THEN
          BEGIN
          p := OpcodeTbl;
          IF p <> NIL THEN
            REPEAT
              IF p^.Opcode = Id THEN
                BEGIN
                IsOpcode := True; Exit(IsOpcode);
                END;
              IF p^.Opcode < Id THEN
                p := p^.Rlink
              ELSE
                p := p^.Llink;
            UNTIL p = NIL;
          END;

        IsOpcode := False;
      END; {IsOpcode}

    BEGIN {VerifyId - if AsmOnly then make sure the OrigId does not conflict with
           any Assembler opcodes. If it does, modify the name. Return the name as
           a string in UsableId.}
      i := 1; Ch := OrigId[1];
      REPEAT
        UsableId[i] := Ch;
        i := i + 1;
        IF i > ALFALEN THEN
          Ch := ' '
        ELSE
          Ch := OrigId[i];
      UNTIL Ch = ' ';

      IF i <= ALFALEN THEN
        IF IsOpcode(OrigId) THEN
          REPEAT
            UsableId[i] := '%'; i := i + 1;
          UNTIL i > ALFALEN;

      UsableId[0] := Chr(i - 1);
    END; {VerifyId}

  PROCEDURE MakeGlobalLbl(LinkName: Alfa8; VAR Lbl: AlfaStr);

    VAR
      i: Integer;

    BEGIN {MakeGlobalLbl - construct a global lable from the internal $xxxxxxxx
           label link name}
      Lbl:= 'Gxxxxxx%';
      FOR i := 2 TO ALFALEN - 1 DO Lbl[i] := LinkName[i];
    END; {MakeGlobalLbl}

  PROCEDURE LkUp(Lc, Dest: LongInt; VAR Name: AlfaStr);

    VAR
      pL: pProcRef;
      lInt: pIntList;
      i: Integer;
      l: LongInt;

    BEGIN {Lkup - this routine is only used by the DisAssembler, but that routine
           requires that LkUp be a level 1 proc.}
      LkUpCalled := True;
      l := Ord(@CodeBuff[0]);
      i := Lc - l;
      pL := SavedPL;
      WHILE pL <> NIL DO
        WITH pL^ DO
          BEGIN
          lInt := RefList;
          WHILE lInt <> NIL DO
            BEGIN
            IF i = lInt^.Int - Delta[lInt^.Int DIV 2] THEN
              BEGIN
              IF UserName[1] <> '*' THEN
                VerifyId(UserName, Name)
              ELSE
                MakeGlobalLbl(LinkName, Name);
              Substituted := True;
              END;
            lInt := lInt^.Next;
            END;
          pL := Next;
          END;
    END; {Lkup}

  PROCEDURE MakeHex(Value: LongInt; Width: Integer; VAR HexStr: AlfaStr);

    TYPE
      Cheat = RECORD
                CASE Boolean OF
                  False:
                    (Long: LongInt);
                  True:
                    (N: PACKED ARRAY [0..7] OF 0..15);
              END;

    VAR
      X: Cheat;
      i: Integer;
      Ch: PACKED ARRAY [0..7] OF Char;

    BEGIN {MakeHex}
      HexStr[0] := Chr(0);
      IF Width > 0 THEN
        WITH X DO
          BEGIN
          Long := Value;
          IF Width > 8 THEN Width := 8;
          IF Width < 1 THEN Width := 1;
          FOR i := 8 - Width TO 7 DO
            IF Odd(i) THEN
              Ch[i - 8 + Width] := Hex[N[i - 1] + 1]
            ELSE
              Ch[i - 8 + Width] := Hex[N[i + 1] + 1];
          HexStr[0] := Chr(Width);
          FOR i := 1 TO Width DO HexStr[i] := Ch[i - 1];
          END;
    END; {MakeHex}

  PROCEDURE ListLine(Loc: Integer; VAR LineNumber: LongInt; VAR Line: SUStr;
                     ShowingAsm: Boolean);

    VAR
      Col1, Col5, Col6, Col17, Len, i: Integer;
      Ch: Char;
      X: AlfaStr;

    BEGIN {ListLine - this code is sensitive to the listing format produced by the
           compiler. Ignoring ejects, the total line number field is cols 1 to 5,
           and the file line number field is cols 10 to 13. The lex info is in
           cols 15 to 18 and blank for conditionally skipped statements.}
      IF XpAbortFlag THEN
        BEGIN
        Aborted := True;
        GOTO 999;
        END;

      Col1 := 1; Len := Length(Line);
      WHILE (Col1 < Len) AND (Line[Col1] = Chr(12)) DO Col1 := Col1 + 1;
      Col5 := Col1 + 4; {must be changed if the compiler chages its format!}

      IF Col5 <= Len THEN
        Ch := Line[Col5]
      ELSE
        Ch := ' ';

      IF (Ch >= '0') AND (Ch <= '9') THEN
        BEGIN
        LineNumber := 0; i := Col5 - 4;
        REPEAT
          Ch := Line[i];
          IF Ch >= '0' THEN
            IF Ch <= '9' THEN LineNumber := LineNumber * 10 + Ord(Ch) - Ord('0');
          i := i + 1;
        UNTIL i > Col5;

        IF AsmOnly THEN
          Line := Concat(';', Copy(Line, 19, Length(Line) - 18))
        ELSE
          BEGIN
          IF ShowingAsm THEN
            Insert('       ', Line, Col1 + 19)
          ELSE IF Line[Col1 + 14] = ' ' THEN
            Insert('       ', Line, Col1 + 19) {conditionally skipped line}
          ELSE
            BEGIN
            MakeHex(Loc, 6, X); X := Concat(X, ' ');
            Insert(X, Line, Col1 + 19); {there could be eject(s) before col 1}
            END;
          END;

        PutLineP(ListFile, @Line);
        END
      ELSE IF NOT AsmOnly THEN
        IF FirstLine THEN
          BEGIN
          FirstLine := False;
          IF Pos('Lisa Pascal Compiler', Line) = 1 THEN
            BEGIN
            PutLineP(ListFile, @Line);
            PutStrS(ListFile, Concat(TITLE, VERSION), 0);
            PutStrS(ListFile, ' ', 79 - Length(TITLE) - Length(VERSION) -
                    Length(DateStr));
            PutLineP(ListFile, @DateStr);
            END
          ELSE
            BEGIN
            IF Pos('Elapsed', Line) = 1 THEN Insert('compilation ', Line, 9);
            PutLineP(ListFile, @Line);
            END;
          END
        ELSE
          BEGIN
          IF Pos('Elapsed', Line) = 1 THEN Insert('compilation ', Line, 9);
          PutLineP(ListFile, @Line);
          END;
    END; {ListLine}

  PROCEDURE MakeListing;

    TYPE
      LblKinds = (NormalLbl, SetLbl, PkdLbl, StrLbl, NoLbl);

    VAR
      i, NextI, BytsUsed, Last, CaseLbl, IcDIV2, SizeIndex: Integer;
      DoingCase: Boolean;
      LblKind: LblKinds;
      Name: Alfa8;
      CaseLabel, Lbl: AlfaStr;
      Line: SUStr;

    PROCEDURE PrntHex(Value: LongInt; Width: Integer);

      VAR
        X: AlfaStr;

      BEGIN {PrntHex}
        MakeHex(Value, Width, X); PutStrS(ListFile, X, 0);
      END; {PrntHex}

    PROCEDURE SetupLbl(LblNbr: Integer; VAR Lbl: AlfaStr; Var LblKind: LblKinds);

      BEGIN {SetupLbl - prepare a label from its nbr}
        IF LblNbr < 8000 THEN
          BEGIN
          Lbl := 'L'; LblKind := NormalLbl;
          END
        ELSE
          BEGIN
          Lbl := 'Cst';
          IF LblNbr < 16000 THEN
            BEGIN
            LblKind := SetLbl; LblNbr := LblNbr - 8000;
            END
          ELSE IF LblNbr < 24000 THEN
            BEGIN
            LblKind := PkdLbl; LblNbr := LblNbr - 16000;
            END
          ELSE {LblNbr < 32000}
            BEGIN
            LblKind := StrLbl; LblNbr := LblNbr - 24000;
            END;
          END;

        Lbl := Concat(Lbl, PutIntP(LblNbr, - 4)^);
      END; {SetupLbl}

    PROCEDURE DisAss1Line(Index: Integer; Name: Alfa8; p: pBuf;
                          VAR BytesUsed: Integer);

      VAR
        i, j, OpndLen, BytesShown: Integer;
        InstLoc, OpndLoc, Temp: LongInt;
        Inline: Boolean;
        Ch: Char;
        LblKind, TempKind: LblKinds;
        X, Y, Opnd: AlfaStr;
        Lbl, TempLbl: AlfaStr;
        Opcode, Operand: Str80;

      PROCEDURE DefineGlobalLbl(InstLoc: LongInt);

        VAR
        lpULab: pUserLabel;
        lpILab: pLabelRec;
        LinkName: Alfa8;
        Lbl: AlfaStr;

        BEGIN {DefineGlobalLbl - if AsmOnly mode then check to see if a global
               label needs to be defined at the current InstLoc.}
          lpULab := ULabelList;
          WHILE lpULab <> NIL DO
            BEGIN
            WITH lpULab^ DO
              IF LinkerNo >= 0 THEN
                BEGIN
                lpILab := LookUpILabel(IntNo);
                IF InstLoc = (lpILab^.Loc - Delta[lpILab^.Loc DIV 2]) THEN
                  BEGIN
                  MakeLName(LinkerNo, LinkName);
                  MakeGlobalLbl(LinkName, Lbl);
                  PutLineS(ListFile, Concat('         .DEF    ', Lbl));
                  PutLineP(ListFile, @Lbl);
                  Exit(DefineGlobalLbl);
                  END;
                END;
            lpULab := lpULab^.Next;
            END;
        END; {DefineGlobalLbl}

      PROCEDURE DumpHex(VAR BytesShown: Integer);

        VAR
          i: Integer;

        BEGIN {DumpHex - dump up to 6 bytes of instruction}
          FOR i := 0 TO 5 DO
            BEGIN
            IF BytesShown < BytesUsed THEN
              PrntHex(p^[BytesShown], 2)
            ELSE
              PutStrS(ListFile, '  ', 0);
            IF Odd(BytesShown) THEN PutcF(ListFile, ' ');
            BytesShown := BytesShown + 1;
            END;
        END; {DumpHex}

      PROCEDURE ConvertHexConstants(VAR Operand: Str80);

        VAR
          First, Last, ValuLen, i, k: Integer;
          Valu: LongInt;
          Ch: Char;
          Stop: Boolean;

        BEGIN {ConvertHexConstants - converts all $xxx... hex constants in a
               disassembled operand to decimal. This is only done if AsmOnly is
               true to generate assmebly source. The stupid assembler can't
               handle operands containing certain hex values! (#!@#^%&*)}
          i := Pos(';', Operand);
          IF i > 0 THEN Operand[0] := Chr(i - 1);
          SUTrimBlanks(@Operand);
          Operand := Concat(Operand, ' ');

          First := Pos('$', Operand);
          WHILE First > 0 DO
            BEGIN
            Valu := 0; Stop := False;
            Last := First + 1;
            REPEAT
              Ch := Operand[Last];
              IF (Ch >= '0') AND (Ch <= '9') THEN
                Valu := Valu * 16 + Ord(Ch) - Ord('0')
              ELSE IF (Ch >= 'A') AND (Ch <= 'F') THEN
                Valu := Valu * 16 + Ord(Ch) - Ord('A') + 10
              ELSE
                Stop := True;
              IF NOT Stop THEN Last := Last + 1;
            UNTIL Stop;

            ValuLen := Last - First;
            IF ValuLen < 6 THEN
              BEGIN {treat values less or equal to $FFFF as 16-bit integers}
              i := Valu; {cram 32-bit integer into 16-bit integer}
              Valu := i; {this should cause sign extension for neg nbrs}
              END;

            Delete(Operand, First, ValuLen);
            Insert(PutIntP(Valu, 0)^, Operand, First);

            First := Pos('$', Operand);
            END; {while}

          SUTrimBlanks(@Operand);
        END; {ConvertHexConstants}

      PROCEDURE RefToLbl(LblNbr: Integer; VAR Operand: Str80);

        VAR
          i: Integer;
          LblKind: LblKinds;
          Lbl: AlfaStr;
          Opnd, Comment: Str80;

        BEGIN {RefToLbl - operand has a label reference so edit it to the reference}
          i := Pos(';', Operand); {for safety, split the operand and comment}
          IF i = 0 THEN
            BEGIN
            Opnd := Operand; Comment := '';
            END
          ELSE
            BEGIN
            Opnd := Copy(Operand, 1, i - 1);
            SUTrimBlanks(@Opnd);
            Comment := Copy(Operand, i, Length(Operand) - i + 1);
            END;

          SetupLbl(LblNbr, Lbl, LblKind);

          i := Pos('(', Opnd);
          IF i = 0 THEN
            BEGIN
            i := Pos(',', Opnd);
            IF i = 0 THEN
              Opnd := Lbl
            ELSE
              BEGIN {opnd is of form x...,reg so replace x... with lbl}
              Delete(Opnd, 1, i - 1);
              Opnd := Concat(Lbl, Opnd);
              END;
            END
          ELSE
            BEGIN {opnd is of form x...(y...) so replace x... with lbl}
            Delete(Opnd, 1, i - 1);
            Opnd := Concat(Lbl, Opnd);
            END;

          i := 16 - Length(Opnd);
          IF i > 0 THEN Opnd := Concat(Opnd, Copy('                ', 1, i));
          Operand := Concat(Opnd, Comment);
        END; {RefToLbl}

      PROCEDURE InsertProcHdr;

        VAR
          i: Integer;
          pL: pProcRef;
          NameStr: AlfaStr;

        BEGIN {InsertProcHdr - for AsmOnly, generate start of a new proc}
          PutLineS(ListFile, ';');

          IF CurrSeg <> PrevSeg THEN
            BEGIN
            PutLineS(ListFile, Concat('         .SEG    ''', CurrSeg, ''''));
            PrevSeg := CurrSeg;
            END;

          IF Funct THEN
            PutStrS(ListFile, '         .FUNC   ', 0)
          ELSE IF ProcLvl <> 1 THEN
            PutStrS(ListFile, '         .PROC   ', 0)
          ELSE
            PutStrS(ListFile, '         .MAIN   ', 0);
          VerifyId(Name, NameStr);
          PutLineP(ListFile, @NameStr);

          IF SavedPL <> NIL THEN
            BEGIN
            pL := SavedPL;
            PutLineS(ListFile, ';');
            REPEAT
              WITH pL^ DO
                BEGIN
                PutStrS(ListFile, '         .REF    ', 0);
                IF UserName[1] <> '*' THEN
                  VerifyId(UserName, NameStr)
                ELSE
                  MakeGlobalLbl(LinkName, NameStr);
                PutLineP(ListFile, @NameStr);
                pL := Next;
                END;
            UNTIL pL = NIL;
            PutLineS(ListFile, ';');
            END;
        END; {InsertProcHdr}

      BEGIN {DisAss1Line }
        InstLoc := Index + Index;

        Lbl[0] := Chr(0);
        IF pLblDef^[Index] <> 0 THEN
          SetupLbl(ABS(pLblDef^[Index]), Lbl, LblKind)
        ELSE IF Index = 0 THEN
          IF NOT AsmOnly THEN
            BEGIN
            Lbl[0] := Chr(ALFALEN);
            FOR i := 1 TO ALFALEN DO Lbl[i] := Name[i];
            END;

        IF pLineNumber^[Index] >= 0 THEN
          BEGIN
          Substituted := False; LkUpCalled := False; {set only by LkUp}
          Disassembler( - Ord(p) + InstLoc, NIL, BytesUsed, p^, Opcode, Operand,
                       @LkUp);
          IF AsmOnly THEN
            BEGIN
            ConvertHexConstants(Operand);
            IF NOT LkUpCalled THEN
              IF Opcode = 'JMP' THEN
                IF Operand = '0' THEN
                  BEGIN
                  LkUp(Ord(@CodeBuff[Index + 1]), 0, Opnd);
                  IF Substituted THEN Operand := Opnd;
                  END;
            END;
          i := Pos(';', Operand);
          IF i > 0 THEN IF Substituted THEN Operand[0] := Chr(i - 1);
          IF pLblRef^[Index] <> 0 THEN RefToLbl(ABS(pLblRef^[Index]), Operand);
          Inline := False; DoingCase := False;
          END
        ELSE
          BEGIN {Inline code or case list}
          Inline := True;
          BytesUsed := 2;
          Opcode := '.WORD';
          IF pLblRef^[Index] < 0 THEN
            BEGIN {case label reference}
            IF NOT DoingCase THEN
              BEGIN {1st entry of a case table}
              DoingCase := True; {set false at end of table}
              CaseLbl := CaseLbl + 1;
              CaseLabel := Concat('Case', PutIntP(CaseLbl, 1)^);
              Lbl := CaseLabel;
              END; {1st entry}
            SetupLbl(Abs(pLblRef^[Index]), TempLbl, TempKind);
            Operand := Concat(TempLbl, '-', CaseLabel, '+2');  {"Lxxx-CaseLbl+2"}
            END {case setup}
          ELSE
            BEGIN {Inline code}
            MakeHex(p^[0], 2, X); MakeHex(p^[1], 2, Y);
            Operand := Concat('$', X, Y);
            DoingCase := False;
            END; {Inline setup}
          END; {Inline fudge}

        IF AsmOnly THEN
          BEGIN
          IF Index = 0 THEN InsertProcHeader;
          DefineGlobalLbl(InstLoc);
          END
        ELSE
          BEGIN
          PutStrS(ListFile, ' ', 19);
          PrntHex(InstLoc, 6); PutcF(ListFile, ' ');
          BytesShown := 0;
          DumpHex(BytesShown);
          END;

        PutStrS(ListFile, Lbl, - (ALFALEN + 1));
        PutStrP(ListFile, @Opcode, - ALFALEN);
        PutLineP(ListFile, @Operand);

        IF NOT AsmOnly THEN
          IF BytesShown < BytesUsed THEN
            REPEAT {show remaining bytes on next line}
              PutStrS(ListFile, ' ', 19);
              PrntHex(InstLoc + BytesShown, 6); PutcF(ListFile, ' ');
              DumpHex(BytesShown);
              PutcF(ListFile, IONewline);
            UNTIL BytesShown >= BytesUsed;

        IF NOT Inline THEN
          IF p^[1] = $FF95 THEN {note, the $FF is because of sign-extension}
            IF p^[0] = $4E THEN
              BEGIN {$4E95 ==> JSR (A5) ==> Method call ==> treat specially}
              IF AsmOnly THEN
                PutStrS(ListFile, '         .BYTE   ', 0)
              ELSE
                BEGIN
                PutStrS(ListFile, ' ', 19);
                PrntHex(Index + Index + 2, 6); PutcF(ListFile, ' ');
                PrntHex(p^[2], 2); PutcF(ListFile, ' '); PrntHex(p^[3], 2);
                PutStrS(ListFile, '.BYTE   ', 27);
                END;
              PutcF(ListFile, '$'); PrntHex(p^[2], 2); PutcF(ListFile, ',');
              PutcF(ListFile, '$'); PrntHex(p^[3], 2);
              PutLineS(ListFile, '         ; lev#, proc#');
              BytesUsed := BytesUsed + 2;
              END; {$4E95}
      END; {DisAss1Line }

    PROCEDURE DumpData(Index: Integer; p: pBuf; VAR BytesUsed: Integer);

      VAR
        i, k, l, BytesShown, ChunkSize: Integer;
        InstLoc: LongInt;
        Ascii: Boolean;
        Quote, Ch: Char;
        Lbl: AlfaStr;
        LblKind: LblKinds;
        Comment: Str80;

      PROCEDURE GetChunk(BytesShown: Integer; VAR ChunkSize: Integer;
                         VAR Quote: Char);

        VAR
          MaxChunk, Remaining, i: Integer;
          FirstQuote: Boolean;
          Ch: Char;

        BEGIN {GetChunk - determine max nbr of bytes we can show on one line.
               Ascii strings must be treated carefully because of quotes.}
          IF AsmOnly THEN
            IF Ascii THEN
              MaxChunk := 58 {max str chunk "<58 chars>" }
            ELSE
              MaxChunk := 22 {max set chunk $1234,... 22 bytes, or 11 $xxxx's}
          ELSE
            MaxChunk := 6; {if not AsmOnly max any chunk is 6 bytes}

          Remaining := BytesUsed - BytesShown;
          IF Remaining > MaxChunk THEN
            ChunkSize := MaxChunk
          ELSE
            ChunkSize := Remaining;

          IF Ascii THEN
            BEGIN {see if Chunksize must be cut even shorter due to quotes}
            FirstQuote := True; Quote := '''';
            FOR i := 1 TO ChunkSize DO
              BEGIN
              Ch := Chr(p^[BytesShown]);
              IF Ch = '''' THEN
                BEGIN
                IF FirstQuote THEN
                  BEGIN
                  Quote := '"'; FirstQuote := False;
                  END
                ELSE IF Ch = Quote THEN
                  BEGIN
                  ChunkSize := i - 1; Exit(GetChunk); {ChunkSize cut back}
                  END;
                END
              ELSE IF Ch = '"' THEN
                BEGIN
                IF FirstQuote THEN
                  BEGIN
                  Quote := ''''; FirstQuote := False;
                  END
                ELSE IF Ch = Quote THEN
                  BEGIN
                  ChunkSize := i - 1; Exit(GetChunk); {ChunkSize cut back}
                  END;
                END
              ELSE IF (Ord(Ch) < 32) OR (Ord(Ch) > 127) THEN
                BEGIN {special chars also treated uniquely}
                IF i = 1 THEN
                  ChunkSize := 1 {special as 1st char of chunk}
                ELSE
                  ChunkSize := i - 1; {special will be at i = 1 on next call}
                Exit(GetChunk); {ChunkSize cut back}
                END;
              BytesShown := BytesShown + 1;
              END; {for}
            END; {Ascii}
        END; {GetChunk}

      PROCEDURE DumpHex(BytesShown: Integer);

        VAR
          i: Integer;

        BEGIN {DumpHex - dump bytes of data}
          FOR i := 1 TO 6 DO
            BEGIN
            IF i > ChunkSize THEN
              PutStrS(ListFile, '  ', 0)
            ELSE
              PrntHex(p^[BytesShown], 2);
            IF NOT Odd(i) THEN PutcF(ListFile, ' ');
            BytesShown := BytesShown + 1;
            END;
        END; {DumpHex}

      BEGIN {DumpData}
        IF pLblDef^[Index] <> 0 THEN
          SetupLbl(Abs(pLblDef^[Index]), Lbl, LblKind)
        ELSE
          BEGIN
          IF AsmOnly THEN
            Lbl := ';'
          ELSE
            Lbl := ' ';
          LblKind := NoLbl;
          END;

        Ascii := (LblKind = PkdLbl) OR (LblKind = StrLbl);

        InstLoc := Index + Index;
        BytesUsed := 0;

        IF NOT AsmOnly AND (LblKind <> NoLbl) THEN
          BEGIN
          PutStrS(ListFile, ' ', 19);
          PrntHex(InstLoc, 6); PutStrS(ListFile, ' ', 16);
          END;
        PutLineP(ListFile, @Lbl);

        IF Index = SizeIndex THEN
          BEGIN {special .WORD that defines length of constant area}
          IF NOT AsmOnly THEN
            BEGIN
            PutStrS(ListFile, ' ', 19);
            PrntHex(InstLoc, 6); PutcF(ListFile, ' ');
            PrntHex(p^[0], 2); PrntHex(p^[1], 2);
            PutStrS(ListFile, ' ', 11);
            END;
          PutLineS(ListFile, 'CstSize  .WORD   Last-CstSize-2');
          BytesUsed := 2;
          Exit(DumpData);
          END;

        REPEAT
          BytesUsed := BytesUsed + 2;
          Index := Index + 1;
        UNTIL (Index >= IcDiv2) OR (pLblDef^[Index] <> 0) OR (Index = SizeIndex);

        IF LblKind <> StrLbl THEN
          BytesShown := 0
        ELSE
          BEGIN {treat 1st byte of strings specially}
          IF NOT AsmOnly THEN
            BEGIN
            PutStrS(ListFile, ' ', 19);
            PrntHex(InstLoc, 6); PutcF(ListFile, ' ');
            PrntHex(p^[0], 2);
            PutStrS(ListFile, ' ', 13);
            END;
          PutStrS(ListFile, '         .BYTE   ', 0);
          PutLinesS(ListFile, PutIntP(p^[0], 1)^);
          BytesShown := 1;
          END; {1st string byte is now off my back!}

        WHILE BytesShown < BytesUsed DO
          BEGIN
          GetChunk(BytesShown, ChunkSize, Quote);
          IF NOT AsmOnly THEN
            BEGIN
            PutStrS(ListFile, ' ', 19);
            PrntHex(InstLoc + BytesShown, 6); PutcF(ListFile, ' ');
            DumpHex(BytesShown);
            END;

          IF Ascii THEN
            BEGIN {generate packed array of char or string}
            Ch := Chr(p^[BytesShown]);
            IF (ChunkSize = 1) AND ((Ord(Ch) < 32) OR (Ord(Ch) > 127)) THEN
              BEGIN
              PutStrS(ListFile, '         .BYTE   $', 0);
              PrntHex(Ord(Ch), 2);
              BytesShown := BytesShown + 1;
              END
            ELSE
              BEGIN
              PutStrS(ListFile, '         .ASCII  ', 0);
              PutcF(ListFile, Quote);
              FOR i := 1 TO ChunkSize DO
                BEGIN
                PutcF(ListFile, Chr(p^[BytesShown]));
                BytesShown := BytesShown + 1;
                END;
              PutcF(ListFile, Quote);
              END;
            END {packed array of char or string}
          ELSE
            BEGIN {generate set or unknown constant}
            PutStrS(ListFile, '         .WORD   ', 0);
            Comment := ' ; "'; l := Length(Comment);
            FOR i := 1 TO ChunkSize DO
              BEGIN
              IF i = 1 THEN
                PutcF(ListFile, '$')
              ELSE IF Odd(i) THEN
                PutStrS(ListFile, ',$', 0);
              Ch := Chr(p^[BytesShown]);
              PrntHex(Ord(Ch), 2);
              IF (Ord(Ch) < 32) OR (Ord(Ch) > 127) THEN Ch := '.';
              l := l + 1; Comment[l] := Ch;
              BytesShown := BytesShown + 1;
              END;
            IF NOT AsmOnly THEN
              IF LblKind <> SetLbl THEN
                BEGIN
                FOR i := (ChunkSize + 2) DIV 2 TO 3 DO PutStrS(ListFile, '      ', 0);
                l := l + 1; Comment[l] := '"'; Comment[0] := Chr(l);
                PutStrS(ListFile, Comment, 0);
                END;
            END; {set or unknown}

          PutcF(ListFile, IONewline);
          END; {while}
      END; {DumpData}

    BEGIN {MakeListing}
      IF LnOvflo THEN
        BEGIN
        IF FirstOnCons THEN WriteLn;
        WriteLn(SUBell, 'The listing file contains more than ', MAXLNUM: 1,
                ' lines!  The rest of the listing will');
        WriteLn('be produced, but it will *not* contain any code ',
                'information.  This is due to a');
        WriteLn('limitation between the Compiler and the Code Generator',
                '...Sorry about that!', SUBell);
        WHILE GetLine(CListFile, @Line) DO ListLine(0, LineNumber, Line, True);
        WriteLn; FirstOnCons := False;
        Listing := False;
        ConsListing := False;
        ListingOk := False; {master override}
        Exit(MakeListing);
        END;

      IF NOT ShowAsmCode THEN IF LineNumber >= EndLineNbr THEN Exit(MakeListing);

      IF FirstLine THEN
        IF ConsListing THEN
          BEGIN
          WriteLn; FirstOnCons := False;
          END;

      IF AsmProc THEN
        Last := EndLineNbr
      ELSE
        Last := FirstLNum - 1;

      WHILE LineNumber < Last DO
        BEGIN
        IF NOT GetLine(CListFile, @Line) THEN Exit(MakeListing);
        ListLine(0, LineNumber, Line, True);
        END;

      IF DumpProcInfo = 1 THEN
        SizeIndex := CaPatchLoc DIV 2
      ELSE
        SizeIndex := - 1;

      NextI := 0;
      IcDIV2 := Ic DIV 2;
      DoingCase := False; CaseLbl := 0;

      FOR i := 0 TO IcDIV2 - 1 DO
        BEGIN
        IF NOT AsmProc THEN
          WHILE (LineNumber <= (Abs(pLineNumber^[i]) - 1)) AND (LineNumber < (LNum - 1)) DO
            BEGIN
            IF NOT GetLine(CListFile, @Line) THEN Exit(MakeListing);
            ListLine(i + i, LineNumber, Line, ShowAsmCode);
            END;

        IF i = NextI THEN
          BEGIN
          IF XpAbortFlag THEN
            BEGIN
            Aborted := True;
            GOTO 999;
            END;

          IF ShowAsmCode THEN
            BEGIN
            IF i < LastCode THEN
              DisAss1Line(i, UserPNam, @CodeBuff[i], BytsUsed)
            ELSE
              DumpData(i, @CodeBuff[i], BytsUsed);
            NextI := NextI + (BytsUsed DIV 2);
            END;
          END;
        END; {for}

      IF ShowAsmCode THEN
        BEGIN
        IF pLblDef^[IcDIV2] <> 0 THEN
          BEGIN {this could happen because of sets}
          SetupLbl(Abs(pLblDef^[IcDIV2]), Lbl, LblKind);
          IF NOT AsmOnly THEN
            BEGIN
            PutStrS(ListFile, ' ', 19);
            PrntHex(Ic, 6); PutStrS(ListFile, ' ', 16);
            END;
          PutLineP(ListFile, @Lbl);
          END;

        IF DumpProcInfo = 1 THEN
          BEGIN
          IF NOT AsmOnly THEN
            BEGIN
            PutStrS(ListFile, ' ', 19);
            PrntHex(Ic, 6); PutStrS(ListFile, ' ', 16);
            END;
          PutLineS(ListFile, 'Last');
          END;
        END;

      IF NOT AsmProc THEN
        WHILE LineNumber < EndLineNbr DO
          BEGIN
          IF NOT GetLine(CListFile, @Line) THEN Exit(MakeListing);
          ListLine(0, LineNumber, Line, True);
          END;
    END; {MakeListing}

  {$S }

  FUNCTION NextByte: Integer;

    BEGIN
      IF InByte > 511 THEN
        BEGIN
        IF XpAbortFlag THEN
          BEGIN
          Aborted := True;
          GOTO 999;
          END;

        InBlock := InBlock + 1;
        IF BlockRead(InFile, InBuff, 1, InBlock) <> 1 THEN
          BEGIN
          CodError(409); Aborted := True;
          GOTO 999;
          END;
        InByte := 0;
        END;

      NextByte := Ord(InBuff[InByte]);
      InByte := InByte + 1;
    END; {nextbyte}

  FUNCTION NextWord: Integer;

    BEGIN
      NextWord := (NextByte * 256) + NextByte;
    END; {nextword}

  PROCEDURE GenWord(fOp: Integer; fTag: Flags);

    BEGIN
      CurrCode := Ic DIV 2;
      IF CurrCode <= MAXCODE THEN
        BEGIN
        CodeBuff[CurrCode] := fOp;
        pLineNumber^[CurrCode] := LNum;
        Tags[CurrCode] := fTag;
        Ic := Ic + 2;
        END
      ELSE
        CodError(350);
    END; {genword}

  PROCEDURE Gen(fOp: Integer);

    BEGIN
      GenWord(fOp, ABSI);
    END; {gen}

  PROCEDURE GenR(fOp, r: Integer);

    BEGIN
      GenWord(fOp + (r MOD 8), ABSI);
    END; {gen}

  PROCEDURE GenRR(fOp, RR, r: Integer);

    BEGIN
      GenWord(fOp + (RR MOD 8) * 512 + (r MOD 8), ABSI);
    END; {gen}

  PROCEDURE PatchWord(fLoc, fValu: Integer);

    BEGIN
      CodeBuff[fLoc DIV 2] := fValu;
    END; {patchword}

  {$S SEG1}

  FUNCTION GetReg(LoReg, HiReg: Register): Register;

    LABEL 1;

    VAR
      i: Integer;

    BEGIN
      FOR i := LoReg TO HiReg DO
        IF Reg[i].Count <= 0 THEN
          BEGIN
          Reg[i].Count := 1;
          GOTO 1;
          END;

      WriteLn('Register ', LoReg: 1, '..', HiReg: 1);
      CodError(2001); i := LoReg;
    1:
      GetReg := i;
      IF SaveA2D3 THEN
        IF i = A2 THEN
          A2Used := True
        ELSE IF i = D3 THEN D3Used := True;
    END; {getreg}

  {************************************************************************

                                  ReuseIfPossible

          if we are going to do a geneffaddr immediately after the call
          to ReuseIfPossible, then under certain circumstances we can
          reuse the source register (if the destination is a register of
          the same type).  for now, this only works with A registers, since
          we are running out of A registers.

          if we can reuse a register then we simply increment the register
          count.


          Input Parameters
                  sattr - cattr of source expression for geneffaddr to
                          follow
                  loreg - lowest register we will accept
                  hireg - highest register we will accept

          Return Result
                  the register we allocated

  *************************************************************************}

  FUNCTION ReuseIfPossible(SAttr: CAttr; LoReg, HiReg: Register): Register;

    VAR
      i: Integer;

    BEGIN
      i := - 1;
      WITH SAttr DO
        BEGIN
        IF cKind = EXPR THEN
          BEGIN
          IF (ExReg >= LoReg) AND (ExReg <= HiReg) THEN i := ExReg;
          END
        ELSE IF cKind = ADDR THEN
          BEGIN
          IF (AdReg >= LoReg) AND (AdReg <= HiReg) THEN i := AdReg;
          END
        ELSE IF cKind = INDX THEN
          BEGIN
          IF (InxAReg >= LoReg) AND (InxAReg <= HiReg) THEN i := InxAReg;
          IF (InxRReg >= LoReg) AND (InxRReg <= HiReg) THEN i := InxRReg;
          END;
        END;
      IF i <> - 1 THEN { reused a register }
        BEGIN
        WITH Reg[i] DO
          BEGIN
          IF Count > 1 THEN
            i := GetReg(LoReg, HiReg)
          ELSE
            Count := Count + 1;
          END;
        END
      ELSE
        i := GetReg(LoReg, HiReg);
      ReuseIfPossible := i;
    END; {ReuseIfPossible}

  PROCEDURE FreeReg(fReg: Register);

    BEGIN
      IF (fReg <= Ahigh) AND ((fReg <= Dhigh) OR (fReg >= Alow)) THEN
        WITH Reg[fReg] DO
          BEGIN
          IF Count <= 0 THEN
            BEGIN
            WriteLn('Register ', fReg);
            CodError(2002);
            Count := 0;
            END
          ELSE
            Count := Count - 1;
          END;
    END; {freereg}

  PROCEDURE ClearRegs;

    VAR
      r: Integer;

    BEGIN
      FOR r := Dlow TO Anth DO WITH Reg[r] DO Count := 0;
    END; {clearregs}

  FUNCTION SaveRegs: Integer;

    VAR
      LastReg: Integer;
      NRegs: Integer;
      lMask, lMask2, i, Bit: Integer;

    BEGIN
      lMask := 0; lMask2 := 0; Bit := 1; NRegs := 0;
      FOR i := D0 TO Anth DO
        BEGIN
        lMask := lMask + lMask;
        IF Reg[i].Count > 0 THEN
          BEGIN
          LastReg := i;
          NRegs := NRegs + 1;
          lMask := lMask + 1;
          lMask2 := lMask2 + Bit;
          END;
        Bit := Bit + Bit;
        END;
      FOR i := Anth + 1 TO SP DO lMask := lMask + lMask;
      IF lMask <> 0 THEN
        BEGIN
        IF NRegs > 1 THEN
          BEGIN
          Gen($48E7); Gen(lMask); { MOVEM.L mask,-(SP) }
          END
        ELSE
          BEGIN
          IF LastReg <= D7 THEN {MOVE.L Di,-(SP) }
            GenR($2F00, LastReg)
          ELSE {MOVE.L Ai,-(SP) }
            GenR($2F08, LastReg);
          END;
        END;
      SaveRegs := lMask2;
    END; {saveregs}

  PROCEDURE RestoreRegs(fRegMask: Integer);

    VAR
      NRegs, LastReg, TempMask, i: Integer;

    BEGIN
      NRegs := 0; TempMask := fRegMask;
      FOR i := 0 TO 15 DO
        BEGIN
        IF Odd(TempMask) THEN
          BEGIN
          LastReg := i;
          NRegs := NRegs + 1;
          END;
        TempMask := TempMask DIV 2;
        END;
      IF fRegMask <> 0 THEN
        BEGIN
        IF NRegs > 1 THEN
          BEGIN
          Gen($4CDF); Gen(fRegMask); { MOVEM.L (SP)+,mask }
          END
        ELSE
          BEGIN
          IF LastReg <= D7 THEN {MOVE.L (SP)+,Di }
            GenRR($2018, LastReg, SP)
          ELSE {MOVE.L (SP)+,Ai) }
            GenRR($2058, LastReg, SP);
          END;
        END;
    END; {restoreregs}

  PROCEDURE CheckClobber(VAR fReg: Register);

    VAR
      NewReg: Register;
      fOp: Integer;

    BEGIN
      IF ((fReg >= A1st) AND (fReg <= Anth)) OR
         ((fReg >= Alow) AND (fReg <= Ahigh) AND (Reg[fReg].Count > 1)) THEN   {!2-22-84}
        BEGIN
        NewReg := GetReg(Alow, Ahigh);
        fOp := $2008; { MOVE.L Ai,Dj }
        IF NewReg >= A0 THEN fOp := fOp + $40; { MOVE.L Ai,Aj }
        GenRR(fOp, NewReg, fReg);
        fReg := NewReg;
        END
      ELSE IF ((fReg >= D1st) AND (fReg <= Dnth)) OR
              ((fReg >= Dlow) AND (fReg <= Dhigh) AND (Reg[fReg].Count > 1)) THEN
        BEGIN
        NewReg := GetReg(Dlow, Dhigh);
        fOp := $2000; { MOVE.L Di,Dj }
        IF NewReg >= A0 THEN fOp := fOp + $40; { MOVE.L Di,Aj }
        GenRR(fOp, NewReg, fReg);
        fReg := NewReg;
        END;
    END; {CheckClobber}

  PROCEDURE GetTemp(VAR fCAttr: CAttr; fSize: Integer);

    BEGIN
      Lc := Lc + fSize;
      WITH fCAttr DO
        BEGIN
        cKind := VARB; VOffset := - Lc; VLev := ProcLvl;
        END;
      IF Odd(Lc) THEN Lc := Lc + 1;
    END; {gettemp}

  PROCEDURE FreeTemp(fCAttr: CAttr; fSize: Integer);

    BEGIN
    END; {freetemp}

  PROCEDURE MakeLName(fLabelNo: Integer; VAR FName: Alfa8);

    VAR
      i: Integer;

    BEGIN
      FName[1] := '$';
      FOR i := 2 TO ALFALEN DO
        BEGIN
        FName[i] := Chr(Ord('0') + fLabelNo MOD 10); fLabelNo := fLabelNo DIV 10;
        END;
    END; {makelname}

  FUNCTION NewLabel: Integer;

    BEGIN
      NextLabel := NextLabel - 1;
      NewLabel := NextLabel;
    END; {newlabel}

  FUNCTION LookUpILabel(fLabelNo: Integer): pLabelRec;

    VAR
      lpLab: pLabelRec;
      DoneFlag: Boolean;

    FUNCTION NewLabelRec(fLabelNo: Integer): pLabelRec;

      VAR
        lpLab: pLabelRec;

      BEGIN
        New(lpLab);
        WITH lpLab^ DO
          BEGIN
          LabelNo := fLabelNo; Llink := NIL; Rlink := NIL;
          Defined := False; RefList := NIL;
          END;
        NewLabelRec := lpLab;
      END; {newlabelrec}

    BEGIN {lookupilabel}
      IF LabelTree = NIL THEN
        BEGIN
        LabelTree := NewLabelRec(fLabelNo);
        LookUpILabel := LabelTree;
        END
      ELSE
        BEGIN
        lpLab := LabelTree; DoneFlag := False;
        WHILE NOT DoneFlag DO
          WITH lpLab^ DO
            IF LabelNo = fLabelNo THEN
              BEGIN
              LookUpILabel := lpLab; DoneFlag := True;
              END
            ELSE IF LabelNo < fLabelNo THEN
              IF Llink = NIL THEN
                BEGIN
                Llink := NewLabelRec(fLabelNo);
                LookUpILabel := Llink;
                END
              ELSE
                lpLab := Llink
            ELSE IF Rlink = NIL THEN
              BEGIN
              Rlink := NewLabelRec(fLabelNo);
              LookUpILabel := Rlink;
              END
            ELSE
              lpLab := Rlink;
        END;
    END; {lookupilabel}

  PROCEDURE DefILabel(fLabNo: Integer);

    VAR
      lpLab: pLabelRec;
      lInt: pIntList;

    BEGIN
      lpLab := LookUpILabel(fLabNo);
      WITH lpLab^ DO
        BEGIN
        lInt := RefList;
        WHILE lInt <> NIL DO
          WITH lInt^ DO
            BEGIN
            PatchWord(Int, Ic);
            lInt := Next;
            END;
        Defined := True; Loc := Ic;
        END;
    END; {defilabel}

  FUNCTION ShiftMult(fValue: Integer; VAR Bits: Integer): Boolean;

    BEGIN
      Bits := 0;
      IF fValue > 0 THEN
        BEGIN
        WHILE NOT Odd(fValue) DO
          BEGIN
          Bits := Bits + 1; fValue := fValue DIV 2;
          END;
        ShiftMult := (fValue = 1) AND (Bits <= 8);
        END
      ELSE
        ShiftMult := False;
    END; {ShiftMult}

  PROCEDURE ExtRef;

    VAR
      N, i: Integer;
      lpRoc: pProcRef;

    BEGIN
      New(lpRoc);
      WITH lpRoc^ DO
        BEGIN
        FOR i := 1 TO ALFALEN DO LinkName[i] := Chr(NextByte);
        FOR i := 1 TO ALFALEN DO UserName[i] := Chr(NextByte);
        N := NextWord; PFLev := NextByte; RefList := NIL;
        Next := ProcList; ProcList := lpRoc; UserProcs[N] := lpRoc;
        END;
    END; {extref}

  FUNCTION ComHash(N: Integer): Integer;

    BEGIN
      ComHash := (N * 111) MOD MAXUNITS;
    END; {comhash}

  PROCEDURE ComRef;

    VAR
      i, lHashNo: Integer;
      lCom, mCom: pCommonRec;
      ExitFlag: Boolean;

    BEGIN
      New(lCom);
      WITH lCom^ DO
        BEGIN
        Left := NIL; Right := NIL;
        FOR i := 1 TO ALFALEN DO Name[i] := Chr(NextByte);
        CommonNo := NextByte; lHashNo := ComHash(CommonNo);
        CommonKind := NextByte;
        HashNo := lHashNo; RefList := NIL;
        END;
      IF CommonTree = NIL THEN
        CommonTree := lCom
      ELSE
        BEGIN
        mCom := CommonTree; ExitFlag := False;
        REPEAT
          WITH mCom^ DO
            IF HashNo < lHashNo THEN
              IF Left = NIL THEN
                BEGIN
                Left := lCom; ExitFlag := True;
                END
              ELSE
                mCom := Left
            ELSE IF Right = NIL THEN
              BEGIN
              Right := lCom; ExitFlag := True;
              END
            ELSE
              mCom := Right;
        UNTIL ExitFlag;
        END;
    END; {comref}

  FUNCTION FindCommon(fCommonNo: Integer): pCommonRec;

    VAR
      lCom: pCommonRec;
      lHashNo: Integer;
      ExitFlag: Boolean;

    BEGIN
      lHashNo := ComHash(fCommonNo);
      lCom := CommonTree;
      ExitFlag := False;
      WHILE (lCom <> NIL) AND NOT ExitFlag DO
        WITH lCom^ DO
          IF HashNo = lHashNo THEN
            ExitFlag := True
          ELSE IF HashNo < lHashNo THEN
            lCom := Left
          ELSE
            lCom := Right;
      FindCommon := lCom;
    END; {findcommon}

  PROCEDURE ComVRef(fCommonNo, fIc: Integer);

    VAR
      lCom: pCommonRec;
      lInt: pIntList;

    BEGIN
      lCom := FindCommon(fCommonNo); New(lInt);
      WITH lInt^ DO
        BEGIN
        Int := fIc; Next := lCom^.RefList; lCom^.RefList := lInt;
        END;
    END; {comvref}

