paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-10 23:20:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
+ added test

git-svn-id: trunk@42240 -
This commit is contained in:
svenbarth 2019-06-16 21:36:25 +00:00
parent 749c4d4e47
commit 89e454aca8
3 changed files with 269 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -14032,6 +14032,7 @@ tests/test/trtti18a.pp svneol=native#text/pascal
tests/test/trtti18b.pp svneol=native#text/pascal
tests/test/trtti19.pp svneol=native#text/pascal
tests/test/trtti2.pp svneol=native#text/plain
tests/test/trtti20.pp svneol=native#text/pascal
tests/test/trtti3.pp svneol=native#text/plain
tests/test/trtti4.pp svneol=native#text/plain
tests/test/trtti5.pp svneol=native#text/plain

107
rtl/objpas/typinfo.pp
View File

@ -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}

184
tests/test/trtti20.pp Normal file
View File

@ -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.