Add SetToArray and ArrayToSet functions for more general RTTI Set handling

rtl/objpas/typinfo.pp

@@ -990,11 +990,19 @@ procedure AddEnumElementAliases(aTypeInfo: PTypeInfo; const aNames: array of str
 procedure RemoveEnumElementAliases(aTypeInfo: PTypeInfo);
 function GetEnumeratedAliasValue(aTypeInfo: PTypeInfo; const aName: string): Integer;
 
+function SetToArray(TypeInfo: PTypeInfo; Value: Pointer) : TBytes;
+function SetToArray(PropInfo: PPropInfo; Value: Pointer) : TBytes;
+function SetToArray(TypeInfo: PTypeInfo; Value: LongInt) : TBytes;
+function SetToArray(PropInfo: PPropInfo; Value: LongInt) : TBytes;
 function SetToString(TypeInfo: PTypeInfo; Value: LongInt; Brackets: Boolean) : String;
 function SetToString(PropInfo: PPropInfo; Value: LongInt; Brackets: Boolean) : String;
 function SetToString(PropInfo: PPropInfo; Value: LongInt) : String;
 function SetToString(TypeInfo: PTypeInfo; Value: Pointer; Brackets: Boolean = False) : String;
 function SetToString(PropInfo: PPropInfo; Value: Pointer; Brackets: Boolean = False) : String;
+function ArrayToSet(PropInfo: PPropInfo; const Value: array of Byte): LongInt;
+function ArrayToSet(TypeInfo: PTypeInfo; const Value: array of Byte): LongInt;
+procedure ArrayToSet(PropInfo: PPropInfo; const Value: array of Byte; Result: Pointer);
+procedure ArrayToSet(TypeInfo: PTypeInfo; const Value: array of Byte; Result: Pointer);
 function StringToSet(PropInfo: PPropInfo; const Value: string): LongInt;
 function StringToSet(TypeInfo: PTypeInfo; const Value: string): LongInt;
 procedure StringToSet(PropInfo: PPropInfo; const Value: String; Result: Pointer);
@@ -1212,18 +1220,45 @@ begin
 end;
 
 function SetToString(TypeInfo: PTypeInfo; Value: Pointer; Brackets: Boolean): String;
+var
+  A: TBytes;
+  B: Byte;
+  PTI : PTypeInfo;
+begin
+  PTI:=GetTypeData(TypeInfo)^.CompType;
+  A:=SetToArray(TypeInfo, Value);
+  Result := '';
+  for B in A do
+    If Result='' then
+      Result:=GetEnumName(PTI,B)
+    else
+      Result:=Result+','+GetEnumName(PTI,B);
+  if Brackets then
+    Result:='['+Result+']';
+end;
+
+Function SetToString(PropInfo: PPropInfo; Value: LongInt) : 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;
+
+function SetToArray(TypeInfo: PTypeInfo; Value: Pointer) : TBytes;
 type
   tsetarr = bitpacked array[0..SizeOf(LongInt)*8-1] of 0..1;
 Var
   I,El,Els,Rem,V,Max : Integer;
-  PTI : PTypeInfo;
   PTD : PTypeData;
   ValueArr : PLongInt;
 begin
   PTD := GetTypeData(TypeInfo);
-  PTI:=PTD^.CompType;
   ValueArr := PLongInt(Value);
-  Result:='';
+  Result:=[];
 {$ifdef ver3_0}
   case PTD^.OrdType of
     otSByte, otUByte: begin
@@ -1259,26 +1294,26 @@ begin
           if (tsetarr(ValueArr[El])[i]<>0) then
             begin
               V := I + SizeOf(LongInt) * 8 * El;
-              If Result='' then
-                Result:=GetEnumName(PTI,V)
-              else
-                Result:=Result+','+GetEnumName(PTI,V);
+              SetLength(Result, Length(Result)+1);
+              Result[High(Result)]:=V;
             end;
         end;
     end;
-  if Brackets then
-    Result:='['+Result+']';
 end;
 
-Function SetToString(PropInfo: PPropInfo; Value: LongInt) : String;
+function SetToArray(PropInfo: PPropInfo; Value: Pointer) : TBytes;
+begin
+  Result:=SetToArray(PropInfo^.PropType,Value);
+end;
 
+function SetToArray(TypeInfo: PTypeInfo; Value: LongInt) : TBytes;
 begin
-  Result:=SetToString(PropInfo,Value,False);
+  Result:=SetToArray(TypeInfo,@Value);
 end;
 
-function SetToString(PropInfo: PPropInfo; Value: Pointer; Brackets: Boolean): String;
+function SetToArray(PropInfo: PPropInfo; Value: LongInt) : TBytes;
 begin
-  Result := SetToString(PropInfo^.PropType, Value, Brackets);
+  Result:=SetToArray(PropInfo^.PropType,@Value);
 end;
 
 Const
@@ -1323,17 +1358,10 @@ Var
   I, ElOfs, BitOfs : Integer;
   PTD: PTypeData;
   PTI : PTypeInfo;
-  ResArr: PLongWord;
-
+  A: TBytes;
 begin
   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
@@ -1342,6 +1370,7 @@ begin
         Inc(I);
       Delete(S,1,i-1);
     end;
+  A:=[];
   While (S<>'') do
     begin
       T:=GetNextElement(S);
@@ -1350,16 +1379,11 @@ begin
           I:=GetEnumValue(PTI,T);
           if (I<0) then
             raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [T]);
