Реализация шаблонов в Delphi

Версия для печати

http://www.delphikingdom.com/asp/viewitem.asp?catalogID=453

Алексей Горкуша
дата публикации 07-09-2001 16:53

Реализация шаблонов в Delphi

Многие скажут что сабж невозможен. Но...посмотрите что у меня получилось (На примере простого списка).

Итак.

Необходимо создать два пустых ((Через File-> New->Text или в файловой системе) без interface, implementation, uses... и т.д.) .pas файла.
Первый назовем InterfaceTemp.pas(заголовок), второй ImplementTemp.pas(реализация). Далее копируем, соответственно, в них в InterfaceTemp.pas (заголовочный файл шаблона):

  TemplateList = class  // заголовочный файл шаблона (для ordinal types или
real types, shortstring)
  private
    FList: PIntList;
    FCount: Integer;
    FCapacity: Integer;
  protected
    procedure Grow;
    function Get(Index: Integer): _DATA_TYPE_; // Вот оно чудо  :-)
    procedure Put(Index: Integer; Item: _DATA_TYPE_);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    destructor Destroy; override;
    class procedure Error(const Msg: string; Data: Integer); overload;
virtual;
    class procedure Error(Msg: PResStringRec; Data: Integer); overload;
    function Add(Item: _DATA_TYPE_): Integer;
    procedure Clear;
    function Last: _DATA_TYPE_;
    function First: _DATA_TYPE_;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function IndexOf(Item: _DATA_TYPE_): Integer;
    procedure Insert(Index: Integer; Item: _DATA_TYPE_);
    procedure Move(CurIndex, NewIndex: Integer);
    procedure Sort;
    function Min: _DATA_TYPE_;
    function Max: _DATA_TYPE_;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: _DATA_TYPE_ read Get write Put; default;
  end;

в ImplementTemp.pas (файл реализации шаблона):

function TemplateList.Add(Item: _DATA_TYPE_): Integer;
begin
  Result := FCount;
  if Result = FCapacity then
    Grow;
  FList^[Result] := Item;
  Inc(FCount);
end;

procedure TemplateList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

procedure TemplateList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then
    Error(@SListIndexError, Index);
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(_DATA_TYPE_));
end;

destructor TemplateList.Destroy;
begin
 Clear;
end;

procedure TemplateList.Exchange(Index1, Index2: Integer);
var
  Item: _DATA_TYPE_;
begin
if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1);
if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2);
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TemplateList.Get(Index: Integer): _DATA_TYPE_;
begin
if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  Result := FList^[Index];
end;

procedure TemplateList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := {371053//}FCapacity div 4
  else
    if FCapacity > 8 then
      Delta := 16
    else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TemplateList.IndexOf(Item: _DATA_TYPE_): Integer;
begin
  Result := 0;
  while (Result < FCount) and (FList^[Result] <> Item) do
    Inc(Result);
  if Result = FCount then
    Result := -1;
end;

procedure TemplateList.Insert(Index: Integer; Item: _DATA_TYPE_);
begin
if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index);
  if FCount = FCapacity then
    Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(_DATA_TYPE_));
  FList^[Index] := Item;
  Inc(FCount);
end;

function TemplateList.Max: _DATA_TYPE_;
var
  i: Integer;
begin
if Fcount=0 then Error(@SListCountError, 0);
Result:=Flist^[0];
for i:=0 to Fcount-1 do
 if Result < Flist^[i] then Result:=Flist^[i];
end;

function TemplateList.Min: _DATA_TYPE_;
var
  i: Integer;
begin
if Fcount=0 then Error(@SListCountError, 0);
Result:=Flist^[0];
for i:=0 to Fcount-1 do
 if Result>Flist^[i] then Result:=Flist^[i];
end;

procedure TemplateList.Move(CurIndex, NewIndex: Integer);
var
  Item: _DATA_TYPE_;
begin
  if CurIndex <> NewIndex then
  begin
if (NewIndex < 0) or (NewIndex >= FCount) then
  Error(@SListIndexError, NewIndex);
    Item := Get(CurIndex);
    Delete(CurIndex);
    Insert(NewIndex, Item);
  end;
end;

procedure TemplateList.Put(Index: Integer; Item: _DATA_TYPE_);
begin
if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  FList^[Index] := Item;
end;

