File Archive

 
Output of file : MEMALLOC.PAS contained in archive : ITP9012.ZIP

{$F+,N-,O-,R- -- far calls,no 8087,no overlays,no range checks}
UNIT MemAlloc;
{
MemAlloc.tpu RKB 89/06/20.

This unit incorporates library routines for memory
allocation independent of Turbo's heap.

Copyright (C) 1989-1990 Robert K. Blaine/ECONO-SOFT.
All rights reserved.
Permission is hereby granted to freely use these routines
as long as this copyright remains intact.
}
{========================} INTERFACE {========================}

TYPE
DLListRec = RECORD {Doubly linked list}
Head: Pointer; {Head of the list}
Last: Pointer; {Last item in list}
Circular: Boolean; {true iff list is Circular}
END;
MemRecP = ^MemRec;
MemRec = RECORD {Element of linked list}
Prev: MemRecP; {Previous item or NIL}
Next: MemRecP; {Next item or NIL}
Size: Word; {Size of this item}
END;

CONST
{GetMem will expand the main DOS block by the following
amount (in paragraphs) when memory is not available.}

DOSAllocIncrement: Word = 0;

{Pointers to our replacement Heap}

Heap: DLListRec = (
Head: NIL;
Last: NIL;
Circular: FALSE);

{Top of process memory in the Program Segment Prefex}

PSP_TopOfMemory = $02;

FUNCTION DiffPtr (P1, P2: Pointer): Longint;
FUNCTION Long2Ptr (L: Longint): Pointer;
FUNCTION Normalize (P: Pointer): Pointer;
FUNCTION Ptr2Long (P: Pointer): Longint;

FUNCTION GetMem (VAR Pt: Pointer; Size: Word): Boolean;
PROCEDURE FreeMem (VAR Pt: Pointer; Size: Word);
FUNCTION MaxAvail: Longint;
FUNCTION MemAvail: Longint;

PROCEDURE Link (Pt: Pointer; At: Pointer; VAR DL: DLListRec);
PROCEDURE DeLink (Pt: Pointer; VAR DL: DLListRec);

{dummy routines not implemented}

PROCEDURE New (VAR P: Pointer);
PROCEDURE Dispose (VAR P: Pointer);
PROCEDURE Mark (VAR P: Pointer);
PROCEDURE Release (VAR P: Pointer);

{=====================} IMPLEMENTATION {======================}

USES Dos;

FUNCTION DiffPtr (P1, P2: Pointer): Longint;
{
Return the number of bytes between the two addresses.

entry conditions:
passed : P1, P2 = the two pointers.

exit conditions:
return : number of bytes between the two pointers.
}
BEGIN {DiffPtr}
DiffPtr := Abs (Ptr2Long (P1) - Ptr2Long (P2));
END; {DiffPtr}

FUNCTION Long2Ptr (L: Longint): Pointer;
{
Convert a 32-bit long integer to a segment:offset pointer.

entry conditions:
passed : L = the long integer address.

exit conditions:
return : the address in segment:offset format.
}
BEGIN {Long2Ptr}
Long2Ptr := Pointer (((L AND $FFFF0) SHL 12) OR (L AND $F));
END; {Long2Ptr}

FUNCTION Normalize (P: Pointer): Pointer;
{
Insure that a pointer is in the proper format. That is,
it's offset portion must be IN the range 0 TO $F (15).

entry conditions:
passed : P = the Pointer IN segment:offset format.

Exit conditions:
return : the normalized Pointer.
}
BEGIN {Normalize}
Normalize := Long2Ptr (Ptr2Long (P));
END; {Normalize}

FUNCTION Ptr2Long (P: Pointer): Longint;
{
Convert a segment:offset pointer to a 32-bit address.

entry conditions:
passed : P = the pointer in segment:offset format.

exit conditions:
return : the 32-bit integer address.
}
BEGIN {Ptr2Long}
Ptr2Long := Longint (Seg (Pointer (P)^)) SHL 4 +
Longint (ofs (Pointer (P)^));
END; {Ptr2Long}

FUNCTION GetMem (VAR Pt: Pointer; Size: Word): Boolean;
{
GetMem replaces Turbo's GetMem procedure with a more flexible
heap manager. Memory can be allocated anywhere in the 1MB
address space of the 808x.

entry conditions:
passed : Size = the size, in bytes, of the requested block.

exit conditions:
passed : Pt = a pointer to the returned block.
Pt = NIL if memory is not available.
return : true iff the request was satisfied.
}
VAR
BestFit, T: MemRecP;
P: MemRecP ABSOLUTE Pt;
Regs: Registers;
TopOfSeg, NewTop, ParasReq: Word;

