Browse Source

+ add Rtti types for static and dynamic arrays
+ added tests

Sven/Sarah Barth 3 years ago
parent
commit
caaed25f18
2 changed files with 176 additions and 0 deletions
  1. 74 0
      packages/rtl-objpas/src/inc/rtti.pp
  2. 102 0
      packages/rtl-objpas/tests/tests.rtti.pas

+ 74 - 0
packages/rtl-objpas/src/inc/rtti.pp

@@ -312,6 +312,32 @@ type
     property ReferredType: TRttiType read GetReferredType;
     property ReferredType: TRttiType read GetReferredType;
   end;
   end;
 
 
+  TRttiArrayType = class(TRttiType)
+  private
+    function GetDimensionCount: SizeUInt; inline;
+    function GetDimension(aIndex: SizeInt): TRttiType; inline;
+    function GetElementType: TRttiType; inline;
+    function GetTotalElementCount: SizeInt; inline;
+  public
+    property DimensionCount: SizeUInt read GetDimensionCount;
+    property Dimensions[Index: SizeInt]: TRttiType read GetDimension;
+    property ElementType: TRttiType read GetElementType;
+    property TotalElementCount: SizeInt read GetTotalElementCount;
+  end;
+
+  TRttiDynamicArrayType = class(TRttiType)
+  private
+    function GetDeclaringUnitName: String; inline;
+    function GetElementSize: SizeUInt; inline;
+    function GetElementType: TRttiType; inline;
+    function GetOleAutoVarType: TVarType; inline;
+  public
+    property DeclaringUnitName: String read GetDeclaringUnitName;
+    property ElementSize: SizeUInt read GetElementSize;
+    property ElementType: TRttiType read GetElementType;
+    property OleAutoVarType: TVarType read GetOleAutoVarType;
+  end;
+
   { TRttiMember }
   { TRttiMember }
 
 
   TMemberVisibility=(mvPrivate, mvProtected, mvPublic, mvPublished);
   TMemberVisibility=(mvPrivate, mvProtected, mvPublic, mvPublished);
@@ -1274,6 +1300,8 @@ begin
           tkClass   : Result := TRttiInstanceType.Create(ATypeInfo);
           tkClass   : Result := TRttiInstanceType.Create(ATypeInfo);
           tkInterface: Result := TRttiRefCountedInterfaceType.Create(ATypeInfo);
           tkInterface: Result := TRttiRefCountedInterfaceType.Create(ATypeInfo);
           tkInterfaceRaw: Result := TRttiRawInterfaceType.Create(ATypeInfo);
           tkInterfaceRaw: Result := TRttiRawInterfaceType.Create(ATypeInfo);
+          tkArray: Result := TRttiArrayType.Create(ATypeInfo);
+          tkDynArray: Result := TRttiDynamicArrayType.Create(ATypeInfo);
           tkInt64,
           tkInt64,
           tkQWord: Result := TRttiInt64Type.Create(ATypeInfo);
           tkQWord: Result := TRttiInt64Type.Create(ATypeInfo);
           tkInteger,
           tkInteger,
@@ -2590,6 +2618,52 @@ begin
   Result := GRttiPool.GetType(FTypeData^.RefType);
   Result := GRttiPool.GetType(FTypeData^.RefType);
 end;
 end;
 
 
+{ TRttiArrayType }
+
+function TRttiArrayType.GetDimensionCount: SizeUInt;
+begin
+  Result := FTypeData^.ArrayData.DimCount;
+end;
+
+function TRttiArrayType.GetDimension(aIndex: SizeInt): TRttiType;
+begin
+  if aIndex >= FTypeData^.ArrayData.DimCount then
+    raise ERtti.CreateFmt(SErrDimensionOutOfRange, [aIndex, FTypeData^.ArrayData.DimCount]);
+  Result := GRttiPool.GetType(FTypeData^.ArrayData.Dims[Byte(aIndex)]);
+end;
+
+function TRttiArrayType.GetElementType: TRttiType;
+begin
+  Result := GRttiPool.GetType(FTypeData^.ArrayData.ElType);
+end;
+
+function TRttiArrayType.GetTotalElementCount: SizeInt;
+begin
+  Result := FTypeData^.ArrayData.ElCount;
+end;
+
+{ TRttiDynamicArrayType }
+
+function TRttiDynamicArrayType.GetDeclaringUnitName: String;
+begin
+  Result := FTypeData^.DynUnitName;
+end;
+
+function TRttiDynamicArrayType.GetElementSize: SizeUInt;
+begin
+  Result := FTypeData^.elSize;
+end;
+
+function TRttiDynamicArrayType.GetElementType: TRttiType;
+begin
+  Result := GRttiPool.GetType(FTypeData^.ElType2);
+end;
+
+function TRttiDynamicArrayType.GetOleAutoVarType: TVarType;
+begin
+  Result := Word(FTypeData^.varType);
+end;
+
 { TRttiRefCountedInterfaceType }
 { TRttiRefCountedInterfaceType }
 
 
 function TRttiRefCountedInterfaceType.IntfData: PInterfaceData;
 function TRttiRefCountedInterfaceType.IntfData: PInterfaceData;

+ 102 - 0
packages/rtl-objpas/tests/tests.rtti.pas

