Unit D2Comp;

Interface

Uses
  d2type,d2tabx86,dt2x86;

Const
  MaxFixUp = 256;

Type

  PcBuf=^TcBuf;
  TcBuf=Array[0..Pred(High(Word))] Of Byte;

Const
  ShortJump : Array[JumpType] Of Byte = ( $EB, $74, $7C, $75, $7F, $7D, $7E );
  LongPfx = $0F;
  LongJump  : Array[JumpType] Of Byte = ( $E9, $84, $8C, $85, $8F, $8D, $8E );


Type
  Opt = ( _none, _PopPush, _PushPop );

  pComp = ^tComp;
  tComp = Object
  Private
{    RegAX : Boolean;}
    OptReg : Byte;
    LastLb : Word;
    IP:Word;
    FU : 0..MaxFixUp;
    FixUp : Array [1..MaxFixUp] Of Record
      Term : pTerm;
      Size,
      Offs : Word;
    End;
    OptFlag:Opt;
  Public
    Buf:PcBuf;
  Private
    Start,Size:Word;
    Procedure IncIP;
    Procedure qPfx(T:JumpType);
    Procedure Shift(L:Word);
  Public
    Constructor Init(aStart,aSize:Word);
    Destructor Done;Virtual;
{---}
  Procedure _push_ax;
  Procedure _pop_ax;
  Function cIP:Word;
  Procedure cCode(C:Byte);
  Procedure cByte(B:Byte); Procedure iByte(Offs:Word;B:Byte); Function gByte(Offs:Word):Byte;
  Procedure cWord(W:Word); Procedure iWord(Offs,W:Word);      Function gWord(Offs:Word):Word;
  Procedure cInline(S:String);
{---}
  Procedure cAscii2z(S:String);
  Procedure cPattern(Pattern:Byte;Len:Word);
{----------- вспомогательные функции годогенерации -------------}
  (*метка вперед*)
  Procedure bLabel(Var Loc:Word);
  (*прыг на уже определенну метку*)
  Procedure bJump(T:JumpType;Loc:Word);
  (*метка назад*)
  Procedure fLabel(Loc:Word);
  (*прыжок на еще не определенную метку*)
  Procedure fJump(T:JumpType;Var Loc:Word);
  (*условный переход на уже определенную метку*)
  Procedure bJc(T:JumpType;Loc:Word);
  (*условный переход на еще не определенную метку*)
  Procedure fJc(T:JumpType;Var Loc:Word);
{---}
  Procedure AddFixUp(Var P:pTerm;S:Word);
  Procedure AllFixUp;
{---}
  Procedure Save(Name:String);
End;

Var
  c:pComp;

Implementation

Constructor tComp.Init;
Begin
  Start:=aStart;
  Size:=aSize;
  FU:=0;
  IP:=Start;
  GetMem(Buf,Size-Start);
  OptFlag:=_NONE;
  LastLb:=0;
  {RegAX:=False}
End;

Destructor tComp.Done;
Begin
  FreeMem(Buf,Size-Start);
End;

Procedure tComp.IncIP;
Begin
  If IP=Size then errorMsg(Input,'code is too big');
  Inc(IP);
End;



  Function tComp.cIP;
  Begin
    cIP:=IP
  End;



  Procedure tComp.cCode;
  Begin
    Case OptFlag Of
      _NONE: ;
      _poppush: { pop Reg ; push Reg }
        If (C=OptReg-8)And(LastLb<>IP)Then Begin
          OptFlag:=_NONE;
          Dec(IP);
          Exit
        End;
      _pushpop: { push Reg ; pop Reg }
        If (C=OptReg+8)And(LastLb<>IP)Then Begin
          OptFlag:=_NONE;
          Dec(IP);
          Exit;
        End Else
        If (C In [$58..$5F])And(LastLb<>IP)Then Begin
          OptFlag:=_NONE;
          Dec(IP);
          cByte($8B);
          cByte($C0 + (OptReg-$50) Shl 3 + C - $58);
          Exit;
        End;
    End;
    If d2Type.optFLG {optimization?} Then
    Case C Of
      $58..$5F: Begin OptFlag:=_poppush; OptReg:=C End;
      $50..$57: Begin OptFlag:=_pushpop; OptReg:=C End;
    Else
      OptFlag:=_NONE;
    End;
    Buf^[IP-Start]:=C;
    IncIP;
  End;

  Procedure tComp.cByte;
  Begin
    Buf^[IP-Start]:= B;
    IncIP;
    OptFlag:=_NONE;
  End;



  Procedure tComp.cWord;
  Begin
    cByte(Lo(W));
    cByte(Hi(W));
  End;

  Procedure tComp.iByte;
  Begin
    Buf^[Offs-Start]:=B;
  End;

  Procedure tComp.iWord;
  Begin
    iByte(Offs,Lo(W));
    iByte(Offs+1,Hi(W));
  End;

  Function tComp.gByte;
  Begin
    gByte:=Buf^[Offs-Start];
  End;

  Function tComp.gWord;
  Begin
    gWord:=$100*gByte(Offs+1)+gByte(Offs);
  End;

  Procedure tComp.cInline(S:String);
  Var
    B:Byte;
    W:String[2];
    I:Byte;
    E:Integer;
  Begin
    For I:=0 To Length(S) Div 2-1 Do Begin
      W:=Copy(S,I*2+1,2);
      Val('$'+W,B,E);
      cByte(B);
    End;
    OptFlag:=_NONE;
  End;

  Procedure tComp.cAscii2z;
  Var
    I:Byte;
  Begin
    For I:=1 To Length(S) Do cByte(Ord(S[I]));
    cByte($0);
  End;

  Procedure tComp.cPattern(Pattern:Byte;Len:Word);
  Var
    I:Word;
  Begin
    For I:=1 To Len Do cByte(Pattern)
  End;


