mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-26 14:20:33 +01:00
+ add support for open arrays in TValue; this is *not* supported by Delphi
Note: open array TValue "instances" are only valid till the routine with the open array parameter has returned, but they can be converted to a dynamic array value with the help of the OpenArrayToDynArrayValue<> function git-svn-id: trunk@39886 -
This commit is contained in:
svenbarth
parent
b9ec7e1e06
commit
0f7f9c2bb8
@ -76,6 +76,8 @@ type
|
||||
14: (FAsSInt64: Int64);
|
||||
15: (FAsMethod: TMethod);
|
||||
16: (FAsPointer: Pointer);
|
||||
{ FPC addition for open arrays }
|
||||
17: (FArrLength: SizeInt; FElSize: SizeInt);
|
||||
end;
|
||||
|
||||
{ TValue }
|
||||
@ -91,10 +93,15 @@ type
|
||||
public
|
||||
class function Empty: TValue; static;
|
||||
class procedure Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); static;
|
||||
{ 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 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;
|
||||
{$endif}
|
||||
function IsArray: boolean; inline;
|
||||
function IsOpenArray: Boolean; inline;
|
||||
function AsString: string; inline;
|
||||
function AsUnicodeString: UnicodeString;
|
||||
function AsAnsiString: AnsiString;
|
||||
@ -436,6 +443,10 @@ procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
|
||||
|
||||
function IsManaged(TypeInfo: PTypeInfo): boolean;
|
||||
|
||||
{$ifndef InLazIDE}
|
||||
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
|
||||
{$endif}
|
||||
|
||||
{ these resource strings are needed by units implementing function call managers }
|
||||
resourcestring
|
||||
SErrInvokeNotImplemented = 'Invoke functionality is not implemented';
|
||||
@ -794,6 +805,19 @@ begin
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
{$ifndef InLazIDE}
|
||||
generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
|
||||
var
|
||||
arr: specialize TArray<T>;
|
||||
i: SizeInt;
|
||||
begin
|
||||
SetLength(arr, Length(aArray));
|
||||
for i := 0 to High(aArray) do
|
||||
arr[i] := aArray[i];
|
||||
Result := TValue.specialize From<specialize TArray<T>>(arr);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
{ TRttiPointerType }
|
||||
|
||||
function TRttiPointerType.GetReferredType: TRttiType;
|
||||
@ -1467,11 +1491,48 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue);
|
||||
var
|
||||
el: TValue;
|
||||
begin
|
||||
Result.FData.FTypeInfo := ATypeInfo;
|
||||
{ resets the whole variant part; FValueData is already Nil }
|
||||
{$if SizeOf(TMethod) > SizeOf(QWord)}
|
||||
Result.FData.FAsMethod.Code := Nil;
|
||||
Result.FData.FAsMethod.Data := Nil;
|
||||
{$else}
|
||||
Result.FData.FAsUInt64 := 0;
|
||||
{$endif}
|
||||
if not Assigned(ATypeInfo) then
|
||||
Exit;
|
||||
if ATypeInfo^.Kind <> tkArray then
|
||||
Exit;
|
||||
if not Assigned(AArray) then
|
||||
Exit;
|
||||
if ALength < 0 then
|
||||
Exit;
|
||||
Result.FData.FValueData := TValueDataIntImpl.CreateRef(@AArray, ATypeInfo, False);
|
||||
Result.FData.FArrLength := ALength;
|
||||
Make(Nil, Result.TypeData^.ArrayData.ElType, el);
|
||||
Result.FData.FElSize := el.DataSize;
|
||||
end;
|
||||
|
||||
{$ifndef NoGenericMethods}
|
||||
generic class function TValue.From<T>(constref aValue: T): TValue;
|
||||
begin
|
||||
TValue.Make(@aValue, System.TypeInfo(T), Result);
|
||||
end;
|
||||
|
||||
generic class function TValue.FromOpenArray<T>(constref aValue: array of T): TValue;
|
||||
var
|
||||
arrdata: Pointer;
|
||||
begin
|
||||
if Length(aValue) > 0 then
|
||||
arrdata := @aValue[0]
|
||||
else
|
||||
arrdata := Nil;
|
||||
TValue.MakeOpenArray(arrdata, Length(aValue), System.TypeInfo(aValue), Result);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
function TValue.GetTypeDataProp: PTypeData;
|
||||
@ -1586,6 +1647,14 @@ begin
|
||||
result := kind in [tkArray, tkDynArray];
|
||||
end;
|
||||
|
||||
function TValue.IsOpenArray: Boolean;
|
||||
var
|
||||
td: PTypeData;
|
||||
begin
|
||||
td := TypeData;
|
||||
Result := (Kind = tkArray) and (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0)
|
||||
end;
|
||||
|
||||
function TValue.AsString: string;
|
||||
begin
|
||||
if System.GetTypeKind(String) = tkUString then
|
||||
@ -1795,19 +1864,27 @@ begin
|
||||
end;
|
||||
|
||||
function TValue.GetArrayLength: SizeInt;
|
||||
var
|
||||
td: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
raise EInvalidCast.Create(SErrInvalidTypecast);
|
||||
if Kind = tkDynArray then
|
||||
Result := DynArraySize(PPointer(FData.FValueData.GetReferenceToRawData)^)
|
||||
else
|
||||
Result := TypeData^.ArrayData.ElCount;
|
||||
else begin
|
||||
td := TypeData;
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then
|
||||
Result := FData.FArrLength
|
||||
else
|
||||
Result := td^.ArrayData.ElCount;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TValue.GetArrayElement(AIndex: SizeInt): TValue;
|
||||
var
|
||||
data: Pointer;
|
||||
eltype: PTypeInfo;
|
||||
elsize: SizeInt;
|
||||
td: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
@ -1818,7 +1895,15 @@ begin
|
||||
end else begin
|
||||
td := TypeData;
|
||||
eltype := td^.ArrayData.ElType;
|
||||
data := PByte(FData.FValueData.GetReferenceToRawData) + AIndex * (td^.ArrayData.Size div td^.ArrayData.ElCount);
|
||||
{ open array? }
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin
|
||||
data := PPointer(FData.FValueData.GetReferenceToRawData)^;
|
||||
elsize := FData.FElSize
|
||||
end else begin
|
||||
data := FData.FValueData.GetReferenceToRawData;
|
||||
elsize := td^.ArrayData.Size div td^.ArrayData.ElCount;
|
||||
end;
|
||||
data := PByte(data) + AIndex * elsize;
|
||||
end;
|
||||
{ MakeWithoutCopy? }
|
||||
Make(data, eltype, Result);
|
||||
@ -1828,6 +1913,7 @@ procedure TValue.SetArrayElement(AIndex: SizeInt; constref AValue: TValue);
|
||||
var
|
||||
data: Pointer;
|
||||
eltype: PTypeInfo;
|
||||
elsize: SizeInt;
|
||||
td, tdv: PTypeData;
|
||||
begin
|
||||
if not IsArray then
|
||||
@ -1838,7 +1924,15 @@ begin
|
||||
end else begin
|
||||
td := TypeData;
|
||||
eltype := td^.ArrayData.ElType;
|
||||
data := PByte(FData.FValueData.GetReferenceToRawData) + AIndex * (td^.ArrayData.Size div td^.ArrayData.ElCount);
|
||||
{ open array? }
|
||||
if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin
|
||||
data := PPointer(FData.FValueData.GetReferenceToRawData)^;
|
||||
elsize := FData.FElSize
|
||||
end else begin
|
||||
data := FData.FValueData.GetReferenceToRawData;
|
||||
elsize := td^.ArrayData.Size div td^.ArrayData.ElCount;
|
||||
end;
|
||||
data := PByte(data) + AIndex * elsize;
|
||||
end;
|
||||
{ maybe we'll later on allow some typecasts, but for now be restrictive }
|
||||
if eltype^.Kind <> AValue.Kind then
|
||||
|
||||
@ -52,6 +52,9 @@ type
|
||||
procedure TestMakeObject;
|
||||
procedure TestMakeArrayDynamic;
|
||||
procedure TestMakeArrayStatic;
|
||||
{$ifdef fpc}
|
||||
procedure TestMakeArrayOpen;
|
||||
{$endif}
|
||||
|
||||
procedure TestDataSize;
|
||||
procedure TestDataSizeEmpty;
|
||||
@ -59,6 +62,9 @@ type
|
||||
procedure TestReferenceRawDataEmpty;
|
||||
|
||||
procedure TestIsManaged;
|
||||
{$ifdef fpc}
|
||||
procedure TestOpenArrayToDyn;
|
||||
{$endif}
|
||||
|
||||
procedure TestInterface;
|
||||
{$ifdef fpc}
|
||||
@ -393,6 +399,84 @@ begin
|
||||
CheckEquals(value.GetArrayElement(3).AsInteger, 63);
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
procedure TTestCase1.TestMakeArrayOpen;
|
||||
|
||||
procedure TestOpenArrayValueCopy(aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
end;
|
||||
|
||||
procedure TestOpenArrayValueVar(var aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
end;
|
||||
|
||||
procedure TestOpenArrayValueOut(var aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, True);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 21);
|
||||
value.SetArrayElement(0, 84);
|
||||
value.SetArrayElement(1, 128);
|
||||
{ since this is an open array the original array is modified! }
|
||||
CheckEquals(aArr[0], 84);
|
||||
CheckEquals(aArr[1], 128);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 84);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 128);
|
||||
end;
|
||||
|
||||
var
|
||||
arr: array of LongInt;
|
||||
begin
|
||||
TestOpenArrayValueCopy([42, 21]);
|
||||
|
||||
arr := [42, 21];
|
||||
TestOpenArrayValueVar(arr);
|
||||
CheckEquals(arr[0], 84);
|
||||
CheckEquals(arr[1], 21);
|
||||
|
||||
arr := [42, 21];
|
||||
TestOpenArrayValueOut(arr);
|
||||
CheckEquals(arr[0], 84);
|
||||
CheckEquals(arr[1], 128);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure TTestCase1.TestGetIsReadable;
|
||||
var
|
||||
c: TRttiContext;
|
||||
@ -1285,6 +1369,34 @@ begin
|
||||
CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
procedure TTestCase1.TestOpenArrayToDyn;
|
||||
|
||||
procedure OpenArrayProc(aArr: array of LongInt);
|
||||
var
|
||||
value: TValue;
|
||||
begin
|
||||
{$ifndef InLazIDE}
|
||||
value := specialize OpenArrayToDynArrayValue<LongInt>(aArr);
|
||||
{$endif}
|
||||
CheckEquals(value.IsArray, True);
|
||||
CheckEquals(value.IsOpenArray, False);
|
||||
CheckEquals(value.IsObject, False);
|
||||
CheckEquals(value.IsOrdinal, False);
|
||||
CheckEquals(value.IsClass, False);
|
||||
CheckEquals(value.GetArrayLength, 2);
|
||||
CheckEquals(value.GetArrayElement(0).AsInteger, 42);
|
||||
CheckEquals(value.GetArrayElement(1).AsInteger, 84);
|
||||
value.SetArrayElement(0, 21);
|
||||
{ since this is a copy the original array is not modified! }
|
||||
CheckEquals(aArr[0], 42);
|
||||
end;
|
||||
|
||||
begin
|
||||
OpenArrayProc([42, 84]);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure TTestCase1.TestInterface;
|
||||
var
|
||||
context: TRttiContext;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user