View Issue Details

IDProjectCategoryView StatusLast Update
0038381FPCRTLpublic2021-05-13 11:53
Reporterravi dion Assigned ToSven Barth  
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Product Version3.3.1 
Fixed in Version3.3.1 
Summary0038381: Add TValue.Make functions
DescriptionFPC does not yet support Delphi methods:

class procedure Make(AValue: NativeInt; ATypeInfo: PTypeInfo; var Result: TValue); overload; static;
class procedure Make<T>(const Value: T; var Result: TValue); overload; static; inline;

see http://docwiki.embarcadero.com/Libraries/Sydney/en/System.Rtti.TValue.Make
TagsNo tags attached.
Fixed in Revision49327
FPCOldBugId
FPCTarget-
Attached Files

Activities

Bi0T1N

2021-01-23 17:53

reporter   ~0128528

Last edited: 2021-01-23 17:54

View 2 revisions

The generic implementation is pretty straight forward, see below. The NativeInt version should be similar to the Pointer method but I don't see why one would need a version for NativeInt?

Implementation:
  TValue = record
  public
    ...
{$ifndef NoGenericMethods}
    generic class procedure Make<T>(const Value: T; out Result: TValue); overload; static; inline;
{$endif}
    ...
  end;

{$ifndef NoGenericMethods}
generic class procedure TValue.Make<T>(const Value: T; out Result: TValue);
begin
  TValue.Make(@Value, TypeInfo(T), Result);
end;
{$endif}


Simple tests:
procedure TTestCase1.TestMakeGenericNil;
var
  value: TValue;
