{$I ASSEMBLIFY.H}
{* S Compiler, ver 1.00.
   Copyright (C) 1994, Henri LESOURD.

   This software is free software; you can redistribute it and/or
   modify it under the terms of the GNU Library General Public License as
   published by the Free Software Foundation; either version 2 of the
   License, or (at your option) any later version.

   This compiler is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   Library General Public License for more details.

   You should have received a copy of the GNU Library General Public
   License along with the GNU C Library; see the file COPYING.LIB.  If not,
   write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
   Boston, MA 02111-1307, USA.  *}

Function GetWAt(I : Word) : Word;

Implementation

{ ****************
  Lo et Hi 32 bits
  **************** }
Procedure SetHiWord(Var V : LongInt; C : Integer);
Begin
{ LES DI,[BP+@V] }
  InLine($C4/$7E/<V);
{ MOV AX,[BP+@C] }
  InLine($8B/$46/<C);
{ ES:            }
{ MOV [DI+2],AX  }
  InLine($26/$89/$45/$02);
End;

Procedure SetLoWord(Var V : LongInt; C : Integer);
Begin
{ LES DI,[BP+@V] }
  InLine($C4/$7E/<V);
{ MOV AX,[BP+@C] }
  InLine($8B/$46/<C);
{ ES:            }
{ MOV [DI],AX  }
  InLine($26/$89/$05);
End;

Function HiWord(V : LongInt) : Integer;
Begin
{ MOV AX,[BP+@V+2] }
  InLine($8B/$46/<V+2);
{ MOV [BP-2],AX }
  InLine($89/$46/$FE);
End;

Function LoWord(V : LongInt) : Integer;
Begin
{ MOV AX,[BP+@V] }
  InLine($8B/$46/<V);
{ MOV [BP-2],AX }
  InLine($89/$46/$FE);
End;

{ *******
  Scratch
  ******* }
Var
   TA : TypedAddress;
   Ptr : Pointer;
   IPtr : ^Integer;
   WPtr : ^Word;
   I,J : Integer;

{ **********
  Assemblage
  ********** }
Const
     SizDefaultByteCode=50000;
Type
    ByteBuf=Array[0..$FFFE] Of Byte;
    ByteBufPtr=^ByteBuf;
Var
   ByteCode : ^ByteBuf;
   SizByteCode : Word;
   BPtr : Word;
   F : Text;

Procedure SetByteCode(P : Pointer; L : Word);
Begin
  ByteCode:=P;
  SizByteCode:=L;
End;

Function GetByteCode : Pointer;
Begin
  GetByteCode:=ByteCode;
End;

Function GetBPtr : Word;
Begin
  GetBPtr:=BPtr;
End;

Procedure PokeB(B : Byte);
Begin
  If BPtr>=SizByteCode Then Error('Bytecode buf full');
  ByteCode^[BPtr]:=B;
  Inc(BPtr);
End;

Procedure PokeBAt(I : Word; B : Byte);
Begin
  If I>=SizByteCode-1 Then Error('Bytecode buf full');
  ByteCode^[I]:=B;
End;

Procedure PokeS(S : ShortInt);
Var
   SP : ^ShortInt;
Begin
  If BPtr>=SizByteCode Then Error('Bytecode buf full');
  SP:=@ByteCode^[BPtr];
  SP^:=S;
  Inc(BPtr);
End;

Procedure PokeW(W : Word);
Begin
  If BPtr>=SizByteCode-1 Then Error('Bytecode buf full');
  ByteCode^[BPtr]:=Lo(W);
  ByteCode^[BPtr+1]:=Hi(W);
  Inc(BPtr,2);
End;

Procedure PokeWAt(I,W : Word);
Begin
  If I>=SizByteCode-1 Then Error('Bytecode buf full');
  ByteCode^[I]:=Lo(W);
  ByteCode^[I+1]:=Hi(W);
End;

Function GetWAt(I : Word) : Word;
Type
    WordPtr=^Word;
Var
   WP : WordPtr;
Begin
  If I>SizByteCode-1 Then Error('Bytecode buf full');
  WP:=@ByteCode^[I];
  GetWAt:=WP^;
End;

Procedure PokeI(I : Integer);
Var
   IP : ^Integer;
Begin
  If BPtr>=SizByteCode-1 Then Error('Bytecode buf full');
  IP:=@ByteCode^[BPtr];
  IP^:=I;
  Inc(BPtr,2);
End;

{ Poke la chaŒne ds ByteCode }
Procedure PokeStr(A : Word);
Var
   StrPtr : ^String;
   IP : ^ShortInt;
   I : Integer;
