Unit Addressify;
{* 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.  *}

Interface

Uses
    Crt,Errorify,Symbolize,Lexify,Assemblify;

{ ********************************
  Gestion des TypedAddress 32 bits
  ******************************** }
Procedure GetHigh(Var R,TA : TypedAddress);
Procedure GetLow(Var R,TA : TypedAddress);
Procedure SetHigh(Var R,TA : TypedAddress);
Procedure SetLow(Var R,TA : TypedAddress);

{ Quelques variables predefinies }
Var
   NullAddr,ImmAddr,ImmOne,ImmZero : TypedAddress;

{ Registres }
Var
   Reg : Array[AX..rSS] Of TypedAddress;
   DontUseThisAddr : TypedAddress;

{ Contexte ctrl }
   CurLabel : TypedAddress;
   InvCondJump : Boolean;
   Imbricated : Boolean;
   SizVarStat,SizVarLoc,SizParms,SizBindings : Word;

{ ***************
  Alloc registres
  *************** }
Var
   TopOfStack  : TypedAddress;
   SizTmp      : Word;

Procedure SetRegValueMode;
Procedure SetFirstLastReg(F,L : Word);
Procedure SetRegAddrMode(WithBX : Boolean);

Var
   CurCOP : COP;
Procedure GetReg16(Var R,V : TypedAddress);
Procedure GetDataReg16(Var R,V : TypedAddress; WithAddrRegs : Boolean);
Procedure GetAddrReg16(Var R,V : TypedAddress; WithBX       : Boolean);
Procedure GetNamedReg16(Var Resu : TypedAddress; R : Integer; Var V : TypedAddress);
Procedure AllocReg16(Var R : TypedAddress);
Procedure ReallocNamedReg16(R : Integer);
Procedure FreeReg16(Var T : TypedAddress);

Procedure GetReg32(Var R,V : TypedAddress);
Procedure GetAddrReg32(Var R,V : TypedAddress);
Procedure GetAddrDataReg32(Var R,V : TypedAddress);
Procedure FreeReg32(Var T : TypedAddress);

Procedure SetRegContainsOn(Var R,TA : TypedAddress);
Procedure ReallocReg(Var TA : TypedAddress);
Function  StackUsedRegs : Integer;
Procedure UnStackRegSet(S : Integer);
Procedure FreeAllRegs;

{ *********************
  Calcul des constantes
  ********************* }
Procedure CalcConst(Var Resu : TypedAddress; B : BoxPtr);
Procedure CalcExprConst(Var Resu : TypedAddress; Opn : Word; Var A1,A2 : TypedAddress);

{ ****************
  Calcul des types
  **************** }
Function  CalcTVPtr(Suiv : Pointer) : Pointer;
Function  CalcTVArray(Interv : BoxPtr; Suiv : Pointer) : Pointer;
Procedure CalcRecordType(Var C : BoxPtr);
Procedure CalcType(Var B : BoxPtr);

{ *******************
  Tests sur les types
  ******************* }
Function IsScalaire8(Typ : SymbPtr) : Boolean;
Function IsScalaire16(Typ : SymbPtr) : Boolean;
Function IsScalaire(Typ : SymbPtr) : Boolean;
Function IsInteger(Typ : SymbPtr) : Boolean;
Function IntTypeSup(T1,T2 : SymbPtr) : Boolean;
Function IsPointer(Typ : SymbPtr) : Boolean;
Function TypeEQ(A,B : TVPtrPtr) : Boolean;
Function GetTypeSize(B : BoxPtr) : LongInt;

{ ******************************************
  Calcul sur la repr‚sentation des fonctions
  ****************************************** }
Procedure GetRegisterResultLocation(Var Resu : TypedAddress; T : BoxPtr);
Procedure GetFuncResultLocation(Var Resu : TypedAddress; FName : BoxPtr);
Function  GetFuncType(FName : BoxPtr) : BoxPtr;

{ ***********
  Compilation
  *********** }
Type
    ValueMode=(CopyMode,DefaultMode,AddrDataMode);
Procedure LoadIt(Var Resu,TA : TypedAddress; M : ValueMode);
Procedure StackIt(Var TA : TypedAddress);
Procedure CastIt(Var T : TypedAddress; Typ : SymbPtr);

Procedure StartAddressify;

Implementation

{ ********************************
  Gestion des TypedAddress 32 bits
  ******************************** }
{ ATTENTION, CES PROCEDURES DEALENT AVEC LA
  PARTIE "MACHINE" D'UNE TA, PAS AVEC LE TYPE,
  DONC, APRES 1 GetHigh, FE, LE TYPE EST
  INCOHERENT AVEC LA CLASSE }
Procedure GetHigh(Var R,TA : TypedAddress);
Begin
  Case (TA.C) Of
    Reg32,RegMem32:
      Begin
        R.C:=Register;
        R.Value:=HiWord(TA.Value);
      End;
    MemReg32,Mem32:
      Begin
        R.C:=SS;
        R.M:=IndOfs;
        R.Value:=HiWord(TA.Value);
      End;
    CS,DS,SS,ES:
      Case TA.M Of
        IndOfs: Begin
                  R.C:=TA.C;
                  R.M:=TA.M;
                  R.Value:=TA.Value+2;
                End;
        IndReg: Begin
                  R.C:=TA.C;
                  R.M:=IndRegOfs;
                  R.Value:=TA.Value;
                  SetHiWord(R.Value,2);
                End;
        IndRegOfs: Begin
                     R.C:=TA.C;
                     R.M:=TA.M;
                     R.Value:=TA.Value;
                     SetHiWord(R.Value,HiWord(TA.Value)+2);
                   End;
        Else
          Error('GetHigh : bad TA.M')
      End;
    Immediate:
      If GetTypeSize(@TA.SType^)<=4 Then
        Begin
          R.C:=Immediate;
          R.Value:=HiWord(TA.Value);
        End
      Else
        Error('GetHigh : Immediate');
    Else
      Error('GetHigh : Bad TA');
  End;
End;

{ Peut marcher avec @R=@TA }
Procedure GetLow(Var R,TA : TypedAddress);
Begin
  Case (TA.C) Of
    Reg32,MemReg32:
      Begin
        R.C:=Register;
        R.Value:=LoWord(TA.Value);
      End;
    RegMem32,Mem32:
      Begin
        R.C:=SS;
        R.M:=IndOfs;
        R.Value:=LoWord(TA.Value);
      End;
    CS,DS,SS,ES:
      Case TA.M Of
        IndOfs,IndReg,IndRegOfs: Begin
                                   R.C:=TA.C;
                                   R.M:=TA.M;
                                   R.Value:=TA.Value;
                                 End
        Else
          Error('GetLow : bad TA.M')
      End;
    Immediate:
      If GetTypeSize(@TA.SType^)<=4 Then
        Begin
          R.C:=Immediate;
          R.Value:=LoWord(TA.Value);
        End
      Else
        Error('GetLow : Immediate');
    Else
      Error('GetLow : Bad TA');
  End;
End;

Procedure SetHigh(Var R,TA : TypedAddress);
Begin
  If Not ((Ord(R.C)>=Ord(Reg32)) And (Ord(R.C)<=Ord(Mem32))) Then Error('SetHigh : Bad R');
  If Not ((Ord(TA.C)>=Ord(SS)) And (Ord(TA.C)<=Ord(Register))) Then Error('SetHigh : Bad TA');
  Case (R.C) Of
    Reg32,MemReg32: If TA.C=SS Then R.C:=MemReg32 Else R.C:=Reg32;
    RegMem32,Mem32: If TA.C=SS Then R.C:=Mem32 Else R.C:=RegMem32;
  End;
  SetHiWord(R.Value,TA.Value);
End;

