Check base type of dedicated type

[Andre1 0]

Hi,

I wrote a framework to call delphi methods from other programming languages. This works quite well, except for the method

procedure TBitmap.Clear(const AColor: TAlphaColor);

TAlphaColor is defined as dedicated type with base type Cardinal

TAlphaColor = type Cardinal;

 

The generic logic to execute delphi methods fails, because from the foreign programming language an Unsigned Integer is passed, while the logic expects
exactly TAlphaColor.

The condition "if parameters[Index].ParamType.Handle <> Args[Index].TypeInfo then" evaluates to false.

 

function executeInstanceMethod(Reference: Pointer; const AName: string;
  const Args: array of TValue): TValue;
var
  context: TRttiContext;
  instType: TRttiInstanceType;
  obj: TObject;
  meth: TRttiMethod;
  parameters: TArray<TRttiParameter>;
  Found: Boolean;
  index: Integer;
begin
  context := TRttiContext.Create;
  try
    meth := nil;
    Found := false;
    obj := TObject(Reference);
    instType := (context.GetType(obj.ClassType) as TRttiInstanceType);

    for meth in instType.GetMethods do
      if SameText(meth.Name, AName) then
      begin
        parameters := meth.GetParameters;

        if Length(Args) = Length(parameters) then
        begin
          Found := True;
          for Index := 0 to Length(parameters) - 1 do

            if parameters[Index].ParamType.Handle <> Args[Index].TypeInfo then
            begin

              IF Args[Index].IsObject AND Args[Index].AsObject.InheritsFrom
                (parameters[Index].ParamType.AsInstance.MetaclassType) then
              begin

              end
              else
              begin
                Found := false;
                Break;
              end;

            end;
        end;

        if Found then
          Break;
      end;

    if (meth <> nil) and Found then
    begin
      result := meth.Invoke(obj, Args);
    end
    else
      raise Exception.CreateFmt('method %s not found', [AName]);

  finally
    context.Free;
  end;
end;

I wonder whether there are some means to check whether the dedicated type (parameters[Index].ParamType.Handle) has the base type (Args[Index].TypeInfo) ?

Kind regards
André

[TiGü 21]

Are you sure? Did you debug it properly?

Because the line 

if parameters[Index].ParamType.Handle <> Args[Index].TypeInfo then

works for me but because of the following line

if Args[Index].IsObject AND Args[Index].AsObject.InheritsFrom (parameters[Index].ParamType.AsInstance.MetaclassType) then

the Found variable is set to false.

 

So, if you added a new if-condition (or just comment out the IsObject-condition), you will see, that the TRttiMethod is there and can be called:
 

Full Example with a FMX form and a button:

 

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, FMX.StdCtrls,
  System.Rtti;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

function executeInstanceMethod(Reference: Pointer; const AName: string;
  const Args: array of TValue): TValue;
var
  context: TRttiContext;
  instType: TRttiInstanceType;
  obj: TObject;
  meth: TRttiMethod;
  parameters: TArray<TRttiParameter>;
  Found: Boolean;
  index: Integer;
begin
  context := TRttiContext.Create;
  try
    meth := nil;
    Found := false;
    obj := TObject(Reference);
    instType := (context.GetType(obj.ClassType) as TRttiInstanceType);

    for meth in instType.GetMethods do
    begin
      if SameText(meth.Name, AName) then
      begin
        parameters := meth.GetParameters;

        if Length(Args) = Length(parameters) then
        begin
          Found := True;
          for Index := 0 to Length(parameters) - 1 do
          begin
            if parameters[Index].ParamType.Handle <> Args[Index].TypeInfo then
            begin

              if Args[Index].IsObject AND Args[Index].AsObject.InheritsFrom
                (parameters[Index].ParamType.AsInstance.MetaclassType) then
              begin

              end  // I added this line, because TAlphaColor ist obviously a Ordninal and not a class
              else if Args[Index].IsOrdinal then
              begin
                // everything is okay, Found is still True
              end else
              begin
                Found := false;
                Break;
              end;
            end;
          end;
        end;

        if Found then
          Break;
      end;
    end;

    if (meth <> nil) and Found then
    begin
      result := meth.Invoke(obj, Args);
    end
    else
      raise Exception.CreateFmt('method %s not found', [AName]);

  finally
    context.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    MyBitmap: TBitmap;
