Sound, Music & MIDI Collection 2/SMMVOL2.bin/PROG/ASMOD09S.ZIP/GUSHEAP.PAS

Pascal/Delphi Source File | 1994-11-02 | 16.4 KB | 501 lines

{ ────────────────────────────────────────────────────────────────────────

  This code is Copyright (c) 1994 by Jonathan E. Wright and AmoebaSoft.

  To communicate with the author, send internet mail to: [e-mail]

  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.