{---------------------------------------------------------------------------}
{   eXtended Memory Specification Unit for Turbo Pascal 6.0 - Version 1.0   }
{ Written by Yuval Tal, 13 Glazer st, Rehovot 76283, Israel  Date: 4-Mar-91 }
{ BitNet: NYYUVAL@WEIZMANN        InterNet: NYYUVAL@WEIZMANN.WEIZMANN.AC.IL }
{---------------------------------------------------------------------------}
{ This program may be freely distributed for non-commercial, non-business,  }
{ and non-governmental uses, provided this notice is attached with it.  My  }
{ only request is that if you plan to use it regularly, you let me know of  }
{ it through e-mail or postal mail, so that I have an idea of how useful    }
{ this program is (if you will add some cash to that letter it would be     }
{ nice, ofcourse :-)). Also, if you have any problems, suggestions etc'     }
{ please let me know. For more information read the document file.          }
{---------------------------------------------------------------------------}

{$N+,A+,G+,F+,D-,E-,L-,R-,S-,Q-,Y-,I-}
Unit XMS2;

Interface

Var
  Present: Boolean;                        {True if XMM driver is installed}
  XMSError: Byte;                          {Error number. If 0 -> no error}

Function  XMMPresent: Boolean;
Function  XMSErrorString(Error: Byte): String;
Function  XMSMemAvail: Word;
Function  XMSMaxAvail: Word;
Function  GetXMMVersion: Word;
Function  GetXMSVersion: Word;
Procedure MoveFromEMB(Handle: Word; Var Dest; BlockLength: LongInt);
Procedure MoveToEMB(Var Source; Handle: Word; BlockLength: LongInt);
Function  EMBGetMem(Size: Word): Word;
Procedure EMBFreeMem(Handle: Word);
Procedure EMBResize(Handle, Size: Word);
Function  GetAvailEMBHandles: Byte;
Function  GetEMBLock(Handle: Word): Byte;
Function  GetEMBSize(Handle: Word): Word;
Function  LockEMB(Handle: Word): LongInt;
Procedure UnlockEMB(Handle: Word);
Function  UMBGetMem(Size: Word; Var Segment: Word): Word;
Procedure UMBFreeMem(Segment: Word);
Function  GetA20Status: Boolean;
Procedure DisableLocalA20;
Procedure EnableLocalA20;
Procedure DisableGlobalA20;
Procedure EnableGlobalA20;
Procedure HMAGetMem(Size: Word);
Procedure HMAFreeMem;
Function  GetHMA: Boolean;

Procedure MoveFromXMS(Handle: Word; Dest_seg,Dest_ofs:word; BlockLength: LongInt);
Procedure MoveToXMS(Source_seg,Source_ofs:word; Handle: Word; BlockLength: LongInt);
Procedure MoveFromXMS_Adv(Handle: Word; Dest_seg,Dest_ofs, Source_ofs:longint; BlockLength: LongInt);
Procedure MoveToXMS_Adv(Source_seg,Source_ofs:word; Handle: Word; Dest_ofs, BlockLength: LongInt);
Procedure FreeXMS;


Implementation

Uses Dos, global;

Const
  High=1;
  Low=2;
  NumberOfErrors=27;
  ErrorNumber: Array [1..NumberOfErrors] Of Byte = ($80,$81,$82,$8E,$8F,$90,
                $91,$92,$93,$94,$A0,$A1,$A2,$A3,$A4,$A5,$A6,$A7,$A8,$A9,$AA,
                $AB,$AC,$AD,$B0,$B1,$B2);
  ErrorString: Array [0..NumberOfErrors] Of String = (
               'Unknown error',
               'Function no implemented',
               'VDISK device driver was detected',
               'A20 error occured',
               'General driver errror',
               'Unrecoverable driver error',
               'High memory area does not exist',
               'High memory area is already in use',
               'DX is less than the ninimum of KB that program may use',
               'High memory area not allocated',
               'A20 line still enabled',
               'All extended memory is allocated',
               'Extended memory handles exhausted',
               'Invalid handle',
               'Invalid source handle',
               'Invalid source offset',
               'Invalid destination handle',
               'Invalid destination offset',
               'Invalid length',
               'Invalid overlap in move request',
               'Parity error detected',
               'Block is not locked',
               'Block is locked',
               'Lock count overflowed',
               'Lock failed',
               'Smaller UMB is available',
               'No UMBs are available',
               'Inavlid UMB segment number');

Type
  XMSParamBlock=
    Record
      Length: LongInt;
      SHandle: Word;
      SOffset: Array[High..Low] Of Word;
      DHandle: Word;
      DOffset: Array[High..Low] Of Word;
    End;