begin
  TValue.specialize Make<TObject>(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.specialize Make<TClass>(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);

  TValue.specialize Make<LongInt>(Nil, 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);

  TValue.specialize Make<String>(Nil, value);
  CheckFalse(value.IsEmpty);
  CheckFalse(value.IsObject);
  CheckFalse(value.IsClass);
  CheckFalse(value.IsArray);
  CheckEquals('', value.AsString);
end;

procedure TTestCase1.TestMakeGenericObject;
var
  AValue: TValue;
  ATestClass: TTestValueClass;
begin
  ATestClass := TTestValueClass.Create;
  ATestClass.AInteger := 54329;
  TValue.specialize Make<TTestValueClass>(ATestClass, AValue);
  CheckEquals(AValue.IsClass, False);
  CheckEquals(AValue.IsObject, True);
  Check(AValue.AsObject=ATestClass);
  Check(PPointer(AValue.GetReferenceToRawData)^ = Pointer(ATestClass));
  CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
  ATestClass.Free;
end;

procedure TTestCase1.TestMakeGenericDouble;
var
  fd: Double;
  v: TValue;
  hadexcept: Boolean;
begin
  fd := 3.14;

  TValue.specialize Make<Double>(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;

Sven Barth

2021-01-24 12:24

manager   ~0128551

The NativeInt variant is required, because Delphi provides it. Though back when I gave it a try I think there were a few problems when making a TypeInfo(AnsiString) and such (or at least to write nice, consistent tests for it...)

Bi0T1N

2021-01-24 21:41

reporter   ~0128574

I thought the code for NativeInt would be:
class procedure Make(Value: NativeInt; TypeInfo: PTypeInfo; out Result: TValue); overload; static; inline;
...
class procedure TValue.Make(Value: NativeInt; TypeInfo: PTypeInfo; out Result: TValue);
begin
  TValue.Make(@Value, TypeInfo, Result);
end;

and that's why I said I don't see why this was added by Delphi in the first place.

Sven Barth

2021-01-25 14:19

manager   ~0128587

Probably some low level functionality inside the Rtti unit uses it (e.g. the Invoke or virtual interface stuff).

Bi0T1N

2021-04-30 18:02

reporter   ~0130683

Would it help if I provide the changes as patch file to get it merged?

Michael Van Canneyt

2021-05-01 08:35

administrator   ~0130699

Yes. A patch will usually be applied faster.

Bi0T1N

2021-05-01 15:17

reporter   ~0130702

Patch attached.
01-Add_TValue_Make_functions.patch (6,476 bytes)   
diff --git packages/rtl-objpas/src/inc/rtti.pp packages/rtl-objpas/src/inc/rtti.pp
index 38810eda6a..1a7b5728c4 100644
--- packages/rtl-objpas/src/inc/rtti.pp
+++ 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<T>(const AValue: T; out Result: TValue); static; inline;
     generic class function From<T>(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<T>(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<T>(const AValue: T; out Result: TValue);
+begin
+  TValue.Make(@AValue, PTypeInfo(System.TypeInfo(T)), Result);
+end;
+
 generic class function TValue.From<T>(constref aValue: T): TValue;
 begin
   TValue.Make(@aValue, PTypeInfo(System.TypeInfo(T)), Result);
diff --git packages/rtl-objpas/tests/tests.rtti.pas packages/rtl-objpas/tests/tests.rtti.pas
index 18e04b0c82..4da6034358 100644
--- packages/rtl-objpas/tests/tests.rtti.pas
+++ 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;
@@ -778,6 +788,166 @@ begin
   Check(v.AsWideChar = #$1234);
 end;
 
+procedure TTestCase1.TestMakeNativeInt;
+var
+  fni: NativeInt;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fni := 2021;
+
+  TValue.Make(@fni, TypeInfo(fni), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, True);
+  Check(v.GetReferenceToRawData <> @fni);
+end;
+
+procedure TTestCase1.TestMakeGenericNil;
+var
+  value: TValue;
+begin
+  TValue.specialize Make<TObject>(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.specialize Make<TClass>(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.specialize Make<LongInt>(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.specialize Make<String>('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.specialize Make<TTestValueClass>(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.specialize Make<Double>(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.specialize Make<AnsiChar>(c, v);
+  Check(not v.IsClass);
+  Check(not v.IsArray);
+  Check(not v.IsEmpty);
+  Check(not v.IsOpenArray);
+  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.specialize Make<WideChar>(c, v);
+  Check(not v.IsClass);
+  Check(not v.IsArray);
+  Check(not v.IsEmpty);
+  Check(not v.IsOpenArray);
+  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);

jamie philbrook

2021-05-01 16:06

reporter   ~0130704

I just can't understand what appears to be a simple problem ends up to be a massive load of bloat..

There are some here that seems like that is all they want to do, is find ways to fatten the compiler up more and more using the lardiest methods possible.

I can see how Delphi is going to win this game.

Sven Barth

2021-05-02 14:38

manager   ~0130722

@jamie philbrook: this does in no way affect the compiler, its only contained in the Rtti unit not to mention that this code is for Delphi compatiblity.

Sven Barth

2021-05-02 21:10

manager   ~0130728

@Bi0T1N: Thank you for the patch. I've applied it with slight adjustments to the tests so that they can be compiled with Delphi as well.

Please test and close if okay.

ravi dion

2021-05-13 11:53

reporter   ~0130849

THX!!!

Issue History

Date Modified Username Field Change
2021-01-21 16:42 ravi dion New Issue
2021-01-23 17:53 Bi0T1N Note Added: 0128528
2021-01-23 17:54 Bi0T1N Note Edited: 0128528 View Revisions
2021-01-24 12:24 Sven Barth Note Added: 0128551
2021-01-24 21:41 Bi0T1N Note Added: 0128574
2021-01-25 14:19 Sven Barth Note Added: 0128587
2021-04-30 18:02 Bi0T1N Note Added: 0130683
2021-05-01 08:35 Michael Van Canneyt Note Added: 0130699
2021-05-01 15:17 Bi0T1N Note Added: 0130702
2021-05-01 15:17 Bi0T1N File Added: 01-Add_TValue_Make_functions.patch
2021-05-01 16:06 jamie philbrook Note Added: 0130704
2021-05-02 14:38 Sven Barth Note Added: 0130722
2021-05-02 21:10 Sven Barth Assigned To => Sven Barth
2021-05-02 21:10 Sven Barth Status new => resolved
2021-05-02 21:10 Sven Barth Resolution open => fixed
2021-05-02 21:10 Sven Barth Fixed in Version => 3.3.1
2021-05-02 21:10 Sven Barth Fixed in Revision => 49327
2021-05-02 21:10 Sven Barth FPCTarget => -
2021-05-02 21:10 Sven Barth Note Added: 0130728
2021-05-13 11:53 ravi dion Status resolved => closed
2021-05-13 11:53 ravi dion Note Added: 0130849