UNIT HEAP7;
{ ******************************************************************* }
{ HEAP7.PAS = Protected Mode Mark/Release!                            }
{                                                                     }
{ This Unit implements a protected mode heap supporting Mark, GetMem, }
{ and Release. NEW can be simulated with GetMem(pVar, Sizeof(pVar^)), }
{ where pVar can be a pointer to an array or record, but of course,   }
{ it *CANNOT* be a pointer to an object!                              }
{                                                                     }
{ A program can simultaniously use the heap provided by this unit and }
{ the SYSTEM heap. Since the SYSTEM supports all forms of NEW/DISPOSE }
{ and GETMEM/FREEMEM, you can take the best from both worlds.         }
{                                                                     }
{ The Heap is initialized by calling HEAP7.Init(Low, High, Reserved), }
{ and released by calling HEAP7.Done.  Init and Done are intellegent  }
{ enough to be called out-of-turn. Calling Init twice w/o calling     }
{ Done will automatically call Done before performing the 2nd Init.   }
{ When Init is called the first time, the links are placed to cause   }
{ Done to be called as part of the stardard exit procedure.           }
{                                                                     }
{ I chose to keep the names GetMem, Mark, Release, MaxAvail, thereby  }
{ making it relatively easy to convert an older program. Should both  }
{ heaps be used within a program, the procedures may be qualified     }
{ using SYSTEM.GetMem and HEAP7.GetMem. Of course you can rename the  }
{ procedures to something else if you prefer...                       }
{                                                                     }
{ Mark, GetMem, and Release are simple, yet even with error checking, }
{ they are capable of destroying the heap at your request. If you     }
{ are really interested in watching the sparks fly you might release  }
{ a pointer that wasn't obtained by HEAP7's Mark/GetMem procedures,   }
{ maybe an uninitialized one, or one obtained from the SYSTEM. Then   }
{ again you could feed the SYSTEM FreeMem or Dispose the 1st pointer  }
{ you obtained from HEAP7's GetMem or Mark. Either way the results    }
{ should be quite interesting <g>.                                    }
{                                                                     }
{ Enjoy.    ...red                                                    }
{                                            Roger Donais [70414,524] }
{ ******************************************************************* }
INTERFACE

PROCEDURE Init(LowerLimit, UpperLimit, Reserve: Longint);
PROCEDURE Done;
FUNCTION  MaxAvail: Longint;
PROCEDURE Mark(VAR P: Pointer);
PROCEDURE Release(VAR p: Pointer);
PROCEDURE GetMem(VAR p: Pointer; Size: Word);

{ ******************************************************************* }
IMPLEMENTATION
USES WinAPI;

TYPE Long = RECORD Lo, Hi: Word; END;
CONST HeapBase: Pointer = NIL;
      HeapTop : Longint = 0;
      HeapSize: Longint = 0;


FUNCTION  MaxAvail: Longint;
{ ------------------------------------------------------------------- }
BEGIN
    MaxAvail := HeapSize - HeapTop;
END;


PROCEDURE Mark(VAR P: Pointer);
{ ------------------------------------------------------------------- }
BEGIN
    {$IFOPT R+}
        If NOT(Assigned(HeapBase)) Then
           RunError(203);
    {$ENDIF}
    p := Ptr(Long(HeapTop).Hi * SelectorInc + Seg(HeapBase^), Long(HeapTop).Lo);
END;


PROCEDURE Release(VAR p: Pointer);
{ ------------------------------------------------------------------- }
BEGIN
    {$IFOPT R+}
        If NOT(Assigned(HeapBase))
        or (Seg(p^) < Seg(HeapBase^))
        or (Seg(p^) > Long(HeapSize).Hi * SelectorInc + Seg(HeapBase^)) Then
           RunError(204);
    {$ENDIF}
    Long(HeapTop).Lo := Ofs(p^);
    Long(HeapTop).Hi := (Seg(p^) - Seg(HeapBase^)) div SelectorInc;
END;


PROCEDURE GetMem(VAR p: Pointer; Size: Word);
{ ------------------------------------------------------------------- }
VAR i: Longint;
BEGIN
    If Long(HeapTop).Hi <> HiWord(HeapTop + Pred(Size)) Then Begin
        Inc(Long(HeapTop).Hi);
        Long(HeapTop).Lo := 0;
    End;
    If HeapTop + Size > HeapSize Then
       RunError(203);

    p := Ptr(Long(HeapTop).Hi * SelectorInc + Seg(HeapBase^), Long(HeapTop).Lo);
    Inc(HeapTop, Size);
END;


CONST TurboExitProc: Pointer = NIL;
PROCEDURE AtExit; FAR;
{ ------------------------------------------------------------------- }
BEGIN
    ExitProc := TurboExitProc;
    TurboExitProc := NIL;         { Set NIL incase recovery occurs... }
    Done;
END;


PROCEDURE Init(LowerLimit, UpperLimit, Reserve: Longint);
{ ------------------------------------------------------------------- }
BEGIN
    Done;
    If NOT Assigned(TurboExitProc) Then Begin
       TurboExitProc := ExitProc;
       ExitProc := @AtExit;
    End;
    HeapSize := (SYSTEM.MaxAvail - Reserve);
    If HeapSize > UpperLimit Then HeapSize := UpperLimit;
    If HeapSize < LowerLimit Then RunError(8);
    HeapBase := GlobalAllocPtr(GMEM_FIXED, HeapSize);
    HeapTop := 0;
END;


PROCEDURE Done;
{ ------------------------------------------------------------------- }
BEGIN
    If Assigned(HeapBase) Then Begin
       GlobalFreePtr(HeapBase);
       HeapBase := NIL;
       HeapTop  := 0;
       HeapSize := 0;
    End;
END;

END.