(**********************************************************)
(*                                                        *)
(*      Code-Optimierer fuer Turbo Pascal 3.0 (Z80-CPU)   *)
(*      Version 1.0,   06.1985                            *)
(*                                                        *)
(**********************************************************)
TYPE Tstr4=STRING[4];
     SprungZgr=^SprungEintrag;
     SprungEintrag=RECORD        (* Fuer Eintragungen der Sprungmarken *)
                     Adr,NeueAdr : Integer;
                     Klein,Gross : SprungZgr
                   END;
     SprungVor=^SprungVorEintr;
     SprungVorEintr=RECORD     (* Tabelle der Vorwaertsspruenge *)
                      Pc:Integer;
                      Next:SprungVor;
                      Adresse : SprungZgr;
                    END;
     CodeBuffer=ARRAY[0..15] OF RECORD
                  C,Z,A,L,Pc:Integer;
                END;
CONST HexTab:STRING[17]='0123456789ABCDEF';
VAR ComFile,OptFile : FILE;
    QuellName : STRING[16];  Ext:STRING[3];
    FileTyp   : (Com,Chn);
    Pass      : 1..2;
    Beg,Ende,NeuPc,ComZgr,Count,ErsteProcedure,
    Pc,ErrPc,Bz: Integer;
    OptBuffer,ComBuffer : ARRAY[0..4095] OF Byte;
    Buf       : CodeBuffer;
    SprungTab : SprungZgr;
    SprungVorTab,TabEnde : SprungVor;




FUNCTION Hex(Zahl,Anz:Integer):Tstr4;
VAR B:ARRAY[1..2] OF Byte ABSOLUTE Zahl;
    H:Tstr4;  I:Integer;
BEGIN
  H:='';
  FOR I:=Anz DOWNTO 1 DO
    H:=H+HexTab[B[I] DIV 16+1]+HexTab[B[I] MOD 16+1];
  Hex:=H;
END;

