QBasic & Borland Pascal & C/Delphi5.iso/Pascal/Samples/MCUNIT10.ARJ/MCXMS10.PAS

Pascal/Delphi Source File | 1993-02-03 | 18.7 KB | 576 lines

{*******************************************************************************
*   Unit name: MCXMS10 interface
*      Author: Martin CEKAL
*        Note: This unit is based on unit XMSheap by Michael Gallias and
*              TPXMS by Vernon E.Davis,Jr.
*        Date: January 15, 1993
*     Version: 1.0
*     Purpose: Usage of XMS (extended) memory
********************************************************************************}
Unit MCXMS10;

Interface

Uses DOS;

Const
  MaxPointers       = 100;

  BlockFree         = 0;        {Free XMS Memory Block}
  BlockUsed         = 1;        {Allocated in XMS, not in Conventional}
  BlockRead         = 2;        {Allocated in XMS and Conventional (Read Mode)}
  BlockReadWrite    = 3;        {Allocated in XMS and Conventional (R/W Mode)}
  BlockWrite        = 4;        {Allocated in XMS and Conventional (Write Mode)}

  XMSReadMode       = 0;
  XMSReadWriteMode  = 1;
  XMSWriteMode      = 2;

Type
  XMSModes          = XMSReadMode..XMSWriteMode;



{*******************************************************************************
*        Name: InitXMS
*  Parametres: init_XMS =0 initialization OK
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Initialization of XMS heap, all XMS is used for heap
*   Important: Use only once
********************************************************************************}
procedure InitXMS(var init_XMS:byte);

{*******************************************************************************
*        Name: FreeXMSHeap
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Realease XMS heap from  XMS
********************************************************************************}
Procedure FreeXMSHeap;

{*******************************************************************************
*        Name: MaxXMSAvail
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Returns largest block in XMS heap
********************************************************************************}
Function  MaxXMSAvail    :LongInt;

{*******************************************************************************
*        Name: XMSAvail
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Returns total available XMS heap
********************************************************************************}
Function  XMSAvail       :LongInt;

{*******************************************************************************
*        Name: GetXMS
*  Parametres: Handle block's unique number
*              Size size of blocks in bytes
*              OK = true request succesfull
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Requests handler to XMS heap
********************************************************************************}
Procedure GetXMS(Var Handle:Word;Size:LongInt;var ok:boolean);

{*******************************************************************************
*        Name: FreeXMS
*  Parametres: Handle block's unique number
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Release block from XMS heap
********************************************************************************}
Procedure FreeXMS(Handle:Word);

{*******************************************************************************
*        Name: AwakePointer
*  Parametres: Handle block's unique number
*              p pointer to data copied from XMS
*              mode mode of acces to block
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Gets a block in conventional memory
*   Important: Never call on awake handle
********************************************************************************}
Procedure AwakePointer(Handle:Word;Var P:Pointer;Mode:XMSModes);

{*******************************************************************************
*        Name: SleepPointer
*  Parametres: Handle block's unique number
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Reverse of AwakePointer
*   Important: Never call on sleeping handle
********************************************************************************}
Procedure SleepPointer(Handle:Word);

Var
  XMSHeapSize :Word;
  XMSResult   : Word;
  XMSError    : Byte;
  XMM_Control : Array[0..1] of Word;
  init_XMS    : Byte;
  isXMS       : Boolean;

{*******************************************************************************
*   Unit name: MCXMS10 implementation
*      Author: Martin CEKAL
*        Note: This unit is based on unit XMSheap by Michael Gallias and
*              TPXMS by Vernon E.Davis,Jr.
*        Date: January 15, 1993
*     Version: 1.0
*     Purpose: Usage of XMS (extended) memory
********************************************************************************}
Implementation

type
   Bit32Struct = LongInt;

   ExtMemMoveStruct =
   Record
      Length       : Bit32Struct;
      SourceHandle : Word;
      SourceOffset : Bit32Struct;
      DestHandle   : Word;
      DestOffset   : Bit32Struct
   End;

  OneXMSPointer     = Record
                        XMSAddr  :LongInt;    {Offset into XMS Heap}
                        ConvAddr :Pointer;    {Pointer to Conventional Memory}
                        Size     :LongInt;    {Size in Bytes of Pointer}
                        Status   :Byte;       {Block Status}
                      End;

  AllXMSPointers    = Array [1..MaxPointers] Of OneXMSPointer;

Var
  OldExitProc   :Pointer;
  HeapHandle    :Word;
  HeapPointer   :^AllXMSPointers;


