Черновик. Новое виденье определения операторов в скриптовой машине

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

+Виктор Морозов Витя, напомни, если будет не трудно - я тебе "на пальцах расскажу". Это к сегодняшнему разговору об "операторах" и параметрах "слева и справа".

Чтобы определить например оператор ".Height" для контрола делаем следующее:

type
 TControlHeightImpl = class
 ...
 end;//TControlHeightImpl

class function TControlHeightImpl.GetValueSemiGenerated(const aCtx: TtfwContext; aSelf: TControl): Integer;
begin
 // Start UC
 Result := aSelf.Height;
 // End UC
end;

class procedure TControlHeightImpl.SetValueSemiGenerated(const aCtx: TtfwContext; aSelf: TControl; aValue: Integer);
begin
 // Start UC
 aSelf.Height := aValue;
 // End UC
end;

class function TControlHeightImpl.GetValueGenerated(const aCtx: TtfwContext; aSelf: TObject): TtfwValue;
begin
 Result := TtfwValue_C(GetValueSemiGenerated(aCtx, TControl(aSelf)));
end;

class procedure TControlHeightImpl.SetValueGenerated(const aCtx: TtfwContext; aSelf: TObject; const aValue: TtfwValue);
begin
 SetValueSemiGenerated(aCtx, TControl(aSelf), aValue.AsInteger);
end;

initialization
 TOperator.RegisterProp('Height', TControl, TControlHeightImpl.GetValueGenerated, TControlHeightImpl.SetValueGenerated);

Эту часть, без "кодогенерации" сделать МОЖНО, но - "муторно". А вот далее пойдут - вполне себе "проектные классы".

Тогда возможен код на скрипте:

OBJECT VAR X

X := GetControlFromSomewhere

X .Height .
X .Height := SomeValue

Теперь как выглядит TOperator.RegisterProp:

type
 TtfwObjectPropGetter = function (const aCtx: TtfwContext; aSelf: TObject): TtfwValue of object;
 TtfwObjectPropSetter = procedure (const aCtx: TtfwContext; aSelf: TObject; const aValue: TtfwValue) of object;