{----------- вспомогательные функции годогенерации -------------}

Procedure tComp.qPfx(T:JumpType);
Begin
  If T <> __Jmp Then cByte(LongPfx)
End;

Function gLongJumpType(Mnm:Byte):JumpType;
Var
  Pos:JumpType;
Begin
  For Pos:=Low(JumpType) To High(JumpType) Do
    If LongJump[Pos]=Mnm Then Begin
      gLongJumpType:=Pos;
      Exit;
    End;
  ErrorMsg(Input,'unknown jump type');
End;

Procedure tComp.bLabel(Var Loc:Word);
Begin
  Loc:=IP;
  LastLb:=IP
End;

Procedure tComp.bJump;
Begin
  If Abs(Integer(Loc-IP-1))<=LenShortJmp Then Begin
    cByte(ShortJump[T]);cByte(Loc-(IP+1));
  End Else Begin
    If ipx386 Then Begin
      qPfx(T);
      cByte(LongJump[T]);cWord(Loc-(IP+2));
    End Else Begin
      If T<>__Jmp Then Begin
        cByte(ShortJump[InvJump(T)]);cByte(3);
      End;
      cByte($E9);cWord(Loc-(IP+2));
    End;
  End;
End;

Procedure tComp.bJc;
Begin
  cWord($C00A);                 {or al, al}
  _pop_ax;
  bJump(T,Loc);
End;


Procedure tComp.fLabel(Loc:Word);
Var
  JT:JumpType;
Begin
  If ipx386 Then Begin
    if Abs(Integer(IP-Loc+2))<=LenShortJmp Then Begin
      JT:=gLongJumpType(gByte(Loc-3));
      Case JT Of
        __Jmp: {jmp}
           Begin
             iByte(Loc-3,ShortJump[JT]);
             iByte(Loc-2,IP-Loc+1);
           End;
        __Jz,__Jnz,__Jl,__Jg,__Jle,__Jge: {jz/jl}
           Begin
             iByte(Loc-4,ShortJump[JT]);
             iByte(Loc-3,IP-Loc+2);
           End;
        Else
          ErrorMsg(Input,'unknown jump type');
      End;
    End Else
      iWord(Loc-2,IP-Loc)
  End Else
    iWord(Loc-2,IP-Loc)
End;

Procedure tComp.fJump;
Begin
  if ipx386 then begin
    qPfx(T);
    cByte(LongJump[T]);
    cWord($9090);
  end else begin
    If T<>__Jmp Then Begin
      cByte(ShortJump[InvJump(T)]);            {    inv_j $+3}
      cByte(3);
    End;
    cByte($E9);
    cWord(0);
  end;
  Loc:=IP;
End;

Procedure tComp.fJc;
Begin
  cWord($C00A);            {or al, al}
  _pop_ax;
  fJump(T,Loc);
End;



  {------сохранение кода---------}

  Procedure tComp.Save(Name:String);
  Var
    F:File;
  Begin
    Assign(F,Name);
    Rewrite(F,SizeOf(Byte));
    BlockWrite(F,Buf^,IP-Start);
    Close(F);
  End;

  Procedure tComp.AddFixUp;
  Begin
    Inc(FU);
    FixUp[FU].Term:=P;
    FixUp[FU].Size:=S;
    FixUp[FU].Offs:=IP;
  End;

  Procedure tComp.AllFixUp;
  Var
    w:Word;

  Begin
    While FU>0 Do Begin
      If FixUp[FU].Term^.Extrn Then Begin
        FixUp[FU].Term^.Offs:=IP;
        {comp}
        cInline('8F46FE');            {pop w,[bp-2]}
        cInline('83ED');            {sub bp,2+loc}
        cByte(2+FixUp[FU].Term^.Loc);
        For w:=0 To Pred(FixUp[FU].Size) Do
          cByte(FixUp[FU].Term^.Body^[w]);
        cInline('83C5');            {add bp,2+loc}
          cByte(2+FixUp[FU].Term^.Loc);
        cInline('FF66FE');            {jmp w,[bp-2]}
        FixUp[FU].Term^.Extrn:=False;
        {WriteLn('-------',FixUp[FU].Size);}
      End;
      iWord(FixUp[FU].Offs-2,FixUp[FU].Term^.Offs-FixUp[FU].Offs);
      Dec(FU);
    End;
  End;

  Procedure TComp._push_ax;
  Begin
    {If Not RegAX Then} cCode($50);
{    RegAX:=False}
  End;

  Procedure TComp._pop_ax;
  Begin
    cCode($58)
  End;

  Procedure TComp.Shift;
  Var
    k:Word;
  Begin
    For k:=L To IP Do Buf^[k-Start]:=Buf^[k+1-Start];
    Dec(IP)
  End;

Begin
  c:=New(pComp,Init($100,High(Word)))
End.