Var
  XMSAddr: Array[High..Low] Of Word;       {XMM driver address 1=Low,2=High}

{---------------------------------------------------------------------------}

Function XMMPresent: Boolean;

Var
  Regs: Registers;

Begin
  With Regs Do
    Begin
      AX:=$4300;
      Intr($2F,Regs);
      XMMPresent:=AL=$80;
    End;
End;

{---------------------------------------------------------------------------}

Function XMSErrorString(Error: Byte): String;

Var
  I,Index: Byte;

Begin
  Index:=0;
  For I:=1 To NumberOfErrors Do
    If ErrorNumber[I]=Error Then Index:=I;
  XMSErrorString:=ErrorString[Index];
End;

{---------------------------------------------------------------------------}

Function XMSMemAvail: Word;

Var
  Memory: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,8
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Memory,DX
@@2:
  End;
  XMSMemAvail:=Memory;
End;

{---------------------------------------------------------------------------}

Function XMSMaxAvail: Word;

Var
  Temp: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,8
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp,AX
@@2:
  End;
  XMSMaxAvail:=Temp;
End;

{---------------------------------------------------------------------------}

Function EMBGetMem(Size: Word): Word;

Var
  Temp: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,9
    Mov  DX,Size
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp,DX
@@2:
  End;
  EMBGetMem:=Temp;
End;

{---------------------------------------------------------------------------}

Procedure EMBFreeMem(Handle: Word);

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Ah
    Mov  DX,Handle
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure EMBResize(Handle, Size: Word);

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Fh
    Mov  DX,Handle
    Mov  BX,Size
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure MoveToEMB(Var Source; Handle: Word; BlockLength: LongInt);

Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=0;
      SOffset[High]:=Ofs(Source);
      SOffset[Low]:=Seg(Source);
      DHandle:=Handle;
      DOffset[High]:=0;
      DOffset[Low]:=0;
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;

{---------------------------------------------------------------------------}

Procedure MoveFromEMB(Handle: Word; Var Dest; BlockLength: LongInt);

Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=Handle;
      SOffset[High]:=0;
      SOffset[Low]:=0;
      DHandle:=0;
      DOffset[High]:=Ofs(Dest);
      DOffset[Low]:=Seg(Dest);
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg;
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;

{---------------------------------------------------------------------------}

Function GetXMSVersion: Word;

Var
  HighB, LowB: Byte;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  HighB,AH
    Mov  LowB,AL
@@2:
  End;
  GetXMSVersion:=(HighB*100)+LowB;
End;

{---------------------------------------------------------------------------}

Function GetXMMVersion: Word;

Var
  HighB, LowB: Byte;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  HighB,BH
    Mov  LowB,BL
@@2:
  End;
  GetXMMVersion:=(HighB*100)+LowB;
End;

{---------------------------------------------------------------------------}

Function GetHMA: Boolean;

Var
  Temp: Boolean;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Temp:=False;
  Asm
    Mov  AH,0
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Cmp  DX,0
    Je   @@2
    Mov  Temp,1
@@2:
  End;
  GetHMA:=Temp;
End;

{---------------------------------------------------------------------------}

Procedure HMAGetMem(Size: Word);

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,1
    Mov  DX,Size
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure HMAFreeMem;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,2
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure EnableGlobalA20;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,3
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;


{---------------------------------------------------------------------------}

Procedure DisableGlobalA20;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,4
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure EnableLocalA20;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,5
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Procedure DisableLocalA20;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,6
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Function GetA20Status: Boolean;

Var
  Temp: Boolean;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Temp:=True;
  Asm
    Mov  AH,6
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Or   AX,AX
    Jne  @@1
    Or   BL,BL
    Jne  @@2
    Mov  Temp,0
    Jmp  @@1
@@2:
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Function LockEMB(Handle: Word): LongInt;

Var
  Temp1,Temp2: Word;
  Temp: LongInt;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Ch
    Mov  DX,Handle
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp1,DX
    Mov  Temp2,BX
@@2:
  End;
  Temp:=Temp1;
  LockEMB:=(Temp Shl 4)+Temp2;
End;

{---------------------------------------------------------------------------}

Procedure UnlockEMB(Handle: Word);

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Dh
    Mov  DX,Handle
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;

{---------------------------------------------------------------------------}

Function GetEMBSize(Handle: Word): Word;

Var
  Temp: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Eh
    Mov  DX,Handle
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp,DX
@@2:
  End;
  GetEMBSize:=Temp;
End;

{---------------------------------------------------------------------------}

Function GetEMBLock(Handle: Word): Byte;