...
class procedure TOperator.RegisterProp(const aPropName: AnsiString; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
var
 l_Key : Il3CString;
begin
 l_Key := TtfwStringFactory.C('.' + aPropName);
 TtfwClassOperatorCompiler.Register(Self, l_Key, aClass, aGetter, aSetter);
end;

Теперь как выглядит TtfwClassOperatorCompiler.Register:

type
 TtfwClassOperatorCompiler = class(TtfwWordWorkerRunner)
  ...
 end;//TtfwClassOperatorCompiler

class procedure TtfwClassOperatorCompiler.Register(aProducer: TtfwWord; const aKey: Il3CString; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
var
 l_Inst : TtfwClassOperatorCompiler;
begin
 l_Inst := Self.Create(aProducer, aKey, aClass, aGetter, aSetter);
 try
  l_Inst.RegisterInAxiomatics;
 finally
  FreeAndNil(l_Inst);
 end;//try..finally
end;

constructor TtfwClassOperatorCompiler.Create(aProducer: TtfwWord; const aKey: Il3CString; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
var
 l_Compiled : TtfwClassOperatorCompiled; 
begin
 inherited Create(aProducer, aKey);
 // - с aProducer и aKey - пусть разбирается предок
 l_Compiled := TtfwClassOperatorCompiled.Create(aKey, Self, aClass, aGetter, aSetter);
 try
  l_Compiled.SetRefTo(f_Compiled);
 finally
  FreeAndNil(l_Compiled);
 end;//try..finally
end;  

Тут фишка какая? А такая, что TtfwClassOperatorCompiler НАСЛЕДУЕТСЯ от TtfwWordWorkerRunner, а посему - все "сложности компиляции" берёт на себя ИМЕННО - TtfwWordWorkerRunner.

Теперь как выглядит TtfwClassOperatorCompiled:

constructor TtfwClassOperatorCompiled.Create(const aKey: Il3CString; aCompiler: TtfwClassOperatorCompiler; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
begin
 inherited Create(aKey);
 // - с aKey - пусть разбирается предок
 f_Class := aClass;
 f_Getter := aGetter;
 f_Setter := aSetter;
 f_Compiler := aCompiler;
 Self.DefineLeftWordRefParam('Self');
 // - определяем один ссылочный параметр слева, чисто для документации и диагностики
end;

function TtfwClassOperatorCompiled.GetSelf(const aCtx: TtfwContext): TObject;
begin
 Result := f_Compiler.LeftWordRefValues.First.GetValue(aCtx).AsObject;
 // - получаем значение параметра у того парня, который нас компилировал
 //Result := LeftWordRefParams.First.GetValue(aCtx).AsObject;
 CompilerAssert(Result <> nil, 'Подан пустой объект', aCtx);
 CompilerAssert(Result.InheritsFrom(f_Class), 'Подан объект класса ' + Result.ClassName + ', а должен быть ' + f_Class.ClassName, aCtx);
end;

function TtfwClassOperatorCompiled.GetValue(const aCtx: TtfwContext): TtfwValue; override;
begin
 Result := f_Getter(aCtx, Self.GetSelf(aCtx));
end; 

procedure TtfwClassOperatorCompiled.SetValue(const aCtx: TtfwContext; const aValue: TtfwValue); override;
begin
 f_Setter(aCtx, Self.GetSelf(aCtx), aValue);
end; 

procedure TtfwClassOperatorCompiled.DoDoIt(const aCtx: TtfwContext);
begin
 if aCtx.rNeedValue then
  aCtx.Push(Self.GetValue(aCtx))
 else
  CompilerAssert(false, 'Что-то пошло не так', aCtx);
end;

Заметка "на полях":

• "определяем один ссылочный параметр слева, чисто для документации и диагностики" - ХРЕНА! НЕ ТОЛЬКО для диагностики, но и для ТОГО, чтобы ВЕРНО скомпилировать "ссылочный параметр слева".

Теперь положим мы хотим определить свойство Height для TControl и TvgControl.

Что делать?

А тут мы делаем bundle.

Unit ControlsPublishing;
...
initialization
 TOperator.RegisterProp('Height', TControl, TControlHeightImpl.GetValueGenerated, TControlHeightImpl.SetValueGenerated);
...
Unit vgControlsPublishing;
...
initialization
 TOperator.RegisterProp('Height', TvgControl, TvgControlHeightImpl.GetValueGenerated, TvgControlHeightImpl.SetValueGenerated);

TControlHeightImpl и TvgControlHeightImpl - в общем - похожи.

Ну "с точностью до запятых".

А вот TtfwClassOperatorCompiler и TtfwClassOperatorCompiled - видоизменяются достаточно СИЛЬНО.

И вообще говоря - "приобретают черты" Dependency Injection.

Посмотрим для начала на TtfwClassOperatorCompiler.Register:

Изменим его примерно так:

class procedure TtfwClassOperatorCompiler.Register(aProducer: TtfwWord; const aKey: Il3CString; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
var
 l_Inst : TtfwClassOperatorCompiler;
begin
 if Axiomatics.Registered(aKey, l_Inst) then
  l_Inst.AddAnotherClass(aClass, aGetter, aSetter)
 else
 begin
  l_Inst := Self.Create(aProducer, aKey, aClass, aGetter, aSetter);
  try
   l_Inst.RegisterInAxiomatics;
  finally
   FreeAndNil(l_Inst);
  end;//try..finally
 end;//Axiomatics.Registered(aKey, l_Inst)
end;

procedure TtfwClassOperatorCompiler.AddAnotherClass(aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
begin
 f_Compiled.AddAnotherClass(aClass, aGetter, aSetter);
end;

Теперь как выглядит TtfwClassOperatorCompiled?

Пусть у нас есть "ассоциативный массив" вида:

type
 TtfwClassOperatorCompiledInfo = record
  rClass : TClass;
  rGetter : TtfwObjectPropGetter;
  rSetter : TtfwObjectPropSetter;
  constructor Create(aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter); 
 end;//TtfwClassOperatorCompiledInfo
 
 TtfwClassOperatorCompiledInfoList = class(TList<TtfwClassOperatorCompiledInfo>)
 public
  procedure AddIfNotHasClass(const aClass: TtfwClassOperatorCompiledInfo);
 end;//TtfwClassOperatorCompiledInfo

procedure TtfwClassOperatorCompiledInfoList.AddIfNotHasClass(const aClass: TtfwClassOperatorCompiledInfo): Boolean;
var
 l_Info : TtfwClassOperatorCompiledInfo;
begin
 for l_Info in Self do
  if (aClass.rClass = l_Info.rClass) then
   Exit;
 Self.Add(aClass);
end;

Тогда класс TtfwClassOperatorCompiled будет выглядеть так:

type
 TtfwClassOperatorCompiled = ...
 private
  f_List : TtfwClassOperatorCompiledInfoList;
 end;//TtfwClassOperatorCompiled

constructor TtfwClassOperatorCompiled.Create(const aKey: Il3CString; aCompiler: TtfwClassOperatorCompiler; aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
begin
 inherited Create(aKey);
 // - с aKey - пусть разбирается предок
 f_List := TtfwClassOperatorCompiledInfoList.Create;
 f_List.Add(TtfwClassOperatorCompiledInfo.Create(aClass, aGetter, aSetter));
 f_Compiler := aCompiler;
 Self.DefineLeftWordRefParam('Self');
 // - определяем один ссылочный параметр слева, чисто для документации и диагностики
end;

procedure TtfwClassOperatorCompiled.AddAnotherClass(aClass: TClass; aGetter: TtfwObjectPropGetter; aSetter: TtfwObjectPropSetter);
begin
 f_List.AddIfNotHasClass(TtfwClassOperatorCompiledInfo.Create(aClass, aGetter, aSetter));
end;

type
 TInvokeOnSelf = reference to procedure (anObj: TObject; const anInfo: TtfwClassOperatorCompiledInfo);

procedure TtfwClassOperatorCompiled.InvokeOnSelf(const aCtx: TtfwContext; aWhatToInvoke: TInvokeOnSelf);
var
 l_Info : TtfwClassOperatorCompiledInfo;
 l_Obj : TObject;
begin
 l_Obj := f_Compiler.LeftWordRefValues.First.GetValue(aCtx).AsObject;
 // - получаем значение параметра у того парня, который нас компилировал
 CompilerAssert(Result <> nil, 'Подан пустой объект', aCtx);
 for l_Info in f_List downto do
  if (l_Obj.InheritsFrom(l_Info.rClass)) then
  begin
   aWhatToInvoke(l_Obj, l_Info);
   Exit;
  end;
 CompilerAssert('Подан объект класса ' + l_Obj.ClassName + ', который непонятно как обрабатывать', aCtx);
end;

function TtfwClassOperatorCompiled.GetValue(const l_Obj TtfwContext): TtfwValue; override;
begin
 InvokeOnSelf(aCtx, 
  procedure (anObj: TObject; const anInfo: TtfwClassOperatorCompiledInfo)
  begin
   Result := anInfo.rGetter(aCtx, anObj);
  end;
 );
end; 

procedure TtfwClassOperatorCompiled.SetValue(const aCtx: TtfwContext; const aValue: TtfwValue); override;
begin
 InvokeOnSelf(aCtx, 
  procedure (anObj: TObject; const anInfo: TtfwClassOperatorCompiledInfo)
  begin
   anInfo.rSetter(aCtx, anObj, aValue);
  end;
 );
end; 

procedure TtfwClassOperatorCompiled.DoDoIt(const aCtx: TtfwContext);
begin
 if aCtx.rNeedValue then
  aCtx.Push(Self.GetValue(aCtx))
 else
  CompilerAssert(false, 'Что-то пошло не так', aCtx);
end;

Далее будем обобщать эту схему на переменное число параметров и неклассовые GetSelf.

С "новым" RTTI всё "относительно проще, но всё равно без TtfwClassOperatorCompiler и TtfwClassOperatorCompiled не обойтись.

Можно кстати начать с более простого:

type
 TGetAddr = class
 end;//TGetAddr

procedure TGetAddr.DoIt(const aCtx: TtfwContext; aRightParam: TtfwWord);
begin
 aCtx.rEngine.PushObj(aRightParam);
end;

initialization
 TOperator.RegisterWordRefAtRight('@', TGetAddr.DoIt);

Или:

type
 TWhile = class
 end;//TWhile

procedure TWhile.DoIt(const aCtx: TtfwContext; aRightParam1: TtfwWord; aRightParam2: TtfwWord);
begin
 while aRightParam1.DoAndTrue(aCtx) do
 // - выполняем код слова aRightParam1 и проверяем его результат на ИСТИННОСТЬ
  aRightParam2.DoOnly(aCtx); 
  // - выполняем код слова aRightParam2 
end;

initialization
 TOperator.RegisterWordRefAtRight2('WHILE', TWhile.DoIt);