BEGIN {GetMem}
GetMem := TRUE; {assume success}

IF Size < SizeOf (MemRec) THEN {minimum size of a block}
Size := SizeOf (MemRec);

T := Heap.Head;
BestFit := NIL;

{Traverse the heap looking for the BestFit}
WHILE T <> NIL DO
BEGIN
{cannot fragment smaller than the header}
IF (Longint (T^.Size) - Longint (Size) > SizeOf (MemRec)) OR
(T^.Size = Size) THEN
IF (BestFit = NIL) OR (T^.Size < BestFit^.Size) THEN
BestFit := T;
T := T^.Next;
END;

{If no block was found, maybe we can expand DOS memory}
IF (BestFit = NIL) AND (DOSAllocIncrement <> 0) THEN
BEGIN
TopOfSeg := memw [PrefixSeg : PSP_TopOfMemory];
ParasReq := (Size + 15) SHR 4; {requested size in paragraphs}
IF DOSAllocIncrement > ParasReq THEN
ParasReq := DOSAllocIncrement; {minimum request Size}
NewTop := TopOfSeg + ParasReq;

Regs.AH := $4A {DOS ReSizeMemoryBlock request};
Regs.BX := NewTop - PrefixSeg;
Regs.ES := PrefixSeg;
msdos (Regs);

{if the expansion worked, FreeMem it}
IF Regs.Flags AND FCarry = 0 THEN
BEGIN
memw [PrefixSeg : PSP_TopOfMemory] := NewTop;
T := ptr (TopOfSeg, 0);
BestFit := T; {keep track of this block}
FreeMem (Pointer (T), ParasReq SHL 4);
END;
END;

IF BestFit = NIL THEN {memory not available}
BEGIN
GetMem := FALSE;
P := NIL;
END
ELSE IF BestFit^.Size = Size THEN {exact fit}
BEGIN
P := BestFit;
DeLink (BestFit, Heap); {return the entire block}
END
ELSE {split the block; returning the tail END}
BEGIN
Dec (BestFit^.Size, Size);
P := Long2Ptr (Ptr2Long (BestFit) + BestFit^.Size);
END;
END; {GetMem}

PROCEDURE FreeMem (VAR Pt: Pointer; Size: Word);
{
FreeMem replaces Turbo's FreeMem PROCEDURE WITH a more
flexible Heap manager. Any memory can be released TO the
Heap including EMS, Dos, AND non-standard memory.

entry conditions:
passed : Pt = a Pointer TO the block TO be released.
Size = the Size, IN bytes, OF the block.

Exit conditions:
passed : Pt = Set TO NIL.
}
VAR
P: MemRecP ABSOLUTE Pt;
T0, T1: MemRecP;

BEGIN {FreeMem}
{pointer NIL, exit; should probably generate an error}
IF P = NIL THEN
Exit;

IF Size < SizeOf (MemRec) THEN {minimum size of a block}
Size := SizeOf (MemRec);
P^.Size := Size;

{find the adjacent blocks, if Any}
T1 := Heap.Head; T0 := NIL;
WHILE (T1 <> NIL) AND (Ptr2Long (T1) < Ptr2Long (Pt)) DO
BEGIN
T0 := T1; T1 := T1^.Next;
END;

IF (T0 <> NIL) AND (DiffPtr (T0, Pt) = T0^.Size) THEN
BEGIN {if adjacent to previous block}
P := T0;
Inc (P^.Size, Size); {size of both}
END
ELSE {otherwise link it before the next block}
Link (Pt, T1, Heap);

{check if it is adjacent to the next block}
IF (T1 <> NIL) AND (DiffPtr (P, T1) = P^.Size) THEN
BEGIN
Inc (P^.Size, T1^.Size); {size of both}
P^.Next := T1^.Next; {fix up all pointers}
IF T1^.Next <> NIL THEN
T1^.Next^.Prev := P;
IF Heap.Head = T1 THEN
Heap.Head := P;
IF Heap.Last = T1 THEN
Heap.Last := P;
END;

{once the block has been freed, it should not be referenced}
P := NIL;
END; {FreeMem}

