From c670c026d5297f558947edd3941f767296eb7cac Mon Sep 17 00:00:00 2001
From: svenbarth <svenbarth@3ad0048d-3df7-0310-abae-a5850022a9f2>
Date: Thu, 13 Jun 2019 21:08:44 +0000
Subject: * fix for Mantis #35687: implement TValue.FromOrdinal() + added tests

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@42221 3ad0048d-3df7-0310-abae-a5850022a9f2
---
 packages/rtl-objpas/src/inc/rtti.pp      | 10 +++++
 packages/rtl-objpas/tests/tests.rtti.pas | 69 ++++++++++++++++++++++++++++++++
 2 files changed, 79 insertions(+)

diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp
index f0b72d0ec9..17329f5a42 100644
--- a/packages/rtl-objpas/src/inc/rtti.pp
+++ b/packages/rtl-objpas/src/inc/rtti.pp
@@ -120,6 +120,7 @@ type
     { 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;
 {$endif}
+    class function FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue; static; {inline;}
     function IsArray: boolean; inline;
     function IsOpenArray: Boolean; inline;
     function AsString: string; inline;
@@ -1455,6 +1456,15 @@ begin
 end;
 {$endif}
 
+class function TValue.FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue;
+begin
+  if not Assigned(aTypeInfo) or
+      not (aTypeInfo^.Kind in [tkInteger, tkInt64, tkQWord, tkEnumeration, tkBool, tkChar, tkWChar, tkUChar]) then
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+
+  TValue.Make(@aValue, aTypeInfo, Result);
+end;
+
 function TValue.GetIsEmpty: boolean;
 begin
   result := (FData.FTypeInfo=nil) or
diff --git a/packages/rtl-objpas/tests/tests.rtti.pas b/packages/rtl-objpas/tests/tests.rtti.pas
index b95c26a8ff..594ac1b123 100644
--- a/packages/rtl-objpas/tests/tests.rtti.pas
+++ b/packages/rtl-objpas/tests/tests.rtti.pas
@@ -64,6 +64,8 @@ type
     procedure TestMakeAnsiChar;
     procedure TestMakeWideChar;
 
+    procedure TestFromOrdinal;
+
     procedure TestDataSize;
     procedure TestDataSizeEmpty;
     procedure TestReferenceRawData;
@@ -81,6 +83,11 @@ type
 
     procedure TestProcVar;
     procedure TestMethod;
+  private
+    procedure MakeFromOrdinalTObject;
+    procedure MakeFromOrdinalSet;
+    procedure MakeFromOrdinalString;
+    procedure MakeFromOrdinalNil;
   end;
 
 implementation
@@ -725,6 +732,68 @@ begin
   Check(WideChar(v.AsOrdinal) = #$1234);
 end;
 
+procedure TTestCase1.MakeFromOrdinalTObject;
+begin
+  TValue.FromOrdinal(TypeInfo(TObject), 42);
+end;
+
+procedure TTestCase1.MakeFromOrdinalSet;
+begin
+  TValue.FromOrdinal(TypeInfo(TTestSet), 42);
+end;
+
+procedure TTestCase1.MakeFromOrdinalString;
+begin
+  TValue.FromOrdinal(TypeInfo(AnsiString), 42);
+end;
+
+procedure TTestCase1.MakeFromOrdinalNil;
+begin
+  TValue.FromOrdinal(Nil, 42);
+end;
+
+procedure TTestCase1.TestFromOrdinal;
+var
+  v: TValue;
+begin
+  v := TValue.FromOrdinal(TypeInfo(LongInt), 42);
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, 42);
+
+  v := TValue.FromOrdinal(TypeInfo(Boolean), Ord(True));
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, Ord(True));
+
+  v := TValue.FromOrdinal(TypeInfo(Int64), $1234123412341234);
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, $1234123412341234);
+
+  v := TValue.FromOrdinal(TypeInfo(QWord), $1234123412341234);
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, $1234123412341234);
+
+  v := TValue.FromOrdinal(TypeInfo(LongBool), Ord(True));
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, Ord(True));
+
+  v := TValue.FromOrdinal(TypeInfo(TTestEnum), Ord(te1));
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, Ord(te1));
+
+  v := TValue.FromOrdinal(TypeInfo(AnsiChar), Ord(#20));
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, Ord(#20));
+
+  v := TValue.FromOrdinal(TypeInfo(WideChar), Ord(#$1234));
+  Check(v.IsOrdinal);
+  CheckEquals(v.AsOrdinal, Ord(#$1234));
+
+  CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalNil, EInvalidCast);
+  CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalTObject, EInvalidCast);
+  CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalSet, EInvalidCast);
+  CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalString, EInvalidCast);
+end;
+
 procedure TTestCase1.TestGetIsReadable;
 var
   c: TRttiContext;
-- 
cgit v1.2.1