


{ Here some procedures using protected mode }
{$L 386UTIL.OBJ}
FUNCTION  RByte(Q:LongInt): Byte; External;
PROCEDURE WByte(C:Byte;Q:LongInt); External;
FUNCTION  RDWord(Q:LongInt): LongInt; External;
PROCEDURE WDWord(C:LongInt;Q:LongInt); External;
FUNCTION  RWord(Q:LongInt): Word; External;
PROCEDURE WWord(C:Word;Q:LongInt); External;

PROCEDURE Copy_DWord(Source, Dest : LongInt; Taille : LongInt); External;
PROCEDURE Copy_Byte(Source, Dest : LongInt; Taille : LongInt); External;
PROCEDURE Clear_XMS(Adresse, Taille : LongInt); External;






(*======================================================================
========================================================================
========================================================================
========================================================================
=====  Ensemble de Procedures de Gestion de la Memoire Haute  ==========
========================================================================
========================================================================
========================================================================
======================================================================*)
TYPE
   { Memory Control Block definition }
   Descriptor  =   RECORD
                      Adresse        :   LongInt;
                      User           :   Byte;
                      Size,
                      Prec           :   LongInt;
                   END;

VAR
  Search            :   Descriptor;
  System_Error      :   Byte;

CONST
  Descriptor_Size   :   Byte=9;  { Size of descriptor (for futures versions) }
  Error_Enable      :   Boolean=True;





{ Converts a Pointer in a LongInt }
FUNCTION Adr(Variable : Pointer): LongInt;
VAR
  Bolo : LongInt;
BEGIN
  Bolo:=Seg(Variable^);
  Adr:=Bolo*16+Ofs(Variable^);
END;



{ Converts a Longint into a caracter chain }
FUNCTION Cha(X : LongInt): String;
VAR
  Cha_ : String;
BEGIN
  Str(X, Cha_);
  Cha:=Cha_;
END;