-          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 (LongInt(1) shl BitOfs);
+          SetLength(A, Length(A)+1);
+          A[High(A)]:=I;
         end;
     end;
+  ArrayToSet(TypeInfo,A,Result);
 end;
 
 procedure StringToSet(PropInfo: PPropInfo; const Value: String; Result: Pointer);
@@ -1367,6 +1391,57 @@ begin
   StringToSet(PropInfo^.PropType, Value, Result);
 end;
 
+Function ArrayToSet(PropInfo: PPropInfo; const Value: array of Byte): LongInt;
+
+begin
+  Result:=ArrayToSet(PropInfo^.PropType,Value);
+end;
+
+Function ArrayToSet(TypeInfo: PTypeInfo; const Value: array of Byte): LongInt;
+begin
+  ArrayToSet(TypeInfo, Value, @Result);
+{$if defined(FPC_BIG_ENDIAN)}
+  { correctly adjust packed sets that are smaller than 32-bit }
+  case GetTypeData(TypeInfo)^.OrdType of
+    otSByte,otUByte: Result := Result shr (SizeOf(Integer)*8-8);
+    otSWord,otUWord: Result := Result shr (SizeOf(Integer)*8-16);
+  end;
+{$endif}
+end;
+
+procedure ArrayToSet(TypeInfo: PTypeInfo; const Value: array of Byte; Result: Pointer);
+Var
+  ElOfs, BitOfs : Integer;
+  PTD: PTypeData;
+  ResArr: PLongWord;
+  B: Byte;
+
+begin
+  PTD:=GetTypeData(TypeInfo);
+{$ifndef ver3_0}
+  FillChar(Result^, PTD^.SetSize, 0);
+{$else}
+  PInteger(Result)^ := 0;
+{$endif}
+  ResArr := PLongWord(Result);
+  for B in Value do
+    begin
+      ElOfs := B shr 5;
+      BitOfs := B 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 (LongInt(1) shl BitOfs);
+    end;
+end;
+
+procedure ArrayToSet(PropInfo: PPropInfo; const Value: array of Byte; Result: Pointer);
+begin
+  ArrayToSet(PropInfo^.PropType, Value, Result);
+end;
+
 Function AlignTypeData(p : Pointer) : Pointer;
 {$packrecords c}
   type

tests/test/trtti24.pp