begin
    MyBitmap := TBitmap.Create(256, 256);
    try
        // if you set a breakpoint in FMX.Graphics.TBitmap.Clear, you will see that the Clear() method is called twice
        MyBitmap.Clear(TAlphaColorRec.Black);
        executeInstanceMethod(MyBitmap, 'Clear', [TAlphaColorRec.Black]);
    finally
        MyBitmap.Free;
    end;
end;

end.

 

[Andre1 0]

Hi,
thanks for having a look. In the button1Click method you have used the dedicated type TAlphaColorRec.Black. This is correct in Delphi but I call the function from another programming language,
therefor I have only the primitive known to C. To simulate the behavior, the button1Click could look like this:

 

procedure TForm1.Button1Click(Sender: TObject);
var
    MyBitmap: TBitmap;
    black_card: Cardinal;
begin
    MyBitmap := TBitmap.Create(256, 256);
    try
        // if you set a breakpoint in FMX.Graphics.TBitmap.Clear, you will see that the Clear() method is called twice
        MyBitmap.Clear(TAlphaColorRec.Black);

        black_card := TAlphaColorRec.Black;
        executeInstanceMethod(MyBitmap, 'Clear', [black_card]);
    finally
        MyBitmap.Free;
    end;
end;

I noticed you added in the method executeInstanceMethod a  very specific solution for this sample. While this works fine for this specific case, it is not generic.
I will fail if the dedicated type is not based on Ordinal type.
 

else if Args[Index].IsOrdinal then

I wonder whether there is some generic function in Delphi to check whether the given arg from the method signature (in this case Cardinal) is the base type of the
called method parameter (in this case TAlphaColor)?

Kind regards
André


 

[TiGü 21]

1 hour ago, Andre1 said:

procedure TForm1.Button1Click(Sender: TObject); var MyBitmap: TBitmap; black_card: Cardinal; begin MyBitmap := TBitmap.Create(256, 256); try // if you set a breakpoint in FMX.Graphics.TBitmap.Clear, you will see that the Clear() method is called twice MyBitmap.Clear(TAlphaColorRec.Black); black_card := TAlphaColorRec.Black; executeInstanceMethod(MyBitmap, 'Clear', [black_card]); finally MyBitmap.Free; end; end;

Hm, for me it works in Win64 Debug with Delphi 11.3 with the direct use of a Cardinal/UInt32 variable.
Do you get other results when you call from the C context?

 

Call Stack

FMX.Graphics.TBitmap.Clear(4278190080)
System.Rtti.RawInvoke(???,???)
System.Rtti.Invoke($E35330,(($E1DF70, Pointer($13D40A0) as IValueData, 0, 6656, 4038203904, $26BF0B21A00, TClass($26BF0B21A00), 0, 6656, -256763392, -4,40958110556075e+29, 1,31551053242737e-311, 1,31551053242737e-311, 2662622960128, 266262296,0128, 2662622960128, 2662622960128, ($26BF0B21A00, nil), $26BF0B21A00), ($C74CA0, Pointer($13D40A0) as IValueData, 0, 0, 4278190080, $FF000000, TClass($FF000000), 0, 0, -16777216, -1,70141183460469e+38, 2,11370674490681e-314, 2,11370674490681e-314, 4278190080, 427819,008, 4278190080, 4278190080, ($FF000000, nil), $FF000000)),ccReg,nil,False,False)
System.Rtti.TRttiInstanceMethodEx.DispatchInvoke(($E1DF70, Pointer($13D40A0) as IValueData, 0, 6656, 4038203904, $26BF0B21A00, TClass($26BF0B21A00), 0, 6656, -256763392, -4,40958110556075e+29, 1,31551053242737e-311, 1,31551053242737e-311, 2662622960128, 266262296,0128, 2662622960128, 2662622960128, ($26BF0B21A00, nil), $26BF0B21A00),(...))
System.Rtti.TRttiMethod.Invoke($26BF0B21A00,(...))
Unit1.executeInstanceMethod($26BF0B21A00,'Clear',(...))
Unit1.TForm1.Button1Click(???)

 

