home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
EXTEND5.ZIP
/
SHRINK.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1990-10-19
|
5KB
|
130 lines
unit Shrink;
{ This unit allows you to allocate memory from the DOS memory pool rather than
from the Turbo Pascal heap. It also provides a procedure for shrinking the
current program to free up DOS memory.
Scott Bussinger
Professional Practice Systems
110 South 131st Street
Tacoma, WA 98444
(206)531-8944
Compuserve [72247,2671] }
{ ** Revision History **
1 SHRINK.PAS 15-Sep-89,`SCOTT' Initial version of SHRINK unit
2 SHRINK.PAS 19-Oct-90,`SCOTT'
Added support for Turbo Pascal 6's new heap manager
** Revision History ** }
interface
procedure DosNew(var P: pointer;
Bytes: word);
{ Get a pointer to a chunk of memory from DOS. Returns NIL if
sufficient DOS memory is not available. }
procedure DosDispose(var P: pointer);
{ Return an allocated chunk of memory to DOS. Only call this function
with pointers allocated with DosNew or DosNewShrink. }
procedure DosNewShrink(var P: pointer;
Bytes: word);
{ Get a pointer to a chunk of memory from DOS, shrinking current program
to gain DOS memory if necessary. Returns NIL if sufficient DOS memory
is not available and there is insufficient free space in the heap to
allow program to be shrunk to accomodate the request. }
implementation
uses Dos;
const DosOverhead = 1; { Extra number of paragraphs that DOS requires in overhead for MCB chain }
function Linear(P: pointer): longint;
{ Return the pointer as a linear longint value }
begin
Linear := (longint(seg(P^)) shl 4) + ofs(P^)
end;
procedure DosNew(var P: pointer;
Bytes: word);
{ Get a pointer to a chunk of memory from DOS. Returns NIL if
sufficient DOS memory is not available. }
var SegsToAllocate: word;
Regs: Registers;
begin
SegsToAllocate := (Bytes+15) shr 4; { DOS allocates memory in paragraph sized pieces only }
with Regs do
begin
AH := $48;
BX := SegsToAllocate;
MsDos(Regs);
if odd(Flags)
then
P := nil { No memory available }
else
P := ptr(AX,$0000) { Return pointer to memory block }
end
end;
procedure DosDispose(var P: pointer);
{ Return an allocated chunk of memory to DOS. Only call this function
with pointers allocated with DosNew or DosNewShrink. }
var Regs: Registers;
begin
with Regs do
begin
AH := $49;
ES := seg(P^);
MsDos(Regs)
end
end;
procedure DosNewShrink(var P: pointer;
Bytes: word);
{ Get a pointer to a chunk of memory from DOS, shrinking current program
to gain DOS memory if necessary. Returns NIL if sufficient DOS memory
is not available and there is insufficient free space in the heap to
allow program to be shrunk to accomodate the request. }
var BytesToAllocate: word;
Regs: Registers;
begin
BytesToAllocate := (((Bytes+15) shr 4) + DosOverhead) shl 4;
DosNew(P,Bytes); { Try to get memory the easy way first }
{$IFDEF VER60} { Check for Turbo 6's new heap manager }
if (P=nil) and (Linear(HeapEnd)-Linear(HeapPtr)>=BytesToAllocate) then
begin { The easy method didn't work but there is sufficient space in the heap }
dec(longint(HeapEnd),longint(BytesToAllocate) shl 12); { Move the top of the heap down }
with Regs do
begin
AH := $4A;
BX := seg(HeapEnd^) - prefixseg - (BytesToAllocate shr 4);
ES := prefixseg;
MsDos(Regs)
end;
DosNew(P,Bytes) { Try the DOS allocation one more time }
end
{$ELSE}
if (P=nil) and { Handle the old free list style heap }
(((ofs(FreePtr^)=0) and (Linear(FreePtr)+$10000-Linear(HeapPtr)>=BytesToAllocate)) or
((ofs(FreePtr^)<>0) and (Linear(FreePtr)-Linear(HeapPtr)>=BytesToAllocate))) then
begin { The easy method didn't work but there is sufficient space in the heap }
OldFreePtr := FreePtr;
dec(longint(FreePtr),longint(BytesToAllocate) shl 12); { Decrement the segment of the pointer to the free list }
if ofs(OldFreePtr^) <> 0 then { If free list is empty, then there's nothing to move }
move(OldFreePtr^,FreePtr^,$10000-ofs(OldFreePtr^)); { Otherwise, move the free list down in memory }
with Regs do
begin
AH := $4A;
BX := seg(OldFreePtr^) + $1000 - prefixseg - (BytesToAllocate shr 4);
ES := prefixseg;
MsDos(Regs)
end;
DosNew(P,Bytes) { Try the DOS allocation one more time }
end
{$ENDIF}
end;
end.