Begin
  StrPtr:=GetStringAddr(A);
  If Ord(StrPtr^[0])>+127 Then Error('PokeStr : Const string too long')
  Else
    PokeB(Ord(StrPtr^[0]));

  For I:=1 To Ord(StrPtr^[0]) Do PokeB(Ord(StrPtr^[I]));
End;

{ Poke la chaŒne avec un skip devant, et renvoie l'offset ds CS }
Function PokeSkippedStr(A : Word) : Word;
Var
   StrPtr : ^String;
   IP : ^ShortInt;
   I : Integer;
Begin
  StrPtr:=GetStringAddr(A);
  PokeB($EB);
  PokeSkippedStr:=BPtr;
  If Ord(StrPtr^[0])>+127 Then Error('PokeSkippedStr : Const string too long')
  Else
    PokeB(Ord(StrPtr^[0]));

  For I:=1 To Ord(StrPtr^[0]) Do PokeB(Ord(StrPtr^[I]));
End;

Var
   RegCode : Array[AX..rSS] of Byte;

{ ************************************************************
  Convention : le 1er est 1 registre, ou Ext<>$FF, et reg:=Ext
  ************************************************************ }
Var
   RMCode : Array[Ord(CS)..Ord(ES),BX..DI] Of Byte;

Procedure ModRegRM(Var A,B : TypedAddress; Ext : Byte);
Var
   ToPoke : Byte;
Begin
{ Codage champ Reg }
  If Ext<>$FF Then ToPoke:=Ext
              Else
                If A.C=Register Then ToPoke:=RegCode[A.Value] Shl 3
                Else
                  Error('Mod reg r/m: exp. A reg');
{ Codage Mod R/M }
  Case B.C Of
  { *********************************************************
    Important : qd c'est IndRegOfs avec offset=0, il faudrait
    faire coder un index simple plut“t qu'un index court.
    Pas possible ds SS (L'@ [BP] est tjrs [BP+00]).
    ********************************************************* }
    CS,DS,SS,ES: Case B.M Of
                   IndReg,IndRegOfs:
                     Begin
                     { Codage champ R/M }
                       ToPoke:=ToPoke Or RMCode[Ord(B.C),LoWord(B.Value)];
                       If ToPoke=$FF Then Error('ModRM : bad address mode');
                     { Codage champs Mod & Offset }
                       If (B.M=IndRegOfs) And (HiWord(B.Value)<>0) Then
                         If (HiWord(B.Value)>=-128) And
                            (HiWord(B.Value)<=+127)
                         Then
                           Begin
                             PokeB(ToPoke Or $40);
                             PokeS(HiWord(B.Value));
                           End
                         Else
                           Begin
                             PokeB(ToPoke Or $80);
                             PokeI(HiWord(B.Value));
                           End
                       Else
                         PokeB(ToPoke);
                     End;
                   IndOfs:
                     If B.C=SS Then
                       If (B.Value>=-128) And
                          (B.Value<=+127)
                       Then
                         Begin
                           PokeB(ToPoke Or $46);
                           PokeS(B.Value);
                         End
                       Else
                         Begin
                           PokeB(ToPoke Or $86);
                           PokeI(B.Value);
                         End
                     Else
                       Begin
                         PokeB(ToPoke Or $06);
                         PokeW(B.Value);
                       End;
                   Else
                     Error('ModRM : Bad mode');
                End;
    Register:   PokeB((ToPoke Or $C0) Or RegCode[B.Value]);
    Immediate:  Error('Mod reg r/m : immediate');
    Null:       Error('Mod reg r/m : unexp. Null @');
    Else
      Error('Mod reg r/m : bad class');
  End;
End;

Procedure Assemble1(Code : Byte; Var A : TypedAddress; Ext : Byte);
Begin
  PokeB(Code);
  ModRegRM(A,A,Ext);
End;

Procedure Assemble2(Code : Byte; Var A,B : TypedAddress);
Begin
  If A.C=Register Then
    Begin
      PokeB(Code Or 2);
      ModRegRM(A,B,$FF)
    End
  Else
    Begin
      PokeB(Code);
      ModRegRM(B,A,$FF);
    End;
End;

Procedure AssembleImm2(Code : Byte; Var A : TypedAddress; V : Integer; Ext : Byte);
Begin
  If Code And 1<>0 Then
  { Adressage long }
    Begin
      If (V>=-128) And (V<=+127) Then Code:=Code Or 2;
      PokeB(Code);
      ModRegRM(A,A,Ext);
      If (V>=-128) And (V<=+127) Then PokeS(V)
                                 Else PokeI(V);
    End
  Else
  { Adressage court }
    Begin
      PokeB(Code);
      ModRegRM(A,A,Ext);
      PokeB(Byte(V));
    End;
End;

Procedure AssembleImmShort2(Code : Byte; Var A : TypedAddress; V : Integer; Ext : Byte);
Begin
  PokeB(Code);
  ModRegRM(A,A,Ext);
  PokeB(Byte(V));
End;

Procedure AssembleJump(Var A : TypedAddress);
{ JMPShort=$E9, JMPLong=$EB }
Var
   Dep : LongInt;
Begin
  If (A.C<>CS) Or (A.SType<>@SymbLabel) Then Error('AssembleJump : bad A');
  If A.M<>IndOfs Then
    Begin
      PokeB($FF);
      ModRegRM(A,A,$20);
    End
  Else
    If A.Value<$10000 Then
    { BackWard }
      Begin
        Dep:=A.Value-BPtr-2;
        If (Dep>=-128) And (Dep<=+127) Then
          Begin
            PokeB($EB);
            PokeS(Dep);
          End
        Else
          Begin
            PokeB($E9);
            PokeI(Dep-1);
          End;
      End
    Else
    { ForWard }
      Begin
        PokeB($E9);
        PokeI(LoWord(A.Value));
        A.Value:=$10000;
        Dec(BPtr,2);
        IPtr:=@BPtr;
        SetLoWord(A.Value,IPtr^);
        Inc(BPtr,2);
      End;
End;

{ *****************************************************
  Tableau InvJump : InvJump[COP_BCC And $0F] = Inv(BCC)
  ***************************************************** }
Var
   InvJump : Array[$02..$0F] Of Byte;

Procedure AssembleCondJump(Code : Byte; Var A : TypedAddress);
Var
   Dep : LongInt;
Begin
  If (A.C<>CS) Or (A.SType<>@SymbLabel) Then Error('AssembleCondJump : bad A');
  If A.Value<$10000 Then
  { BackWard }
    Begin
      Dep:=A.Value-BPtr-2;
      If (Dep>=-128) And (Dep<=+127) Then
        Begin
          PokeB(Code);
          PokeS(Dep);
        End
      Else
        Begin
          PokeB(InvJump[Code And $0F]);
          PokeB(3);
          PokeB($E9);
          PokeI(Dep-3);
        End;
    End
  Else
  { ForWard }
    Begin
      PokeB(InvJump[Code And $0F]);
      PokeB(3);
      PokeB($E9);
      PokeI(LoWord(A.Value));
      A.Value:=$10000;
      Dec(BPtr,2);
      IPtr:=@BPtr;
      SetLoWord(A.Value,IPtr^);
      Inc(BPtr,2);
    End;
End;

Procedure AssembleNearCall(Var A : TypedAddress);
{ Call Near=$E8, Call Far=$9A }
Var
   Dep : LongInt;
Begin
  If ((A.C<>CS) And
      (A.C<>Export) And
      (A.C<>NullExport)
     )
  Or
     ((A.SType^.Nature<>KeySub) And
      (A.SType^.Nature<>KeyDef)
     )
  Then
    Error('AssembleNearCall : bad A');

  If A.Value<$10000 Then
  { BackWard }
    Begin
      Dep:=A.Value-BPtr-2;
      If A.C=Export Then Inc(Dep,SizHeadFarFuncs);
      PokeB($E8);
      PokeI(LoWord(Dep-1));
    End
  Else
  { ForWard }
    Begin
      PokeB($E8);
      PokeI(LoWord(A.Value));
      A.Value:=$10000;
      Dec(BPtr,2);
      IPtr:=@BPtr;
      SetLoWord(A.Value,IPtr^);
      Inc(BPtr,2);
    End;
End;

Procedure PokePrefix(Var A1,A2 : TypedAddress);
Begin
  If (A1.C=ES) Or (A2.C=ES) Then PokeB($26);
End;

Var
   MaskShort : Byte;

Procedure Assemble(C : COP; Var A1,A2 : TypedAddress);
Begin
{ **********************************************************
  WARNING : je le vire a cause de RETX, mais ‡a pourrait
            couiller a cause de ‡a.
  **********************************************************
  If A1.C=Immediate Then Error('Assemble : unexp. imm. A1');
  ********************************************************** }
{*************************
  Pas super, comme test...
  ************************ }
{ Prefixe }
  If (C<>LEA) And (C<>UDIV) And (C<>IDIV) Then PokePrefix(A1,A2);
{ Adressage 8/16 }
  If ByteAddr Then MaskShort:=$FE Else MaskShort:=$FF;
  Case C Of
    PUSH:  If A1.C=Register Then
             If IsSegReg[A1.Value] Then PokeB($06 Or (RegCode[A1.Value] Shl 3))
                                   Else PokeB($50 Or RegCode[A1.Value])
           Else
             Assemble1($FF,A1,$30);

    POP:   If A1.C=Register Then
             If IsSegReg[A1.Value] Then PokeB($07 Or (RegCode[A1.Value] Shl 3))
                                   Else PokeB($58 Or RegCode[A1.Value])
           Else
             Assemble1($8F,A1,$00);

    MOV:   If A1.C=Immediate Then Error('Assemble : A1 imm.')
           Else
           If A2.C=Immediate Then
             If A1.C=Register Then
               Begin
                 If IsSegReg[A1.Value] Then Error('Assemble : MOV SegReg,Imm');
                 PokeB(($B8 Or RegCode[A1.Value]) And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               Begin
                 PokeB($C7 And MaskShort);
                 ModRegRM(A1,A1,$00);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
           Else
           If (A1.C=Register) And (IsSegReg[A1.Value]) Then
             Begin
               If (A2.C=Register) And (IsSegReg[A2.Value]) Then Error('Assemble : MOV SegReg1,SegReg2 forbidden');
               PokeB($8E);
               ModRegRM(A1,A2,$FF);
             End
           Else
           If (A2.C=Register) And (IsSegReg[A2.Value]) Then
             Begin
               PokeB($8C);
               ModRegRM(A2,A1,$FF);
             End
           Else
             Assemble2($89 And MaskShort,A1,A2);

    LEA:   If A2.C=Register Then Error('Assemble : LEA X,Reg')
           Else
           If A1.C<>Register Then Error('Assemble : LEA X,Y, X=Reg@ expected')
                             Else
                               Begin
                                 PokeB($8D);
                                 ModRegRM(A1,A2,$FF);
                               End;

    LES:   If A2.C=Register Then Error('Assemble : LES X,Reg')
           Else
           If A1.C<>Register Then Error('Assemble : LES X,Y, X=Reg@ expected')
                             Else
                               Begin
                                 PokeB($C4);
                                 ModRegRM(A1,A2,$FF);
                               End;

    XCHG:  Assemble2($87 And MaskShort,A1,A2);
    COR:   If A2.C<>Immediate Then Assemble2($09 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($0D And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,Integer(A2.Value),$08);

    CAND:  If A2.C<>Immediate Then Assemble2($21 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($25 And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,Integer(A2.Value),$20);

    CXOR:  If A2.C<>Immediate Then Assemble2($31 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($35 And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,Integer(A2.Value),$30);

    CSHL,
     SAL:  If A2.C<>Immediate Then
             Begin
               If (A2.C<>Register) Or (A2.Value<>CX) Then Error('Assemble : SHL/SAL @,!Imm; !Imm=CX expected');
               Assemble1($D3 And MaskShort,A1,$20);
             End
           Else
             If (A2.Value=1) Then Assemble1($D1 And MaskShort,A1,$20)
             Else
               AssembleImmShort2($C1 And MaskShort,A1,A2.Value,$20);

    CSHR:  If A2.C<>Immediate Then
             Begin
               If (A2.C<>Register) Or (A2.Value<>CX) Then Error('Assemble : SHR @,!Imm; !Imm=CX expected');
               Assemble1($D3 And MaskShort,A1,$28);
             End
           Else
             If (A2.Value=1) Then Assemble1($D1 And MaskShort,A1,$28)
             Else
               AssembleImmShort2($C1 And MaskShort,A1,A2.Value,$28);

    SAR:   If A2.C<>Immediate Then
             Begin
               If (A2.C<>Register) Or (A2.Value<>CX) Then Error('Assemble : SAR @,!Imm; !Imm=CX expected');
               Assemble1($D3 And MaskShort,A1,$38);
             End
           Else
             If (A2.Value=1) Then Assemble1($D1 And MaskShort,A1,$38)
             Else
               AssembleImmShort2($C1 And MaskShort,A1,A2.Value,$38);

    RCL:   If A2.C<>Immediate Then
             Begin
               If (A2.C<>Register) Or (A2.Value<>CX) Then Error('Assemble : SAR @,!Imm; !Imm=CX expected');
               Assemble1($D3 And MaskShort,A1,$10);
             End
           Else
             If (A2.Value=1) Then Assemble1($D1 And MaskShort,A1,$10)
             Else
               AssembleImmShort2($C1 And MaskShort,A1,A2.Value,$10);

    RCR:   If A2.C<>Immediate Then
             Begin
               If (A2.C<>Register) Or (A2.Value<>CX) Then Error('Assemble : SAR @,!Imm; !Imm=CX expected');
               Assemble1($D3 And MaskShort,A1,$18);
             End
           Else
             If (A2.Value=1) Then Assemble1($D1 And MaskShort,A1,$18)
             Else
               AssembleImmShort2($C1 And MaskShort,A1,A2.Value,$18);

    CMP:   If A2.C<>Immediate Then Assemble2($39 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($3D And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,A2.Value,$38);

    JZ:    AssembleCondJump($74,A1);
    JNZ:   AssembleCondJump($75,A1);
    JL:    AssembleCondJump($7C,A1);
    JLE:   AssembleCondJump($7E,A1);
    JG:    AssembleCondJump($7F,A1);
    JGE:   AssembleCondJump($7D,A1);
    JB:    AssembleCondJump($72,A1);
    JBE:   AssembleCondJump($76,A1);
    JA:    AssembleCondJump($77,A1);
    JAE:   AssembleCondJump($73,A1);
    JMP:   AssembleJump(A1);
    NCALL: AssembleNearCall(A1);
    FCALL: Begin
             If A1.C<>Extern Then Error('Assemble : call far : A1.C=Extern expected');
             PokeB($9A);
             PokeW(Word(LoWord(A1.Value)));
             PokeW(Word(HiWord(A1.Value)));
           End;
    RETN:  If A2.C<>Null Then Error('Assemble : RETN : 0 or 1 Parm expected')
           Else
             If A1.C=Null Then PokeB($C3)
             Else
             If A1.C=Immediate Then
               Begin
                 PokeB($C2);
                 PokeW(A1.Value);
               End
             Else
               Error('Assemble : RETN : Immediate parm expected');

    RETF:  If A2.C<>Null Then Error('Assemble : RETF : 0 or 1 Parm expected')
           Else
             If A1.C=Null Then PokeB($CB)
             Else
             If A1.C=Immediate Then
               Begin
                 PokeB($CA);
                 PokeW(A1.Value);
               End
             Else
               Error('Assemble : RETN : Immediate parm expected');

    ADD:   If A2.C<>Immediate Then Assemble2($01 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($05 And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,A2.Value,$00);

    ADC:   If A2.C<>Immediate Then Assemble2($11 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($15 And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,A2.Value,$10);

    SUB:   If A2.C<>Immediate Then Assemble2($29 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($2D And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,A2.Value,$28);

    SBB:   If A2.C<>Immediate Then Assemble2($19 And MaskShort,A1,A2)
           Else
             If (A1.C=Register) And (A1.Value=AX) Then
               Begin
                 PokeB($1D And MaskShort);
                 If ByteAddr Then PokeB(Byte(A2.Value))
                             Else PokeW(Word(A2.Value));
               End
             Else
               AssembleImm2($81 And MaskShort,A1,A2.Value,$18);

  { Rajouter le codage direct registre pour INC et DEC }
    CINC:  Assemble1($FF And MaskShort,A1,$00);
    CDEC:  Assemble1($FF And MaskShort,A1,$08);
    NEG:   Assemble1($F7 And MaskShort,A1,$18);
    CNOT:  Assemble1($F7 And MaskShort,A1,$10);
    IMUL:  Assemble1($F7 And MaskShort,A1,$28);
    MUL:   Assemble1($F7 And MaskShort,A1,$20);
    CBW:   PokeB($98);
    CWD:   PokeB($99);
  { Il faudra rajouter XOR DX,DX devant, ou un truc du genre }
    UDIV:
      Begin
      { XOR AH,AH/XOR DX,DX }
        If ByteAddr Then PokeW($E430) Else PokeW($D231);
      { Pr‚fixe }
        PokePrefix(A1,A2);
      { DIV }
        Assemble1($F7 And MaskShort,A1,$30);
      End;
    IDIV:
      Begin
      { CBW/CWD }
        If ByteAddr Then PokeB($98) Else PokeB($99);
      { Pr‚fixe }
        PokePrefix(A1,A2);
      { IDIV }
        Assemble1($F7 And MaskShort,A1,$38);
      End;
  Else
    Error('Assemble : badcop');
  End;
End;

{ ******
  Labels
  ****** }
Function IsForWard(Var L : TypedAddress) : Boolean;
Begin
  If (L.C<>CS) Or
     ((L.SType^.Nature<>KeySub) And
      (L.SType^.Nature<>KeyDef) And
      (L.SType<>@SymbLabel)
     )
  Then
    Error('IsForWard : bad L');

  IsForWard:=L.Value>=$10000;
End;

Procedure NewLabel(Var R : TypedAddress);
Begin
  R.C:=CS;
  R.M:=IndOfs;
  R.Value:=$1ffff;
  R.SType:=@SymbLabel;
End;

{ ************************************************
  Cette procedure affecte le label R au IP actuel,
  et remonte la chaine des jmps lies a ce label.
  ************************************************ }
Procedure PutLabel(Var R : TypedAddress);
Var
   CurPtr,CurPtrOld : Word;
   LI : LongInt;
Begin
  If ((R.C<>CS) And (R.C<>Export)) Or (R.Value<$10000) Or
     ((R.SType^.Nature<>KeySub) And
      (R.SType^.Nature<>KeyDef) And
      (R.SType<>@SymbLabel)
     )
  Then
    Error('PutLabel : bad R');

  LI:=R.Value-$10000;
  WPtr:=@LI;
  CurPtr:=WPtr^;
  While CurPtr<>$ffff Do
    Begin
      IPtr:=@ByteCode^[CurPtr];
      WPtr:=@ByteCode^[CurPtr];
      CurPtrOld:=CurPtr;
      CurPtr:=WPtr^;
      If R.C<>Export Then IPtr^:=BPtr-CurPtrOld-2
                     Else IPtr^:=BPtr-CurPtrOld-2+SizHeadFarFuncs;
    End;
  R.Value:=BPtr;
End;

{ **************************************************
  Gestion des tables de symboles des fichiers objets
  ************************************************** }
Type
    WordPtr=^Word;

Procedure PutType(T,Self : TVArrayPtr);
Label
     TheEnd;
Var
   B : BoxPtr;
   S : SymbPtr;
   Len,Ptr0 : Word;
   Len1,Ptr1 : Word;
   TVR : TVRecElemPtr;
Begin
{ Init Ptr0 }
  PokeW(0);
  Ptr0:=BPtr;

{ Pokage du type }
  If (T^.Nature=KeyWord Or KeySub) Or (T^.Nature=KeyWord Or KeyDef) Then
    Begin
    { ********************************************************
      REM : Aucune v‚rif., bikoze le proto a d‚j… ‚t‚ formatt‚
      ******************************************************** }
    { Poker le tag }
      If T^.Nature=KeyWord Or KeySub Then PokeB(ValTVSub)
                                     Else PokeB(ValTVDef);
      B:=BoxPtr(T);

    { Si Def, poker Type(Result) }
      If T^.Nature=KeyWord Or KeyDef Then PutType(TVArrayPtr(B^.Droite^.Droite),Self);

    { Putter le type des parms }
      If B^.Gauche^.Nature=Operator Or OpPouvr Then
        Begin
          B:=B^.Gauche^.Droite;
          While B^.Nature=Operator Or OpVirg Do
          Begin
            PutType(TVArrayPtr(B^.Droite^.Droite),Self);
            B:=B^.Gauche;
          End;
          PutType(TVArrayPtr(B^.Droite),Self);
        End;
    End
  Else
    Begin
      While IsValTV(Name(T^.Nature)) Do
      Begin
        If Not Nature(T^.Nature)=Symbol Then Error('PutType : Nat(T)=Symb expected');
        Case Name(T^.Nature) Of
          ValTVPtr,ValTVRef:
            Begin
              PokeB(Name(T^.Nature));
              PokeW(T^.Size);
            End;
          ValTVArray:
            Begin
              PokeB(Name(T^.Nature));
              PokeW(T^.Size);
              PokeW(T^.NbElems);
              PokeI(T^.FirstInd);
            End;
          ValTVRecord:
            Begin
            { Test bouclage }
              If T=Self Then
              Begin
                PokeB(PredSelf);
                PokeW(0);
                Goto TheEnd;
              End;
              PokeB(Name(T^.Nature));
              PokeW(T^.Size);
              Ptr1:=BPtr;
              Len1:=0;
              PokeW(0);
              TVR:=TVRecordPtr(T)^.First;
              While TVR<>Nil Do
              Begin
              { Putter le name de TVR }
                If (TVR^.Name=Nil) Or (Nature(TVR^.Name^.Nature)<>Symbol) Then
                  Error('PutType : RecElem : Name : Symbol expected')
                ;
                PokeStr(TVR^.Name^.Name);
              { Putter le type de TVR }
                PutType(TVArrayPtr(TVR^.SType),T);
                TVR:=TVR^.Next;
                Inc(Len1);
              End;
              WordPtr(@ByteCode^[Ptr1])^:=Len1;
              Goto TheEnd;
            End;
          Else
            Error('PutType : Bad ValTV');
        End;
        T:=T^.Next;
      End;
      S:=@T^;
      If S^.Addr.C<>CType Then Error('PutType : Type val exp.');
      PokeB(Name(S^.Nature));
      PokeW(S^.Addr.Value);
    End;

{ Maj len }
TheEnd:
  Len:=BPtr-Ptr0;
  WordPtr(@ByteCode^[Ptr0-2])^:=Len;
End;

Function GetTypeSize(B : BoxPtr) : LongInt;
Begin
  If B=Nil Then Error('GetTypeSize : Nil B');
  If Nature(B^.Nature)=Symbol Then
    Begin
      If IsValTV(Name(B^.Nature)) Then GetTypeSize:=TVRefPtr(B)^.Size
      Else
        If SymbPtr(B)^.Addr.C=Null Then Error('GetTypeSize : undeclared type name')
        Else
        If SymbPtr(B)^.Addr.C<>CType Then Error('GetTypeSize : not a type name')
        Else
          GetTypeSize:=SymbPtr(B)^.Addr.Value;
    End
  Else
    Error('GetTypeSize : Bad Type Val');
End;

Procedure PutSigma(S : SymbPtr);
Begin
  If S^.Addr.C=CType Then
  Begin
    PokeStr(S^.Name);
    PokeW(1);
    PokeB(ValTVType);
    PutType(Pointer(S^.Addr.Value),Nil);
  End
  Else
  If S^.Addr.C=Immediate Then
  Begin
    PokeStr(S^.Name);
    PokeW(1);
    PokeB(ValTVConst);
    PutType(Pointer(S^.Addr.SType),Nil);
    Case GetTypeSize(BoxPtr(S^.Addr.SType)) Of
      2: PokeW(Word(S^.Addr.Value));
      4: Begin
           PokeW(Word(S^.Addr.Value));
           PokeW(Word(HiWord(S^.Addr.Value)));
         End;
      Else
        Error('PutSigma : Imm : bad type size');
    End;
  End
  Else
  Begin
    If (S^.Addr.C<>Export) And
       (S^.Addr.C<>Extern) And
       (S^.Addr.C<>CS) And
       (S^.Addr.C<>DS)
    Then
      Exit
    ;
    PokeStr(S^.Name);
    PutType(@S^.Addr.SType^,Nil);
    PokeW(LoWord(S^.Addr.Value));
  End;
End;

Var
   FBin : File;
   FName : String;

{ **********************************************************
  ATTENTION : Cette fonction est suppos‚e avoir ‚t‚ appell‚e
  avec H pointant DANS le buffer ByteCode. Gaffe, donc.
  ********************************************************** }
Procedure RecordObjFile(Var H : Header; Name : Word);
Var
   StrPtr,S : ^String;
   BPtr0,BPtr1 : Word;
   C : ConsPtr;
   A : AccessPtr;
Begin
{ Imports }
  While BPtr And $0F<>0 Do PokeB($BB);
  BPtr0:=BPtr;
  While Imports<>Nil Do
  Begin
    C:=ConsPtr(Imports^.Car);
    Imports:=Imports^.Cdr;
  { Nom du module import‚ }
    PokeStr(SymbPtr(C^.Car)^.Name);
  { #Sigmas }
    C:=C^.Cdr;
  { Les sigmas }
    BPtr1:=BPtr;
    PokeW(0);
    While C<>Nil Do
    Begin
      If (C^.Car^.Addr.C=CType) Or
         (C^.Car^.Addr.C=Immediate) Or
         (Word(HiWord(C^.Car^.Addr.Value))<>$FFFF) Then
      Begin
        PutSigma(C^.Car);
        If C^.Car^.Addr.C<>CType Then PokeW(Word(HiWord(C^.Car^.Addr.Value)))
                                 Else PokeW($FFFF);
      End;
      C:=C^.Cdr;
    End;
    PokeWAt(BPtr1,BPtr-BPtr1-2);
  End;
  H.SizImports:=BPtr-BPtr0;
  StrPtr:=@ByteCode^[BPtr0];
  A:=@StrPtr;
  Inc(A^[1],A^[0] Shr 4);
  A^[0]:=0;
  If CompileToDisk Then
  Begin
  { Open }
    Assign(FBin,FName);
    Rewrite(FBin,1);
  { Header / Exports }
    BlockWrite(FBin,H,((H.C0+2) And $FFF0)+$10);
  { Code }
    BlockWrite(FBin,ByteCode^,H.SizCode);
  { Imports }
    BlockWrite(FBin,StrPtr^,H.SizImports);
  { Close }
    Close(FBin);
  End;
{ Fill EnvirCour }
  EnvirCour.H:=@H;
  EnvirCour.CS.BA:=ByteCode;
  EnvirCour.DS.BA:=StrPtr;
  EnvirCour.Linked:=False;
End;

Procedure StartAssemblify(S : String);
Begin
  If ByteCode=Nil Then
  Begin
    GetBlock(EnvirCour.CS,SizDefaultByteCode);
    ByteCode:=EnvirCour.CS.BA;
    If ByteCode=Nil Then Error('StartAssemblify : out of memory');
    SizByteCode:=SizDefaultByteCode;
  End;
  Case FT Of
    COM: FName:=Concat(S,'.com');
    OBJ: FName:=Concat(S,'.pak');
    BOOT: FName:=Concat(S,'.pos');
  End;
  BPtr:=0;
End;

Procedure EndAssemblify;
Begin
  If (FT=COM) Or (FT=BOOT) Then
    Begin
      Assign(FBin,FName);
      Rewrite(FBin,1);
      BlockWrite(FBin,ByteCode^,BPtr);
      Close(FBin);
    End;
End;

Procedure SaveContextCompilo(Var C : ContextCompilo);
Var
   I : Integer;
Begin
  For I:=AX To rSS Do
    Begin
      If Not RegFree[I] Then C.RegContainsValues[I]:=RegContains[I]^;
      C.RegContains[I]:=RegContains[I];
      C.RegFree[I]:=RegFree[I];
      C.BPtr:=BPtr;
    End;
End;

Procedure RestoreContextCompilo(Var C : ContextCompilo);
Var
   I : Integer;
Begin
  For I:=AX To rSS Do
    Begin
      RegFree[I]:=C.RegFree[I];
      RegContains[I]:=C.RegContains[I];
      If Not RegFree[I] Then RegContains[I]^:=C.RegContainsValues[I];
      BPtr:=C.BPtr;
    End;
End;

Begin
{ Init ByteCode }
  ByteCode:=Nil;
{ Codes des registres }
  RegCode[AX]:=$00;
  RegCode[BX]:=$03;
  RegCode[CX]:=$01;
  RegCode[DX]:=$02;
  RegCode[SP]:=$04;
  RegCode[BP]:=$05;
  RegCode[SI]:=$06;
  RegCode[DI]:=$07;
  RegCode[rES]:=$00;
  RegCode[rCS]:=$01;
  RegCode[rDS]:=$03;
  RegCode[rSS]:=$02;
{ Modes d'@ }
  ByteAddr:=False;
  For I:=Ord(CS) To Ord(ES) Do For J:=BX To DI Do RMCode[I,J]:=$FF;
{ Modes d'@ / CS }
  RMCode[Ord(CS),SI]:=$04;
  RMCode[Ord(CS),DI]:=$05;
  RMCode[Ord(CS),BX]:=$07;
{ Modes d'@ / DS }
  RMCode[Ord(DS),SI]:=$04;
  RMCode[Ord(DS),DI]:=$05;
  RMCode[Ord(DS),BX]:=$07;
{ Modes d'@ / ES }
  RMCode[Ord(ES),SI]:=$04;
  RMCode[Ord(ES),DI]:=$05;
  RMCode[Ord(ES),BX]:=$07;
{ Modes d'@ / SS }
  RMCode[Ord(SS),SI]:=$02;
  RMCode[Ord(SS),DI]:=$03;
{ Codes conditions }
  InvJump[$04]:=$75; { Inv(JZ)=JNZ }
  InvJump[$05]:=$74; { Inv(JNZ)=JZ }
  InvJump[$0C]:=$7D; { Inv(JL)=JGE }
  InvJump[$0D]:=$7C; { Inv(JGE)=JL }
  InvJump[$0E]:=$7F; { Inv(JLE)=JG }
  InvJump[$0F]:=$7E; { Inv(JG)=JLE }
  InvJump[$02]:=$73; { Inv(JB)=JAE }
  InvJump[$03]:=$72; { Inv(JAE)=JB }
  InvJump[$06]:=$77; { Inv(JBE)=JA }
  InvJump[$07]:=$76; { Inv(JA)=JBE }
{ CompileToDisk }
  CompileToDisk:=True;
{ SizHeadFarFuncs }
  SizHeadFarFuncs:=5;
End.