Procedure SetLow(Var R,TA : TypedAddress);
Begin
  If Not ((Ord(R.C)>=Ord(Reg32)) And (Ord(R.C)<=Ord(Mem32))) Then Error('SetLow : Bad R');
  If Not ((Ord(TA.C)>=Ord(SS)) And (Ord(TA.C)<=Ord(Register))) Then Error('SetLow : Bad TA');
  Case (R.C) Of
    Reg32,RegMem32: If TA.C=SS Then R.C:=RegMem32 Else R.C:=Reg32;
    MemReg32,Mem32: If TA.C=SS Then R.C:=Mem32 Else R.C:=MemReg32;
  End;
  SetLoWord(R.Value,TA.Value);
End;

{ ***************
  Alloc registres
  *************** }
{ Procedures de contr“le reg@/regë }
Var
   FirstHighReg,LastHighReg : Word;
   FirstReg,LastReg : Word;

Procedure SetRegValueMode;
Begin
  FirstReg:=AX;
  LastReg:=BX;
End;

Procedure SetFirstLastReg(F,L : Word);
Begin
  FirstReg:=F;
  LastReg:=L;
End;

Procedure SetRegAddrMode(WithBX : Boolean);
Begin
  If WithBX Then FirstReg:=BX Else FirstReg:=SI;
  LastReg:=DI;
End;

{* Qd on deplace un registre, il faut mettre a jour son RegContains *}
Procedure MajRegContains(R : Integer; Var NewLoc : TypedAddress);
Begin
  If Not ((Ord(NewLoc.C)>=Ord(SS)) And (Ord(NewLoc.C)<=Ord(Register))) Then Error('MajRegContains : Bad NewLoc');
  Case RegContains[R]^.C Of
    Register: RegContains[R]^:=NewLoc;
    Reg32:
      Begin
        If LoWord(RegContains[R]^.Value)=R Then SetLow(RegContains[R]^,NewLoc)
                                           Else SetHigh(RegContains[R]^,NewLoc);
      End;
    RegMem32: SetHigh(RegContains[R]^,NewLoc);
    MemReg32: SetLow(RegContains[R]^,NewLoc);
    Else
      Error('MajRegContains[R] : bad RegContains[R]');
  End;
  SetRegContainsOn(RegContains[R]^,RegContains[R]^);
End;

{ ***********************************************************
  Rajouter 1 optim pour baisser SizTmp au cas ou T=TopOfStack
  *********************************************************** }
Procedure GetReg16(Var R,V : TypedAddress);
Var
   I : Integer;