{ Procedure which wait a delay  }
{ input a LongInt in 1/1000000 s}
PROCEDURE Delay_BIOS(N : LongInt);
BEGIN
  ASM
    { On remet le flag a zero }
    MOV CX, Word(N+2)
    MOV DX, Word(N)
    { Dans CX:DX, on place l'adresse de N }
    MOV AH, 86h
    INT 15h
    { Fonction attente du bios }
  END;
END;



{ Internal error system }
PROCEDURE System_Erreur(Error_Msg : String; Number : Byte);
BEGIN
  If Error_Enable Then
  BEGIN
    WriteLN('Error #'+Cha(Number)+' : '+Error_Msg);
    Delay_BIOS(200); { On attend 0.05 secondes }
    Halt(Number);
  END
  Else
    System_Error:=Number;
END;



{ Internal Procedure. Get heap state }
PROCEDURE Get_Heap(Adresse : LongInt; Var Heap_Result : Descriptor);
BEGIN
  Heap_Result.User:=RByte(Adresse);
  Heap_Result.Size:=RDWord(Adresse+1);
  Heap_Result.Prec:=RDWord(Adresse+5);
  Heap_Result.Adresse:=Adresse;
END;




{ Internal Procedure. Set heap state }
PROCEDURE Set_Heap(Heap_Result : Descriptor);
BEGIN
  WByte(Heap_Result.User, Heap_Result.Adresse);
  WDWord(Heap_Result.Size, Heap_Result.Adresse+1);
  WDWord(Heap_Result.Prec, Heap_Result.Adresse+5);
END;




{ Internal procedure of memory linearisation }
PROCEDURE Effect_Defrag_High(Current : Descriptor);
VAR
  Suivant,
  Apres_Suivant       :  Descriptor;
  Taille_Totale       :  LongInt;
BEGIN
  Get_Heap(Current.Size+Current.Adresse+Descriptor_Size, Suivant);
  Get_Heap(Suivant.Size+Suivant.Adresse+Descriptor_Size, Apres_Suivant);
  BEGIN
    If Current.User=0 Then
    BEGIN
      If Suivant.User=0 Then
      BEGIN
        Taille_Totale:=Suivant.Size+Descriptor_Size+Current.Size;
        Current.Size:=Taille_Totale;
        Suivant.User:=0;
        Suivant.Size:=0;
        Suivant.Prec:=0;
        If (Suivant.User<>$FF) And (Apres_Suivant.User<>$FF) Then
        BEGIN
          Apres_Suivant.Prec:=Current.Adresse;
          Set_Heap(Apres_Suivant);
        END;
        Set_Heap(Current);
        Set_Heap(Suivant);
      END;
    END;
  END;
END;




{ Internal Procedure }
PROCEDURE Defrag(Current : Descriptor);
VAR
  Suivant,
  Precedent       :     Descriptor;
BEGIN
  Get_Heap(Current.Size+Current.Adresse+Descriptor_Size, Suivant);
  Get_Heap(Current.Prec, Precedent);
  Effect_Defrag_High(Suivant);
  Effect_Defrag_High(Current);
  Effect_Defrag_High(Precedent);
END;




{ Allocate an XMS Block. Error checking. }
PROCEDURE Get_XMS(Var Adresse : LongInt; Taille : LongInt);
VAR
  Current,
  Suivant,
  Precedent,
  Insere               :   Descriptor;
  Found                :   Boolean;
  Old_Size             :   LongInt;
  Adresse_Precedente   :   LongInt;
BEGIN
  Found:=False;
  Get_Heap(Memory_Begin, Current);
  Repeat
     If Current.User=0 Then
     BEGIN
       If Current.Size=Taille Then
       BEGIN
         Found:=True;
         Current.User:=1;
         Set_Heap(Current);
         Adresse:=Current.Adresse;
       END;
       If Current.Size>=Taille+Descriptor_Size Then
       BEGIN
         Found:=True;
         Get_Heap(Current.Adresse+Current.Size+Descriptor_Size, Suivant);
         Old_Size:=Current.Size;

         Current.Size:=Taille;
         Current.User:=1;

         Insere.Adresse:=Current.Adresse+Taille+Descriptor_Size;
         Insere.User:=0;
         Insere.Size:=(Old_Size-Taille)-Descriptor_Size;
         Insere.Prec:=Current.Adresse;
         Suivant.Prec:=Insere.Adresse;

         Set_Heap(Suivant);
         Set_Heap(Insere);
         Set_Heap(Current);
         Adresse:=Current.Adresse;
       END;
     END;
     Adresse_Precedente:=Current.Adresse;
     Get_Heap(Current.Size+Current.Adresse+Descriptor_Size, Current);
   Until (Found) Or (Current.User=$FF);
   If Found=False Then
     System_Erreur('No high memory Available', 2);

   Adresse:=Adresse+Descriptor_Size;
   Get_Heap(Current.Prec, Current);
   Defrag(Current);
END;




{ Free a XMS Block }
PROCEDURE Free_XMS(Adresse : LongInt);
VAR
  Current,
  Precedent  :  Descriptor;
BEGIN
  Get_Heap(Adresse-Descriptor_Size, Current);
  If Current.User<255 Then
  BEGIN
    Current.User:=0;
    Set_Heap(Current);
    Defrag(Current);
  END;
END;




{ Get Total Free Memory }
FUNCTION Get_Free_XMS : LongInt;
VAR
  Search : Descriptor;
  Taille : LongInt;
BEGIN
  Taille:=0;
  Get_Heap(Memory_Begin, Search);
  Repeat
    If Search.User=0 Then
      Taille:=Taille+Search.Size-Descriptor_Size;
    Get_Heap(Search.Size+Search.Adresse+Descriptor_Size, Search);
  Until (Search.User=$FF);
  Get_Free_XMS:=Taille;
END;




{ Get biggest free block }
FUNCTION Get_Max_Free : LongInt;
VAR
  Search : Descriptor;
  Taille : LongInt;
BEGIN
  Taille:=0;
  Get_Heap(Memory_Begin, Search);
  Repeat
    If (Search.User=0) And (Search.Size-Descriptor_Size>Taille) Then
    BEGIN
      Taille:=Search.Size-Descriptor_Size;
    END;
    Get_Heap(Search.Size+Search.Adresse+Descriptor_Size, Search);
  Until (Search.User=$FF);
  Get_Max_Free:=Taille;
END;




{ Get Total memory used }
FUNCTION Get_Used_XMS : LongInt;
VAR
  Search : Descriptor;
  Taille : LongInt;
BEGIN
  Taille:=0;
  Get_Heap(Memory_Begin, Search);
  Repeat
    If Search.User<>0 Then
      Taille:=Taille+Search.Size+Descriptor_Size;
    Get_Heap(Search.Size+Search.Adresse+Descriptor_Size, Search);
  Until (Search.User=$FF);
  Get_Used_XMS:=Taille;
END;





{ Get Total memory }
FUNCTION Get_Total_XMS : LongInt;
BEGIN
  Get_Total_XMS:=Get_Used_XMS+Get_Free_XMS;
END;





{ Get size of a file. }
FUNCTION FSize(Nom : String): LongInt;
Var
  F : File Of Byte;
BEGIN
  Assign(F, Nom);
  Reset(F);
  FSize:=FileSize(F);
  Close(F);
END;




CONST
  { Input / Output buffers size for file transfert }
  Block_Size    :  Word=65532;


{ Load a file in XMS (and do allocations) }
PROCEDURE Load_XMS(NomFich : String; Var Adresse : LongInt; Var Taille : LongInt);
Var
  Fichier       :  File;
  Compteur      :  LongInt;
  Buffer        :  Pointer;
  Result        :  Word;
  FTaille       :  LongInt;
BEGIN
  GetMem(Buffer, Block_Size);
  Assign(Fichier, NomFich);
  Reset(Fichier, 1);
  If IOResult<>0 Then
    System_Erreur('Unable to find file to Load', 6);

  Taille:=FileSize(Fichier);
  FTaille:=Taille;
  Get_XMS(Adresse, Taille);
  If Taille>=Block_Size Then
  While Taille>=Block_Size Do
  BEGIN
    BlockRead(Fichier, Buffer^, Block_Size, Result);
    Copy_DWord(Adr(Buffer), Adresse, Block_Size Div 4);
    Inc(Adresse, Block_Size);
    Dec(Taille, Block_Size);
  END;

  If Taille>0 Then
  BEGIN
    BlockRead(Fichier, Buffer^, Taille, Result);
    Copy_Byte(Adr(Buffer), Adresse, Taille-1);
    Inc(Adresse, Taille Mod Block_Size);
    Dec(Taille, Taille Mod Block_Size);
  END;
  Dec(Adresse, FTaille);
  Taille:=FTaille;
  FreeMem(Buffer, Block_Size);
  Close(Fichier);
END;





{ Initialise Flat System }
PROCEDURE Init_Heap_XMS;
VAR
  Current,
  Fin         : Descriptor;
BEGIN
  Current.Adresse:=Memory_Begin;
  Current.Size:=(Total_Memory*1024-192*1024);
  Current.Prec:=0;
  Current.User:=0;
  Fin.Adresse:=Current.Size+Current.Adresse+Descriptor_Size;
  Fin.Size:=0;
  Fin.Prec:=Current.Adresse;
  Fin.User:=$FF;
  Set_Heap(Current);
  Set_Heap(Fin);
END;





{ Show allocated memory blocks - Test procedure }
PROCEDURE Heap_Inspect;
VAR
  Search : Descriptor;
  I      : Byte;
  J      : Word;
  Ch     : Char;
BEGIN
  I:=0;
  J:=0;
  Get_Heap(Memory_Begin, Search);
  Repeat
    TextColor(7);
    Write('Blk:', J);
    Get_Heap(Search.Size+Search.Adresse+Descriptor_Size, Search);
    Inc(J);
    Inc(I);
    If I=20 Then
    BEGIN
      I:=0;
      Ch:=ReadKey;
      ClrScr;
    END;
  Until Search.User=$FF;
  TextColor(7);
  WriteLN('"Terminate" Block Found. End Of Heap.');
END;





{ Initialise Protected Mode, Heap System, and Do a 386 or better test }
PROCEDURE Init_Memory;
BEGIN
  ClrScr;
  If Processor<7 Then
  BEGIN
    TextColor(7);
    WriteLN('Your processor must be a 386 or better,');
    WriteLN('and your current processor is a '+Get_Proc+'. ');
    WriteLN;
    Halt($FF);
  END;
  If Virtual386 Then
  BEGIN
    TextColor(7);
    WriteLN('This program only run in 8086 Real Mode. ');
    WriteLN('Remove Expanded Memory Manager (such as EMM386, QEMM...) ');
    WriteLN;
    Halt($FE);
  END;
  If Init386=False Then
  BEGIN
    TextColor(7);
    WriteLN('System not Ready : Initialisation Failure. ');
    WriteLN;
    Halt($FD);
  END;
  Init_Heap_XMS;
END;




{ Fill a decimal string to obtain 0 before beggining of number }
FUNCTION Add_Decim(Nbr : LongInt; K : Byte): String;
VAR
  Tampon,
  Cv       : String;
BEGIN
  Str(Nbr, Cv);
  FillChar(Tampon, K-Length(Cv)+1, 48);
  Tampon[0]:=Chr(K-Length(Cv));
  Add_Decim:=Tampon+Cv;
END;