ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/XMSLIBR1.ZIP/XMSLIB.PAS

Pascal/Delphi Source File | 1991-08-11 | 20.1 KB | 580 lines

(******************************************************************************
*                                   xmsLib                                    *
******************************************************************************)
unit xmsLib;

interface

uses
    dos
    ;
type
   xmsMovePtr = ^xmsMoveStructure;
   xmsMoveStructure = record
      length         : longint; { 32-bit # of bytes to transfer }
      sourceHandle   : word;
      sourceOffset   : longint;
      destHandle     : word;
      destOffset     : longint;
   end; { xmsMoveStructure definition }
var
   xmsPresent   : boolean; { true if XMS was detected }
   xmsAddress   : pointer; { used to point to XMS entry address }
   xmsVersion   : word;
   xmmVersion   : word;
   hmaPresent   : boolean;
   xmsErrorCode : byte; { if an error exists, it will be placed here }

procedure detectXMS; { look for xms existance, and sets global library variables }
procedure setXMSHandlerAddress;
procedure getXMSVersionNumber;
function  printXMSVersion : string; { a readable string .. }
function  printXMMVersion : string; { a readable string .. }
function  requestHMA : boolean;
function  releaseHMA : boolean;
function globalEnableA20 : boolean;
function globalDisableA20 : boolean;
function localEnableA20 : boolean;
function localDisableA20 : boolean;
function queryA20 : boolean;
procedure queryFreeExtendedMemory(var largestBlock, totalInK : word);
function xmsLargestBlock : word;
function xmsTotalFreeMemory : word;
function allocateXMB(sizeInK : word; var handle : word) : boolean;
function freeXMB(handle : word) : boolean;
function moveXMB(structure : xmsMovePtr) : boolean;
function moveXMBlock(len : longint; srcHandle : word; srcOfs : longint;
                     dstHandle : word; dstOfs : longint) : boolean;
function mainstgToXMB(len : word; fromPtr : pointer;
                      toHandle : word; toOfs : longint) : boolean;
function XMBtoMainstg(len : word; toPtr : pointer;
                      fmHandle : word; fmOfs : longint) : boolean;
function lockXMB(handle : word) : boolean;
function unlockXMB(handle : word) : boolean;
function getXMBInformation(handle : word; var lockCount, freeHandles : byte;
                           var sizeInK : word) : boolean;
function reallocXMB(newSizeInK, handle : word) : boolean;
function requestUMB(sizeInParagraphs : word; var segmentOfUMB : word;
                    var sizeAllocatedOrAvailable : word) : boolean;
function releaseUMB(segmentOfUMB : word) : boolean;
function xmsErrorStr : string;

implementation
type
   xmsErrorType = record
      errorNumber  : byte;
      errorMessage : string;
   end;
const
   maxXMSErrors = 27;
   xmsErrorArray : array [1 .. maxXMSErrors] of xmsErrorType = (
      (errorNumber : $80; errorMessage :  'Function not implemented'),
      (errorNumber : $81; errorMessage :  'VDISK device detected'),
      (errorNumber : $82; errorMessage :  'A20 Error occured'),
      (errorNumber : $8e; errorMessage :  'General driver error'),
      (errorNumber : $8f; errorMessage :  'Fatal driver error'),
      (errorNumber : $90; errorMessage :  'HMA does not exist'),
      (errorNumber : $91; errorMessage :  'HMA is already in use'),
      (errorNumber : $92; errorMessage :  'Size is smaller then /HMAMIN= parameter'),
      (errorNumber : $93; errorMessage :  'HMA not allocated'),
      (errorNumber : $94; errorMessage :  'A20 line still enabled'),
      (errorNumber : $a0; errorMessage :  'No more free extended memory'),
      (errorNumber : $a1; errorMessage :  'No more XMS handles'),
      (errorNumber : $a2; errorMessage :  'Invalid handle'),
      (errorNumber : $a3; errorMessage :  'Invalid source handle'),
      (errorNumber : $a4; errorMessage :  'Invalid source offset'),
      (errorNumber : $a5; errorMessage :  'Invalid destination handle'),
      (errorNumber : $a6; errorMessage :  'Invalid destination offset'),
      (errorNumber : $a7; errorMessage :  'Invalid length'),
      (errorNumber : $a8; errorMessage :  'Move resulted in overlap'),
      (errorNumber : $a9; errorMessage :  'Parity error'),
      (errorNumber : $aa; errorMessage :  'Block not locked'),
      (errorNumber : $ab; errorMessage :  'Block locked'),
      (errorNumber : $ac; errorMessage :  'Block lock count overflow'),
      (errorNumber : $ad; errorMessage :  'Lock failure'),
      (errorNumber : $b0; errorMessage :  'Smaller UMB available'),
      (errorNumber : $b1; errorMessage :  'No UMBs available'),
      (errorNumber : $b2; errorMessage :  'Invalid UMB segment number')
      );
var
   regs : registers;

(******************************************************************************
*                                  detectXMS                                  *
******************************************************************************)
procedure detectXMS;
begin
     asm
        mov xmsPresent, 0 { no xms available }
        mov ax, $4300
        int $2f { multiplexer interrupt identification }
        cmp al, $80 { well , is there XMM ? }
        jne @noXMSDriver
        mov xmsPresent, 1 { true, we have an xms driver }
@noXMSDriver:
     end; { asm }
end; {detectXMS}

(******************************************************************************
*                            setXMSHandlerAddress                             *
******************************************************************************)
procedure setXMSHandlerAddress;
begin
     asm
        mov ax,$4310
        int $2f { ES:BX points to xms driver entry point }
        mov word ptr [xmsAddress], bx
        mov word ptr [xmsAddress + 2], es
     end; { asm }
end; {setXMSHandlerAddress}

(******************************************************************************
*                             getXMSVersionNumber                             *
******************************************************************************)
procedure getXMSVersionNumber;
begin
     asm
        xor ah, ah; { function 0 .. }
        call [xmsAddress]
        mov xmsVersion, ax
        mov xmmVersion, bx
        mov byte ptr hmaPresent, dl { true or false .. }
     end; { asm }
end; {getXMSVersionNumber}

(******************************************************************************
*                               printXMSVersion                               *
******************************************************************************)
function printXMSVersion;
var
   s1, s2  : string;
begin
   str(xmsVersion div $100, s1);
   str(xmsVersion mod $100, s2);
   printXMSVersion := s1 + '.' + s2;
end; {printXMSVersion}

(******************************************************************************
*                               printXMMVersion                               *
******************************************************************************)
function printXMMVersion;
var
   s1, s2, s3  : string;
begin
   str(XMMVersion div $100, s1);
   str((XMMVersion mod $100) div $10, s2);
   str(XMMVersion mod $10, s3);
   printXMMVersion := s1 + '.'+ s2 + s3;
end; {printXMMVersion}

(******************************************************************************
*                                 requestHMA                                  *
******************************************************************************)
function requestHMA;
var
   requestGranted : boolean;
begin
     asm
        mov ah, 1
        mov dx, $ffff { assume we are not tsr, but an application }
        call [xmsAddress]
        mov requestGranted, al
        mov xmsErrorCode, bl
     end; { asm }
     requestHMA := requestGranted; { if not, check xmsErrorCode }
end; {requestHMA}

(******************************************************************************
*                                 releaseHMA                                  *
******************************************************************************)
function releaseHMA;
var
   releaseGranted : boolean;
begin
     asm
        mov ah, 2
        call [xmsAddress]
        mov releaseGranted, al
        mov xmsErrorCode, bl
     end; {asm}
     releaseHMA := releaseGranted;
end; {releaseHMA}

(******************************************************************************
*                              globalEnableA20                                *
******************************************************************************)
function globalEnableA20;
var
   A20geGranted : boolean;
begin
   asm
      mov ah, 3
      call [xmsAddress]
      mov A20geGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   globalEnableA20 := a20geGranted;
end; {globalEnableA20}

(******************************************************************************
*                              globalDisableA20                               *
******************************************************************************)
function globalDisableA20;
var
   A20gdGranted : boolean;
begin
   asm
      mov ah, 4
      call [xmsAddress]
      mov A20gdGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   globalDisableA20 := a20gdGranted;
end; {globalDisableA20}

(******************************************************************************
*                              localEnableA20                                 *
******************************************************************************)
function localEnableA20;
var
   A20geGranted : boolean;
begin
   asm
      mov ah, 5
      call [xmsAddress]
      mov A20geGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   localEnableA20 := a20geGranted;
end; {localEnableA20}

(******************************************************************************
*                              localDisableA20                                *
******************************************************************************)
function localDisableA20;
var
   A20gdGranted : boolean;
begin
   asm
      mov ah, 6
      call [xmsAddress]
      mov A20gdGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   localDisableA20 := a20gdGranted;
end; {localDisableA20}

(******************************************************************************
*                                  queryA20                                   *
* Returns True if A20 is physically enabled. query validity of respons by     *
* looking at the xmsErrorCode first !                                         *
* i.e. ...                                                                    *
* findA20State := queryA20;                                                   *
* if (xmsErrorCode <> 0) then                                                 *
*     Error                                                                   *
* else findA20State has the proper value according to the A20 state           *
******************************************************************************)
function queryA20;
var
   A20State : boolean;
begin
   asm
      mov ah, 7
      call [xmsAddress]
      mov A20State, al
      mov xmsErrorCode, bl
   end; { asm }
   queryA20 := A20State;
end; {queryA20}

(******************************************************************************
*                           queryFreeExtendedMemory                           *
******************************************************************************)
procedure queryFreeExtendedMemory;
var
   ourLB, ourTIK : word;
begin
   asm
      mov ah, 8
      call [xmsAddress]
      mov ourLB, ax
      mov ourTIK, dx
      mov xmsErrorCode, bl
   end; { asm }
   largestBlock := ourLB;
   totalInK := ourTIK;
end; {queryFreeExtendedMemory}

(******************************************************************************
*                               xmsLargestBlock                               *
******************************************************************************)
function xmsLargestBlock;
var
   lb, tik : word;
begin
   queryFreeExtendedMemory(lb, tik);
   xmsLargestBlock := lb;
end; {xmsLargestBlock}

(******************************************************************************
*                             xmsTotalFreeMemory                              *
******************************************************************************)
function xmsTotalFreeMemory;
var
   lb, tik : word;
begin
   queryFreeExtendedMemory(lb, tik);
   xmsTotalFreeMemory := tik;
end; {xmsTotalFreeMemory}

(******************************************************************************
*                                 allocateXMB                                 *
* if returns True handle has the handle to the memory block                   *
******************************************************************************)
function allocateXMB;
var
   allocGranted : boolean;
   ourHandle    : word;
begin
   asm
      mov ah, 9
      mov dx, sizeInK
      call [xmsAddress]
      mov allocGranted, al { did we make it ? }
      mov ourHandle, dx
      mov xmsErrorCode, bl
   end; { asm }
   allocateXMB := allocGranted;
   if (allocGranted) then
      handle := ourHandle;
end; {allocateXMB}

(******************************************************************************
*                                   freeXMB                                   *
******************************************************************************)
function freeXMB;
var
   releaseGranted : boolean;
begin
   asm
      mov ah, $a
      mov dx, handle
      call [xmsAddress]
      mov releaseGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   freeXMB := releaseGranted;
end; {freeXMB}

(******************************************************************************
*                                   moveXMB                                   *
******************************************************************************)
function moveXMB;
var
   moveGranted : boolean;
   segmento    : word;
   offseto     : word;
begin
   segmento := seg(structure^);
   offseto  := ofs(structure^);
   asm
      push ds
      pop es
      mov si, offseto
      mov ax, segmento
      mov ds, ax
      mov ah, $b
      call [es:xmsAddress]
      push es
      pop ds
      mov moveGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   moveXMB := moveGranted;
end; {moveXMB}

(******************************************************************************
*                                 moveXMBlock                                 *
******************************************************************************)
function moveXMBlock;
var
   struct : xmsMoveStructure;
begin
   with struct do begin
      length := len;
      sourceHandle := srcHandle;
      sourceOffset := srcOfs;
      destHandle := dstHandle;
      destOffset := dstOfs;
   end; { with }
   moveXMBlock := moveXMB(@struct); { go do it ! }
end; {moveXMBlock}

(******************************************************************************
*                                mainstgToXMB                                 *
* move fm ptr len bytes to XMB handle, at offset                              *
******************************************************************************)
function mainstgToXMB;
var
   l : longint;
begin
   l := longint(fromPtr);
   mainstgToXMB := moveXMBlock(len, 0, l, toHandle, toOfs);
end; {mainstgToXMB}

(******************************************************************************
*                                XMBtoMainstg                                 *
* xmb fmhandle at ofsset fmofs, move to main storage at pointer toptr, len byt*
******************************************************************************)
function XMBtoMainstg;
var
   l : longint;
begin
   l := longint(toPtr);
   XMBtoMainstg := moveXMBlock(len, fmHandle, fmOfs, 0, l);
end; {XMBtoMainstg}

(******************************************************************************
*                                   lockXMB                                   *
******************************************************************************)
function lockXMB;
var
   lockGranted : boolean;
begin
   asm
      mov ah, $c
      mov dx, handle
      call [xmsAddress]
      mov lockGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   lockXMB := lockGranted;
end; {lockXMB}

(******************************************************************************
*                                  unlockXMB                                  *
******************************************************************************)
function unlockXMB;
var
   unlockGranted : boolean;
begin
   asm
      mov ah, $d
      mov dx, handle
      call [xmsAddress]
      mov unlockGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   unlockXMB := unlockGranted;
end; {unlockXMB}

(******************************************************************************
*                              getXMBInformation                              *
******************************************************************************)
function getXMBInformation;
var
   informationReceived : boolean;
   ourSIK              : word;
   ourFH, ourLC        : byte;
begin
   asm
      mov ah, $e
      mov dx, handle
      call [xmsAddress]
      mov informationReceived, al
      mov ourLC, bh
      mov ourFH, bl
      mov ourSIK, dx
      mov xmsErrorCode, bl
   end; { asm }
   getXMBInformation := informationReceived;
   sizeInK := ourSIK;
   freeHandles := ourFH;
   lockCount := ourLC;
end; {getXMBInformation}

(******************************************************************************
*                                 reallocXMB                                  *
******************************************************************************)
function reallocXMB;
var
   reallocGranted : boolean;
begin
   asm
      mov ah, $f
      mov bx, newSizeInK
      mov dx, handle
      call [xmsAddress]
      mov reallocGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   reallocXMB := reallocGranted;
end; {reallocXMB}

(******************************************************************************
*                                 requestUMB                                  *
******************************************************************************)
function requestUMB;
var
   requestGranted : boolean;
   ourSOUMB, ourSAOA : word;
begin
   asm
      mov ah, $10
      mov dx, sizeInParagraphs
      call [xmsAddress]
      mov requestGranted, al
      mov ourSOUMB, bx
      mov ourSAOA, dx
      mov xmsErrorCode, bl
   end; { asm }
   requestUMB := requestGranted;
   segmentOfUMB := ourSOUMB;
   sizeAllocatedOrAvailable := ourSAOA;
end; {requestUMB}

(******************************************************************************
*                                 releaseUMB                                  *
******************************************************************************)
function releaseUMB;
var
   releaseGranted : boolean;
begin
   asm
      mov ah, $11
      mov dx, segmentOfUMB
      call [xmsAddress]
      mov releaseGranted, al
      mov xmsErrorCode, bl
   end; { asm }
   releaseUMB := releaseGranted;
end; {releaseUMB}

(******************************************************************************
*                                 xmsErrorStr                                 *
******************************************************************************)
function xmsErrorStr;
var
   i, errorFound : byte;
begin
   errorFound := 0;
   for i := 1 to maxXMSErrors do
      if (xmsErrorCode = xmsErrorArray[i].errorNumber) then
         errorFound := i;
   if (errorFound = 0) then
      xmsErrorStr := 'Unknown XMS error'
   else
      xmsErrorStr := xmsErrorArray[errorFound].errorMessage;
end; {xmsErrorStr}

(******************************************************************************
*                                    MAIN                                     *
******************************************************************************)
begin
   detectXMS;
   if (xmsPresent) then begin
      setXMSHandlerAddress;
      getXMSVersionNumber;
   end;
end.