Параметризовать конструктор

[zub]

stanilar
Примеров как реализовать подобное можно напридумывать много... с объектами, классами, рекордами, указателями, процедурными типами... хоть с кучей ифов или ветвистым case`ом.
Но это все не про то - задача создать объект тип которого станет известен в рантайме и вызов соответствующего конструктора вполне рабочее и логичное решение.

класс внутри обжекта (тогда уже сразу делать просто класс) или обжект с указателем или процедурным типом внутри - мы теряем все плюсы обжекта, всё что надо в нем уже есть, а мы городим еще один слой "виртуализации"

[stanilar]

Никаких плюсов обжектов не теряется, именно что "городим еще один слой "виртуализации".

Ифы и case'ы сложнее разделять по юнитам, код становится более запутанный. Но, как не практикующий сторонник ФП, буду солидарен с Вами, надо было просто определить TAnimal = (taDog, taCat) и налепить ифов с кейсами. Сопровождаемость и читаемость кода повысилась бы если не на порядки, то в разы уж точно.

[zub]

>>Никаких плюсов обжектов не теряется, именно что "городим еще один слой "виртуализации".
Главный плюс - минимализм достаточный для данной задачи (PVMT всё что нужно чтоб организовать различное поведение экземпляров), его и теряем в первую очередь, т.к. придумываем свои нахлабучки. О возможности быстрого создания объестов без выделений памяти промолчу.

>>Сопровождаемость и читаемость кода повысилась бы если не на порядки, то в разы уж точно.
Шутите? Тогда хоть смайлы ставте. А если не шутите предлагаю представить читаемость и поддерживаемость LCL написаной в стиле "TControl = (tForm, tButton, tScrollBar, etc...) и налепить ифов с кейсами"

[Дож]

О возможности быстрого создания объестов без выделений памяти промолчу.

Вы не поняли, там нет никаких выделений памяти (там не экземпляр класса создаётся, а классовый тип записывается).

[zub]

Я понял и "промолчал" об этом)) имея ввиду вообще замену обжекта на класс.
В топике поставлена конкретная задача и найдено вполне нормальное решение, но пошли длинные рассуждалки на тему лучше делать вообще не так

[stanilar]

Шутите?

Мне показалось любопытным Ваше замечание про ифы, в нем была большая доля истины.

Насчет LCL - а что в ней предлагается заменить на ифы? Там вроде особо и нечего менять.

[Дож]

Прошу прощения у почтенной публики, в своём посте я написал чушь из-за тотального непонимания того, как работает VMT в объектах. Код перестанет работать, если в TAnimal добавить какие-то дополнительные поля.

Сейчас в Free Pascal у объектов ссылка на VMT размещается после всех полей. (В том случае, когда виртуальных методов нет, ссылки на VMT тоже не будет.) Не знаю зачем так сделано, возможно, для большей совместимости с обычными записями (и для совместимости в тех случаях, когда объект без виртуальных методов переписывается на объект с виртуальными методами). Поэтому, предполагаю, что чтобы корректно изменить VMT объекта, нужно (1) знать тот тип его предка, в котором VMT впервые появляется (2) используя какую-то магию с SizeOf(…) поменять ссылку.

Таким образом, я предлагаю такой рабочий код для изменения VMT вместо того, что в указанном посте:

Код: Выделить всё

[doj@korica ~/temp]$ cat switch.pas
type
TFlexible = object
  destructor Done; virtual;
  {function GetVMT: Pointer; inline;}
  procedure SetVMT(_VMT: Pointer); inline;
  property VMT: Pointer {read GetVMT} write SetVMT;
end;

TAnimal = object(TFlexible)
  FName: AnsiString;
  constructor Init(const Name: AnsiString);
  procedure TellAboutYourSelf; virtual; abstract;
end;

TCat = object(TAnimal)
  procedure TellAboutYourSelf; virtual;
end;

TDog = object(TAnimal)
  procedure TellAboutYourSelf; virtual;
end;

destructor TFlexible.Done;
begin
end;

procedure TFlexible.SetVMT(_VMT: Pointer);
begin
  PPointer(@Self)^ := _VMT;
end;

constructor TAnimal.Init(const Name: AnsiString);
begin
  FName := Name;
end;

procedure TCat.TellAboutYourSelf;
begin
  Writeln('Я кот по имени ', FName, '.');
end;

procedure TDog.TellAboutYourSelf;
begin
  Writeln('Я ', FName, ', гав-гав!');
end;

var
  Pet: TAnimal;

begin
  Pet.Init('Бусик');
  Pet.VMT := TypeOf(TCat);
  Pet.TellAboutYourSelf;
  Pet.VMT := TypeOf(TDog);
  Pet.TellAboutYourSelf;
  Pet.Done;
end.
[doj@korica ~/temp]$ fpc switch.pas && ./switch
Я кот по имени Бусик.
Я Бусик, гав-гав!

[Sergei I. Gorelkin]

VMT размещается не после всех полей, а в том месте, где встречается первый виртуальный метод. Если у потомков есть дополнительные поля - то VMT окажется где-то в середине. Если виртуальный метод объявить до полей в первом объекте иерархии - VMT будет в начале, как и у классов.

[zub]

Сейчас в Free Pascal у объектов ссылка на VMT размещается после всех полей. (В том случае, когда виртуальных методов нет, ссылки на VMT тоже не будет.) Не знаю зачем так сделано, возможно, для большей совместимости с обычными записями (и для совместимости в тех случаях, когда объект без виртуальных методов переписывается на объект с виртуальными методами). Поэтому, предполагаю, что чтобы корректно изменить VMT объекта, нужно (1) знать тот тип его предка, в котором VMT впервые появляется (2) используя какую-то магию с SizeOf(…) поменять ссылку.

Я когдато для этих целей сделал "парсер" исходников (их части с определениями объектов) чтоб обнаружить момент появления VMT и зафиксировать последовательность объявления виртуальных методов для возможности их самомтоятельного (чтото вроде выполнения в рантайме пользовательского скрипта) вызова в рантайме. Этот код практически неизменно работает со времен 2.0 до сегодняшнего 2.7.1. Единственное, когда я поддерживал совместимость с делфи, кажется в 2009 версии, в дельфях изменилось поведение - указатель на VMT стал появлятся в объектах независимо от присутствия виртуальных методов и для совместимости в мой базовый родительский объект пришлость добавить виртуальность. На делфи я давно забил, но VMT так в базовом объекте и болтается

[MylnikovDm]

Мужики, вы мазохисты!

[Дож]

VMT размещается не после всех полей, а в том месте, где встречается первый виртуальный метод. Если у потомков есть дополнительные поля - то VMT окажется где-то в середине.

Да, я не имел в виду, что VMT будет глобально после всех полей, я имел в виду, что будет после всех полей в рамках текущего объекта.

Если виртуальный метод объявить до полей в первом объекте иерархии - VMT будет в начале, как и у классов.

А вот это не подтверждается на практике! По моим наблюдениям, даже если объявить виртуальный метод до полей, VMT всё равно будет в конце объекта. Иллюстрирую кодом:

Код: Выделить всё

[doj@korica ~/temp]$ cat vmt.pas
type
// Это базовый объект, в нём нет VMT вообще
TBaseObject = object
  Q, W: Pointer;
end;

// Это тестовый объект, в нём VMT будет после всех полей, а не между A и B
TTestObject = object(TBaseObject)
public
  A: Pointer;
  constructor Init;
  procedure Test; virtual;
public
  B: Pointer;
end;

// Этот объект унаследует положение VMT от предка
TDescendObject = object(TTestObject)
public
  X: Pointer;
  procedure Test1; virtual;
public
  Y: Pointer;
  procedure Test2; virtual;
end;

constructor TTestObject.Init;
begin
end;

procedure TTestObject.Test;
begin
end;

procedure TDescendObject.Test1;
begin
end;

procedure TDescendObject.Test2;
begin
end;

procedure Detect(const Name: String; var O; S: Integer; VMT: Pointer);
var
  I: Integer;
  A: array[0..1] of Pointer absolute O;
begin
  for I := 0 to S div SizeOf(Pointer) do
    if A[I] = VMT then
      Writeln(Name, '''s VMT found at ', I);
end;

procedure PrintPos(const Name: String; var O; var F: Pointer);
begin
  Writeln(Name, ' pos: ', (PtrUint(@F) - PtrUint(@O)) div SizeOf(Pointer));
end;

procedure PrintFields(const Name: String; S: Integer);
begin
  Writeln(Name, ' contains ', S div SizeOf(Pointer), ' fields');
end;

var
  T: TTestObject;
  D: TDescendObject;

begin
  PrintFields('TBaseObject', SizeOf(TBaseObject));

  T.Init;
  PrintFields('TTestObject', SizeOf(T));
  PrintPos('T.Q', T, T.Q);
  PrintPos('T.W', T, T.W);
  PrintPos('T.A', T, T.A);
  PrintPos('T.B', T, T.B);
  Detect('TTestObject', T, SizeOf(TTestObject), TypeOf(TTestObject));

  D.Init;
  PrintFields('TDescendObject', SizeOf(D));
  PrintPos('D.Q', D, D.Q);
  PrintPos('D.W', D, D.W);
  PrintPos('D.A', D, D.A);
  PrintPos('D.B', D, D.B);
  PrintPos('D.X', D, D.X);
  PrintPos('D.Y', D, D.Y);
  Detect('TDescendObject', D, SizeOf(TDescendObject), TypeOf(TDescendObject));
end.
[doj@korica ~/temp]$ fpc -Mobjfpc vmt.pas && ./vmt
TBaseObject contains 2 fields
TTestObject contains 5 fields
T.Q pos: 0
T.W pos: 1
T.A pos: 2
T.B pos: 3
TTestObject's VMT found at 4
TDescendObject contains 7 fields
D.Q pos: 0
D.W pos: 1
D.A pos: 2
D.B pos: 3
D.X pos: 5
D.Y pos: 6
TDescendObject's VMT found at 4

[zub]

>>Мужики, вы мазохисты!
Похоже на то)) В моем случае целью был скриптовый язык и инспектор объектов умеющий показывать-редактировать обычные рекорды и обжекты. Скрипт так у меня и неполучился, а инспектор работает. В итоге парсенье выборки исходников гораздо меньший мазохизм чем ручная регистрация всех типов показываемых в инспекторе. Возможно сейчас это можно сделать на основе RTTI, но во времена когда это писалось ртти мне нехватало, непомню подробностей. Еще думал на основе этого сделать автоматическую сериализацию, но так и не взялся, т.к. сохранять данные приходится в сторонние форматы.

[Дож]

И, чтобы не создавать бесполезную тему, спрошу заодно здесь. Есть ли способ заставить исключения, брошенные из конструкторов object'ов, освобождать только что выделенную память? new(PObj, Init) => вызов Fail внутри Init немедленно dispose'ает объект и возвращает nil, но если взамен бросить исключение, происходит утечка.

Я смотрел исходники: оно освобождает объект, если было брошено исключение из конструктора (см. мои комментарии):

Код: Выделить всё

{$ifndef FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
// Дож: тут говорится, что _vmt:=-1 нужно, чтобы пометить выделенный в куче объект для fpc_help_fail
{ Note: _vmt will be reset to -1 when memory is allocated,
  this is needed for fpc_help_fail }
function fpc_help_constructor(_self:pointer;var _vmt:pointer;_vmt_pos:cardinal):pointer;[public,alias:'FPC_HELP_CONSTRUCTOR'];compilerproc;
var
  vmtcopy : pobjectvmt;
begin
  vmtcopy:=pobjectvmt(_vmt);
  { Inherited call? }
  if vmtcopy=nil then
    begin
      fpc_help_constructor:=_self;
      exit;
    end;

  if (_self=nil) and
     (vmtcopy^.size>0) then
    begin
      getmem(_self,vmtcopy^.size);
      { reset vmt needed for fail }
      _vmt:=pointer(-1); // Дож: помечаем
    end;
  if _self<>nil then
    begin
      fillchar(_self^,vmtcopy^.size,0);
      ppointer(_self+_vmt_pos)^:=vmtcopy;
    end;
  fpc_help_constructor:=_self;
end;
{$endif FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}

...

{$ifndef FPC_SYSTEM_HAS_FPC_HELP_FAIL}
{ Note: _self will not be reset, the compiler has to generate the reset }
procedure fpc_help_fail(_self:pointer;var _vmt:pointer;vmt_pos:cardinal);[public,alias:'FPC_HELP_FAIL'];compilerproc;
begin
   if (_self=nil) or (_vmt=nil) then
     exit;
   { vmt=$ffffffff when memory was allocated }
   if ptruint(_vmt)=high(ptruint) then // Дож: тут мы обнаруживаем пометку
     begin
       if (_self=nil) or (ppointer(_self+vmt_pos)^=nil) then
         HandleError(210)
       else
         begin
           ppointer(_self+vmt_pos)^:=nil;
           freemem(_self); // Дож: освобождаем память!
           { reset _vmt to nil so it will not be freed a
             second time }
           _vmt:=nil;
         end;
     end
   else
     ppointer(_self+vmt_pos)^:=nil;
end;
{$endif FPC_SYSTEM_HAS_FPC_HELP_FAIL}

Добавлено спустя 3 часа 3 минуты 51 секунду:
В качестве резюме полученных знаний, я написал пост себе в блог:
http://keyfighter.blogspot.ru/2014/09/free-pascal.html

[Vapaamies]

Прочитал статью, решил высказать свое мнение о FPC_CallPointerConstructor_Implemented. Эта процедура похожа на заточку (точку входа RTL) компилятора, вызов которой формируется кодогенератором. Нужно смотреть map-файл сборки. При отсутствии упоминания FPC_CallPointerConstructor_Implemented ее можно считать будущей или прошлой заточкой, еще/уже не используемой.

Это лишь предположение. В исходники FPC лезть лень. У меня снова приступ лени.

[Sergei I. Gorelkin]

В модуле objects вообще хватает ужас-ужас-ужаса. Он изначально был завязан на детали вроде структуры кадра стека, характерные для i386. Поэтому работоспособности на MIPS, у которого frame pointer указывает на другой конец кадра (а чаще всего вообще не нужен), добивались даже не костылями...