* rework/extend SetToString/StringToSet so that sets with a size > 4 can be converted as well (this is Delphi compatible)

+ added test

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@42240 3ad0048d-3df7-0310-abae-a5850022a9f2

2 files changed, 268 insertions, 23 deletions

diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp
index d031a26889..c3bb1fa74e 100644
--- a/rtl/objpas/typinfo.pp
+++ b/rtl/objpas/typinfo.pp
@@ -884,8 +884,12 @@ function GetEnumeratedAliasValue(aTypeInfo: PTypeInfo; const aName: string): Int
 function SetToString(TypeInfo: PTypeInfo; Value: Integer; Brackets: Boolean) : String;
 function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
 function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
+function SetToString(TypeInfo: PTypeInfo; Value: Pointer; Brackets: Boolean = False) : String;
+function SetToString(PropInfo: PPropInfo; Value: Pointer; Brackets: Boolean = False) : String;
 function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
 function StringToSet(TypeInfo: PTypeInfo; const Value: string): Integer;
+procedure StringToSet(PropInfo: PPropInfo; const Value: String; Result: Pointer);
+procedure StringToSet(TypeInfo: PTypeInfo; const Value: String; Result: Pointer);
 
 const
     BooleanIdents: array[Boolean] of String = ('False', 'True');
@@ -1044,50 +1048,83 @@ end;
 Function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
 
 begin
-  Result:=SetToString(PropInfo^.PropType,Value,Brackets);
+  Result:=SetToString(PropInfo^.PropType, @Value, Brackets);
 end;
 
 Function SetToString(TypeInfo: PTypeInfo; Value: Integer; Brackets: Boolean) : String;
+begin
+  Result := SetToString(TypeInfo, @Value, Brackets);
+end;
 
+function SetToString(TypeInfo: PTypeInfo; Value: Pointer; Brackets: Boolean): String;
 type
   tsetarr = bitpacked array[0..SizeOf(Integer)*8-1] of 0..1;
 Var
-  I : Integer;
+  I,El,Els,Rem,V,Max : Integer;
   PTI : PTypeInfo;
-
+  PTD : PTypeData;
+  ValueArr : PLongWord;
 begin
-{$if defined(FPC_BIG_ENDIAN)}
-  { On big endian systems, set element 0 is in the most significant bit,
-    and the same goes for the elements of bitpacked arrays there.  }
-  case GetTypeData(TypeInfo)^.OrdType of
-    otSByte,otUByte: Value:=Value shl (SizeOf(Integer)*8-8);
-    otSWord,otUWord: Value:=Value shl (SizeOf(Integer)*8-16);
+  PTD := GetTypeData(TypeInfo);
+  PTI:=PTD^.CompType;
+  ValueArr := PLongWord(Value);
+  Result:='';
+{$ifdef ver3_0}
+  case PTD^.OrdType of
+    otSByte, otUByte: begin
+      Els := 0;
+      Rem := 1;
+    end;
+    otSWord, otUWord: begin
+      Els := 0;
+      Rem := 2;
+    end;
+    otSLong, otULong: begin
+      Els := 1;
+      Rem := 0;
+    end;
   end;
+{$else}
+  Els := PTD^.SetSize div SizeOf(Integer);
+  Rem := PTD^.SetSize mod SizeOf(Integer);
 {$endif}
 
-  PTI:=GetTypeData(TypeInfo)^.CompType;
-  Result:='';
-  For I:=0 to SizeOf(Integer)*8-1 do
+{$ifdef ver3_0}
+  El := 0;
+{$else}
+  for El := 0 to (PTD^.SetSize - 1) div SizeOf(Integer) do
+{$endif}
     begin
-      if (tsetarr(Value)[i]<>0) then
+      if El = Els then
+        Max := Rem
+      else
+        Max := SizeOf(Integer);
+      For I:=0 to Max*8-1 do
         begin
-          If Result='' then
-            Result:=GetEnumName(PTI,i)
-          else
-            Result:=Result+','+GetEnumName(PTI,I);
+          if (tsetarr(ValueArr[El])[i]<>0) then
+            begin
+              V := I + SizeOf(Integer) * 8 * El;
+              If Result='' then
+                Result:=GetEnumName(PTI,V)
+              else
+                Result:=Result+','+GetEnumName(PTI,V);
+            end;
         end;
     end;
   if Brackets then
     Result:='['+Result+']';
 end;
 
