
{*******************************************************}
{                                                       }
{       Graphics Vision Unit                            }
{                                                       }
{	Portions copyright (c) 1992 Borland Intl.       }
{       Copyright (c) 1994 Stefan Milius                }
{	Copyright (c) 1997 Matthias Koeppe              }
{                                                       }
{*******************************************************}

unit Memory;

{$ifndef Windows}
' This is not the original Memory unit of Turbo Vision.  '
' It only contains a few definitions for use with the    '
' Windows version of Graphics Vision. Remove the path to '
' this source from your unit search path if you want to  '
' compile for DOS or DPMI target.                        '
{$endif}

{$O+,F+,X+,I-,S-,Q-}

interface

{$ifndef VER90}
uses OMemory;
{$endif}

{ Note that these variables are ignored in Windows. }
const
  MaxHeapSize: Word = 655360 div 16;    { 640K }
  LowMemSize: Word = 4096 div 16;       {   4K }
  MaxBufMem: Word = 65536 div 16;       {  64K }

procedure InitMemory;
procedure DoneMemory;
procedure InitDosMem; {does nothing}
procedure DoneDosMem; {does nothing}
function LowMemory: Boolean;
function MemAlloc(Size: Word): Pointer;
function MemAllocSeg(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;

{ SetBufferSize: Note that P may change (Windows only). }
function SetBufferSize(var P: Pointer; Size: Word): Boolean;

implementation

uses WinTypes, {$ifndef VER90} {$ifndef VER80} WinAPI, {$endif} {$endif} WinProcs;

type
  PtrRec = record
    Ofs, Seg: Word;
  end;

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

const
  CacheList: PCache = nil;

var
  OldHeapError: function(Size: Word): Integer;

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

function HeapNotify(Size: Word): Integer; {$ifndef FPK}far;{$endif}
begin
  if Size <> 0 then
    if FreeCache then HeapNotify := 2
    else HeapNotify := OldHeapError(Size);
end;

procedure InitMemory;
begin
{$ifndef VER90}
  OMemory.InitMemory;
{$endif}
  @OldHeapError := HeapError;
  HeapError := @HeapNotify;
end;

procedure DoneMemory;
begin
{$ifndef VER90}
  while FreeCache do;
  OMemory.DoneMemory;
{$endif}
end;

procedure InitDosMem;
begin
end;

procedure DoneDosMem;
begin
end;

function LowMemory: Boolean;
begin
{$ifdef VER90}
  LowMemory := false;
{$else}
  LowMemory := OMemory.LowMemory
{$endif}
end;

function MemAlloc(Size: Word): Pointer;
{$ifdef VER90}
var
  P: Pointer;
begin
  GetMem(P, Size);
  MemAlloc := P
end;
{$else}
begin
  MemAlloc := OMemory.MemAlloc(Size)
end;
{$endif}

function MemAllocSeg(Size: Word): Pointer;
begin
{$ifdef VER90}
  MemAllocSeg := MemAlloc;
{$else}
  MemAllocSeg := OMemory.MemAllocSeg(Size);
{$endif}
end;

procedure NewCache(var P: Pointer; Size: Word);
var
  Cache: PCache;
begin
  Inc(Size, SizeOf(TCache));
  Cache := GlobalAllocPtr(4, Size);
  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;
    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);
  PtrRec(Cache).Seg := PtrRec(P).Seg;
  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;
    GlobalFreePtr(Cache);
  end;
end;

procedure NewBuffer(var P: Pointer; Size: Word);
begin
  P := MemAllocSeg(Size);
end;

procedure DisposeBuffer(P: Pointer);
begin
  GlobalFreePtr(P);
end;

function GetBufferSize(P: Pointer): Word;
begin
  GetBufferSize := GlobalSize(GlobalPtrHandle(P));
end;

function SetBufferSize(var P: Pointer; Size: Word): Boolean;
begin
  P := GlobalReAllocPtr(P, Size, 2);
  SetBufferSize := P <> nil;
end;

end.