FUNCTION MaxAvail: Longint;
{
Replaces Turbo's MaxAvail function. Returns the size of the
largest contiguous block of memory on the heap.

entry conditions:
none.

exit conditions:
return : size of the largest block of memory available.
}
VAR
Largest: Longint;
T: MemRecP;

BEGIN {MaxAvail}
Largest := 0;
T := Heap.Head;
WHILE T <> NIL DO
BEGIN
IF T^.Size > Largest THEN
Largest := T^.Size;
T := T^.Next;
END;
MaxAvail := Largest;
END; {MaxAvail}

FUNCTION MemAvail: Longint;
{
Replaces Turbo's MemAvail FUNCTION. Returns the sum OF the
sizes OF all blocks OF memory on the Heap.

entry conditions:
none.

Exit conditions:
return : sum OF all blocks OF memory available.
}
VAR
sum: Longint;
T: MemRecP;

BEGIN {MemAvail}
sum := 0;
T := Heap.Head;
WHILE T <> NIL DO
BEGIN
Inc (sum, T^.Size);
T := T^.Next;
END;
MemAvail := sum;
END; {MemAvail}

PROCEDURE Link (Pt: Pointer; At: Pointer; VAR DL: DLListRec);
{
The Link procedure is a general purpose procedure for linking
a node into a doubly-linked list.

entry conditions:
passed : Pt = pointer to the node to link into the list.
At = location to link "at". The node is linked
before this location or at the end of the
list if "At" is NIL.
DL = the doubly-linked list structure.

exit conditions:
none.
}
VAR
P: MemRecP ABSOLUTE Pt;
a: MemRecP ABSOLUTE At;
T: MemRecP;

BEGIN {Link}
IF P <> NIL THEN
WITH DL DO
BEGIN
{if list is empty, create a one-item list}

IF Head = NIL THEN
BEGIN
Head := P; Last := P;
IF Circular THEN
BEGIN
P^.Next := P; P^.Prev := P;
END
ELSE
BEGIN
P^.Next := NIL; P^.Prev := NIL;
END;
END {if Head=NIL}

{if location is not specified and the list is not
circular, we'll add the node to the END}

ELSE IF (a = NIL) AND (NOT Circular) THEN
BEGIN
IF Last <> NIL THEN {may be a short cut to finding END}
a := Last
ELSE
a := Head;

{find the end of the list}
WHILE a^.Next <> NIL DO
a := a^.Next;

{link the node to the END}
a^.Next := P; P^.Prev := a; P^.Next := NIL;
END

{insert in established list (before "At") or
at the end of a circular list}

ELSE
BEGIN
IF (a = NIL) AND Circular THEN {adding at END}
T := MemRecP (Head)
ELSE
T := a;
IF T^.Prev <> NIL THEN
T^.Prev^.Next := P;

{link the node}
P^.Prev := T^.Prev; T^.Prev := P; P^.Next := T;

{if adding before Head, make this the new Head}
IF a = Head THEN
Head := P;
END; {Insert}
END; {WITH}
END; {Link}

PROCEDURE DeLink (Pt: Pointer; VAR DL: DLListRec);
{
The DeLink procedure is a general purpose procedure for
removing a node from a doubly-linked list.

entry conditions:
passed : Pt = pointer to the node to remove from the list.
DL = the doubly-linked list structure.

exit conditions:
none.
}
VAR
P: MemRecP ABSOLUTE Pt;

BEGIN {DeLink}
IF P <> NIL THEN
WITH DL DO
BEGIN
IF P = P^.Next THEN {only item on list}
BEGIN
Head := NIL;
Last := NIL;
END
ELSE
BEGIN
IF P = Head THEN
Head := P^.Next;
IF P = Last THEN
Last := P^.Next;
IF P^.Prev <> NIL THEN
P^.Prev^.Next := P^.Next;
IF P^.Next <> NIL THEN
P^.Next^.Prev := P^.Prev;
END;
END; {WITH}
END; {DeLink}

{
The following routines are not implemented. If called, they
will halt the program.
}
PROCEDURE New (VAR P: Pointer);
BEGIN Halt (1); END;

PROCEDURE Dispose (VAR P: Pointer);
BEGIN Halt (1); END;

PROCEDURE Mark (VAR P: Pointer);
BEGIN Halt (1); END;

PROCEDURE Release (VAR P: Pointer);
BEGIN Halt (1); END;

{======================= initialization ======================}

END. {MemAlloc UNIT}