Procedure PokeAddrXMS(Var b32 : Bit32Struct; sb,ob : Word);
   Procedure PTR_W_W(iptr : Pointer; incr,wval : Word);
   Var
      vptr    : ^Word;
   Begin
      vptr    := Ptr(Seg(iptr^),Ofs(iptr^)+incr);
      vptr^   := wval
   End;
Begin
   PTR_W_W(Addr(b32),0,ob);
   PTR_W_W(Addr(b32),2,sb)
End; {*** end PokeAddrXMS ***}

Function EXISTXMS : Boolean;
Var
   regs : Registers;
Begin
   regs.AX := $4300;
   Intr($2F,regs);
   If regs.al = $80 Then
   Begin
      regs.AX := $4310;
      Intr($2F,regs);
      XMM_Control[0] := regs.bx;
      XMM_Control[1] := regs.es;
      EXISTXMS := TRUE
   End
   Else
      EXISTXMS := FALSE
End; {*** end EXISTXMS ***}




Procedure MoveExtMemBlockXMS(Var MoveStructure : ExtMemMoveStruct);
(* NOTE: This procedure assumes that the ExtMemMove structure is valid *)
Var
   ax,
   segs,
   ofss : Word;
   bl   : Byte;
Begin
   XMSResult := 1;
   XMSError  := 0;
   If NOT isXMS Then
   Begin
      XMSResult := 0;
      XMSError  := $80;
      Exit
   End;
   segs := Seg(MoveStructure);
   ofss := Ofs(MoveStructure);
   Inline
   (  $1E/                                 {  PUSH DS                    }
      $1E/                                 {  PUSH DS                    }
      $07/                                 {  POP  ES                    }
      $8B/$86/segs/                        {  MOV  AX,segs[BP]           }
      $8E/$D8/                             {  MOV  DS,AX                 }
      $8B/$B6/ofss/                        {  MOV  SI,ofss[BP]           }
      $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
      $B8/$00/$0B/                         {  MOV  AX,0B00               }
      $55/                                 {  PUSH BP                    }
      $26/                                 {  ES:                        }
      $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
      $5D/                                 {  POP  BP                    }
      $1F/                                 {  POP  DS                    }
      $89/$86/ax/                          {  MOV  ax[BP],AX             }
      $88/$9E/bl                           {  MOV  bl[BP],BL             }
   );
   XMSResult := ax;
   XMSError  := bl
End; {*** end MoveExtMemBlockXMS ***}

{*******************************************************************************
*        Name: FreeXMSHeap
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Realease XMS heap from  XMS
********************************************************************************}
Procedure FreeXMSHeap;

  Procedure FreeExtMemBlockXMS(handle : Word);
  Var
     ax : Word;
     bl : Byte;
  Begin
     XMSResult := 1;
     XMSError  := 0;
     If NOT isXMS Then
     Begin
        XMSResult := 0;
        XMSError  := $80;
        Exit
     End;
     Inline
     (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
        $8B/$96/handle/                      {  MOV  DX,handle[BP]         }
        $B8/$00/$0A/                         {  MOV  AX,0A00               }
        $55/                                 {  PUSH BP                    }
        $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
        $5D/                                 {  POP  BP                    }
        $89/$86/ax/                          {  MOV  ax[BP],AX             }
        $88/$9E/bl                           {  MOV  bl[BP],BL             }
     );
     XMSResult := ax;
     XMSError  := bl
  End;  {*** end FreeExtMemBlockXMS ***}

Begin
  FreeExtMemBlockXMS(HeapHandle);
  ExitProc:=OldExitProc;
  FillChar(HeapPointer^,SizeOf(HeapPointer^),0);
End; {*** end FreeXMSHeap ***}

{*******************************************************************************
*        Name: MaxXMSAvail
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Returns largest block in XMS heap
********************************************************************************}
Function MaxXMSAvail:LongInt;
Var
  Size   :LongInt;
  X      :Word;
Begin
  X:=2;
  Size:=HeapPointer^[1].Size;
  While (HeapPointer^[X].Size>0) And (X<=MaxPointers) do
  Begin
    If HeapPointer^[X].Status=BlockFree Then
      If HeapPointer^[X].Size>Size Then
        Size:=HeapPointer^[X].Size;
    Inc(X);
  End;
  MaxXMSAvail:=Size;
End; {*** end MaxXMSAvail ***}

{*******************************************************************************
*        Name: XMSAvail
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Returns total available XMS heap
********************************************************************************}
Function XMSAvail:LongInt;
Var
  Size   :LongInt;
  X      :Word;
