OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ATVSRC.RAR/MEMORY.PAS

Pascal/Delphi Source File | 2000-08-15 | 5KB | 235 lines

{*******************************************************}
{                                                       }
{       Turbo Pascal Version 7.0                        }
{       Turbo Vision Unit                               }
{                                                       }
{       Copyright (c) 1992 Borland International        }
{                                                       }
{       Virtual Pascal v2.1                             }
{       Copyright (C) 1996-2000 vpascal.com             }
{                                                       }
{*******************************************************}

unit Memory;

{$X+,I-,S-,Q-,Use32+}

interface

const
  LowMemSize: Word = 4096 div 16;       {   4K }

procedure InitMemory;
procedure DoneMemory;
procedure InitDosMem;
procedure DoneDosMem;
function LowMemory: Boolean;
function MemAlloc(Size: Word): Pointer;
procedure NewCache(var P: Pointer; Size: Word);
procedure DisposeCache(P: Pointer);
procedure NewBuffer(var P: Pointer; Size: Word);
procedure DisposeBuffer(P: Pointer);
function GetBufferSize(P: Pointer): Word;
function SetBufferSize(P: Pointer; Size: Word): Boolean;

{ The following procedure is not implemented

function MemAllocSeg(Size: Word): Pointer;

}

implementation

type
  PtrRec = record
    Ofs: Longint;
  end;

type
  PCache = ^TCache;
  TCache = record
    Next: PCache;
    Master: ^Pointer;
    Size: Word;
    Data: record end;
  end;

  PBuffer = ^TBuffer;
  TBuffer = record
    Next: PBuffer;
    Size: Word;
    Data: record end;
  end;

const
  CacheList: PCache = nil;
  SafetyPool: Pointer = nil;
  BufferList: PBuffer = nil;
  SafetyPoolSize: Word = 0;
  DisablePool: Boolean = False;

function FreeCache: Boolean;
begin
  FreeCache := False;
  if CacheList <> nil then
  begin
    DisposeCache(CacheList^.Next^.Master^);
    FreeCache := True;
  end;
end;

function FreeSafetyPool: Boolean;
begin
  FreeSafetyPool := False;
  if SafetyPool <> nil then
  begin
    FreeMem(SafetyPool, SafetyPoolSize);
    SafetyPool := nil;
    FreeSafetyPool := True;
  end;
end;

function HeapNotify(Size: Word): Integer;
begin
  if FreeCache then HeapNotify := 2 else
    if DisablePool then HeapNotify := 1 else
      if FreeSafetyPool then HeapNotify := 2 else HeapNotify := 0;
end;

procedure InitMemory;
begin
  HeapError := @HeapNotify;
  SafetyPoolSize := LowMemSize * 16;
  LowMemory;
end;

procedure DoneMemory;
begin
  while FreeCache do;
  FreeSafetyPool;
end;

procedure InitDosMem;
begin
end;

procedure DoneDosMem;
begin
end;

function LowMemory: Boolean;
begin
  LowMemory := False;
  if SafetyPool = nil then
  begin
    SafetyPool := MemAlloc(SafetyPoolSize);
    if SafetyPool = nil then LowMemory := True;
  end;
end;

function MemAlloc(Size: Word): Pointer;
var
  P: Pointer;
begin
  DisablePool := True;
  GetMem(P, Size);
  DisablePool := False;
  MemAlloc := P;
end;

procedure NewCache(var P: Pointer; Size: Word);
var
  Cache: PCache;
begin
  Inc(Size, SizeOf(TCache));
  if MaxAvail >= Size then GetMem(Cache,Size) else Cache := nil;
  if Cache <> nil then
  begin
    if CacheList = nil then Cache^.Next := Cache else
    begin
      Cache^.Next := CacheList^.Next;
      CacheList^.Next := Cache;
    end;
    CacheList := Cache;
    Cache^.Master := @P;
    Cache^.Size := Size;
    Inc(PtrRec(Cache).Ofs, SizeOf(TCache));
  end;
  P := Cache;
end;

procedure DisposeCache(P: Pointer);
var
  Cache, C: PCache;
begin
  PtrRec(Cache).Ofs := PtrRec(P).Ofs - SizeOf(TCache);
  C := CacheList;
  while (C^.Next <> Cache) and (C^.Next <> CacheList) do C := C^.Next;
  if C^.Next = Cache then
  begin
    if C = Cache then CacheList := nil else
    begin
      if CacheList = Cache then CacheList := C;
      C^.Next := Cache^.Next;
    end;
    Cache^.Master^ := nil;
    FreeMem(Cache,Cache^.Size);
  end;
end;

procedure NewBuffer(var P: Pointer; Size: Word);
var
  Buffer: PBuffer;
begin
  Inc(Size, SizeOf(TBuffer));
  Buffer := MemAlloc(Size);
  if Buffer <> nil then
  begin
    Buffer^.Next := BufferList;
    Buffer^.Size := Size;
    BufferList := Buffer;
    Inc(PtrRec(Buffer).Ofs, SizeOf(TBuffer));
  end;
  P := Buffer;
end;

procedure DisposeBuffer(P: Pointer);
var
  Buffer,PrevBuf: PBuffer;
begin
  if P <> nil then
  begin
    Dec(PtrRec(P).Ofs, SizeOf(TBuffer));
    Buffer := BufferList;
    PrevBuf := nil;
    while (Buffer <> nil) and (P <> Buffer) do
    begin
      PrevBuf := Buffer;
      Buffer := Buffer^.Next;
    end;
    if Buffer <> nil then
    begin
      if PrevBuf = nil then BufferList := Buffer^.Next else PrevBuf^.Next := Buffer^.Next;
      FreeMem(Buffer,Buffer^.Size);
    end;
  end;
end;

function GetBufferSize(P: Pointer): Word;
begin
  if P = nil then GetBufferSize := 0
 else
  begin
    Dec(PtrRec(P).Ofs,SizeOf(TBuffer));
    GetBufferSize := PBuffer(P)^.Size;
  end;
end;

function SetBufferSize(P: Pointer; Size: Word): Boolean;
begin
  SetBufferSize := False;
end;

end.