+ 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 -

packages/rtl-objpas/src/inc/rtti.pp

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

packages/rtl-objpas/tests/tests.rtti.pas

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