unit memunit;
interface
uses dos,modtypes;
type
Bit32Struct = LongInt;
ExtMemMoveStruct =
Record
Length : Bit32Struct;
SourceHandle : Word;
SourceOffset : Bit32Struct;
DestHandle : Word;
DestOffset : Bit32Struct
End;
const
isXMS : Boolean = false;
Var
XMSResult : Word;
XMSError : Byte;
XMM_Control : Array[0..1] of Word;
xmsinfo : record
buf : pointer;
bufsize : integer; {size of buf}
curptn : integer;
handle : word;
size : word; {kbytes}
end;
movestruct : extmemmovestruct;
Function EXISTXMS : Boolean;
function xmsmaxavail : word;
Function AllocXMSBlock(malloc : Word) : Word;
Procedure FreeXMSBlock(handle : Word);
Procedure MoveXMSBlock(Var MoveStructure : ExtMemMoveStruct);
function initxms : integer; {0 if ok}
procedure donexms;
implementation
const
xmssize = 400;
var
patterns : array[0..128] of longint;
{$s-}
Function EXISTXMS : Boolean;
Var
_al : byte;
_bx,_es : word;
Begin
asm
mov ax,4300h
int 2fh
mov _al,al
end;
If _al = $80 Then
Begin
asm
mov ax,4310h
int 2fh
mov _bx,bx
mov _es,es
end;
XMM_Control[0] := _bx;
XMM_Control[1] := _es;
EXISTXMS := TRUE
End
Else
EXISTXMS := FALSE
End;
function XMSMaxAvail : word;
(* XMSResult = largest free block of Extended Memory in kilobytes *)
Var
dx : Word;
Begin
XMSResult := 1;
XMSError := 0;
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;
XMSMaxAvail := dx;
End;
Function AllocXMSBlock(malloc : Word) : Word;
(* If successful, returns handle to Extended Memory Block *)
Var
ax : Word;
dx : Word;
bl : Byte;
Begin
XMSResult := 1;
XMSError := 0;
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;
AllocXMSBlock := dx
End;
Procedure FreeXMSBlock(handle : Word);
Var
ax : Word;
bl : Byte;
Begin
XMSResult := 1;
XMSError := 0;
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;
Procedure MoveXMSBlock(Var MoveStructure : ExtMemMoveStruct);
(* NOTE: This procedure assumes that the ExtMemMove structure is valid *)
(* Changed 10/06/89: Needed to force ES: override for XMM Call *)
Var
ax,
segs,
ofss : Word;
bl : Byte;
Begin
XMSResult := 1;
XMSError := 0;
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;
{$s-}
{$f+}
procedure xms_virt_alloc(numptn,ptnsize : integer);
var
n : integer;
begin
for n := 0 to 128 do patterns[n] := -1;
virt_info.numptn := numptn;
virt_info.ptnsize := ptnsize;
virt_info.err_cptn := -1;
virt_info.err_wptn := -1;
virt_info.err_nptn := -1;
xmsinfo.curptn := -1;
end;
procedure xms_virt_free;
var
n : integer;
begin
for n := 0 to 128 do if patterns[n] <> -1 then begin
patterns[n] := -1;
end;
end;
procedure xms_virt_allocptn(ptn : integer);
begin
patterns[ptn] := longint(ptn)*longint(virt_info.ptnsize);
end;
procedure xms_virt_loadptn(ptn : integer;p : pointer);
begin
with movestruct do begin
length := virt_info.ptnsize;
sourcehandle := 0;
sourceoffset := longint(p);
desthandle := xmsinfo.handle;
destoffset := patterns[ptn];
end;
movexmsblock(movestruct);
end;
procedure xms_virt_freeptn(ptn : integer);
begin
patterns[ptn] := -1;
end;
function xms_virt_getptn(ptn : integer) : pointer;
begin
xms_virt_getptn := xmsinfo.buf;
end;
procedure xms_virt_warnptn(ptn : integer);
begin
virt_info.warnedptn := ptn;
if xmsinfo.curptn <> ptn then begin
with movestruct do begin
length := virt_info.ptnsize;
sourcehandle := xmsinfo.handle;
sourceoffset := patterns[ptn];
desthandle := 0;
destoffset := longint(xmsinfo.buf);
end;
movexmsblock(movestruct);
xmsinfo.curptn := ptn;
end;
end;
procedure xms_virt_needptn(ptn : integer);
begin
if ptn <> virt_info.warnedptn then begin
virt_info.err_cptn := -1;
virt_info.err_wptn := virt_info.warnedptn;
virt_info.err_nptn := ptn;
end;
if xmsinfo.curptn <> ptn then begin
with movestruct do begin
length := virt_info.ptnsize;
sourcehandle := xmsinfo.handle;
sourceoffset := patterns[ptn];
desthandle := 0;
destoffset := longint(xmsinfo.buf)
{asm
mov ax,word ptr xmsinfo.buf
mov word ptr destoffset,ax
mov ax,word ptr xmsinfo.buf+2
mov word ptr destoffset+2,ax
end;}
end;
movexmsblock(movestruct);
xmsinfo.curptn := ptn;
end;
end;
procedure xms_virt_noneedptn(ptn : integer);
begin
end;
{$f-}
function initxms : integer;
var
n : integer;
begin
fillchar(xmsinfo,sizeof(xmsinfo),0);
if not existxms then begin
initxms := 1;
exit;
end;
if xmsmaxavail < xmssize then begin
initxms := 2;
exit;
end;
for n := 0 to 128 do patterns[n] := -1;
xmsinfo.handle := allocxmsblock(xmssize);
if xmsresult <> 1 then begin
initxms := 3;
exit;
end;
xmsinfo.bufsize :=6000;
getmem(xmsinfo.buf,xmsinfo.bufsize);
virt_alloc := xms_virt_alloc;
virt_free := xms_virt_free;
virt_allocptn := xms_virt_allocptn;
virt_loadptn := xms_virt_loadptn;
virt_freeptn := xms_virt_freeptn;
virt_getptn := xms_virt_getptn;
virt_warnptn := xms_virt_warnptn;
virt_needptn := xms_virt_needptn;
virt_noneedptn := xms_virt_noneedptn;
isxms := true;
initxms := 0;
end;
procedure donexms;
begin
freemem(xmsinfo.buf,xmsinfo.bufsize);
freexmsblock(xmsinfo.handle);
end;
end.
