技巧：使用自己的内存管理器来优化程序的执行效率。(50分)

{-----------------------------------------------------------------------------
 Unit Name: ShenMM.dpr
 Author:    slq (沈龙强)
 E-Mail:    Chinbo@eyou.com
 Homepage:  http://shenloqi.delphibbs.com
            http://www.shen.h58.net
 Purpose:   用来代替BorlndMM.dll的内存管理器。
            做成动态连接库的目的是因为Dll的特性（引用计数等）。

            用于在BorlndMM.dll不适用的场合，如以不断增加的尺寸增加内存时。

 History:
-----------------------------------------------------------------------------}


library ShenMM;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  CheckMemMgr in 'CheckMemMgr.pas';

exports
  //导出函数
  CheckGet, CheckFree, CheckRealloc;

begin
end.

{-----------------------------------------------------------------------------
 Unit Name: CheckMemMgr
 Author:    slq (沈龙强)
 E-Mail:    Chinbo@eyou.com
 Homepage:  http://shenloqi.delphibbs.com
            http://www.shen.h58.net
 Purpose:   这个单元用来替换Delphi的内存管理。
            主要是知道TMemoryManager这个记录类型的类的用法然后再
            加上简单的指针应用就可以了。

            处理内存泄漏的时候采用了Win32API的Messagebox或许不是一个好办法：）
 History:
-----------------------------------------------------------------------------}


unit CheckMemMgr;

interface

uses
  Windows;

//Dll导出函数

//Mgr.GetMem
function CheckGet(Size: Integer): Pointer;
//Mgr.FreeMem
function CheckFree(Mem: Pointer): Integer;
//Mgr.ReallocMem
function CheckRealloc(Mem: Pointer
Size: Integer): Pointer;

var
  //堆栈标识
  HeapFlags: DWord;

implementation

const
  //指针列表的最多元素
  MaxSize = MaxInt div 4;

type
  //指针列表类型
  TPointerArray = array[1..MaxSize] of Pointer;
  //指向指针列表的指针
  PPointerArray = ^TPointerArray;

var
  //堆栈
  Heap: THandle;
  //列表
  List: PPointerArray;
  //列表大小，最多到MaxSize
  ListSize: Integer;
  //列表分配大小，最多到MaxSize+256
  ListAlloc: Integer;

{-----------------------------------------------------------------------------
  Procedure: MemoryLeak
  Author:    slq
  Date:      21-三月-2002
  Arguments: None
  Result:    None
  Purpose:   内存泄漏时处理函数。
-----------------------------------------------------------------------------}

procedure MemoryLeak;
begin
  MessageBox(0, 'It Seemed Something Wrong , Memory Leak!', 'Warning...',
    MB_OK);
end;

{-----------------------------------------------------------------------------
  Procedure: AddMem
  Author:    slq
  Date:      21-三月-2002
  Arguments: Mem: Pointer
  Result:    None
  Purpose:   增加一个内存指针到列表
-----------------------------------------------------------------------------}

procedure AddMem(Mem: Pointer);
begin
  if List = nil then
  begin
    //新的指针列表
    ListAlloc := 8;
    List := HeapAlloc(Heap, HeapFlags, ListAlloc * SizeOf(Pointer));
  end
  else if ListSize >= ListAlloc then
  begin
    //列表不够大，增加列表大小，每次增加的少一些，可以满足频繁的分配要求
    if ListAlloc < 256 then
      ListAlloc := ListAlloc * 2
    else
      ListAlloc := ListAlloc + 256;
    List := HeapReAlloc(Heap, HeapFlags, List, ListAlloc * SizeOf(Pointer));
  end;
  //增加一个指针到列表
  Inc(ListSize);
  List[ListSize] := Mem;
end;

{-----------------------------------------------------------------------------
  Procedure: RemoveMem
  Author:    slq
  Date:      21-三月-2002
  Arguments: Mem: Pointer
  Result:    Boolean
  Purpose:   查找并删除列表中的指针。
             成功返回True，失败返回False（指针不在列表中）。
-----------------------------------------------------------------------------}

function RemoveMem(Mem: Pointer): Boolean;
var
  I: Integer;
begin
  for I := 1 to ListSize do
    if List[I] = Mem then
    begin
      MoveMemory(@List[I], @List[I + 1], (ListSize - I) * SizeOf(Pointer));
      Dec(ListSize);
      Result := True;
      Exit;
    end;

  Result := False;