[Andre1 0]

Hi,

it works due to the isOrdinal addition, but this has 2 issues:

 

if Args[Index].IsObject AND Args[Index].AsObject.InheritsFrom
(parameters[Index].ParamType.AsInstance.MetaclassType) then
begin

end  // I added this line, because TAlphaColor ist obviously a Ordninal and not a class
else if Args[Index].IsOrdinal then
begin
// everything is okay, Found is still True
end else

1) The framework I build should work with any dedicated type, not only with Ordinal types. Therefore this solution is limited
to this specific sample (TBitmap.Clear) while I search a solution which will work with any dedicated types, indepedent of the base type.

2) It introduces a bug. Without the isOrdinal addition I will get the exception "Method not found" in case a wrong argument type is provided.
But this does not work now anymore. For example if I call now this method with a cardinal, a conversion exception is thrown instead:

executeInstanceMethod(MyBitmap, 'LoadFromFile', [black_card]);

(As explanation the inheritsFrom function is used to enable calling methods with sub classes. As example, a method expect a class of type
Animal. The Inheritsfrom Method is needed to allow calling the method with a class Dog or Duck. Exactly the same mechanism I search for
the issue with dedicated types).

I need to identify the case that I have a dedicted type and need to verify that the passed argument is the base type of the dedicated type in a generic way.
Therefor it must also work if the dedicated type is not a ordinal....

Kind regards
André
 

[TiGü 21]

And when you break the boolean check for the correct method and argument types into two different variables?

 

function executeInstanceMethod(Reference: Pointer; const AName: string;
  const Args: array of TValue): TValue;
var
  context: TRttiContext;
  instType: TRttiInstanceType;
  obj: TObject;
  meth: TRttiMethod;
  parameters: TArray<TRttiParameter>;
  MethodIsFound, ArgumentTypesAreEqual: Boolean;
  index: Integer;
begin
  context := TRttiContext.Create;
  try
    meth := nil;
    MethodIsFound := false;
    obj := TObject(Reference);
    instType := (context.GetType(obj.ClassType) as TRttiInstanceType);

    for meth in instType.GetMethods do
    begin
      MethodIsFound := SameText(meth.Name, AName);
      if MethodIsFound then
      begin
        parameters := meth.GetParameters;
        ArgumentTypesAreEqual := False;
        if Length(Args) = Length(parameters) then
        begin
          for Index := 0 to Length(parameters) - 1 do
          begin
            ArgumentTypesAreEqual := parameters[Index].ParamType.Handle.Kind = Args[Index].TypeInfo.Kind;

            if not ArgumentTypesAreEqual then
            begin
                raise Exception.CreateFmt('Argument type of %s is not %s, is %s', [parameters[Index].Name, parameters[Index].ParamType.Name, Args[Index].TypeInfo.NameFld.ToString]);
                Break;
            end;
          end;
        end;

        if MethodIsFound then
          Break;
      end;
    end;

    if (meth <> nil) and MethodIsFound and ArgumentTypesAreEqual then
    begin
      result := meth.Invoke(obj, Args);
    end
    else
      raise Exception.CreateFmt('method %s not found', [AName]);

  finally
    context.Free;
  end;
end;

 

Edited 4 hours ago by TiGü

[Andre1 0]

Hi,

thanks I will try. But to get it right, there is no way in Delphi to extract the information from TAlphaColor that it is dedicated type of Cardinal?
Or is the only information I can get from TAlphaColor, that it is a Ordinal type?

Kind regards
André
 

[Kas Ob. 124]

Hi, I tried the following to address the overloading and it work, yet the problem you are speaking of is real problem, 

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, rtti,
  Vcl.StdCtrls;

type
  TMyColor = type Cardinal;

type
  TForm10 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure AddNumberToMemo(Value: string); overload;
    procedure AddNumberToMemo(Value: TMyColor); overload;
    procedure AddMyColorToMemo(Value: TMyColor);
  end;