procedure TemplateList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  Error(@SListCapacityError, NewCapacity);
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(_DATA_TYPE_));
    FCapacity := NewCapacity;
  end;
end;

procedure TemplateList.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    Error(@SListCountError, NewCount);
  if NewCount > FCapacity then
    SetCapacity(NewCount);
  if NewCount > FCount then
    FillMemory(@(FList^[FCount]), (NewCount - FCount) * SizeOf(_DATA_TYPE_),0);
    FCount := NewCount;
end;

procedure QuickIntSort(ia: PIntList; iLo,iHi : integer);
var
  Lo, Hi : Integer;  // индексы
  Mid, T : _DATA_TYPE_;  // значения
begin
  Lo := iLo;
  Hi := iHi;
  Mid := ia[(Lo+hi) shr 1];
  repeat
    while ia[Lo] < Mid do Inc(Lo);
    while ia[Hi] > Mid do Dec(Hi);
    if Lo <= Hi then
    begin
      T := ia[Lo];
      ia[Lo] := ia[Hi];
      ia[Hi] := T;
      inc(Lo);
      dec(Hi);
    end;
  until Lo > Hi;
  if Hi > iLo then QuickIntSort(ia,iLo,Hi);
  if Lo < iHi then QuickIntSort(ia,Lo,iHi);
end;

procedure TemplateList.Sort;
begin
  if (FList <> nil) and (FCount > 0) then
    QuickIntSort(FList, 0, FCount - 1);
end;

class procedure TemplateList.Error(const Msg: string; Data: Integer);

  function ReturnAddr: Pointer;
  asm
          MOV     EAX,[EBP+4]
  end;

begin
  raise Exception.CreateFmt(Msg, [Data]) at ReturnAddr;
end;

class procedure TemplateList.Error(Msg: PResStringRec; Data: Integer);
begin
  TemplateList.Error(LoadResString(Msg), Data);
end;

function TemplateList.Last: _DATA_TYPE_;
begin
  Result := Get(FCount - 1);
end;

function TemplateList.First: _DATA_TYPE_;
begin
  Result := Get(0);
end;

Теперь необходимо создать файл для так называемого "typedef" (Файл указания конкретного типа). На примере типа Currency (ImplCurrencyList.pas), для другого типа создайте еще один файл с другим названием, например (ImplIntegerList.pas)

Итак Currency:

unit ImplCurrencyList;

interface
uses  windows, sysutils;

{$H-}   // длинные строки недопустимы
  type _DATA_TYPE_ = Currency; // здесь указывается настоящий тип
{$H+}

  const
  MaxListSize = Maxint div (4*sizeof(_DATA_TYPE_));

  type
  PIntList = ^TIntList;
  TIntList = array[0..MaxListSize - 1] of _DATA_TYPE_;

  {$I InterfaceTemp} // соответственно тип уже обозначен и реален

type TCurrencyList = TemplateList; // здесь задается тип реального класса
списка

implementation
uses Consts;
  {$I ImplementTemp} // соответственно тип уже обозначен и реален
end.

Вот собственно и все. Теперь подключате модуль нужного типа uses ImplCurrencyList или ImplIntegerList.

var cyr: TCurrencyList или
var intlist: TIntegerList; где то. (если вы создали два или более "typedef" файла для других типов byte, Extended).

Данный пример работает с обычными типами данных (не объектными). Для объектов можно завернуть "перегрузку операторов"
Например:

TBase = class // это пример для дальнейших обсуждений
function doPlus(value: TBase): TBase; overload; // для выполнения оператора+
(если конечно договорится, что doPlus подразумеывает оператор +)
function doPlus(value: integer): TBase; overload;
function doPlus(value: real): TBase; overload;
end;

Соответсвенно где то в шаблоне (очень примитивный пример)

function TemplateClass.Add(Item: _DATA_TYPE_): Integer; // например
TemplateClass и _DATA_TYPE_ есть TBase;
begin
self.doPlus(Item); {для TBase}
Result:=self.a; // какое-то внутреннее поле (пример)
end;

Вот такие дела в Delphi творятся. Любая критика и предложения принимаются.

Скачать пример PascalTemplates.zip (6.2K)