Begin
{ Check }
  If (Ord(V.C)>=Ord(Reg32)) And (Ord(V.C)<=Ord(Mem32)) Then Error('GetReg16 : Bad V(1)');
{ Lib‚rer les registres utilis‚s ds V au cas o— V n'est pas 1 reg }
  If V.C<>Register Then FreeReg16(V);
{ Essayer de trouver le Reg }
  For I:=FirstReg To LastReg Do
     If RegFree[I]=True Then
     Begin
     { Generer le COP }
       Assemble(CurCOP,Reg[I],V);
     { Lib‚rer V }
       FreeReg16(V);
     { Prendre R=Reg[I]; On peut ‚craser V ds l'affaire, si @R=@V }
       R.C:=Register;
       R.Value:=I;
       R.SType:=V.SType;
     { Marquer que le reg nøI est occup‚ }
       RegFree[I]:=False;
     { Maj RegContains }
       RegContains[I]:=@R;
       Exit;
     End
  ;
{ Cas o— on n'a pas r‚ussi … allouer de registre }
  SetRegContainsOn(V,V);
  GetNamedReg16(R,FirstReg,V);
End;

Function GetPerhapsReg16(Var R,V : TypedAddress) : Boolean;
Var
   I : Integer;
Begin
{ Check }
  If (Ord(V.C)>=Ord(Reg32)) And (Ord(V.C)<=Ord(Mem32)) Then Error('GetReg16 : Bad V(1)');
{ Lib‚rer les registres utilis‚s ds V au cas o— V n'est pas 1 reg }
  If V.C<>Register Then FreeReg16(V);
{ Essayer de trouver le Reg }
  GetPerhapsReg16:=False;
  For I:=FirstReg To LastReg Do
     If RegFree[I]=True Then
     Begin
     { Generer le COP }
       Assemble(CurCOP,Reg[I],V);
     { Lib‚rer V }
       FreeReg16(V);
     { Prendre R=Reg[I]; On peut ‚craser V ds l'affaire, si @R=@V }
       R.C:=Register;
       R.Value:=I;
       R.SType:=V.SType;
     { Marquer que le reg nøI est occup‚ }
       RegFree[I]:=False;
     { Maj RegContains }
       RegContains[I]:=@R;
       GetPerhapsReg16:=True;
       Exit;
     End
  ;
{ Cas o— on n'a pas r‚ussi … allouer de registre }
  R:=V;
End;

Procedure GetDataReg16(Var R,V : TypedAddress; WithAddrRegs : Boolean);
Var
   OFReg,OLReg : Word;
Begin
  OFReg:=FirstReg;
  OLReg:=LastReg;
  If WithAddrRegs Then LastReg:=DI Else LastReg:=BX;
  FirstReg:=AX;
  GetReg16(R,V);
  FirstReg:=OFReg;
  LastReg:=OLReg;
End;

Procedure GetAddrReg16(Var R,V : TypedAddress; WithBX : Boolean);
Var
   OFReg,OLReg : Word;
Begin
  OFReg:=FirstReg;
  OLReg:=LastReg;
  If WithBX Then FirstReg:=BX Else FirstReg:=SI;
  LastReg:=DI;
  GetReg16(R,V);
  FirstReg:=OFReg;
  LastReg:=OLReg;
End;

Procedure GetNamedReg16(Var Resu : TypedAddress; R : Integer; Var V : TypedAddress);
Var
   TA : TypedAddress;
Begin
{ Check }
  If (Ord(V.C)>=Ord(Reg32)) And (Ord(V.C)<=Ord(Mem32)) Then Error('GetNamedReg16 : Bad V');
{ R‚allouer R si n‚c‚ssaire }
  ReallocNamedReg16(R);
{ Generer le COP }
  Assemble(CurCOP,Reg[R],V);
{ Lib‚rer V }
  FreeReg16(V);
{ Prendre Resu=Reg[I]; On peut ‚craser V ds l'affaire, si @Resu=@V }
  Resu.C:=Register;
  Resu.Value:=R;
  Resu.SType:=V.SType;
{ Marquer que le reg nøI est occup‚ }
  RegFree[R]:=False;
{ Maj RegContains }
  RegContains[R]:=@Resu;
End;

Procedure AllocReg16(Var R : TypedAddress);
Var
   I : Integer;
Begin
{ Essayer de trouver le Reg }
  For I:=FirstReg To LastReg Do
     If RegFree[I]=True Then
     Begin
     { Prendre R=Reg[I]; On peut ‚craser V ds l'affaire, si @R=@V }
       R:=Reg[I];
       R.Value:=I;
       R.SType:=@SymbRegister;
     { Marquer que le reg nøI est occup‚ }
       RegFree[I]:=False;
     { Maj RegContains }
       RegContains[I]:=@R;
       Exit;
     End
  ;
{ Cas o— on n'a pas r‚ussi … allouer de registre }
  ReallocNamedReg16(FirstReg);
  AllocReg16(R);
End;

Procedure ReallocNamedReg16(R : Integer);
Var
   TA : TypedAddress;
   BA : Boolean;
Begin
  BA:=ByteAddr;
  ByteAddr:=False;
  If Not RegFree[R] Then
    If (Not GetPerhapsReg16(TA,Reg[R])) Then
      Begin
      { Empilage de Reg[R], afin de le liberer }
        Assemble(PUSH,Reg[R],NullAddr);
      { Maj TopOfStack }
        Inc(SizTmp,2);
        Dec(TopOfStack.Value,2);
      { Maj RegContains }
        MajRegContains(R,TopOfStack);
     End
    Else
      MajRegContains(R,TA)
  ;
  RegFree[R]:=True;
  ByteAddr:=BA;
End;

Procedure FreeReg16(Var T : TypedAddress);
Begin
  If T.C=ES Then RegFree[rES]:=True;
  Case T.C Of
    Register: RegFree[T.Value]:=True;
    Immediate,Null: Exit;
    CS,DS,SS,ES,Export:
      Case T.M Of
        IndReg,IndRegOfs: RegFree[LoWord(T.Value)]:=True;
        IndOfs: Exit;
        Else
          Error('FreeReg16(1)');
      End;
    Else
      Error('FreeReg16(2)');
  End;
End;

Procedure GetReg32(Var R,V : TypedAddress);
Var
   I,N : Integer;
   TA : TypedAddress;
   Re : Array[1..2] Of Integer;
Begin
{ Check }
  If (V.C<>DS) And (V.C<>SS) And (V.C<>ES) And (V.C<>Immediate) Then Error('GetReg32 : bad V');
{ Lib‚rer V, pour pouvoir evt. r‚user ses Regs@ }
  FreeReg32(V);
{ Essai pour trouver les regs }
  N:=0;
  For I:=FirstReg To LastReg Do
     If (N=0) And RegFree[I] Then
       Begin
         Inc(N);
         Re[N]:=I;
         RegFree[I]:=False;
       End
  ;
  For I:=FirstHighReg To LastHighReg Do
     If (N=1) And RegFree[I] Then
       Begin
         Inc(N);
         Re[N]:=I;
         If N=2 Then
           Begin
           { Recopie de V ds R }
             If V.C<>Immediate Then
               Begin
                 Assemble(LES,Reg[Re[1]],V);
                 If Re[2]<>rES Then Assemble(MOV,Reg[Re[2]],Reg[rES]);
               End
             Else
               Begin
                 GetHigh(TA,V);
                 If Re[2]=rES Then
                   Begin
                     Assemble(MOV,Reg[Re[1]],TA);
                     Assemble(MOV,Reg[rES],Reg[Re[1]]);
                   End
                 Else
                   Assemble(MOV,Reg[Re[2]],TA)
                 ;
                 GetLow(TA,V);
                 Assemble(MOV,Reg[Re[1]],TA);
               End
             ;
           { Lib‚rer V }
             FreeReg32(V);
           { Prendre les 2 registres, et les recopier ds R }
             R.C:=Reg32;
             SetHigh(R,Reg[Re[2]]);
             SetLow(R,Reg[Re[1]]);
             R.SType:=V.SType;
           { Marquage }
             RegFree[Re[1]]:=False;
             RegFree[Re[2]]:=False;
           { Maj RegContains }
             RegContains[Re[1]]:=@R;
             RegContains[Re[2]]:=@R;
             Exit;
           End;
       End
  ;
{ Echec => For‡age ds (FirstHighReg:First(Low)Reg) }
  For I:=1 To N Do RegFree[Re[I]]:=True;
  SetRegContainsOn(V,V);
  ReallocNamedReg16(FirstHighReg);
  RegFree[FirstHighReg]:=False;
  ReallocNamedReg16(FirstReg);
  RegFree[FirstHighReg]:=True;
  GetReg32(R,V);
End;

Procedure GetAddrReg32(Var R,V : TypedAddress);
Var
   OFReg,OLReg : Word;
   OFHReg,OLHReg : Word;
Begin
  OFReg:=FirstReg;
  OLReg:=LastReg;
  OFHReg:=FirstHighReg;
  OLHReg:=LastHighReg;
  FirstReg:=BX;
  LastReg:=DI;
  FirstHighReg:=rES;
  LastHighReg:=rES;
  GetReg32(R,V);
  FirstReg:=OFReg;
  LastReg:=OLReg;
  FirstHighReg:=OFHReg;
  LastHighReg:=OLHReg;
End;

Procedure GetAddrDataReg32(Var R,V : TypedAddress);
Var
   OFReg,OLReg : Word;
   OFHReg,OLHReg : Word;
Begin
  OFReg:=FirstReg;
  OLReg:=LastReg;
  OFHReg:=FirstHighReg;
  OLHReg:=LastHighReg;
  FirstReg:=BX;
  LastReg:=DI;
  FirstHighReg:=AX;
  LastHighReg:=BX;
  GetReg32(R,V);
  FirstReg:=OFReg;
  LastReg:=OLReg;
  FirstHighReg:=OFHReg;
  LastHighReg:=OLHReg;
End;

Procedure FreeReg32(Var T : TypedAddress);
Begin
  Case T.C Of
    Reg32: Begin
             RegFree[HiWord(T.Value)]:=True;
             RegFree[LoWord(T.Value)]:=True;
           End;
    RegMem32: RegFree[HiWord(T.Value)]:=True;
    MemReg32: RegFree[LoWord(T.Value)]:=True;
    Register: Error('FreeReg32');
    Else
      FreeReg16(T);
  End;
End;

{ Cette procedure FORCE l'allocation des registres, puis se
  contente de recopier TA ds R et de brancher les RegContains
  n‚c‚ssaires sur R. }
Procedure SetRegContainsOn(Var R,TA : TypedAddress);
Begin
  Case TA.C Of
    Immediate:;
    Register:
      Begin
        RegContains[TA.Value]:=@R;
        RegFree[TA.Value]:=False;
      End;
    Reg32:
      Begin
        RegContains[HiWord(TA.Value)]:=@R;
        RegContains[LoWord(TA.Value)]:=@R;
        RegFree[HiWord(TA.Value)]:=False;
        RegFree[LoWord(TA.Value)]:=False;
      End;
    RegMem32:
      Begin
        RegContains[HiWord(TA.Value)]:=@R;
        RegFree[HiWord(TA.Value)]:=False;
      End;
    MemReg32:
      Begin
        RegContains[LoWord(TA.Value)]:=@R;
        RegFree[LoWord(TA.Value)]:=False;
      End;
    DS,SS,ES:
      Begin
        If TA.C=ES Then
          Begin
            RegContains[rES]:=@R;
            RegFree[rES]:=False;
          End;

        Case TA.M Of
          IndOfs:;
          IndReg,IndRegOfs:
            Begin
              RegContains[LoWord(TA.Value)]:=@R;
              RegFree[LoWord(TA.Value)]:=False;
            End;
          Else
            Error('SetRegContainsOn : Bad TA.M');
        End;
      End;
    Else
      Error('SetRegContainsOn : Bad TA.C');
  End;
  R:=TA;
End;

Procedure ReallocReg(Var TA : TypedAddress);
Begin
  Case TA.C Of
    Register: ReallocNamedReg16(TA.Value);
    Reg32:
      Begin
        ReallocNamedReg16(HiWord(TA.Value));
        RegFree[HiWord(TA.Value)]:=False;
        ReallocNamedReg16(LoWord(TA.Value));
        RegFree[HiWord(TA.Value)]:=True;
      End;
    Else
      Error('ReallocReg : Bad TA');
  End;
End;

Function StackUsedRegs : Integer;
Var
   I,R : Integer;
Begin
  R:=0;
  For I:=AX To rES Do
      If Not RegFree[I] Then
        Begin
          R:=R Or (1 Shl I);
          Assemble(PUSH,Reg[I],NullAddr);
          RegFree[I]:=True;
        End;

  StackUsedRegs:=R;
End;

Procedure UnStackRegSet(S : Integer);
Var
   I : Integer;
Begin
  For I:=rES DownTo AX Do
     If (S And (1 Shl I))<>0 Then
       Begin
         Assemble(POP,Reg[I],NullAddr);
         RegFree[I]:=False;
       End;
End;

Procedure FreeAllRegs;
Var
   I : Integer;
Begin
  For I:=AX To rSS Do RegFree[I]:=True;
  DontUseThisAddr:=Reg[AX];
End;

{ *********************
  Calcul des constantes
  ********************* }
Procedure CalcConstOpSize(Var Resu : TypedAddress; B : BoxPtr);
Begin
{ Check B }
  If B=Nil Then Error('CalcConstOpSize : Nil B');
{ Compil B }
  If (Nature(B^.Nature)=Symbol) And (SymbPtr(B)^.Addr.C<>CType) Then
    Begin
      If SymbPtr(B)^.Addr.C=Null Then Error('CalcConstOpSize : unbound symbol');
      B:=BoxPtr(SymbPtr(B)^.Addr.SType);
    End
  Else
    CalcType(B)
  ;
{ Set Resu }
  Resu.C:=Immediate;
  Resu.Value:=TVArrayPtr(B)^.Size;
  Resu.SType:=@SymbWord;
End;

Procedure CalcConstOpHigh(Var Resu : TypedAddress; B : BoxPtr);
Begin
{ Check B }
  If B=Nil Then Error('CalcConstOpHigh : Nil B');
{ Compil B }
  CalcConst(Resu,B);
{ Burst type }
  If (Resu.SType=Nil) Or (Nature(Resu.SType^.Nature)<>Symbol) Then Error('CalcConstOpHigh : Khouill(1)');
  If Resu.C<>Immediate Then Error('CalcConstOpHigh : Resu.C<>Immediate');
  Case Name(Resu.SType^.Nature) Of
    PredInt,PredWord:
      Begin
        Resu.Value:=Hi(Resu.Value);
        If Name(Resu.SType^.Nature)=PredInt Then Resu.SType:=@SymbShortInt
                                            Else Resu.SType:=@SymbByte;
      End;
    PredLongWord,PredPointer,PredReference,ValTVPtr:
      Begin
        SetHiWord(Resu.Value,HiWord(Resu.Value));
        If Name(Resu.SType^.Nature)=PredLongInt Then Resu.SType:=@SymbInt
                                                Else Resu.SType:=@SymbWord;
      End;
    Else
      Error('CalcConstOpHigh : bad type');
  End;
End;

Procedure CalcConstOpLow(Var Resu : TypedAddress; B : BoxPtr);
Begin
{ Check B }
  If B=Nil Then Error('CalcConstOpLow : Nil B');
{ Compil B }
  CalcConst(Resu,B);
{ Burst type }
  If (Resu.SType=Nil) Or (Nature(Resu.SType^.Nature)<>Symbol) Then Error('CalcConstOpLow : Khouill(1)');
  If Resu.C<>Immediate Then Error('CalcConstOpLow : Resu.C<>Immediate');
  Case Name(Resu.SType^.Nature) Of
    PredInt,PredWord:
      Begin
        Resu.Value:=Lo(Resu.Value);
        If Name(Resu.SType^.Nature)=PredInt Then Resu.SType:=@SymbShortInt
                                            Else Resu.SType:=@SymbByte;
      End;
    PredLongWord,PredPointer,PredReference,ValTVPtr:
      Begin
        SetLoWord(Resu.Value,LoWord(Resu.Value));
        If Name(Resu.SType^.Nature)=PredLongInt Then Resu.SType:=@SymbInt
                                                Else Resu.SType:=@SymbWord;
      End;
    Else
      Error('CalcConstOpLow : bad type');
  End;
End;

Var
   TConstString : TVArray;
Procedure CalcConst(Var Resu : TypedAddress; B : BoxPtr);
Var
   TA,TA2 : TypedAddress;
   BP : BoxPtr;
Begin
  If B=Nil Then
    Begin
      Resu.C:=Immediate;
      Exit;
    End
    ;
  Case Nature(B^.Nature) Of
    Constant:
      Case B^.Nature And 3 Of
        ConstChar,ConstNum:
          Case NumLength(B^.Nature) Of
            Length8:
              Begin
                Resu.C:=Immediate;
                Resu.Value:=ByteBoxPtr(B)^.Value;
                Resu.SType:=@SymbWord;
              End;
            Length16:
              Begin
                Resu.C:=Immediate;
                Resu.Value:=WordBoxPtr(B)^.Value;
                Resu.SType:=@SymbWord;
              End;
            Length32:
              Begin
                Resu.C:=Immediate;
                Resu.Value:=LongBoxPtr(B)^.Value;
                Resu.SType:=@SymbLongWord;
              End;
            Else
              Error('Constant type ! recognized');
          End;
        ConstString:
          Begin
            TA.C:=Immediate;
            TA.Value:=PokeSkippedStr(StringBoxPtr(B)^.Value);
            GetAddrReg16(Resu,TA,True);
            If Resu.C<>Register Then Error('CalcConst : ouarshblom(1)');
            Resu.C:=CS;
            Resu.M:=IndReg;
            Resu.SType:=@TConstString;
          End;
        Else
          Error('Constant type ! recognized');
      End;
    Symbol:
      Begin
        If SymbPtr(B)^.Addr.C<>Immediate Then Error('CalcConst : symbol');
        Resu:=SymbPtr(B)^.Addr;
      End;
    Operator:
      If Name(B^.Nature)=OpPouvr Then
        Begin
        { Check : B^.Gauche=Symbol }
          If (B^.Gauche=Nil) Or (Nature(B^.Gauche^.Nature)<>Symbol) Then
            Error('CalcConst : OpPouvr : B^.Gauche=Symbol expected')
          ;
        { D‚codage : named cast (C=CType), pred func (C=Null), user func }
          Case SymbPtr(B^.Gauche)^.Addr.C Of
            CType:
              Begin
              { Check B^.Droite }
                If B^.Droite=Nil Then Error('CalcConst : Named cast : Nil B');
              { Compil B }
                CalcConst(Resu,B^.Droite);
              { Cast }
                If Name(B^.Gauche^.Nature)=$3FFF
                Then
                  BP:=BoxPtr(SymbPtr(B^.Gauche)^.Addr.Value)
                Else
                  BP:=B^.Gauche
                ;
                If GetTypeSize(BP)=GetTypeSize(BoxPtr(Resu.SType))
                Then
                  Resu.SType:=SymbPtr(BP)
                Else
                  CastIt(Resu,SymbPtr(BP));
              End;
            Null:
              Case Name(B^.Gauche^.Nature) Of
                PredSize: CalcConstOpSize(Resu,B^.Droite);
                PredHigh: CalcConstOpHigh(Resu,B^.Droite);
                PredLow : CalcConstOpLow (Resu,B^.Droite);
                Else
                  Error('CompileOpPouvr : bad pred func');
              End;
            Else
              Error('CalcConst : OpPouvr : bad left operand');
          End;
        End
      Else
        Begin
          CalcConst(TA,B^.Gauche);
          CalcConst(TA2,B^.Droite);
          CalcExprConst(Resu,Name(B^.Nature),TA,TA2);
        End
    Else
      Error('CalcConst : bad nat');
  End;
End;

{ Les variables qui rentrent l… dedans sont toutes des imm‚diates.
  Par cons‚quent, on fait tjrs les calculs en 32 bits (LongInt). }
Procedure CalcExprConst(Var Resu : TypedAddress; Opn : Word; Var A1,A2 : TypedAddress);
Begin
{ Checks }
  If (A1.C<>Immediate) Or (A2.C<>Immediate) Then Error('CalcExprConst : A1,A2 Immediate expected');
{ Casts }
  Case Opn Of
    OpAdd,OpSub,OpDiv,OpMul,OpMod,OpLogOr,OpLogAnd:
      Begin
        If Not (IsInteger(A1.SType) And IsInteger(A2.SType)) Then
          Error('CalcExprConst : binary opns cast : bad types')
        ;
        If IntTypeSup(A1.SType,A2.SType) Then Resu.SType:=A1.SType
                                         Else Resu.SType:=A2.SType;
      End;
    OpVirg:
      Begin
        Resu.C:=Immediate;
        If IsScalaire8(A1.SType) And IsScalaire8(A2.SType) Then
          Begin
            If A2.SType<>@SymbByte Then Error('CalcExprConst : OpVirg : A2 short : A2 Byte expected');
            Resu.Value:=Byte(A1.Value);
            Resu.Value:=(Resu.Value Shl 8)+Byte(A2.Value);
            If A1.SType=@SymbByte Then Resu.SType:=@SymbWord
            Else
            If A1.SType=@SymbShortInt Then Resu.SType:=@SymbInt
            Else
              Error('CalcExprConst : OpVirg : Khouill(1)');
          End
        Else
          Begin
            CastIt(A2,@SymbWord);
            Case Name(A1.SType^.Nature) Of
              PredShortInt,PredInt,PredLongInt: CastIt(A1,@SymbInt);
              Else
                CastIt(A1,@SymbWord);
            End;
            Resu.Value:=Word(A2.Value);
            SetHiWord(Resu.Value,Integer(A1.Value));
            If A1.SType=@SymbWord Then Resu.SType:=@SymbLongWord
            Else
            If A1.SType=@SymbInt Then Resu.SType:=@SymbLongInt
            Else
              Error('CalcExprConst : OpVirg : Khouill(1)');
          End
        ;
        Exit;
      End;
    OpMoins,OpPlus,OpLogNot:
      Begin
        If Not IsInteger(A2.SType) Then
          Error('CalcExprConst : unary opns cast : bad types')
        ;
        Resu.SType:=A2.SType;
      End;
    Else
      Error('CalcExprConst : bad opn');
  End;

{ Calcul }
  Resu.C:=Immediate;
  Case Opn Of
    OpAdd: Resu.Value:=A1.Value+A2.Value;
    OpSub: Resu.Value:=A1.Value-A2.Value;
    OpMul: Resu.Value:=A1.Value*A2.Value;
    OpDiv: Resu.Value:=A1.Value Div A2.Value;
    OpMod: Resu.Value:=A1.Value Mod A2.Value;
    OpLogAnd: Resu.Value:=A1.Value And A2.Value;
    OpLogOr: Resu.Value:=A1.Value Or A2.Value;
    OpLogNot: Resu.Value:=Not A2.Value;
    OpPlus: Resu:=A2;
    OpMoins:
      Begin
        Resu:=A2;
        Resu.Value:=-Resu.Value;
        Case Resu.SType^.Nature Of
          Symbol Or PredByte: Resu.SType:=@SymbShortInt;
          Symbol Or PredShortInt: Resu.SType:=@SymbByte;
          Symbol Or PredInt: Resu.SType:=@SymbWord;
          Symbol Or PredWord: Resu.SType:=@SymbInt;
          Symbol Or PredLongInt: Resu.SType:=@SymbLongWord;
          Symbol Or PredLongWord: Resu.SType:=@SymbLongInt;
          Else
            Error('CalcExprConst : unary opns calc Khouill(1)');
        End;
      End;
  End;
End;

{ ****************
  Calcul des types
  **************** }
Function CalcTVPtr(Suiv : Pointer) : Pointer;
Var
   TV : TVPtrPtr;
Begin
  New(TV);

  TV^.Nature:=Symbol Or ValTVPtr;
  TV^.Size:=4;
  TV^.Next:=Suiv;

  CalcTVPtr:=TV;
End;

Function CalcTVRef(Suiv : Pointer) : Pointer;
Var
   TV : TVRefPtr;
Begin
  New(TV);

  TV^.Nature:=Symbol Or ValTVRef;
  TV^.Size:=4;
  TV^.Next:=Suiv;

  CalcTVRef:=TV;
End;

Function CalcTVArray(Interv : BoxPtr; Suiv : Pointer) : Pointer;
Var
   TA : TypedAddress;
   TV : TVArrayPtr;
Begin
  If (Interv^.Nature<>Operator Or OpPointPoint) Or
     (Interv^.Gauche=Nil) Or
     (Interv^.Droite=Nil)
  Then
    Error('CalcTVArray : Bad Box');

  New(TV);

  TV^.Nature:=Symbol Or ValTVArray;
  CalcConst(TA,Interv^.Gauche);
  If (TA.C<>Immediate) Or ((TA.SType<>@SymbInt) And (TA.SType<>@SymbWord))
  Then
    Error('CalcTVArray : X..? : X; Bad Const Type (Int/Word expected)');

  TV^.FirstInd:=TA.Value;
  CalcConst(TA,Interv^.Droite);
  If (TA.C<>Immediate) Or ((TA.SType<>@SymbInt) And (TA.SType<>@SymbWord))
  Then
    Error('CalcTVArray : X..? : X; Bad Const Type (Int/Word expected)');

  TV^.NbElems:=TA.Value-TV^.FirstInd+1;
  TV^.Size:=TV^.NbElems*GetTypeSize(Suiv);
  TV^.Next:=Suiv;

  CalcTVArray:=TV;
End;

Procedure CompileRec1Elem(Var Resu : TVRecElemPtr; S,T : SymbPtr);
Begin
  Resu^.Name:=S;
  Resu^.SType:=T;
  Resu^.Next:=Nil;
End;

Procedure CompileRecElem(B,T : BoxPtr;
                         Var First,Last : TVRecElemPtr;
                         Var TotalSize : Word);
Var
   Fini : Boolean;
   SizeT : Word;
Begin
  Fini:=False;
  CalcType(T);
  TotalSize:=0;
  SizeT:=GetTypeSize(T);
  First:=Nil;
  Last:=First;
  While Not Fini Do
    If B^.Nature=(Operator Or OpVirg) Then
      Begin
        If B^.Gauche=Nil Then Error('CompileRecElem : syntax error');
        If Nature(B^.Gauche^.Nature)=Symbol Then
          Begin
            If First=Nil Then
              Begin
                New(First);
                Last:=First;
              End
            Else
              Begin
                New(Last^.Next);
                Last:=Last^.Next;
              End
            ;
            CompileRec1Elem(Last,SymbPtr(B^.Gauche),SymbPtr(T));
            Inc(TotalSize,SizeT);
          End
        Else
          Error('CompileRecElem : syntax error');

        B:=B^.Droite;
      End
    Else
    If Nature(B^.Nature)=Symbol Then
      Begin
        If First=Nil Then
          Begin
            New(First);
            Last:=First;
          End
        Else
          Begin
            New(Last^.Next);
            Last:=Last^.Next;
          End
        ;
        CompileRec1Elem(Last,SymbPtr(B),SymbPtr(T));
        Inc(TotalSize,SizeT);
        Fini:=True;
      End
    Else
      Error('CompileRecElem : syntax error');
End;

Procedure CalcRecordType(Var C : BoxPtr);
Var
   T,B : BoxPtr;
   TVR : TVRecordPtr;
   TVRE,First,Last,Resu,ResuLast : TVRecElemPtr;
   Size : Word;
Begin
  B:=C;
  If B=Nil Then Error('CalcRecordType : Nil B');
  New(TVR);
  C:=BoxPtr(TVR);
  TVR^.Nature:=Symbol Or ValTVRecord;
  TVR^.Size:=0;
  Resu:=Nil;
  ResuLast:=Nil;
  While (B^.Nature=KeyWord Or KeyCarriage) Or
        (B^.Nature=KeyWord Or KeyDeuxPoints) Do
  Begin
    T:=B^.Gauche;
    If T=Nil Then Error('CalcRecordType.T=Nil');
    If (T^.Nature<>Operator Or OpAs) Then Error('CalcRecordType : AS expected');
    If (T^.Gauche=Nil) Or (T^.Droite=Nil) Then Error('CalcRecordType.Nil(s)');
    CompileRecElem(T^.Gauche,T^.Droite,First,Last,Size);
    Inc(TVR^.Size,Size);
    If Resu=Nil Then Resu:=First
                Else ResuLast^.Next:=First;
    ResuLast:=Last;
    NbCR:=LiNodePtr(B)^.NbCR;
    B:=B^.Droite;
  End;
  T:=B; If T=Nil Then Error('CalcRecordType.T=Nil');
  If (T^.Nature<>Operator Or OpAs) Then Error('CalcRecordType : AS expected (2)');
  If (T^.Gauche=Nil) Or (T^.Droite=Nil) Then Error('CalcRecordType.Nil(s)');
  CompileRecElem(T^.Gauche,T^.Droite,First,Last,Size);
  Inc(TVR^.Size,Size);
  If Resu=Nil Then Resu:=First
              Else ResuLast^.Next:=First;
  TVR^.First:=Resu;
  B:=BoxPtr(TVR);
End;

Procedure CalcType(Var B : BoxPtr);
Var
   SPtr : SymbPtr;
   BP,BT,Resu : BoxPtr;
Begin
  If Nature(B^.Nature)=Symbol Then
    Begin
      If IsValTV(Name(B^.Nature)) Then Exit
      Else
      Begin
        If SymbPtr(B)^.Addr.C=Null Then Error('CalcType : undeclared type name')
        Else
        If SymbPtr(B)^.Addr.C<>CType Then Error('CalcType : not a type name');
        If Name(B^.Nature)=PredUserSymb Then
        Begin
          B:=BoxPtr(SymbPtr(B)^.Addr.Value);
          CalcType(B);
        End;
      End;
    End
  Else
    Case B^.Nature Of
      Operator Or OpOf:
        Begin
          If (B^.Gauche=Nil) Or (B^.Gauche^.Nature<>Operator Or OpCrouvr)
          Then
            Error('CalcType : W Of T : W=X[Y] expected');

          BP:=B^.Gauche;
          BT:=B^.Droite;

          If (BP^.Gauche=Nil) Or (BP^.Gauche^.Nature<>Symbol Or PredArray)
          Then
            Error('CalcType : X[Y] : X=Array expected')
          Else
            BP:=BP^.Droite;

          CalcType(BT);

          While BP^.Nature=Operator Or OpVirg Do
          Begin
            BT:=CalcTVArray(BP^.Droite,BT);
            BP:=BP^.Gauche;
          End;
          B:=CalcTVArray(BP,BT);

        End;
      Operator Or OpFleche:
        Begin
          If B^.Gauche<>Nil Then Error('X^Y found : pointer declaration expected : Idf as ^T');
          BT:=B^.Droite;
          CalcType(BT);
          B:=CalcTVPtr(BT);
        End;
      Operator Or OpAdr:
        Begin
          If B^.Gauche<>Nil Then Error('X@Y found : ref declaration expected : Idf as @T');
          BT:=B^.Droite;
          CalcType(BT);
          B:=CalcTVRef(BT);
        End;
      Else
        Error('CalcType : Bad typexpr');
    End;
End;

{ ***********
  Tests types
  *********** }
Function IsScalaire8(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsScalaire : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsScalaire8 : Typ : bad nat');
  Case Name(Typ^.Nature) Of
    PredShortInt,PredByte: IsScalaire8:=True;
    Else
      IsScalaire8:=False;
  End;
End;

Function IsScalaire16(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsScalaire : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsScalaire16 : Typ : bad nat');
  Case Name(Typ^.Nature) Of
    PredInt,PredWord: IsScalaire16:=True;
    Else
      IsScalaire16:=False;
  End;
End;

Function IsScalaire(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsScalaire : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsScalaire : Typ : bad nat');
  Case Name(Typ^.Nature) Of
    PredByte,PredShortInt,
    PredWord,PredLongWord,
    PredInt,PredLongInt: IsScalaire:=True;
    Else
      IsScalaire:=False;
  End;
End;

Function IsInteger(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsInteger : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsInteger : Typ : bad nat');
  IsInteger:=(Name(Typ^.Nature)>=PredByte) And
             (Name(Typ^.Nature)<=PredLongInt);
End;

Function IsSignedInteger(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsInteger : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsSignedInteger : Typ : bad nat');
  Case Name(Typ^.Nature) Of
    PredByte,PredWord,PredLongWord:   IsSignedInteger:=False;
    PredShortInt,PredInt,PredLongInt: IsSignedInteger:=True;
    Else
      Error('IsSignedInteger : Int type exp.');
  End;
End;

Function IntTypeSup(T1,T2 : SymbPtr) : Boolean;
Begin
  If Not (IsInteger(T1) And IsInteger(T2)) Then Error('IntTypeSup : Integer types expected');
  IntTypeSup:=Name(T1^.Nature)>=Name(T2^.Nature);
End;

Function IsPointer(Typ : SymbPtr) : Boolean;
Begin
  If Typ=Nil Then Error('IsPointer : Nil Typ');
  If Nature(Typ^.Nature)<>Symbol Then Error('IsPointer : Typ : bad nat');
  Case Name(Typ^.Nature) Of
    PredPointer,PredReference,ValTVPtr,ValTVRef: IsPointer:=True;
    Else
      IsPointer:=False;
  End;
End;

{ Question : ke se passe t'il si on ecrit une decl. avec n'importe
  quoi comme type (1 symbole qqque). A tester. }
Var
   Self1,Self2 : TVPtrPtr;

Function TypeEQ(A,B : TVPtrPtr) : Boolean;
Var
   OSelf1,OSelf2 : TVPtrPtr;
   TVA1,TVA2 : TVArrayPtr;
   TVR1,TVR2 : TVRecElemPtr;
   IsEqual : Boolean;
Begin
  If (Nature(A^.Nature)<>Symbol) Or (Nature(B^.Nature)<>Symbol) Then Error('TypeEQ : Bad A or Bad B');
  If (A=Self1) And (B=Self2) Then
    TypeEQ:=True
  Else
  If (Not IsValTV(Name(A^.Nature))) And (Not IsValTV(Name(B^.Nature)))
  { Ds ce cas, A et B sont 2 symboles de type, il suffit de les
    comparer (Bien sur, ca ne marchera plus dŠs qu'on pourra avoir
    des types nomm‚s; Ds ce cas, il faudra voir si les symboles
    sont des types pr‚d‚finis ou nomm‚s). }
  Then
    TypeEQ:=(A=B)
  Else
  If IsValTV(Name(A^.Nature)) And IsValTV(Name(B^.Nature)) Then
    If A^.Nature<>B^.Nature Then TypeEQ:=False
    Else
      Begin
        If A=B Then
        Begin
          TypeEQ:=True;
          Exit;
        End;
        Case Name(B^.Nature) Of
          ValTVPtr,ValTVRef: TypeEQ:=TypeEQ(A^.Next,B^.Next);
          ValTVArray: Begin
                        TVA1:=@A^;
                        TVA2:=@B^;
                        If (TVA1^.Size=TVA2^.Size) And
                           (TVA1^.FirstInd=TVA2^.FirstInd) And
                           (TVA1^.NbElems=TVA2^.NbElems)
                        Then
                          TypeEQ:=TypeEQ(A^.Next,B^.Next)
                        Else
                          TypeEQ:=False;
                      End;
          ValTVRecord: Begin
                         IsEqual:=True;
                         OSelf1:=Self1;OSelf2:=Self2;
                         Self1:=A;Self2:=B;
                         TVR1:=TVRecordPtr(A)^.First;
                         TVR2:=TVRecordPtr(B)^.First;
                         While (TVR1<>Nil) And (TVR2<>Nil) And IsEqual Do
                         Begin
                           IsEqual:=TypeEQ(TVPtrPtr(TVR1^.SType),TVPtrPtr(TVR2^.SType));
                           TVR1:=TVR1^.Next;
                           TVR2:=TVR2^.Next;
                         End;
                         If TVR1<>TVR2 Then TypeEQ:=False
                                       Else TypeEQ:=IsEqual;
                         Self1:=OSelf1;Self2:=OSelf2;
                       End;
        End;
      End
  Else
  If (     ((A^.Nature=Symbol Or PredPointer) Or
            (A^.Nature=Symbol Or PredReference)
           )
       And
           (B^.Nature=Symbol Or ValTVPtr)
     )
  Or
     (     ((B^.Nature=Symbol Or PredPointer) Or
            (B^.Nature=Symbol Or PredReference)
           )
       And
           (A^.Nature=Symbol Or ValTVPtr)
     )
  Then
    TypeEQ:=True
  Else
    TypeEQ:=False;
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;

{ ******************************************
  Calcul sur la repr‚sentation des fonctions
  ****************************************** }
Procedure GetRegisterResultLocation(Var Resu : TypedAddress; T : BoxPtr);
Var
   S : LongInt;
Begin
  S:=GetTypeSize(T);
  If S<=2 Then Resu:=Reg[AX]
  Else
  If S<=4 Then
    If IsScalaire(@T^) Then
      Begin
        Resu.C:=Reg32;
        SetHigh(Resu,Reg[DX]);
        SetLow(Resu,Reg[AX]);
      End
    Else
    If IsPointer(@T^) Then
      Begin
        Resu.C:=Reg32;
        SetHigh(Resu,Reg[rES]);
        SetLow(Resu,Reg[BX]);
      End
    Else
      Error('GetRegisterResultLocation : bad 32 bit type')
  Else
    Error('GetRegisterResultLocation');

  Resu.SType:=SymbPtr(T);
End;

Procedure GetFuncResultLocation(Var Resu : TypedAddress; FName : BoxPtr);
Var
   Proto : BoxPtr;
Begin
  Proto:=GetFuncType(FName);
  If Proto^.Nature=KeySub Then Error('GetFuncResultLocation : Def exp.');
  Resu:=SymbPtr(Proto^.Droite^.Gauche)^.Addr;
End;

Function GetFuncType(FName : BoxPtr) : BoxPtr;
Var
   Proto : BoxPtr;
Begin
{ Verif. sur l'expr repr. la fn (tjrs 1 symb. pour l'instant) }
{ FName <>Nil, Symbol, et Class=CS }
  If (FName=Nil) Or
     (Nature(FName^.Nature)<>Symbol)
  Then
    Error('GetFuncType : Bad func val (1)');

  If (SymbPtr(FName)^.Addr.C<>CS) And
     (SymbPtr(FName)^.Addr.C<>Export) And
     (SymbPtr(FName)^.Addr.C<>NullExport) And
     (SymbPtr(FName)^.Addr.C<>Extern)
  Then
    Error('GetFuncType : Bad func val (2)');

  Proto:=BoxPtr(SymbPtr(FName)^.Addr.SType);
  If (Proto^.Nature<>KeySub) And (Proto^.Nature<>KeyDef) Then Error('GetFuncType : Bad func val (bad type)');
  GetFuncType:=Proto;
End;

{ ***********
  Compilation
  *********** }
{ Cette Procedure prend une TA, et au cas ou c'est
  une reference, elle la transforme en valeur et
  genere le code correspondant. }
Procedure LoadIt(Var Resu,TA : TypedAddress; M : ValueMode);
Var
   TA2 : TypedAddress;
Begin
  Case TA.C Of
    Null: Error('LoadIt : unbound TA');
    CS,CType: Error('LoadIt : bad TA.C');
    Immediate:
      Begin
        If (TA.SType=@SymbInt) Or (TA.SType=@SymbWord) Then GetReg16(Resu,TA)
        Else
        If (TA.SType=@SymbLongInt) Or (TA.SType=@SymbLongWord) Then GetReg32(Resu,TA)
        Else
          Error('LoadIt : Immediate : bad imm type');
      End;
    Register:
      Begin
        SetRegContainsOn(Resu,TA);
        Resu.SType:=TA.SType;
      End;
    Reg32:
      Case M Of
        DefaultMode:
          If IsScalaire(TA.SType) Then
            If Not (IsDataReg[LoWord(TA.Value)] And IsDataReg[HiWord(TA.Value)])
            Then
              Error('LoadIt : Reg32 : Default Scalaire')
            Else
              Begin
                SetRegContainsOn(Resu,TA);
                Resu.SType:=TA.SType;
              End
          Else
          If IsPointer(TA.SType) Then
          Begin
            If Not IsAddrReg[LoWord(TA.Value)] Then
              Begin
                GetLow(TA2,TA);
                GetAddrReg16(TA2,TA2,True);
                SetLow(TA,TA2);
              End
            ;
            If Not IsSegReg[HiWord(TA.Value)] Then
            Begin
              GetHigh(TA2,TA);
              GetNamedReg16(TA2,rES,TA2);
              SetHigh(TA,TA2);
            End
            ;
            SetRegContainsOn(Resu,TA);
            Resu.SType:=TA.SType;
          End
          Else
            Error('LoadIt : Reg32 : Default');

        AddrDataMode:
          If IsScalaire(TA.SType)
          Then
          { Oblig‚ de virer ‡a, car comme il n'y a pas de
            pr‚-vision, il est in‚vitable d'appeller avec
            AddrDataMode … gauche pour les opbins, mˆme
            si les types doivent se r‚v‚ler, plus tard,
            ˆtre scalaires
            Error('LoadIt : Reg32 : AddrData Scalaire') }
          Else
          If IsPointer(TA.SType) Then
          Begin
            If IsSegReg[HiWord(TA.Value)] Then
            Begin
              GetHigh(TA2,TA);
              GetDataReg16(TA2,TA2,False);
              SetHigh(TA,TA2);
            End;
            SetRegContainsOn(Resu,TA);
            Resu.SType:=TA.SType;
          End
          Else
            Error('LoadIt : Reg32 : AddrData');

        CopyMode:
          Begin
            SetRegContainsOn(Resu,TA);
            Resu.SType:=TA.SType;
          End;

        Else
          Error('LoadIt : Reg32 : Bad M');
      End;
    DS,SS,ES:
      If IsScalaire(TA.SType) Then
        Begin
        { Pas fini : il faut destacker les evt. regs d'@ }
          If (TA.M<>IndOfs) And (TA.M<>IndReg) And (TA.M<>IndRegOfs) Then Error('LoadIt : Bad TA.M(1)');
          If GetTypeSize(BoxPtr(TA.SType))=1 Then
            Begin
              ByteAddr:=True;
              GetReg16(Resu,TA);
              ByteAddr:=False;
            End
          Else
          If GetTypeSize(BoxPtr(TA.SType))=2 Then GetReg16(Resu,TA)
          Else
          If GetTypeSize(BoxPtr(TA.SType))=4 Then GetReg32(Resu,TA)
          Else
            Error('LoadIt : Scalar : bad type size');
        End
      Else
      If IsPointer(TA.SType) Then
        Begin
          If (TA.M<>IndOfs) And (TA.M<>IndReg) And (TA.M<>IndRegOfs) Then Error('LoadIt : Bad TA.M(2)');
          Case M Of
            AddrDataMode,CopyMode: GetAddrDataReg32(Resu,TA);
            DefaultMode          : GetAddrReg32(Resu,TA);
            Else
              Error('LoadIt : IsPointer(TA) : bad M');
          End;
        End
      Else
        Error('LoadIt : not a scalar type');

    Else
    { Pr‚voir les labels }
      Error('LoadIt : bad TA.C');
  End;
End;

Procedure StackIt(Var TA : TypedAddress);
Var
   TA2 : TypedAddress;
Begin
  If GetTypeSize(@TA.SType^)<=2 Then
    Begin
      If TA.C=Immediate Then
        Begin
          GetReg16(TA,TA);
          Assemble(PUSH,TA,NullAddr);
          FreeReg16(TA);
        End
      Else
        If (Ord(TA.C)>=Ord(DS)) And (Ord(TA.C)<=Ord(ES)) Or (TA.C=Register) Then
          Assemble(PUSH,TA,NullAddr)
        Else
          Error('StackIt(2)');
    End
  Else
  If GetTypeSize(@TA.SType^)=4 Then
    If TA.C=Immediate Then
      Begin
        GetHigh(TA2,TA);
        GetReg16(TA2,TA2);
        Assemble(PUSH,TA2,NullAddr);
        FreeReg16(TA2);
        GetLow(TA2,TA);
        GetReg16(TA2,TA2);
        Assemble(PUSH,TA2,NullAddr);
        FreeReg16(TA2);
      End
    Else
    If (Ord(TA.C)>=Ord(CS)) And (Ord(TA.C)<=Ord(ES)) Or
        (TA.C=Reg32) Or (TA.C=RegMem32) Then
      Begin
        GetHigh(TA2,TA);
        Assemble(PUSH,TA2,NullAddr);
        GetLow(TA2,TA);
        Assemble(PUSH,TA2,NullAddr);
      End
    Else
      Error('StackIt(3)')
  Else
    Error('StackIt : Bad type');
End;

{ Convertit la Typed@ T au type Typ, si c'est
  possible, et g‚nŠre le code correspondant si
  n‚c‚ssaire; Post : A LA SORTIE, LES 2 TYPES
  SONT EGAUX }
Procedure CastIt(Var T : TypedAddress; Typ : SymbPtr);
Label
     LongCast;
Var
   TA1,TA2 : TypedAddress;
Begin
  If T.C=Immediate Then
    Begin
      If Not IsInteger(Typ) Then Error('CastIt : Immediate : Scal Typ exp.');
      If Not IsInteger(T.SType) Then Error('CastIt : Immediate : Scal SType exp.');
    {$R-}
      If GetTypeSize(Pointer(Typ))<=GetTypeSize(Pointer(T.SType)) Then
        Case GetTypeSize(Pointer(Typ)) Of
          1: T.Value:=Byte(T.Value);
          2: T.Value:=Word(T.Value);
        End
      Else
      If IsSignedInteger(T.SType) Then
        Case Name(Typ^.Nature) Of
          PredWord,PredInt: T.Value:=Word(Integer(ShortInt(T.Value)));
          PredLongWord,PredLongInt:
            If T.SType^.Nature=Symbol Or PredShortInt Then
              T.Value:=Integer(ShortInt(T.Value))
            Else
              T.Value:=Integer(T.Value);
        End
      Else
        Case GetTypeSize(Pointer(T.SType)) Of
          1: T.Value:=Byte(T.Value);
          2: T.Value:=Word(T.Value);
        End
        ;
    {$R+}
      T.SType:=Typ;
    End
  Else
    Case Typ^.Nature Of
      Symbol Or PredShortInt,Symbol Or PredByte:
        Case T.SType^.Nature Of
          Symbol Or PredByte,
          Symbol Or PredShortInt,
          Symbol Or PredWord,
          Symbol Or PredInt:
            T.SType:=Typ
          ;
          Symbol Or PredLongWord,
          Symbol Or PredLongInt:
            Begin
              GetLow(TA1,T);
              GetHigh(TA2,T);
              FreeReg16(TA2);
              SetRegContainsOn(T,TA1);
              T.SType:=Typ;
            End
          Else
            Error('CastIt : T->ShortInt/Byte');
        End;
      Symbol Or PredInt,Symbol Or PredWord:
        Case T.SType^.Nature Of
          Symbol Or PredByte:
            Begin
            { XORer le highbyte si c'est d‚j… 1 reg, sinon loader et XORer high }
              If T.C<>Register Then GetReg16(T,T);
              ByteAddr:=True;
              Assemble(CXOR,Reg[RegHigh[T.Value]],Reg[RegHigh[T.Value]]);
              ByteAddr:=False;
              T.SType:=Typ;
            End;
          Symbol Or PredShortInt:
            Begin
              If ((T.C<>Register) Or (T.Value<>AX)) Then GetNamedReg16(T,AX,T);
              Assemble(CBW,NullAddr,NullAddr);
              T.SType:=Typ;
            End;
          Symbol Or PredWord,
          Symbol Or PredInt:
            T.SType:=Typ
          ;
          Symbol Or PredLongWord,
          Symbol Or PredLongInt:
            Begin
              GetLow(TA1,T);
              GetHigh(TA2,T);
              FreeReg16(TA2);
              SetRegContainsOn(T,TA1);
              T.SType:=Typ;
            End
          Else
            Error('CastIt : T->Int/Word');
        End;
      Symbol Or PredLongInt,Symbol Or PredLongWord:
        Case T.SType^.Nature Of
          Symbol Or PredByte:
            Begin
            { XORer le highbyte si c'est d‚j… 1 reg, sinon loader et XORer high }
              If T.C<>Register Then GetReg16(T,T);
              ByteAddr:=True;
              Assemble(CXOR,Reg[RegHigh[T.Value]],Reg[RegHigh[T.Value]]);
              ByteAddr:=False;
              Goto LongCast;
            End;
          Symbol Or PredShortInt:
            Begin
              If (T.C<>Register) Or (T.Value<>AX) Then GetNamedReg16(T,AX,T);
              Assemble(CBW,NullAddr,NullAddr);
              ReallocNamedReg16(DX);
              Assemble(CWD,NullAddr,NullAddr);
              T.C:=Reg32;
              SetHiWord(T.Value,DX);
              RegContains[DX]:=@T;
              RegFree[DX]:=False;
              T.SType:=Typ;
            End;
          Symbol Or PredWord:
            Begin
              If (T.C<>Register) And (T.C<>SS) Then
                Begin
                  TA1:=T;
                  LoadIt(T,TA1,DefaultMode);
                End;
            { Il manque la possibilit‚ de GetReg16 without MOV }
LongCast:
              GetReg16(TA1,ImmZero);
              If T.C=Register Then T.C:=Reg32 Else T.C:=RegMem32;
              SetHigh(T,TA1);
              T.SType:=Typ;
            End;
          Symbol Or PredInt:
            Begin
              If ((T.C<>Register) Or (T.Value<>AX)) Then GetNamedReg16(T,AX,T);
              ReallocNamedReg16(DX);
              Assemble(CWD,NullAddr,NullAddr);
              T.C:=Reg32;
              SetHiWord(T.Value,DX);
              RegContains[DX]:=@T;
              RegFree[DX]:=False;
              T.SType:=Typ;
            End;
          Symbol Or PredLongWord,Symbol Or PredLongInt:
            ;
          Else
            Error('CastIt : T->LongInt/LongWord');
        End;
      Symbol Or PredPointer,Symbol Or PredReference:
        If Not IsPointer(T.SType) Then Error('CastIt : T->Pointer')
                                  Else T.SType:=Typ;
      Symbol Or ValTVPtr:
        If (T.SType^.Nature<>Symbol Or PredPointer) And
           (T.SType^.Nature<>Symbol Or PredReference)
        Then
          Error('CastIt : Pointer->T')
        Else
          T.SType:=Typ;
      Else
        Error('CastIt : Uncastable Typ');
    End;
End;

Procedure StartAddressify;
Begin
{ Alloc Regs }
  FirstReg:=AX;
  LastReg:=BX;
  FirstHighReg:=AX;
  LastHighReg:=BX;
  CurCOP:=MOV;
  TopOfStack.C:=SS;
  TopOfStack.M:=IndOfs;
  TopOfStack.SType:=@SymbInt;
{ Init TConstString <- Array[0..255] Of Byte }
  TConstString.Nature:=Symbol Or ValTVArray;
  TConstString.Size:=256;
  TConstString.Next:=@SymbByte;
  TConstString.FirstInd:=0;
  TConstString.NbElems:=256;
End;

Begin
  Self1:=Nil;
  Self2:=Nil;
  StartAddressify;
End.