var
  Form10: TForm10;

implementation

{$R *.dfm}

function ExecuteInstanceMethod(Reference: Pointer; const AName: string; const Args: array of TValue): TValue;
var
  context: TRttiContext;
  instType: TRttiInstanceType;
  obj: TObject;
  meth: TRttiMethod;
  parameters: TArray<TRttiParameter>;
  MethodIsFound, ArgumentTypesAreEqual: Boolean;
  index: Integer;
  LastError: string;
begin
  context := TRttiContext.Create;
  try
    meth := nil;
    MethodIsFound := false;
    obj := TObject(Reference);
    instType := (context.GetType(obj.ClassType) as TRttiInstanceType);

    for meth in instType.GetMethods do
    begin
      MethodIsFound := SameText(meth.Name, AName);
      if MethodIsFound then
      begin
        parameters := meth.GetParameters;
        ArgumentTypesAreEqual := False;
        if Length(Args) = Length(parameters) then
        begin
          for index := 0 to Length(parameters) - 1 do
          begin
            ArgumentTypesAreEqual := parameters[index].ParamType.Handle.Kind = Args[index].TypeInfo.Kind;

            if not ArgumentTypesAreEqual then
            begin
              LastError := 'Argument type of ' + parameters[index].Name + ' is not ' + parameters[index].ParamType.Name + ', it is ' + Args[index].TypeInfo.NameFld.ToString;
              //raise Exception.CreateFmt('Argument type of %s is not %s, is %s', [parameters[index].Name, parameters[index].ParamType.Name, Args[index].TypeInfo.NameFld.ToString]);
              //Break;
            end;
          end;
        end;

        if MethodIsFound and ArgumentTypesAreEqual then
          Break;
      end;
    end;

    if (LastError <> '') and not (MethodIsFound and ArgumentTypesAreEqual) then
      Form10.Memo1.Lines.Add(LastError);
      //raise Exception.Create(LastError);

    if (meth <> nil) and MethodIsFound and ArgumentTypesAreEqual then
    begin
      result := meth.Invoke(obj, Args);
    end
    else
      Form10.Memo1.Lines.Add('method ' + AName + ' not found');
      //raise Exception.CreateFmt('method %s not found', [AName]);

  finally
    context.Free;
  end;
end;

procedure TForm10.AddNumberToMemo(Value: string);
begin
  Memo1.Lines.Add(Value);
end;

procedure TForm10.AddNumberToMemo(Value: TMyColor);
begin
  Memo1.Lines.Add(IntToStr(Value));
end;

procedure TForm10.AddMyColorToMemo(Value: TMyColor);
begin
  Memo1.Lines.Add(IntToStr(Value));
end;

procedure TForm10.FormCreate(Sender: TObject);
var
  T: TMyColor;
begin
  // addressing overload
  ExecuteInstanceMethod(Self, 'AddNumberToMemo', [100]);
  ExecuteInstanceMethod(Self, 'AddNumberToMemo', ['Color3']);

  T := 99;
  ExecuteInstanceMethod(Self, 'AddMyColorToMemo', [55]);
  ExecuteInstanceMethod(Self, 'AddMyColorToMemo', [T]);    // T handled as Int64 !
end;

end.

the result in memo is 

100
Color3
55
Argument type of Value is not TMyColor, it is Int64
method AddMyColorToMemo not found

 

Now, my IDE is XE8, and i have %50 confidence that this behavior might have changed overtime for RTTI, yet i didn't tested it with my older IDEs, i will assume it irrelevant for any of you, yet you may want to make sure that the compiler behavior with RTTI is consistent for newer versions.

 

As for the exact problem i saw above which i assume is your question to begin with (i might be wrong and missed that), if RTTI only will return TMyColor then you need to search and globally of the included/shipped RTTI to try and resolve TMyColor to its base (origin), if that work then it could be resolvable by building a table then cache it for multiple reuse.

 

That is the problem with RTTI, once you typed a type then there is few moving parts, hidden and silent done by the compiler.