Var
  Temp: Byte;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Eh
    Mov  DX,Handle
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp,BH
@@2:
  End;
  GetEMBLock:=Temp;
End;

{---------------------------------------------------------------------------}

Function GetAvailEMBHandles: Byte;

Var
  Temp: Byte;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,0Eh
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp,BL
@@2:
  End;
  GetAvailEMBHandles:=Temp;
End;

{---------------------------------------------------------------------------}

Function UMBGetMem(Size: Word; Var Segment: Word): Word; {Actual size}

Var
  Temp1,Temp2: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,10h
    Mov  DX,Size
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
    Jmp  @@2
@@1:
    Mov  Temp2,BX
@@2:
    Mov  Temp1,DX
  End;
  Segment:=Temp2;
  UMBGetMem:=Temp1;
End;

{---------------------------------------------------------------------------}

Procedure UMBFreeMem(Segment: Word);

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  Asm
    Mov  AH,10h
    Mov  DX,Segment
    Call [XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
  End;
End;


Procedure MoveToXMS(Source_seg,Source_ofs:word; Handle: Word; BlockLength: LongInt);
Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=0;
      SOffset[High]:=Source_ofs;
      SOffset[Low]:=Source_seg;
      DHandle:=Handle;
      DOffset[High]:=0;
      DOffset[Low]:=0;
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;

{---------------------------------------------------------------------------}

Procedure MoveFromXMS(Handle: Word; Dest_seg,Dest_ofs:word; BlockLength: LongInt);
Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=Handle;
      SOffset[High]:=0;
      SOffset[Low]:=0;
      DHandle:=0;
      DOffset[High]:=Dest_ofs;
      DOffset[Low]:=Dest_seg;
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg;
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;
{------------------------------------------------------------------------}

function Lo_dword(x:longint):word;
var y:word;
begin
  asm
  mov ax, word ptr x
  mov y, ax
  end;
  Lo_dword:=y;
end;

function Hi_dword(x:longint):word;
var y:word;
begin
  asm
  db $66; mov ax, word ptr x
  db $66; shr ax, 16
  mov y, ax
  end;
  Hi_dword:=y;
end;


Procedure MoveFromXMS_Adv(Handle: Word; Dest_seg,Dest_ofs, Source_ofs:longint; BlockLength: LongInt);
Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=Handle;
      SOffset[High]:=Lo_dword(Source_ofs);
      SOffset[Low]:=Hi_dword(Source_ofs);
      DHandle:=0;
      DOffset[High]:=Dest_ofs;
      DOffset[Low]:=Dest_seg;
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg;
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;


Procedure MoveToXMS_Adv(Source_seg,Source_ofs:word; Handle: Word; Dest_ofs, BlockLength: LongInt);
Var
  ParamBlock: XMSParamBlock;
  XSeg,PSeg,POfs: Word;

Begin
  XMSError:=0;
  If Not(Present) Then Exit;
  With ParamBlock Do
    Begin
      Length:=BlockLength;
      SHandle:=0;
      SOffset[High]:=Source_ofs;
      SOffset[Low]:=Source_seg;
      DHandle:=Handle;
      DOffset[High]:=Lo_dword(Dest_ofs);
      DOffset[Low]:=Hi_dword(Dest_ofs);
    End;
  PSeg:=Seg(ParamBlock);
  POfs:=Ofs(ParamBlock);
  XSeg:=Seg(XMSAddr);

  Asm
    Push DS
    Mov  AH,0Bh
    Mov  SI,POfs
    Mov  BX,XSeg
    Mov  ES,BX
    Mov  BX,PSeg
    Mov  DS,BX
    Call [ES:XMSAddr]
    Or   AX,AX
    Jne  @@1
    Mov  XMSError,BL
@@1:
    Pop  DS
  End;
End;

Procedure FreeXMS;
var m:word;
begin
  if handler_counter>0 then
  for m:=1 to handler_counter do begin
      if handler_list[m]>0 then
      begin
           if debug_mode=1 then Write(m,'. Free handle: ', handler_list[m]);
           EMBFreeMem(Handler_list[m]);
           if debug_mode=1 then if XMSError<>0 then WriteLn(' - Error') else WriteLn(' - OK');
      end;
  end;
end;


{---------------------------------------------------------------------------}

Var
  Regs: Registers;

Begin
  If Not(XMMPresent) Then
    Begin
      WriteLn('XMS not supported!');
      Present:=False;
      Exit;
    End;
  Present:=True;
  With Regs Do
    Begin
      AX:=$4310;
      Intr($2F,Regs);
      XMSAddr[High]:=BX;
      XMSAddr[Low]:=ES;
    End;
End.