Begin
  X:=2;
  Size:=HeapPointer^[1].Size;
  While (HeapPointer^[X].Size>0) And (X<=MaxPointers) do
  Begin
    If HeapPointer^[X].Status=BlockFree Then
      Size:=Size+HeapPointer^[X].Size;
    Inc(X);
  End;
  XMSAvail:=Size;
End; {*** end XMSAvail ***}

Function IndexForData(Amount:LongInt):Word;
Var
  X     :Word;
  Found :Boolean;
Begin
  X:=1;
  Found:=False;
  While (Not Found) And (X<=MaxPointers) do
  Begin
    If (HeapPointer^[X].Status=BlockFree) And (HeapPointer^[X].Size>=Amount) Then
      Found:=True
    Else
      Inc(X);
  End;
  If Not Found Then
    IndexForData:=0
  Else
    IndexForData:=X;
End; {*** end IndexForData ***}

Function FindBlankIndex:Word;
Var
  X     :Word;
  Found :Boolean;
Begin
  X:=1;
  Found:=False;
  While (Not Found) And (X<MaxPointers) do
  Begin
    If HeapPointer^[X].Size=0 Then
      Found:=True
    Else
      Inc(X);
  End;
  If Not Found Then
    FindBlankIndex:=0
  Else
    FindBlankIndex:=X;
End; {*** end FindBlankIndex ***}

{*******************************************************************************
*        Name: GetXMS
*  Parametres: Handle block's unique number
*              Size size of blocks in bytes
*              OK = true request succesfull
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Requests handler to XMS heap
********************************************************************************}
Procedure GetXMS(Var Handle:Word;Size:LongInt;var ok:boolean);
Var
  FreeIndex  :Word;
Begin
  ok:=false;
  If Odd(Size) Then Inc(Size);
  Handle:=IndexForData(Size);
  If Handle = 0 Then exit;
  If HeapPointer^[Handle].Size>Size Then
  Begin
    FreeIndex:=FindBlankIndex;
    If FreeIndex=0 Then exit;

    HeapPointer^[FreeIndex].Size     :=HeapPointer^[Handle].Size - Size;
    HeapPointer^[FreeIndex].Status   :=BlockFree;
    HeapPointer^[FreeIndex].XMSAddr  :=HeapPointer^[Handle].XMSAddr + Size;

    HeapPointer^[Handle].Size        :=Size;
  End;
  ok:=true;
  HeapPointer^[Handle].Status        :=BlockUsed;
End; {*** end GetXMS ***}

{*******************************************************************************
*        Name: FreeXMS
*  Parametres: Handle block's unique number
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Release block from XMS heap
********************************************************************************}
Procedure FreeXMS(Handle:Word);
Var
  X     :Word;
Begin
  HeapPointer^[Handle].Status:=BlockFree;
  X:=Handle+1;
  While (X<MaxPointers) And (HeapPointer^[X].Status=BlockFree) do
  Begin
    If HeapPointer^[X].Size>0 Then
    Begin
      Inc(HeapPointer^[Handle].Size,HeapPointer^[X].Size);
      HeapPointer^[X].Size:=0;
    End;
    Inc(X);
  End;
End; {end FreeXMS ***}

{*******************************************************************************
*        Name: AwakePointer
*  Parametres: Handle block's unique number
*              p pointer to data copied from XMS
*              mode mode of acces to block
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Gets a block in conventional memory
*   Important: Never call on awake handle
********************************************************************************}
Procedure AwakePointer(Handle:Word;Var P:Pointer;Mode:XMSModes);
Var
  AlreadyIn:Boolean;
  XMSInfo  :ExtMemMoveStruct;
Begin
   If HeapPointer^[Handle].Status in [BlockRead,BlockReadWrite,BlockWrite] Then
    AlreadyIn:=True
  Else
    AlreadyIn:=False;
  Case Mode Of
    XMSReadMode      :HeapPointer^[Handle].Status:=BlockRead;
    XMSReadWriteMode :HeapPointer^[Handle].Status:=BlockReadWrite;
    XMSWriteMode     :HeapPointer^[Handle].Status:=BlockWrite;
  End;
  If AlreadyIn Then
    P:=HeapPointer^[Handle].ConvAddr
  Else
  Begin
    GetMem(P,HeapPointer^[Handle].Size);
    HeapPointer^[Handle].ConvAddr:=P;
    If Mode in [XMSReadMode,XMSReadWriteMode] Then
    Begin
      XMSInfo.Length       :=HeapPointer^[Handle].Size;
      XMSInfo.SourceHandle :=HeapHandle;
      XMSInfo.SourceOffset :=HeapPointer^[Handle].XMSAddr;
      XMSInfo.DestHandle   :=0;
      PokeAddrXMS(XMSInfo.DestOffset,Seg(P^),Ofs(P^));
      MoveExtMemBlockXMS(XMSInfo);
    End;
  End;