-
 Function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
 
 begin
   Result:=SetToString(PropInfo,Value,False);
 end;
 
+function SetToString(PropInfo: PPropInfo; Value: Pointer; Brackets: Boolean): String;
+begin
+  Result := SetToString(PropInfo^.PropType, Value, Brackets);
+end;
 
 Const
   SetDelim = ['[',']',',',' '];
@@ -1110,18 +1147,31 @@ end;
 Function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
 
 begin
-  Result:=StringToSet(PropInfo^.PropType,Value);
+  StringToSet(PropInfo^.PropType,Value,@Result);
 end;
 
 Function StringToSet(TypeInfo: PTypeInfo; const Value: string): Integer;
+begin
+  StringToSet(TypeInfo, Value, @Result);
+end;
+
+procedure StringToSet(TypeInfo: PTypeInfo; const Value: String; Result: Pointer);
 Var
   S,T : String;
-  I : Integer;
+  I, ElOfs, BitOfs : Integer;
+  PTD: PTypeData;
   PTI : PTypeInfo;
+  ResArr: PLongWord;
 
 begin
-  Result:=0;
-  PTI:=GetTypeData(TypeInfo)^.Comptype;
+  PTD:=GetTypeData(TypeInfo);
+{$ifndef ver3_0}
+  FillChar(Result^, PTD^.SetSize, 0);
+{$else}
+  PInteger(Result)^ := 0;
+{$endif}
+  PTI:=PTD^.Comptype;
+  ResArr := PLongWord(Result);
   S:=Value;
   I:=1;
   If Length(S)>0 then
@@ -1138,11 +1188,22 @@ begin
           I:=GetEnumValue(PTI,T);
           if (I<0) then
             raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [T]);
-          Result:=Result or (1 shl i);
+          ElOfs := I shr 5;
+          BitOfs := I and $1F;
+{$ifdef FPC_BIG_ENDIAN}
+          { on Big Endian systems enum values start from the MSB, thus we need
+            to reverse the shift }
+          BitOfs := 31 - BitOfs;
+{$endif}
+          ResArr[ElOfs] := ResArr[ElOfs] or (1 shl BitOfs);
         end;
     end;
 end;
 
+procedure StringToSet(PropInfo: PPropInfo; const Value: String; Result: Pointer);
+begin
+  StringToSet(PropInfo^.PropType, Value, Result);
+end;
 
 Function AlignTypeData(p : Pointer) : Pointer;
 {$packrecords c}