end;

{-----------------------------------------------------------------------------
  Procedure: CheckGet
  Author:    slq
  Date:      21-三月-2002
  Arguments: Size: Integer
  Result:    Pointer
  Purpose:   替换内存分配器。
-----------------------------------------------------------------------------}

function CheckGet(Size: Integer): Pointer;
begin
  //分配内存
  Result := SysGetMem(Size);
  //增加指针
  AddMem(Result);
end;

{-----------------------------------------------------------------------------
  Procedure: CheckFree
  Author:    slq
  Date:      21-三月-2002
  Arguments: Mem: Pointer
  Result:    Integer
  Purpose:   如果指针在列表中则删除实际内存。
             返回值非零则错误。
-----------------------------------------------------------------------------}

function CheckFree(Mem: Pointer): Integer;
begin
  if not RemoveMem(Mem) then
    Result := 1
  else
    //释放内存
    Result := SysFreeMem(Mem);
end;

{-----------------------------------------------------------------------------
  Procedure: CheckRealloc
  Author:    slq
  Date:      21-三月-2002
  Arguments: Mem: Pointer
Size: Integer
  Result:    Pointer
  Purpose:   用新的指针代替旧的指针。
             如果不能移走旧的指针返回值为nil，这样Delphi会自动抛出一个异常。
-----------------------------------------------------------------------------}

function CheckRealloc(Mem: Pointer
Size: Integer): Pointer;
begin
  if not RemoveMem(Mem) then
    Result := nil
  else
  begin
    //重分配；
    Result := SysReallocMem(Mem, Size);
    //增加指针
    AddMem(Result);
  end;
end;

{-----------------------------------------------------------------------------
  Procedure: SetNewManager
  Author:    slq
  Date:      21-三月-2002
  Arguments: None
  Result:    None
  Purpose:   设置为新的内存管理器。
             需要了解TMemoryManager的结构。
-----------------------------------------------------------------------------}

procedure SetNewManager;
var
  Mgr: TMemoryManager;
begin
  Mgr.GetMem := CheckGet;
  Mgr.FreeMem := CheckFree;
  Mgr.ReallocMem := CheckRealloc;
  SetMemoryManager(Mgr);
end;

//初始化的时候分配一块堆栈，并设置为新的内存管理器。
initialization
  Heap := HeapCreate(0, HeapFlags, 0);
  SetNewManager;

//结束的时候检查是否有内存泄漏并释放堆栈。
finalization
  if ListSize <> 0 then
    MemoryLeak;
  HeapDestroy(Heap);
end.

{-----------------------------------------------------------------------------
 Unit Name: ShenShareMem
 Author:    slq (沈龙强)
 E-Mail:    Chinbo@eyou.com
 Homepage:  http://shenloqi.delphibbs.com
            http://www.shen.h58.net
 Purpose:   这个单元用来代替ShareMem单元，使用了ShenMM.dll这个动态连接库。


            适用范围是频繁的分配新的小内存的时候。
            发布的时候需要带上ShenMM.dll（很小，还没有Aspack压缩过）
 History:
-----------------------------------------------------------------------------}


unit ShenShareMem;

interface

//设置TMemoryManager时使用
function CheckGet(Size:Integer):Pointer;
function CheckFree(Mem:Pointer):Integer;
function CheckRealloc(Mem:Pointer;Size:Integer):Pointer;

implementation

const
  DLL = 'ShenMM.dll';

//导入ShenMM.dll的三个导出函数
function CheckGet(Size:Integer):Pointer;external DLL;
function CheckFree(Mem:Pointer):Integer;external DLL;
function CheckRealloc(Mem:Pointer;Size:Integer):Pointer;external DLL;

{-----------------------------------------------------------------------------
  Procedure: SetNewManager
  Author:    slq
  Date:      21-三月-2002
  Arguments: None
  Result:    None
  Purpose:   设置为新的内存管理器。
             需要了解TMemoryManager的结构。
-----------------------------------------------------------------------------}
procedure SetNewManager;
var
  Mgr: TMemoryManager;
begin
  Mgr.GetMem := CheckGet;
  Mgr.FreeMem := CheckFree;
  Mgr.ReallocMem := CheckRealloc;
  SetMemoryManager(Mgr);
end;

//初始化的时候设置新的内存管理器
initialization
  SetNewManager;

end.