End; {*** end AwakePointer ***}

{*******************************************************************************
*        Name: SleepPointer
*  Parametres: Handle block's unique number
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Reverse of AwakePointer
*   Important: Never call on sleeping handle
********************************************************************************}
Procedure SleepPointer(Handle:Word);
Var
  XMSInfo  :ExtMemMoveStruct;
Begin
  If Not(HeapPointer^[Handle].Status=BlockRead) Then
  Begin
    XMSInfo.Length       :=HeapPointer^[Handle].Size;
    XMSInfo.SourceHandle :=0;
    PokeAddrXMS(XMSInfo.SourceOffset,Seg(HeapPointer^[Handle].ConvAddr^),
                                     Ofs(HeapPointer^[Handle].ConvAddr^) );
    XMSInfo.DestHandle   :=HeapHandle;
    XMSInfo.DestOffset   :=HeapPointer^[Handle].XMSAddr;
    MoveExtMemBlockXMS(XMSInfo);
  End;
  FreeMem(HeapPointer^[Handle].ConvAddr,HeapPointer^[Handle].Size);
  HeapPointer^[Handle].Status:=BlockUsed;
End; {*** end SleepPointer ***}

{*******************************************************************************
*        Name: InitXMS
*  Parametres: init_XMS =0 initialization OK
*        Date: January 14, 1993
*     Version: 1.0
*     Purpose: Initialization of XMS heap, all XMS is used for heap
*   Important: Use only once
********************************************************************************}
procedure InitXMS(var init_XMS:byte);

  Procedure QueryFreeBlockXMS;
  (* XMSResult = largest free block of Extended Memory in kilobytes *)
  Var
     dx : Word;
  Begin
     XMSResult := 1;
     XMSError  := 0;
     If NOT isXMS Then
     Begin
        XMSResult := 0;
        XMSError  := $80;
        Exit
     End;
     Inline
     (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
        $B8/$00/$08/                         {  MOV  AX,0800               }
        $55/                                 {  PUSH BP                    }
        $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
        $5D/                                 {  POP  BP                    }
        $89/$96/dx                           {  MOV  dx[BP],DX             }
     );
     XMSResult := dx
  End;

  Function AllocExtMemBlockXMS(malloc : Word) : Word;
  (* If successful, returns handle to Extended Memory Block *)
  Var
     ax : Word;
     dx : Word;
     bl : Byte;
  Begin
     XMSResult := 1;
     XMSError  := 0;
     If NOT isXMS Then
     Begin
        XMSResult := 0;
        XMSError  := $80;
        AllocExtMemBlockXMS := 0;
        Exit
     End;
     Inline
     (  $BF/XMM_Control/                     {  MOV  DI,XMM_Control        }
        $8B/$96/malloc/                      {  MOV  DX,malloc[BP]         }
        $B8/$00/$09/                         {  MOV  AX,0900               }
        $55/                                 {  PUSH BP                    }
        $FF/$1D/                             {  CALL FAR[DI] (XMM_Control) }
        $5D/                                 {  POP  BP                    }
        $89/$86/ax/                          {  MOV  ax[BP],AX             }
        $88/$9E/bl/                          {  MOV  bl[BP],BL             }
        $89/$96/dx                           {  MOV  dx[BP],DX             }
     );
     XMSResult := ax;
     XMSError  := bl;
     AllocExtMemBlockXMS := dx
  End;

  Procedure GetXMSHeap(Amount:Word);         {Call ONCE Only}
  Begin
    HeapHandle:=AllocExtMemBlockXMS(Amount);
    If XMSResult=1 Then
    Begin
      OldExitProc:=ExitProc;
      ExitProc:=@FreeXMSHeap;
      HeapPointer^[1].Size:=LongInt(Amount)*1024;
      HeapPointer^[1].XMSAddr:=0;
      XMSHeapSize:=Amount;
    End
    Else
      HeapHandle:=0;
  End;


begin
  queryfreeblockxms;
  getxmsheap(xmsresult);
  if xmsresult=1 then init_xms:=0 else init_xms:=1;
end; {*** end InitXMS ***}

Begin
  XMM_Control[0] := 0;
  XMM_Control[1] := 0;
  XMSResult      := 1;
  XMSError       := 0;
  isXMS          := EXISTXMS;
  System.New(HeapPointer);
  FillChar(HeapPointer^,SizeOf(HeapPointer^),0);
End. {*** unit MCXMS10 ***}