diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index 38810eda6a..1a7b5728c4 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -113,9 +113,11 @@ type public class function Empty: TValue; static; class procedure Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); static; + class procedure Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result: TValue); static; inline; { Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! } class procedure MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue); static; {$ifndef NoGenericMethods} + generic class procedure Make(const AValue: T; out Result: TValue); static; inline; generic class function From(constref aValue: T): TValue; static; inline; { Note: a TValue based on an open array is only valid until the routine having the open array parameter is left! } generic class function FromOpenArray(constref aValue: array of T): TValue; static; inline; @@ -1722,6 +1724,11 @@ begin end; end; +class procedure TValue.Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result: TValue); +begin + TValue.Make(@AValue, ATypeInfo, Result); +end; + class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue); var el: TValue; @@ -1749,6 +1756,11 @@ begin end; {$ifndef NoGenericMethods} +generic class procedure TValue.Make(const AValue: T; out Result: TValue); +begin + TValue.Make(@AValue, PTypeInfo(System.TypeInfo(T)), Result); +end; + generic class function TValue.From(constref aValue: T): TValue; begin TValue.Make(@aValue, PTypeInfo(System.TypeInfo(T)), Result); diff --git a/packages/rtl-objpas/tests/tests.rtti.pas b/packages/rtl-objpas/tests/tests.rtti.pas index e72c6d714d..509eea0638 100644 --- a/packages/rtl-objpas/tests/tests.rtti.pas +++ b/packages/rtl-objpas/tests/tests.rtti.pas @@ -78,6 +78,16 @@ type procedure TestMakeAnsiChar; procedure TestMakeWideChar; + procedure TestMakeNativeInt; + + procedure TestMakeGenericNil; + procedure TestMakeGenericLongInt; + procedure TestMakeGenericString; + procedure TestMakeGenericObject; + procedure TestMakeGenericDouble; + procedure TestMakeGenericAnsiChar; + procedure TestMakeGenericWideChar; + procedure TestFromOrdinal; procedure TestDataSize; @@ -795,6 +805,188 @@ begin Check(v.AsWideChar = #$1234); end; +procedure TTestCase1.TestMakeNativeInt; +var + fni: NativeInt; + s: AnsiString; + v: TValue; + o: TObject; +begin + fni := 2021; + + TValue.Make(fni, TypeInfo(LongInt), v); + CheckEquals(v.IsClass, False); + CheckEquals(v.IsObject, False); + CheckEquals(v.IsOrdinal, True); + Check(NativeInt(v.GetReferenceToRawData) <> fni); + CheckEquals(v.AsOrdinal, 2021); + + s := 'Hello World'; + TValue.Make(NativeInt(s), TypeInfo(AnsiString), v); + CheckEquals(v.IsClass, False); + CheckEquals(v.IsObject, False); + CheckEquals(v.IsOrdinal, False); + CheckEquals(v.AsString, s); + + o := TObject.Create; + TValue.Make(NativeInt(o), TypeInfo(TObject), v); + CheckEquals(v.IsClass, False); + CheckEquals(v.IsObject, True); + CheckEquals(v.IsOrdinal, False); + Check(PPointer(v.GetReferenceToRawData)^ = Pointer(o)); + Check(v.AsObject = o); + o.Free; +end; + +procedure TTestCase1.TestMakeGenericNil; +var + value: TValue; +begin + TValue.{$ifdef fpc}specialize{$endif} Make(Nil, value); + CheckTrue(value.IsEmpty); + CheckTrue(value.IsObject); + CheckTrue(value.IsClass); + CheckTrue(value.IsOrdinal); + CheckFalse(value.IsArray); + CheckTrue(value.AsObject=Nil); + CheckTrue(value.AsClass=Nil); + CheckTrue(value.AsInterface=Nil); + CheckEquals(0, value.AsOrdinal); + + TValue.{$ifdef fpc}specialize{$endif} Make(Nil, value); + CheckTrue(value.IsEmpty); + CheckTrue(value.IsClass); + CheckTrue(value.IsOrdinal); + CheckFalse(value.IsArray); + CheckTrue(value.AsObject=Nil); + CheckTrue(value.AsClass=Nil); + CheckTrue(value.AsInterface=Nil); + CheckEquals(0, value.AsOrdinal); +end; + +procedure TTestCase1.TestMakeGenericLongInt; +var + value: TValue; +begin + TValue.{$ifdef fpc}specialize{$endif} Make(0, value); + CheckTrue(value.IsOrdinal); + CheckFalse(value.IsEmpty); + CheckFalse(value.IsClass); + CheckFalse(value.IsObject); + CheckFalse(value.IsArray); + CheckEquals(0, value.AsOrdinal); + CheckEquals(0, value.AsInteger); + CheckEquals(0, value.AsInt64); + CheckEquals(0, value.AsUInt64); +end; + +procedure TTestCase1.TestMakeGenericString; +var + value: TValue; +begin + TValue.{$ifdef fpc}specialize{$endif} Make('test', value); + CheckFalse(value.IsEmpty); + CheckFalse(value.IsObject); + CheckFalse(value.IsClass); + CheckFalse(value.IsArray); + CheckEquals('test', value.AsString); +end; + +procedure TTestCase1.TestMakeGenericObject; +var + value: TValue; + TestClass: TTestValueClass; +begin + TestClass := TTestValueClass.Create; + TestClass.AInteger := 54329; + TValue.{$ifdef fpc}specialize{$endif} Make(TestClass, value); + CheckEquals(value.IsClass, False); + CheckEquals(value.IsObject, True); + Check(value.AsObject=TestClass); + Check(PPointer(value.GetReferenceToRawData)^ = Pointer(TestClass)); + CheckEquals(TTestValueClass(value.AsObject).AInteger, 54329); + TestClass.Free; +end; + +procedure TTestCase1.TestMakeGenericDouble; +var + fd: Double; + v: TValue; + hadexcept: Boolean; +begin + fd := 3.14; + + TValue.{$ifdef fpc}specialize{$endif} Make(fd, v); + CheckEquals(v.IsClass, False); + CheckEquals(v.IsObject, False); + CheckEquals(v.IsOrdinal, False); + Check(v.AsExtended=fd); + Check(v.GetReferenceToRawData <> @fd); + + try + hadexcept := False; + v.AsInt64; + except + hadexcept := True; + end; + + CheckTrue(hadexcept, 'No signed type conversion exception'); + + try + hadexcept := False; + v.AsUInt64; + except + hadexcept := True; + end; + + CheckTrue(hadexcept, 'No unsigned type conversion exception'); +end; + + +procedure TTestCase1.TestMakeGenericAnsiChar; +var + c: AnsiChar; + v: TValue; +begin + c := #20; + + TValue.{$ifdef fpc}specialize{$endif} Make(c, v); + Check(not v.IsClass); + Check(not v.IsArray); + Check(not v.IsEmpty); +{$ifdef fpc} + Check(not v.IsOpenArray); +{$endif} + Check(not v.IsObject); + Check(v.IsOrdinal); + + Check(v.GetReferenceToRawData <> @c); + Check(AnsiChar(v.AsOrdinal) = #20); + Check(v.AsAnsiChar = #20); +end; + +procedure TTestCase1.TestMakeGenericWideChar; +var + c: WideChar; + v: TValue; +begin + c := #$1234; + + TValue.{$ifdef fpc}specialize{$endif} Make(c, v); + Check(not v.IsClass); + Check(not v.IsArray); + Check(not v.IsEmpty); +{$ifdef fpc} + Check(not v.IsOpenArray); +{$endif} + Check(not v.IsObject); + Check(v.IsOrdinal); + + Check(v.GetReferenceToRawData <> @c); + Check(WideChar(v.AsOrdinal) = #$1234); + Check(v.AsWideChar = #$1234); +end; + procedure TTestCase1.MakeFromOrdinalTObject; begin TValue.FromOrdinal(TypeInfo(TObject), 42);