diff --git a/tests/test/trtti20.pp b/tests/test/trtti20.pp
new file mode 100644
index 0000000000..ef98118f6c
--- /dev/null
+++ b/tests/test/trtti20.pp
@@ -0,0 +1,184 @@
+program trtti20;
+
+{$mode objfpc}
+
+uses
+  TypInfo;
+
+type
+  TByteEnum = (
+    be1,
+    be2,
+    be3,
+    be4,
+    be5,
+    be6
+  );
+
+  TWordEnum = (
+    we1,
+    we2,
+    we3,
+    we4,
+    we5,
+    we6,
+    we7,
+    we8,
+    we9,
+    we10
+  );
+
+  TDWordEnum = (
+    de1,
+    de2,
+    de3,
+    de4,
+    de5,
+    de6,
+    de7,
+    de8,
+    de9,
+    de10,
+    de11,
+    de12,
+    de13,
+    de14,
+    de15,
+    de16,
+    de17,
+    de18,
+    de19,
+    de20
+  );
+
+  TLargeEnum = (
+    le1,
+    le2,
+    le3,
+    le4,
+    le5,
+    le6,
+    le7,
+    le8,
+    le9,
+    le10,
+    le11,
+    le12,
+    le13,
+    le14,
+    le15,
+    le16,
+    le17,
+    le18,
+    le19,
+    le20,
+    le21,
+    le22,
+    le23,
+    le24,
+    le25,
+    le26,
+    le27,
+    le28,
+    le29,
+    le30,
+    le31,
+    le32,
+    le33,
+    le34,
+    le35,
+    le36,
+    le37,
+    le38,
+    le39,
+    le40
+  );
+
+  TByteSet = set of TByteEnum;
+  TWordSet = set of TWordEnum;
+  TDWordSet = set of TDWordEnum;
+  TLargeSet = set of TLargeEnum;
+
+{$push}
+{$packset 1}
+  TByteSetP = set of TByteEnum;
+  TWordSetP = set of TWordEnum;
+  TDWordSetP = set of TDWordEnum;
+  TLargeSetP = set of TLargeEnum;
+{$pop}
+
+const
+  StrBS = '[be1,be6]';
+  StrWS = '[we1,we8,we10]';
+  StrDS = '[de1,de7,de20]';
+  StrLS = '[le1,le20,le31,le40]';
+
+var
+  bs1, bs2: TByteSet;
+  ws1, ws2: TWordSet;
+  ds1, ds2: TDWordSet;
+  ls1, ls2: TLargeSet;
+  bsp1, bsp2: TByteSetP;
+  wsp1, wsp2: TWordSetP;
+  dsp1, dsp2: TDWordSetP;
+  lsp1, lsp2: TLargeSetP;
+begin
+  bs1 := [be1, be6];
+  ws1 := [we1, we8, we10];
+  ds1 := [de1, de7, de20];
+  ls1 := [le1, le20, le31, le40];
+  bsp1 := [be1, be6];
+  wsp1 := [we1, we8, we10];
+  dsp1 := [de1, de7, de20];
+  lsp1 := [le1, le20, le31, le40];
+
+  if SetToString(PTypeInfo(TypeInfo(TByteSet)), @bs1, True) <> StrBS then
+    Halt(1);
+  if SetToString(PTypeInfo(TypeInfo(TWordSet)), @ws1, True) <> StrWS then
+    Halt(2);
+  if SetToString(PTypeInfo(TypeInfo(TDWordSet)), @ds1, True) <> StrDS then
+    Halt(3);
+  if SetToString(PTypeInfo(TypeInfo(TLargeSet)), @ls1, True) <> StrLS then
+    Halt(4);
+
+  if SetToString(PTypeInfo(TypeInfo(TByteSetP)), @bsp1, True) <> StrBS then
+    Halt(5);
+  if SetToString(PTypeInfo(TypeInfo(TWordSetP)), @wsp1, True) <> StrWS then
+    Halt(6);
+  if SetToString(PTypeInfo(TypeInfo(TDWordSetP)), @dsp1, True) <> StrDS then
+    Halt(7);
+  if SetToString(PTypeInfo(TypeInfo(TLargeSetP)), @lsp1, True) <> StrLS then
+    Halt(8);
+
+  StringToSet(PTypeInfo(TypeInfo(TByteSet)), StrBS, @bs2);
+  if bs2<>bs1 then
+    Halt(9);
+
+  StringToSet(PTypeInfo(TypeInfo(TWordSet)), StrWS, @ws2);
+  if ws2<>ws1 then
+    Halt(10);
+
+  StringToSet(PTypeInfo(TypeInfo(TDWordSet)), StrDS, @ds2);
+  if ds2<>ds1 then
+    Halt(11);
+
+  StringToSet(PTypeInfo(TypeInfo(TLargeSet)), StrLS, @ls2);
+  if ls2<>ls1 then
+    Halt(12);
+
+  StringToSet(PTypeInfo(TypeInfo(TByteSetP)), StrBS, @bsp2);
+  if bsp2<>bsp1 then
+    Halt(9);
+
+  StringToSet(PTypeInfo(TypeInfo(TWordSetP)), StrWS, @wsp2);
+  if wsp2<>wsp1 then
+    Halt(10);
+
+  StringToSet(PTypeInfo(TypeInfo(TDWordSetP)), StrDS, @dsp2);
+  if dsp2<>dsp1 then
+    Halt(11);
+
+  StringToSet(PTypeInfo(TypeInfo(TLargeSetP)), StrLS, @lsp2);
+  if lsp2<>lsp1 then
+    Halt(12);
+end.