home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Hack-Phreak Scene Programs
/
cleanhpvac.zip
/
cleanhpvac
/
ASMCODE.ZIP
/
GUSHEAP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-11-02
|
17KB
|
501 lines
{ ────────────────────────────────────────────────────────────────────────
This code is Copyright (c) 1994 by Jonathan E. Wright and AmoebaSoft.
To communicate with the author, send internet mail to: NELNO@DELPHI.COM
About this code:
This code was converted on the fly from my EMM heap manager and
bacically adapted to manage GUS memory. It's probably not too
efficient and my contain a bug or two, but I haven't found it yet.
If you use this code in any of your programs, or as a basis for anything
else you may write, please give credit to Nelno the Amoeba. A postcard
from your country or town would also be nice. Send it to:
Nelno
58 1/2 Woodland Rd.
Asheville, NC 28804-3823
USA
──────────────────────────────────────────────────────────────────────── }
Unit GUSHeap;
Interface
USES
Types;
CONST
GUS_BankSize = 262144;
GUS_ErrorCode : INTEGER = 0;
GUS_MemAvail : LONGINT = 0;
TYPE
GUS_Ptr = RECORD
GPtr : LONGINT; { location from start of GUS memory }
OfsPtr : LONGINT; { offset from start of bank }
Bank : BYTE;
BlockSize : LONGINT;
END;
PROCEDURE GUS_GetMem (VAR GUS_Block : GUS_Ptr; Size : LONGINT);
PROCEDURE GUS_FreeMem (GUS_Block : GUS_Ptr);
PROCEDURE GUS_InitHeap (MemSize : WORD);
PROCEDURE GUS_DestroyHeap;
FUNCTION GUS_MaxAvail : LONGINT;
Implementation
CONST
MaxFreeBlocks = 1024;
GUS_HeapInitialized : BOOLEAN = FALSE;
TYPE
FreeListPtr = ^FreeListArray;
FreeListType = RECORD
Bank : BYTE;
GPtr : LONGINT; { Block location from start of GUS bank }
BlockSize : LONGINT;
END;
FreeListArray = ARRAY [1..MaxFreeBlocks] OF FreeListType;
VAR
BankPtr : WORD; (* current bank where next allocation is being done *)
OffsPtr : LONGINT; (* Offset in current page where next allocation will *)
(* be performed *)
FreeBanks : WORD;
TotalBanks : WORD;
GUS_FreeList : FreeListPtr;
FreeBlocks : WORD;
SavedExit : POINTER;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ PROCEDURE NewExit; FAR; ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE NewExit; FAR;
BEGIN
ExitProc := SavedExit;
IF DebugKeys THEN Print ('Deallocated GUS Heap.', $0F);
GUS_DestroyHeap;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Sets all entries in the freelist to 0 ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_InitFreeList;
VAR
Count : INTEGER;
BEGIN
FOR Count := 1 to MaxFreeBlocks DO
BEGIN
GUS_FreeList^ [Count].Bank := 0;
GUS_FreeList^ [Count].GPtr := 0;
GUS_FreeList^ [Count].BlockSize := 0;
END;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Searches the GUS_FreeList array for any blocks that are greater than ║
║ or equal to RequiredSize. Returns the element of GUS_FreeList where ║
║ the block is described, or returns 0 if no block was found ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
FUNCTION GUS_SearchFreeList (RequiredSize : LONGINT) : WORD;
VAR
Count : INTEGER;
FoundAt : WORD;
BEGIN
FoundAt := 0;
Count := 0;
IF FreeBlocks > 0 THEN
BEGIN
REPEAT
INC (Count);
IF GUS_FreeList^ [Count].BlockSize >= RequiredSize THEN
FoundAt := Count;
UNTIL (Count >= FreeBlocks) or (FoundAt > 0);
END;
GUS_SearchFreeList := FoundAt;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Adjusts freelist entry n to reflect usage of block of size Size. ║
║ If entire block is used, entry is removed from free list, all entries ║
║ above it are moved down one to fill gap, and FreeBlocks is decremented║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_AdjustFreeList (n : WORD; Size : LONGINT);
VAR
Count : INTEGER;
BEGIN
IF (Size = GUS_FreeList^ [n].BlockSize) AND (Size <> GUS_BankSize) THEN
BEGIN
IF FreeBlocks > 1 THEN
BEGIN
FOR Count := n + 1 to FreeBlocks DO
GUS_FreeList^ [Count - 1] := GUS_FreeList^ [Count];
END;
GUS_FreeList^ [FreeBlocks].BlockSize := 0;
GUS_FreeList^ [FreeBlocks].GPtr := 0;
GUS_FreeList^ [FreeBlocks].Bank := 0;
DEC (FreeBlocks);
END
ELSE
BEGIN
GUS_FreeList^ [n].GPtr := GUS_FreeList^ [n].GPtr + Size;
GUS_FreeList^ [n].BlockSize := GUS_FreeList^ [n].BlockSize - Size;
END;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ searches the freelist and combines free spaces contiguous to free ║
║ block n ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_CombineFreeList (n : WORD);
VAR
I : INTEGER;
BEGIN
I := 1;
REPEAT
IF (GUS_FreeList^ [I].Bank = GUS_FreeList^ [n].Bank) AND (n <> I) THEN
BEGIN
IF GUS_FreeList^ [I].GPtr + GUS_FreeList^ [I].BlockSize = GUS_FreeList^ [n].GPtr THEN
BEGIN
(* Make free list entry's size bigger to encompass the new *)
(* free block at the end of it *)
GUS_FreeList^ [n].BlockSize := GUS_FreeList^ [n].BlockSize + GUS_FreeList^ [I].BlockSize;
GUS_FreeList^ [n].GPtr := GUS_FreeList^ [I].GPtr;
Writeln ('I = ', I);
GUS_AdjustFreeList (I, GUS_FreeList^ [I].BlockSize);
END
ELSE IF GUS_FreeList^ [I].GPtr = GUS_FreeList^ [n].GPtr + GUS_FreeList^ [n].BlockSize THEN
BEGIN
(* Make free list entry's offset equal to the new offset and *)
(* increase it's size to contain both free blocks *)
GUS_FreeList^ [n].BlockSize := GUS_FreeList^ [I].BlockSize + GUS_FreeList^ [n].BlockSize;
GUS_AdjustFreeList (I, GUS_FreeList^ [I].BlockSize);
END;
END;
INC (I);
UNTIL (I > FreeBlocks);
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Adds a free block to the end of the free list, as long as that block ║
║ doesn't start at the end of another free list entry, in which case ║
║ the first free list entry's size is enlarged by the size of the new ║
║ free block. ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_AddToFreeList (Page : WORD; Offset, Size : LONGINT);
VAR
I : INTEGER;
ListUpdated : BOOLEAN;
BEGIN
IF FreeBlocks < MaxFreeBlocks THEN
BEGIN
I := 1;
ListUpdated := FALSE;
REPEAT
IF GUS_FreeList^ [I].Bank = Page THEN
BEGIN
IF GUS_FreeList^ [I].GPtr + GUS_FreeList^ [I].BlockSize = Offset THEN
BEGIN
(* Make free list entry's size bigger to encompass the new *)
(* free block at the end of it *)
GUS_FreeList^ [I].BlockSize := GUS_FreeList^ [I].BlockSize + Size;
ListUpdated := TRUE;
GUS_CombineFreeList (I);
END
ELSE IF GUS_FreeList^ [I].GPtr = Offset + Size THEN
BEGIN
(* Make free list entry's offset equal to the new offset and *)
(* increase it's size to contain both free blocks *)
GUS_FreeList^ [I].BlockSize := GUS_FreeList^ [I].BlockSize + Size;
GUS_FreeList^ [I].GPtr := Offset;
ListUpdated := TRUE;
GUS_CombineFreeList (I);
END;
END;
INC (I);
UNTIL (I > FreeBlocks) OR (ListUpdated);
IF NOT (ListUpdated) THEN
BEGIN
INC (FreeBlocks);
GUS_FreeList^ [FreeBlocks].Bank := Page;
GUS_FreeList^ [FreeBlocks].GPtr := Offset;
GUS_FreeList^ [FreeBlocks].BlockSize := Size;
END;
END
ELSE ErrorHandler (251, 24);
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Allocates a block of free memory from the current GUS_ handle ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_GetMem (VAR GUS_Block : GUS_Ptr; Size : LONGINT);
VAR
PageToAllocate : WORD;
OffsToAllocate : WORD;
FreeListElement : WORD;
BEGIN
GUS_Block.BlockSize := Size;
IF GUS_Block.BlockSize <= GUS_BankSize THEN
BEGIN
{ search the free list for a block that is >= requested size }
FreeListElement := GUS_SearchFreeList (GUS_Block.BlockSize);
IF FreeListElement > 0 THEN
BEGIN
GUS_Block.Bank := GUS_FreeList^ [FreeListElement].Bank;
GUS_Block.OfsPtr := GUS_FreeList^ [FreeListElement].GPtr;
GUS_Block.GPtr := BankPtr * GUS_BankSize + GUS_Block.OfsPtr;
GUS_AdjustFreeList (FreeListElement, GUS_Block.BlockSize);
GUS_MemAvail := GUS_MemAvail - Size;
END
ELSE
BEGIN
{ check if block allocation will extend past current page. if
so: add the unusable area to the free list, increment to
next page, and set OffsPtr to 0 }
IF OffsPtr + GUS_Block.BlockSize > GUS_BankSize THEN
BEGIN
GUS_AddToFreeList (BankPtr, OffsPtr, GUS_BankSize - OffsPtr);
{ GUS_MemAvail := GUS_MemAvail + GUS_BankSize - OffsPtr;}
INC (BankPtr);
OffsPtr := 0;
{ check for heap overflow }
IF BankPtr >= TotalBanks THEN ErrorHandler (251, 18);
END;
{ if no overflow, then set GUS_Block's values to }
IF GUS_ErrorCode = 0 THEN
BEGIN
GUS_Block.Bank:= BankPtr;
GUS_Block.OfsPtr := OffsPtr;
GUS_Block.GPtr := BankPtr * GUS_BankSize + GUS_Block.OfsPtr;
GUS_MemAvail := GUS_MemAvail - Size;
INC (OffsPtr, GUS_Block.BlockSize);
IF OffsPtr >= GUS_BankSize THEN
BEGIN
INC (BankPtr);
OffsPtr := 0;
IF BankPtr >= TotalBanks THEN ErrorHandler (251, 24);
END;
END
ELSE
ErrorHandler (251, GUS_ErrorCode);
END;
END
ELSE ErrorHandler (251, 23);
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Frees a previously allocated block and places its location in the ║
║ free list if it is not at the top of the heap, in which case the ║
║ top of heap pointers (BankPtr and OffsPtr) are adjusted down. ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_FreeMem (GUS_Block : GUS_Ptr);
BEGIN
IF ((BankPtr = GUS_Block.Bank) AND (GUS_Block.OfsPtr + GUS_Block.BlockSize = OffsPtr)) THEN
BEGIN
{ block was the last one allocated from current page }
OffsPtr := GUS_Block.OfsPtr;
GUS_MemAvail := GUS_MemAvail + GUS_Block.BlockSize;
END
ELSE IF (BankPtr = GUS_Block.Bank + 1) AND (GUS_Block.OfsPtr + GUS_Block.BlockSize = GUS_BankSize) THEN
BEGIN
OffsPtr := GUS_Block.OfsPtr;
BankPtr := GUS_Block.Bank;
GUS_MemAvail := GUS_MemAvail + GUS_Block.BlockSize;
END
ELSE
BEGIN
IF GUS_Block.BlockSize = 0 THEN
ErrorHandler (251, 252)
ELSE
BEGIN
GUS_AddToFreeList (GUS_Block.Bank, GUS_Block.OfsPtr, GUS_Block.BlockSize);
GUS_MemAvail := GUS_MemAvail + GUS_Block.BlockSize;
END;
END;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Initializes GUS heap variables ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_InitHeap (MemSize : WORD);
VAR
MemAllocated : LONGINT;
BEGIN
FreeBlocks := 0;
BankPtr := 0;
OffsPtr := 0;
GUS_ErrorCode := 0;
GUS_MemAvail := LONGINT (MemSize) * 1024;
TotalBanks := MemSize DIV 256;
FreeBanks := TotalBanks;
PRINT (ST (MemSize) + 'K UltraSound memory available.', 15);
NEW (GUS_FreeList);
GUS_HeapInitialized := TRUE;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Disables all GUS_ heap functions and returns all Turbo heap memory ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_DestroyHeap;
BEGIN
IF GUS_HeapInitialized = TRUE THEN
BEGIN
DISPOSE (GUS_FreeList);
GUS_HeapInitialized := FALSE;
END;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
FUNCTION GUS_GetError : BYTE;
BEGIN
GUS_GetError := GUS_ErrorCode;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Returns the amount of Expanded memory left in the heap ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
FUNCTION GUS_MaxAvail : LONGINT;
VAR
Count : INTEGER;
Memory : LONGINT;
BEGIN
IF BankPtr < 4 THEN
GUS_MaxAvail := GUS_BankSize
ELSE
BEGIN
Memory := 0;
FOR Count := 1 to FreeBlocks DO
IF GUS_FreeList^ [Count].BlockSize > Memory THEN
Memory := GUS_FreeList^ [Count].BlockSize;
GUS_MaxAvail := Memory;
END;
END;
{ ╔═══════════════════════════════════════════════════════════════════════╗
║ ║
║ Returns the GUS_ heap to its original state, freeing all memory ║
║ Use with caution! ║
║ ║
╚═══════════════════════════════════════════════════════════════════════╝ }
PROCEDURE GUS_ReleaseHeap;
BEGIN
GUS_InitFreeList;
BankPtr := 0;
OffsPtr := 0;
FreeBlocks := 0;
END;
BEGIN
SavedExit := ExitProc;
ExitProc := @NewExit;
END.