PROCEDURE Fehler(Nr,OpCode:Integer);
BEGIN
  Writeln(#13#10);
  CASE Nr OF
    1  : Write('Unbekannter OpCode : OpCode=',Hex(opcode,1));
    2 :  Write('Fehler im Optimierer oder kein Turbo-Pascal-Code');
    3 :  Write('Endadresse groesser wie ',Maxint);
    4 :  Write('Als Quelldatei nur Chain- oder Com-Dateien erlaubt.');
    5 :  Write('Overlays werden derzeit nicht unterstuetzt.');
  END;
  IF Nr IN [1,2] THEN Write('  Pc='+Hex(ErrPc-Beg,2),' ('+Hex(ErrPc,2)+')');
  IF Pass=2 THEN BEGIN Close(OptFile); Erase(OptFile); END;
  Writeln(#13#10,'+++ Programm abgebrochen +++'); Halt;
END;

PROCEDURE PutByte(B:Integer); (* Ein Byte zum optimierten Programm schreiben *)
VAR I:Integer;
BEGIN
  IF Pass=1 THEN Exit;
  IF ComZgr=SizeOf(OptBuffer) THEN BEGIN
    BlockWrite(OptFile,OptBuffer,31); Move(OptBuffer[3968],OptBuffer,128);
    FOR I:=Bz DOWNTO 1 DO IF Buf[i].Z>127 THEN Buf[i].Z:=Buf[i].Z-3968;
    ComZgr:=128;
  END;
  OptBuffer[ComZgr]:=Lo(B); ComZgr:=Succ(ComZgr); NeuPc:=Succ(NeuPc);
END;

PROCEDURE PutCode(C,L,A,Fg:Integer);
(* Z80 Befehlscode im Buffer ablegen; wenn Fg=1 dann die Adresse mit ablegen *)
VAR K:Integer;
BEGIN
  IF Pass=1 THEN Exit;
  Bz:=Succ(Bz); Buf[Bz].Pc:=ErrPc;
  Buf[Bz].Z:=ComZgr; Buf[Bz].C:=C; Buf[Bz].A:=A; Buf[Bz].L:=L;
  IF Hi(C)<>0 THEN BEGIN PutByte(Hi(C)); K:=2; END ELSE K:=1;
  PutByte(Lo(C));
  IF Fg=1 THEN BEGIN
    PutByte(A);  IF L-K=2 THEN PutByte(Hi(A));
  END;
  IF Bz=15 THEN BEGIN
    Move(Buf[5],Buf[1],110); Bz:=11;
  END;
END;

FUNCTION GetByte:Byte;  (* Ein Byte des Originalprogramms holen *)
VAR M:Integer;
BEGIN
  IF Count=SizeOf(ComBuffer) THEN BEGIN
    BlockRead(ComFile,ComBuffer,32,M); Count:=0;
  END;
  GetByte:=ComBuffer[Count]; Count:=Succ(Count);  Pc:=Succ(Pc);
END;

FUNCTION GetInteger:Integer;
BEGIN  GetInteger:=GetByte+256*GetByte END;

PROCEDURE SkipBytes(Anz:Integer);  (* Anzahl Bytes ueberlesen *)
VAR I:Integer;
BEGIN FOR I:=1 TO Anz DO PutByte(GetByte)  END;

PROCEDURE DelCode(P:Integer); (* Z80-Befehl im Buffer loeschen *)
VAR K,L:Integer;
BEGIN
  K:=Bz-P+1;
  FOR L:=Bz DOWNTO K+1 DO Buf[L].Pc:=Buf[L-1].Pc;
  L:=Buf[K].L;
  Move(OptBuffer[Buf[K].Z+Buf[K].L],
       OptBuffer[Buf[K].Z],ComZgr-Buf[K].Z-Buf[K].L);
  ComZgr:=ComZgr-L; NeuPc:=NeuPc-L;
  Move(Buf[K+1],Buf[K],Pred(P)*10); Bz:=Pred(Bz);
  FOR P:=K TO Bz DO Buf[P].Z:=Buf[p].Z-L;
END;

PROCEDURE InsCode(C,L,A,Fg,P:Integer); (* Ein Z80-Befehl im Buffer einfuegen *)
VAR K,Z:Integer;
BEGIN
  K:=Bz-P+1;
  Move(OptBuffer[Buf[K].Z],OptBuffer[Buf[K].Z+L],ComZgr-Buf[K].Z);
  Z:=ComZgr+L; ComZgr:=Buf[K].Z;
  Move(Buf[K],Buf[Succ(K)],P*10);
  P:=Bz; Bz:=K-1; PutCode(C,L,A,Fg); Bz:=Succ(P); ComZgr:=Z;
  FOR P:=Succ(K) TO Bz DO Buf[P].Z:=Buf[P].Z+L;
  FOR P:=K TO Bz-1 DO Buf[P].Pc:=Buf[P+1].Pc; Buf[Bz].Pc:=Pc;
END;

PROCEDURE Ersetze(Code,L,A,Flag,Position:Integer); (* Z80-Befehl ersetzen *)
BEGIN
  DelCode(Position); InsCode(Code,L,A,Flag,Position-1);
END;

FUNCTION Marke(Adr:Integer):SprungZgr;
VAR P:SprungZgr;
BEGIN
  P:=SprungTab;
  WHILE (P<>NIL) AND (P^.Adr<>Adr) DO
    IF Adr>P^.Adr THEN P:=P^.Gross ELSE P:=P^.Klein;
  Marke:=P;
END;

PROCEDURE MarkeEintragen(Lbl:Integer); (* Eintragen der Sprungadresse *)
VAR P,Q:SprungZgr;
BEGIN
  IF Lbl>Beg THEN BEGIN
    IF SprungTab=NIL THEN BEGIN (* Erster Eintrag *)
      New(SprungTab);
      WITH SprungTab^ DO BEGIN
        Adr:=Lbl; Klein:=NIL; Gross:=NIL;
      END
    END ELSE BEGIN
      P:=SprungTab;
      WHILE P<>NIL DO BEGIN (* freien Platz suchen *)
        Q:=P;
        IF Lbl=P^.Adr THEN Exit (* Schon vorhanden *)
        ELSE IF Lbl>P^.Adr THEN P:=P^.Gross ELSE P:=P^.Klein;
      END;
      New(P); P^.Adr:=Lbl; P^.Klein:=NIL; P^.Gross:=NIL;
      IF Lbl>Q^.Adr THEN Q^.Gross:=P ELSE Q^.Klein:=P;
    END;
  END;
END;

PROCEDURE TesteHLVar(P:Integer);  (* Pruefen, ob der Wert schon in HL steht *)
(* Jedoch bei einer Ansprungstelle trotzdem das Register laden *)
VAR K:Integer;
BEGIN
  IF Marke(Buf[Bz-P+1].Pc)=NIL THEN BEGIN
    K:=Bz-P;
    WHILE (Buf[K].C IN [$11,$D5,$E5,$22,$2A]) OR (Buf[K].C=$ED5B)
          AND (Marke(Buf[K].Pc)=NIL) DO
      IF Buf[K].C IN [$2A,$22] THEN BEGIN
        IF Buf[K].A<>Buf[Bz-P+1].A THEN Exit ELSE BEGIN
          DelCode(P); Exit;
        END;
      END ELSE K:=Pred(K);
  END;
END;

PROCEDURE TesteDEVar; (* Testen, ob der Wert in DE steht, sonst wie bei HL *)
VAR K:Integer;
BEGIN
  IF Marke(Buf[Bz].Pc)<>NIL THEN Exit;
  K:=Pred(Bz);
  WHILE NOT (Buf[K].C IN [$D1,$EB,$11,$5E,$56,$CD]) AND (K<>0) DO
    IF Marke(Buf[K].Pc)<>NIL THEN Exit
    ELSE IF Buf[K].C=$ED5B THEN BEGIN  (* LD DE,(NN) *)
      IF Buf[K].A=Buf[Bz].A THEN DelCode(1);  (* Ladebefehl gefunden *)
      Exit;
    END ELSE K:=Pred(K);
END;

PROCEDURE KonstanteLaden; (* Ueberpruefen, ob die Konstante *)
                          (* bereits in HL steht *)
VAR Wert,Z:Integer;
BEGIN
  Wert:=GetInteger;
  IF Pass=1 THEN Exit;
  IF Marke(ErrPc)=NIL THEN BEGIN
    Z:=Bz;
    WHILE (Buf[Z].C IN [$22,$7D,$32,$E5]) AND (Z<>0) DO Z:=Pred(Z);
    IF Z<>0 THEN
      IF (Buf[Z].C=$21) AND (Buf[Z].A=Wert) THEN Exit;
  END;
  PutCode($21,3,Wert,1);
END;

PROCEDURE AkkuSpeichern;
BEGIN
  IF Pass=2 THEN
    IF (Buf[Bz].C=$7D) AND (Buf[Bz-1].C=$6F) THEN BEGIN
      DelCode(1); DelCode(1); (* LD L,A; LD A,L entfernen *)
    END;
  PutCode($32,3,GetInteger,1);
END;

PROCEDURE PopDE;
(* LD HL,NN; PUSH HL; LD HL,NN; POP DE  -->  LD DE,NN; LD HL,NN *)
(* PUSH HL; LD HL,NN; POP DE  -->  EX DE,HL; LD HL,NN           *)
VAR K:Integer;
BEGIN
  IF Pass=2 THEN BEGIN
    IF Buf[Bz].C=$26 THEN K:=Bz-1 ELSE K:=Bz;
    IF (Buf[K].C IN [$21,$2A]) AND (Buf[K-2].C IN [$21,$2A]) THEN BEGIN
      DelCode(Bz-K+2); (* Push HL entfernen *)
      IF (Buf[K-2].C=$21) THEN Ersetze($11,3,Buf[K-2].A,1,Bz-K+3)
      ELSE Ersetze($ED5B,4,Buf[K-2].A,1,Bz-K+3);
    END ELSE IF (Buf[K].C IN [$21,$2A]) AND (Buf[K-1].C=$E5) THEN
      Ersetze($EB,1,0,0,Bz-K+2)   (* EX DE,HL *)
    ELSE PutCode($D1,1,0,0);
  END;
END;

PROCEDURE PopHL;
(*   Eine Konstante oder eine einfache Variable einer Feldvar. zuweisen  *)
(*   PUSH HL; LD HL,NN; EX DE,HL; POP HL  -->  LD DE,NN  *)
BEGIN
  IF Pass=1 THEN Exit;
  IF (Buf[Bz].C=$EB) AND (Buf[Bz-1].C IN [$21,$2A]) AND (Buf[Bz-2].C=$E5)
  THEN BEGIN
    DelCode(3); DelCode(1);
    IF Buf[Bz].C=$21 THEN Ersetze($11,3,Buf[Bz].A,1,1)
      ELSE Ersetze($ED5B,4,Buf[Bz].A,1,1);
  END ELSE PutCode($E1,1,0,0);
END;

PROCEDURE RePopDE;  (* Optimierung fuer POP DE zuruecknehmen *)
BEGIN
  IF (Buf[Bz].C<>$D1) THEN
    CASE Buf[Bz-1].C OF
      $11 : Ersetze($21,3,Buf[Bz-1].A,1,2);
    $ED5B : Ersetze($2A,3,Buf[Bz-1].A,1,2);
      $EB : IF Buf[Bz-2].C<>$56 THEN DelCode(2);
    END;
END;

PROCEDURE TauscheKonst; (* Zb. I:=4*K  -->  I:=K*4  *)
VAR A:Integer;
BEGIN
  IF (Buf[Bz-1].C=$21) AND (Buf[Bz].C=$2A) THEN BEGIN
    A:=Buf[Bz-1].A; Ersetze($2A,3,Buf[Bz].A,1,2);
    Ersetze($21,3,A,1,1); TesteHLVar(2);
  END;
END;

PROCEDURE Add;      (* Behandlung von Additionen *)
VAR I,Adr:Integer;
BEGIN
  IF Pass=1 THEN Exit;
  IF Buf[Bz].C AND $C2 IN [$C3,$C2,0] THEN BEGIN PutCode($19,1,0,0); Exit END;
  RePopDE; TauscheKonst; Adr:=Buf[Bz].A;
  CASE Buf[Bz].C OF
    $26 : PutCode($19,1,0,0);   (* Integer- und Byte-Variable addieren *)
    $D1 : IF Buf[Bz-1].C=$E5 THEN BEGIN
            DelCode(1); DelCode(1); PutCode($29,1,0,0);
          END ELSE PutCode($19,1,0,0);
$11,$21 : BEGIN (* Konstante addieren *)
            DelCode(1);
            IF Buf[Bz].C=$21 THEN Ersetze($21,3,Adr+Buf[Bz].A,1,1)
            ELSE IF Adr IN [0..3] THEN
              FOR I:=1 TO Adr   DO PutCode($23,1,0,0)
            ELSE BEGIN
              PutCode($11,3,Adr,1); PutCode($19,1,0,0);
            END;
          END;
    $2A : BEGIN   (* Zwei Variablen addieren *)
            Ersetze($ED5B,4,Adr,1,1); TesteDEVar; PutCode($19,1,0,0);
          END;
    ELSE Fehler(2,0);
  END
END;

PROCEDURE Sbc;
VAR Adr,I:Integer;

PROCEDURE SubCode;
BEGIN PutCode($B7,1,0,0); PutCode($ED52,2,0,0); END;

BEGIN
  IF Pass=1 THEN Exit;
  IF Buf[Bz-1].C<>$EB THEN BEGIN PutCode($ED52,2,0,0); Exit; END;
  DelCode(1); DelCode(1); RePopDE; Adr:=Buf[Bz].A;
  CASE Buf[Bz].C OF
    $26 : BEGIN PutCode($EB,1,0,0); SubCode; END;
    $D1 : CASE Buf[Bz-1].C OF
            $E5: BEGIN  (* Zwei gleiche Variablen subtrahieren *)
                    DelCode(1); DelCode(1);
                    PutCode($B7,1,0,0); PutCode($ED62,2,0,0);
                 END;
            $EB: BEGIN (* EX DE,HL; POP DE; EX DE,HL  -->  POP HL *)
                   DelCode(1); DelCode(1); PutCode($E1,1,0,0); SubCode
                 END;
            $26: BEGIN PutCode($EB,1,0,0); SubCode; END;
            ELSE BEGIN PutCode($EB,1,0,0); SubCode; END;
          END;
    $21 : BEGIN  (* Konstante abziehen *)
            DelCode(1);
            IF Buf[Bz].C=$21 THEN Ersetze($21,3,Buf[Bz].A-Adr,1,1)
            ELSE IF Adr IN [0..5] THEN
                FOR I:=1 TO Adr DO PutCode($2B,1,0,0)
                  ELSE BEGIN PutCode($11,3,Adr,1); SubCode END
            END;
    $2A   : BEGIN  (* Zwei Variable voneinander abziehen *)
              DelCode(1); PutCode($ED5B,4,Adr,1);
              TesteDEVar; SubCode
            END;
    ELSE Fehler(2,0);
  END;
END;

PROCEDURE Mult;
VAR Adr,I:Integer;

PROCEDURE MultCode;
BEGIN PutCode($CD,3,$6F5,1) END;
  
BEGIN
  IF Pass=1 THEN Exit;
  RePopDE; TauscheKonst; Adr:=Buf[Bz].A;
  CASE Buf[Bz].C OF
    $26 : PutCode($CD,3,$6F5,1);
    $D1 : CASE Buf[Bz-1].C OF
            $E5 : BEGIN
                    DelCode(1); DelCode(1); PutCode($CD,3,$6F3,1);
                  END;
            $CD : MultCode;
            $EB : BEGIN   (* EX DE,HL; POP DE  -->  POP HL *)
                    DelCode(1); Ersetze($E1,1,0,0,1); MultCode
                  END;
            ELSE MultCode;
          END;
    $21 : BEGIN  (* Multiplikation mit einer Konstanten *)
            DelCode(1);
            IF Buf[Bz].C=$21 THEN Ersetze($21,3,Adr*Buf[Bz].A,1,1)
            ELSE IF Adr IN [2,4,8,16,32,64] THEN
              FOR I:=1 TO Round(Ln(Adr)/Ln(2)) DO PutCode($29,1,0,0)
            ELSE BEGIN
              PutCode($11,3,Adr,1); PutCode($CD,3,$6F5,1);
            END;
          END;  (* Konstante *)
    $2A : BEGIN    (* Mit einer Var. multiplizieren *)
            DelCode(1); PutCode($ED5B,4,Adr,1);
            TesteDEVar; PutCode($CD,3,$6F5,1);
          END;
    ELSE Fehler(2,0);
  END;
END;

PROCEDURE UmschalteByteED;
VAR Code:Byte;
BEGIN
  Code:=GetByte;
  CASE Code OF
    $42 : PutCode($ED42,2,0,0);   (* SBC HL,BC *)
    $52 : Sbc;
    $5B : PutCode($ED5B,4,GetInteger,1);
    $B0 : PutCode($EDB0,2,0,0);
    ELSE Fehler(1,code);
  END;
END;

PROCEDURE UmschalteByteCB;
VAR Code:Integer;
BEGIN
  Code:=GetByte;
  IF Pass=1 THEN Exit;
  IF Code=$45 THEN        (* BIT 0,L *)
    CASE Buf[Bz].C OF
      $26 : IF Buf[Bz].A=0 THEN BEGIN (* LD H,0 ueberfluessig *)
              DelCode(1); PutCode($CB45,2,0,0)
            END;
      $6F : IF Buf[Bz-1].C IN [$A3,$B3,$EE] THEN (* LD L,A; BIT 0,L nach *)
              DelCode(1);                      (* And, Or, Not ueberfluessig *)
      ELSE PutCode($CB45,2,0,0);
    END
  ELSE PutCode($CB00+Code,2,0,0);
END;

PROCEDURE UmschalteByteFD;
VAR Code:Integer;
BEGIN
  Code:=GetByte;
  IF Code IN [$E1,$E5] THEN PutCode($FD00+Code,2,0,0)
  ELSE Fehler(1,Code);
END;

PROCEDURE Spruenge(Code:Byte; Adr:Integer);
(* Spruenge, die nach vorne losgehen, koennen erst spaeter beruecksichtigt
   werden *)
VAR Offs:Integer;  P:SprungZgr;  V:SprungVor;
  
PROCEDURE JumpCode(Offs:Integer);
BEGIN
  IF Abs(Offs) IN [0..127] THEN  (* Relativer Sprung *)
    CASE Code OF
      $C3 : PutCode($18,2,Offs,1);
      $C2 : PutCode($20,2,Offs,1);
      $CA : PutCode($28,2,Offs,1);
      $DA : PutCode($38,2,Offs,1);
      $D2 : PutCode($30,2,Offs,1);
      ELSE PutCode(Code,3,P^.NeueAdr,1);
    END ELSE PutCode(Code,3,P^.NeueAdr,1);
END;

BEGIN
  IF Code<>$CD THEN Adr:=GetInteger;
  IF Pass=1 THEN MarkeEintragen(Adr)
  ELSE BEGIN
    IF Adr<ErsteProcedure THEN PutCode(Code,3,Adr,1)  (* Reise geht zum *)
    ELSE BEGIN                                        (* Runtime-Modul *)
      Offs:=Adr-Pc; P:=Marke(Adr);
      IF Offs>0 THEN BEGIN (* Sprung nach vorne *)
        New(V); V^.Adresse:=P; V^.Pc:=NeuPc; V^.Next:=NIL;
        IF TabEnde<>NIL THEN TabEnde^.Next:=V  ELSE SprungVorTab:=V;
        TabEnde:=V; JumpCode(Offs-1);
      END ELSE JumpCode(P^.NeueAdr-NeuPc-2);  (* Sprung nach hinten *)
    END;
  END;
END;

PROCEDURE Calls;
VAR Anz,Adr,Anf:Integer;
BEGIN
  Adr:=GetInteger;
  CASE Adr OF
    $6F5 : Mult;
$676,$666: IF Pass=2 THEN (* Anfangswerte fuer FOR .. TO .. DO *)
             IF (Buf[Bz].C=$21) AND (Buf[Bz-1].C=$11) THEN BEGIN
               Anf:=Buf[Bz-1].A; Anz:=Buf[Bz].A; DelCode(1); DelCode(1);
               PutCode($21,3,Anf,1); PutCode($11,3,Abs(Anz-Anf)+1,1);
             END ELSE PutCode($CD,3,Adr,1);
    $1c59 : Fehler(5,0);  (* Overlays nicht erlaubt *)
    ELSE BEGIN
      Spruenge($CD,Adr);
      IF (Adr=$17BA) OR (Adr=$54D) THEN BEGIN (* Hinter diesen Aufrufen
                                                stehen unmittelbar Konstante *)
        Anz:=GetByte; PutCode(Anz,Anz+1,0,0); SkipBytes(Anz);
      END;
    END;
  END
END;

PROCEDURE GleichUngleich;
{ CALL VERGLEICH; BIT 0,L; JP Z,NN  -->  OR A; SBC HL,DE; JP X,NN }

PROCEDURE VerglCode(Jmp:Integer);
BEGIN
  DelCode(1); DelCode(1); PutCode($B7,1,0,0);
  PutCode($ED52,2,0,0); Spruenge(Jmp,0);
END;
  
BEGIN
  IF Pass=2 THEN
    IF (Buf[Bz].C=$CB45) AND (Buf[Bz-1].C=$CD) THEN
      CASE Buf[Bz-1].A OF
        $67F : BEGIN VerglCode($C2); Exit END; (* Test auf Gleichheit  *)
        $692 : BEGIN VerglCode($CA); Exit END; (* Test auf Ungleichheit *)
      END;
  Spruenge($CA,0);
END;

PROCEDURE Init1;
VAR I:Integer;   Start:Tstr4;
BEGIN
  SprungTab:=NIL; TabEnde:=NIL; SprungVorTab:=NIL;
  Reset(ComFile);
  IF FileTyp=Com THEN BEGIN (* Startadresse ermitteln *)
    BlockRead(ComFile,ComBuffer,1);
    Beg:=ComBuffer[1]+256*ComBuffer[2];
    Seek(ComFile,(Beg-243) DIV 128); Count:=(Beg-243) MOD 128;
  END ELSE BEGIN (* Bei Chain-File abfragen *)
    Write('Startadresse ? 20E2'#8#8#8#8); Readln(Start);
    IF Start='' THEN Start:='20E2';
    Val('$'+Start,Beg,I); Count:=13;
  END;
  Pc:=Beg+13; BlockRead(ComFile,ComBuffer,32,I); Ende:=Pred(GetInteger);
  IF Ende<0 THEN Fehler(3,0);
  Writeln('Programmcode: ',Hex(Beg,2),' - ',Hex(Ende,2),'  <',Ende-Beg,'>');
  SkipBytes(11); ErsteProcedure:=Beg;
  IF (ComBuffer[Count]=$C3) THEN BEGIN
(* Es werden entweder Proceduren oder Konstante uebersprungen *)
    Write(#13#10,'Adresse der 1. Procedure ? '); Readln(ErsteProcedure);
    IF ErsteProcedure=0 THEN ErsteProcedure:=Pc+3;
    Spruenge(GetByte,0); SkipBytes(ErsteProcedure-Pc);
  END;
  Write(#13#10'Aufstellen der Tabelle mit den Sprungadressen  Pc:        ');
END;

PROCEDURE Init2;
VAR I,R:Integer;
BEGIN
  Write(#13#10,'Den Code optimieren  Pc:     ');
  Reset(ComFile); Rewrite(OptFile);  (* Kopieren der Runtime-Routinen *)
  IF FileTyp=Com THEN BEGIN
    FOR I:=1 TO (Beg-$100+26) DIV SizeOf(ComBuffer) DO BEGIN
      BlockRead(ComFile,ComBuffer,32,R); BlockWrite(OptFile,ComBuffer,R);
    END;
     Count:=(Beg-$100+26) MOD 4096
  END ELSE Count:=26;
  BlockRead(ComFile,ComBuffer,32,R);
  Pc:=Beg+26; NeuPc:=Pc; Bz:=0; OptBuffer:=ComBuffer; ComZgr:=Count;
  IF ComBuffer[Count]=$C3 THEN BEGIN
    Spruenge(GetByte,0); SkipBytes(ErsteProcedure-Pc);
  END;
END;

PROCEDURE Optimierer;
VAR OpCode:Integer;  P:SprungZgr;
BEGIN
  WHILE Pc<Ende DO BEGIN
    IF Pass=2 THEN BEGIN  (* Neuen Pc aktualisieren *)
      P:=Marke(Pc); IF P<>NIL THEN P^.NeueAdr:=NeuPc;
    END;
    IF Pc MOD 32=0 THEN Write(#8#8#8#8,Hex(Pc,2));
    ErrPc:=Pc; OpCode:=GetByte;
    CASE OpCode OF
      $2A : BEGIN (*   Variable ins HL-Register laden   *)
              PutCode($2A,3,GetInteger,1);
              IF Pass=2 THEN TesteHLVar(1)
            END;
      $21 : KonstanteLaden;
      $22 : PutCode($22,3,GetInteger,1);  (* HL-Register speichern *)
      $19 : Add;
      $D1 : PopDE;
      $D5 : PopHL;
$C3,$C2,$D2,$DA : Spruenge(OpCode,0);
      $CD : Calls;
      $32 : AkkuSpeichern;
      $ED : UmschalteByteED;
      $CA : GleichUngleich; (* JP Z,NN *)
      $CB : UmschalteByteCB;
      $FD : UmschalteByteFD;
      $65 : BEGIN    (* LD H,L *)
              IF Pass=2 THEN IF Buf[Bz].C=$26 THEN DelCode(1);
              PutCode(OpCode,1,0,0)
            END;
  $01,$11 : PutCode(OpCode,3,GetInteger,1);
  $2E,$EE,
    6,$26 : PutCode(OpCode,2,GetByte,1);
      $2B : IF Pass=2 THEN     (* DEC HL *)
              IF Buf[Bz].C=$21 THEN Ersetze($21,3,Buf[Bz].A-1,1,1)
              ELSE PutCode($2B,1,0,0);
      $29 : IF Pass=2 THEN (* ADD HL,HL  Multiplikation mit 2 *)
              IF Buf[Bz].C=$21 THEN Ersetze($21,3,Buf[Bz].A*2,1,1)
              ELSE PutCode($29,1,0,0);
      ELSE
        IF OpCode IN [$D5,$EB,$B7,$7A,$73,$72,$7C,$7D,$C9,$6C,$A3,$09,$5D,$54,
                      $6F,$D9,$A2,$67,$E5,$C1,$C5,$B3,$23,$1B,$6E,$5E,$56]
            THEN PutCode(OpCode,1,0,0)
        ELSE Fehler(1,OpCode)
    END;
  END;
  Write(#8#8#8#8,Hex(Pc,2));
END;

PROCEDURE Vorwaertsspruenge; (* Vorwaertssprungadressen im OptFile eintragen *)
VAR V:SprungVor; Z,R,Anf,Ende,Tpa:Integer;

PROCEDURE Lesesektor(Pc:Integer);
BEGIN
  Seek(OptFile,(Pc-Tpa) DIV 128); BlockRead(OptFile,OptBuffer,32,R);
  Seek(OptFile,(Pc-Tpa) DIV 128);
  Anf:=((Pc-Tpa) DIV 128)*128+Tpa; Ende:=Anf+R*128;
END;

BEGIN
  BlockWrite(OptFile,OptBuffer,Succ(ComZgr DIV 128));
  Write(#13#10'Vorwaertsspruenge eintragen.  Pc:     ');
  IF FileTyp=Com THEN Tpa:=$100 ELSE Tpa:=Beg;
  Lesesektor(Beg+13); Z:=Beg+13-Anf;
  OptBuffer[Z]:=Lo(NeuPc); OptBuffer[Z+1]:=Hi(NeuPc);
  V:=SprungVorTab;
  WHILE V<>NIL DO BEGIN
    Write(#8#8#8#8,Hex(V^.Pc,2));
    IF V^.Pc>Ende-3 THEN BEGIN
      BlockWrite(OptFile,OptBuffer,R); Lesesektor(V^.Pc);
    END;
    Z:=V^.Pc-Anf;
    IF OptBuffer[Z] IN [$18,$20,$28,$30,$38] THEN  (* Relativer Sprung *)
      OptBuffer[Z+1]:=Lo(V^.Adresse^.NeueAdr-V^.Pc-2)
    ELSE BEGIN       (* Absoluter Sprung *)
      OptBuffer[Z+1]:=Lo(V^.Adresse^.NeueAdr);
      OptBuffer[Z+2]:=Hi(V^.Adresse^.NeueAdr);
    END;
    V:=V^.Next;
  END;
  BlockWrite(OptFile,OptBuffer,R); Close(OptFile);
END;


BEGIN
  Writeln('Code-Optimierer fuer Turbo-Pascal 3.0'#13#10);
  Write('Name der Com oder Chn-Datei ? '); readln(QuellName);
  FOR Bz:=1 TO Length(QuellName) DO QuellName[Bz]:=Upcase(QuellName[Bz]);
  Ext:=Copy(QuellName,Pos('.',QuellName)+1,128);
  IF Ext='COM' THEN FileTyp:=Com
    ELSE IF Ext='CHN' THEN FileTyp:=Chn
      ELSE Fehler(4,0);
  Assign(ComFile,QuellName); Assign(OptFile,'Opt.'+Ext);
  Pass:=1; Init1; Optimierer;
  Pass:=2; Init2; Optimierer;
  Vorwaertsspruenge;
  Writeln(#13#10'Code um ',Pc-NeuPc,' Bytes reduziert');
END.