@@ -0,0 +1,227 @@
+program trtti24;
+
+{$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}
+
+function SameArray(const A, B: array of Byte): Boolean;
+begin
+  Result := True;
+end;
+
+const
+  StrBS: array[0..1] of Byte = (Ord(be1), Ord(be6));
+  StrWS: array[0..2] of Byte = (Ord(we1), Ord(we8), Ord(we10));
+  StrDS: array[0..2] of Byte = (Ord(de1), Ord(de7), Ord(de20));
+  StrLS: array[0..3] of Byte = (Ord(le1), Ord(le20), Ord(le31), Ord(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 not SameArray(SetToArray(PTypeInfo(TypeInfo(TByteSet)), @bs1), StrBS) then
+    Halt(1);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TWordSet)), @ws1), StrWS) then
+    Halt(2);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TDWordSet)), @ds1), StrDS) then
+    Halt(3);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TLargeSet)), @ls1), StrLS) then
+    Halt(4);
+
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TByteSetP)), @bsp1), StrBS) then
+    Halt(5);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TWordSetP)), @wsp1), StrWS) then
+    Halt(6);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TDWordSetP)), @dsp1), StrDS) then
+    Halt(7);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TLargeSetP)), @lsp1), StrLS) then
+    Halt(8);
+
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TByteSet)), LongInt(bs1)), StrBS) then
+    Halt(9);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TWordSet)), LongInt(ws1)), StrWS) then
+    Halt(10);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TDWordSet)), LongInt(ds1)), StrDS) then
+    Halt(11);
+
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TByteSetP)), Byte(bsp1)), StrBS) then
+    Halt(12);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TWordSetP)), Word(wsp1)), StrWS) then
+    Halt(13);
+  if not SameArray(SetToArray(PTypeInfo(TypeInfo(TDWordSetP)), LongInt(dsp1)), StrDS) then
+    Halt(14);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TByteSet)), StrBS, @bs2);
+  if bs2<>bs1 then
+    Halt(15);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TWordSet)), StrWS, @ws2);
+  if ws2<>ws1 then
+    Halt(16);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TDWordSet)), StrDS, @ds2);
+  if ds2<>ds1 then
+    Halt(17);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TLargeSet)), StrLS, @ls2);
+  if ls2<>ls1 then
+    Halt(18);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TByteSetP)), StrBS, @bsp2);
+  if bsp2<>bsp1 then
+    Halt(19);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TWordSetP)), StrWS, @wsp2);
+  if wsp2<>wsp1 then
+    Halt(20);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TDWordSetP)), StrDS, @dsp2);
+  if dsp2<>dsp1 then
+    Halt(21);
+
+  ArrayToSet(PTypeInfo(TypeInfo(TLargeSetP)), StrLS, @lsp2);
+  if lsp2<>lsp1 then
+    Halt(22);
+
+  bs2 := TByteSet(ArrayToSet(PTypeInfo(TypeInfo(TByteSet)), StrBS));
+  if bs2<>bs1 then
+    Halt(23);
+
+  ws2 := TWordSet(ArrayToSet(PTypeInfo(TypeInfo(TWordSet)), StrWS));
+  if ws2<>ws1 then
+    Halt(24);
+
+  ds2 := TDWordSet(ArrayToSet(PTypeInfo(TypeInfo(TDWordSet)), StrDS));
+  if ds2<>ds1 then
+    Halt(25);
+
+  bsp2 := TByteSetP(Byte(ArrayToSet(PTypeInfo(TypeInfo(TByteSetP)), StrBS)));
+  if bsp2<>bsp1 then
+    Halt(26);
+
+  wsp2 := TWordSetP(Word(ArrayToSet(PTypeInfo(TypeInfo(TWordSetP)), StrWS)));
+  if wsp2<>wsp1 then
+    Halt(27);
+
+  dsp2 := TDWordSetP(ArrayToSet(PTypeInfo(TypeInfo(TDWordSetP)), StrDS));
+  if dsp2<>dsp1 then
+    Halt(28);
+end.