И снова про вызовы функций-членов

← →
reonid © (2002-03-27 18:08) [7]

>Толик ©
Я сейчас проверил - с абстракнными методами такое не пройдёт.
В VMT они все имеют одинаковый адрес.
(То, что дает взятие адреса @TBase.F - это какая-то фикция).

А не с абстрактными - вполне проходит.

Кстати, тот примерчик я писал с ходу и он не совсем корректен
Вот работающий пример:

TFunc = function: Integer of object;
PPtrArray = ^TPtrArray;
TPtrArray = array[0..MaxInt div 16] of Pointer;

TVirtMethod = record
BaseClass: TClass;
Index: Integer;
end;

TBase = class
function F: Integer; virtual;
end;

TDerived = class (TBase)
function F: Integer; override;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function TBase.F: Integer;
begin
Result := 0;
end;

function TDerived.F: Integer;
begin
Result := 123;
end;

function AddressToVMTIndex(VMT, Meth: Pointer): Integer;
var i: Integer;
begin
Result := -1;
i := 0;
repeat
if PPtrArray(vmt)^[i] = Meth then
begin
Result := i;
Exit;
end;
Inc(i);
until i = 100000;
end;

function VMTIndexToAddress(VMT: Pointer; Index: Integer): Pointer;
begin
Result := PPtrArray(VMT)^[Index];
end;

function GetVirtMethod(VMT, Meth: Pointer): TVirtMethod;
begin
Result.BaseClass := TClass(VMT);
Result.Index := AddressToVMTIndex(VMT, Meth);
end;

function GetStaticMethod(Instance: TObject; VirtMethod: TVirtMethod): TMethod;
begin
Result.Code := nil;
Result.Data := nil;
if Instance.InheritsFrom(VirtMethod.BaseClass) then
begin
Result.Data := Instance;
Result.Code := VMTIndexToAddress(Instance.ClassType, VirtMethod.Index);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var vmt, pf: Pointer;
VirtMeth: TVirtMethod;
meth: TFunc;
derived: TBase;// Потомок
begin
pf := @TBase.F;

VirtMeth := GetVirtMethod(TBase, pf);

derived := TDerived.Create;
try
TMethod(meth) := GetStaticMethod(derived, VirtMeth);
if Assigned(meth) then Caption := IntToStr(meth);
finally
derived.Free;
end;
end;

И снова про вызовы функций-членов Найти похожие ветки