rtl: added simple TRttiContext to support querying attributes like Delphi

packages/rtl/rtti.pas

@@ -13,11 +13,12 @@
 unit RTTI;
 
 {$mode objfpc}
+{$ModeSwitch advancedrecords}
 
 interface
 
 uses
-  SysUtils, Types, TypInfo, JS;
+  Types, TypInfo, JS;
 
 resourcestring
   SErrInvokeInvalidCodeAddr = 'CodeAddress is not a function';
@@ -27,6 +28,79 @@ type
   // operator overloading is implemented
   TValue = JSValue;
 
+  TRttiType = class;
+
+  { TRTTIContext }
+
+  TRTTIContext = record
+  private
+    FPool: TJSObject; // maps 'modulename.typename' to TRTTIType
+  public
+    class function Create: TRTTIContext; static;
+    procedure Free;
+
+    function GetType(aTypeInfo: PTypeInfo): TRTTIType; overload;
+    function GetType(aClass: TClass): TRTTIType; overload;
+  end;
+
+  { TRttiObject }
+
+  TRttiObject = class abstract
+  protected
+    //function GetHandle: Pointer; virtual; abstract;
+  public
+    //property Handle: Pointer read GetHandle;
+    function GetAttributes: TCustomAttributeArray; virtual;
+  end;
+
+  { TRttiNamedObject }
+
+  TRttiNamedObject = class(TRttiObject)
+  protected
+    function GetName: string; virtual;
+  public
+    property Name: string read GetName;
+  end;
+
+  { TRttiType }
+
+  TRttiType = class(TRttiNamedObject)
+  private
+    FAttributes: TCustomAttributeArray;
+    FTypeInfo: TTypeInfo;
+    //FMethods: specialize TArray<TRttiMethod>;
+    //function GetAsInstance: TRttiInstanceType;
+  protected
+    function GetName: string; override;
+    //function GetHandle: Pointer; override;
+    function GetIsInstance: boolean; virtual;
+    //function GetIsManaged: boolean; virtual;
+    function GetIsOrdinal: boolean; virtual;
+    function GetIsRecord: boolean; virtual;
+    function GetIsSet: boolean; virtual;
+    function GetTypeKind: TTypeKind; virtual;
+    //function GetTypeSize: integer; virtual;
+    //function GetBaseType: TRttiType; virtual;
+  public
+    constructor Create(ATypeInfo : PTypeInfo);
+    destructor Destroy; override;
+    function GetAttributes: TCustomAttributeArray; override;
+    //function GetProperties: specialize TArray<TRttiProperty>; virtual;
+    //function GetProperty(const AName: string): TRttiProperty; virtual;
+    //function GetMethods: specialize TArray<TRttiMethod>; virtual;
+    //function GetMethod(const aName: String): TRttiMethod; virtual;
+    //function GetDeclaredMethods: specialize TArray<TRttiMethod>; virtual;
+    property IsInstance: boolean read GetIsInstance;
+    //property isManaged: boolean read GetIsManaged;
+    property IsOrdinal: boolean read GetIsOrdinal;
+    property IsRecord: boolean read GetIsRecord;
+    property IsSet: boolean read GetIsSet;
+    //property BaseType: TRttiType read GetBaseType;
+    //property AsInstance: TRttiInstanceType read GetAsInstance;
+    property TypeKind: TTypeKind read GetTypeKind;
+    //property TypeSize: integer read GetTypeSize;
+  end;
+
   EInvoke = EJS;
 
   TVirtualInterfaceInvokeEvent = function(const aMethodName: string;
@@ -72,6 +146,118 @@ asm
   IntfVar.set(i);
 end;
 
+{ TRTTIContext }
+
+class function TRTTIContext.Create: TRTTIContext;
+begin
+  Result.FPool:=TJSObject.new;
+end;
+
+procedure TRTTIContext.Free;
+var
+  key: string;
+  o: TRttiType;
+begin
+  for key in FPool do
+    if FPool.hasOwnProperty(key) then begin
+      o:=TRTTIType(FPool[key]);
+      o.Free;
+      end;
+  FPool:=nil;
+end;
+
+function TRTTIContext.GetType(aTypeInfo: Pointer): TRTTIType;
+var
+  t: TTypeinfo absolute aTypeInfo;
+  Name: String;
+begin
+  if aTypeInfo=nil then exit(nil);
+  Name:=t.Name;
+  if isModule(t.Module) then
+    Name:=t.Module.Name+'.'+Name;
+  if FPool.hasOwnProperty(Name) then
+    Result:=TRttiType(FPool[Name])
+  else
+    begin
+    Result:=TRttiType.Create(aTypeInfo);
+    FPool[Name]:=Result;
+    end;
+end;
+
+function TRTTIContext.GetType(aClass: TClass): TRTTIType;
+begin
+  if aClass=nil then exit(nil);
+  Result:=GetType(TypeInfo(aClass));
+end;
+
+{ TRttiObject }
+
+function TRttiObject.GetAttributes: TCustomAttributeArray;
+begin
+  Result:=nil;
+end;
+
+{ TRttiNamedObject }
+
+function TRttiNamedObject.GetName: string;
+begin
+  Result:='';
+end;
+
+{ TRttiType }
+
+function TRttiType.GetName: string;
+begin
+  Result:=FTypeInfo.Name;
+end;
+
+function TRttiType.GetIsInstance: boolean;
+begin
+  Result:=false;
+end;
+
+function TRttiType.GetIsOrdinal: boolean;
+begin
+  Result:=false;
+end;
+
+function TRttiType.GetIsRecord: boolean;
+begin
+  Result:=false;
+end;
+
+function TRttiType.GetIsSet: boolean;
+begin
+  Result:=false;
+end;
+
+function TRttiType.GetTypeKind: TTypeKind;
+begin
+  Result:=FTypeInfo.Kind;
+end;
+
+constructor TRttiType.Create(ATypeInfo: PTypeInfo);
+begin
+  inherited Create();
+  FTypeInfo:=TTypeInfo(ATypeInfo);
+end;
+
+destructor TRttiType.Destroy;
+var
+  o: TCustomAttribute;
+begin
+  for o in FAttributes do
+    o.Free;
+  FAttributes:=nil;
+  inherited Destroy;
+end;
+
+function TRttiType.GetAttributes: TCustomAttributeArray;
+begin
+  FAttributes:=GetRTTIAttributes(FTypeInfo.Attributes);
+  Result:=FAttributes;
+end;
+
 { TVirtualInterface }
 
 constructor TVirtualInterface.Create(InterfaceTypeInfo: Pointer); assembler;
@@ -120,6 +306,11 @@ function Invoke(ACodeAddress: Pointer; const AArgs: TJSValueDynArray;
   ACallConv: TCallConv; AResultType: PTypeInfo; AIsStatic: Boolean;
   AIsConstructor: Boolean): TValue;
 begin
+  if ACallConv=ccReg then ;
+  if AResultType=nil then ;
+  if AIsStatic then ;
+  if AIsConstructor then
+    raise EInvoke.Create('not supported');
   if isFunction(ACodeAddress) then
     Result := TJSFunction(ACodeAddress).apply(nil, AArgs)
   else

packages/rtl/typinfo.pas

@@ -68,6 +68,14 @@ const
   tkProperties = tkAny-tkMethods-[tkUnknown];
 
 type
+
+  { TTypeInfoModule }
+
+  TTypeInfoModule = class external name 'pasmodule'
+  public
+    Name: String external name '$name';
+  end;
+
   TTypeInfoAttributes = type TJSValueDynArray;
 
   { TTypeInfo }
@@ -77,6 +85,7 @@ type
     Name: String external name 'name';
     Kind: TTypeKind external name 'kind';
     Attributes: TTypeInfoAttributes external name 'attr'; // can be undefined
+    Module: TTypeInfoModule external name '$module'; // can be undefined
   end;
   TTypeInfoClassOf = class of TTypeInfo;