@@ -105,6 +105,9 @@ type
     procedure TestInterfaceRaw;
     procedure TestInterfaceRaw;
 {$endif}
 {$endif}
 
 
+    procedure TestArray;
+    procedure TestDynArray;
+
     procedure TestProcVar;
     procedure TestProcVar;
     procedure TestMethod;
     procedure TestMethod;
 
 
@@ -246,6 +249,7 @@ type
 
 
   TArrayOfLongintDyn = array of LongInt;
   TArrayOfLongintDyn = array of LongInt;
   TArrayOfLongintStatic = array[0..3] of LongInt;
   TArrayOfLongintStatic = array[0..3] of LongInt;
+  TArrayOfLongint2DStatic = array[0..3, 2..4] of LongInt;
 
 
   TTestRecord = record
   TTestRecord = record
     Value1: LongInt;
     Value1: LongInt;
@@ -2675,6 +2679,104 @@ begin
 end;
 end;
 {$endif}
 {$endif}
 
 
+procedure TTestCase1.TestArray;
+var
+  context: TRttiContext;
+  t, el: TRttiType;
+  a: TRttiArrayType;
+  o: TRttiOrdinalType;
+begin
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(PTypeInfo(TypeInfo(TArrayOfLongintStatic)));
+    Check(t is TRttiArrayType, 'Type is not a TRttiArrayType');
+
+    a := TRttiArrayType(t);
+    CheckEquals(1, a.DimensionCount, 'Dimension count does not match');
+    CheckEquals(4, a.TotalElementCount, 'Total element count does not match');
+
+    el := a.ElementType;
+    Check(el is TRttiOrdinalType, 'Element type is not a TRttiOrdinalType');
+    Check(el = context.GetType(PTypeInfo(TypeInfo(LongInt))), 'Element type is not a LongInt');
+
+    t := a.Dimensions[0];
+    {$ifdef fpc}
+    Check(t is TRttiOrdinalType, 'Index type is not a TRttiOrdinalType');
+
+    o := TRttiOrdinalType(t);
+    { Currently this is a full type :/ }
+    {CheckEquals(0, o.MinValue, 'Minimum value of 1st dimension does not match');
+    CheckEquals(3, o.MaxValue, 'Maximum value of 1st dimension does not match');}
+    {$else}
+    Check(t = Nil, 'Index type is not Nil');
+    {$endif}
+
+    t := context.GetType(PTypeInfo(TypeInfo(TArrayOfLongint2DStatic)));
+    Check(t is TRttiArrayType, 'Type is not a TRttiArrayType');
+
+    a := TRttiArrayType(t);
+    CheckEquals(2, a.DimensionCount, 'Dimension count does not match');
+    CheckEquals(4 * 3, a.TotalElementCount, 'Total element count does not match');
+
+    el := a.ElementType;
+    Check(el is TRttiOrdinalType, 'Element type is not a TRttiOrdinalType');
+    Check(el = context.GetType(PTypeInfo(TypeInfo(LongInt))), 'Element type is not a LongInt');
+
+    t := a.Dimensions[0];
+    {$ifdef fpc}
+    Check(t is TRttiOrdinalType, 'Index type is not a TRttiOrdinalType');
+
+    o := TRttiOrdinalType(t);
+    { Currently this is a full type :/ }
+    {CheckEquals(0, o.MinValue, 'Minimum value of 1st dimension does not match');
+    CheckEquals(3, o.MaxValue, 'Maximum value of 1st dimension does not match');}
+    {$else}
+    Check(t = Nil, 'Index type is not Nil');
+    {$endif}
+
+    t := a.Dimensions[1];
+    {$ifdef fpc}
+    Check(t is TRttiOrdinalType, 'Index type is not a TRttiOrdinalType');
+
+    o := TRttiOrdinalType(t);
+    { Currently this is a full type :/ }
+    {CheckEquals(2, o.MinValue, 'Minimum value of 1st dimension does not match');
+    CheckEquals(4, o.MaxValue, 'Maximum value of 1st dimension does not match');}
+    {$else}
+    Check(t = Nil, 'Index type is not Nil');
+    {$endif}
+  finally
+    context.Free;
+  end;
+end;
+
+procedure TTestCase1.TestDynArray;
+var
+  context: TRttiContext;
+  t, el: TRttiType;
+  a: TRttiDynamicArrayType;
+begin
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(PTypeInfo(TypeInfo(TArrayOfLongintDyn)));
+    Check(t is TRttiDynamicArrayType, 'Type is not a TRttiDynamicArrayType');
+
+    a := TRttiDynamicArrayType(t);
+
+    CheckEquals('tests.rtti', LowerCase(a.DeclaringUnitName), 'Unit type does not match for dynamic array');
+    CheckEquals(a.ElementSize, SizeUInt(SizeOf(LongInt)), 'Element size does not match for dynamic array');
+
+    el := a.ElementType;
+    Check(el is TRttiOrdinalType, 'Element type is not a TRttiOrdinalType');
+
+    Check(el = context.GetType(PTypeInfo(TypeInfo(LongInt))), 'Element type is not a LongInt');
+
+    { ToDo: check OLE type }
+  finally
+    context.Free;
+  end;
+end;
+
 procedure TTestCase1.TestProcVar;
 procedure TTestCase1.TestProcVar;
 var
 var
   context: TRttiContext;
   context: TRttiContext;