procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: NativeInt; lengthVec: PNativeInt);
var
  i,j: NativeInt;
  newLength, oldLength, minLength: NativeInt;
  elSize: NativeInt;
  t: PDynArrayTypeInfo;
  ElTypeInfo: Pointer;
  neededSize: NativeInt;
  p, pp: Pointer;
begin
  p := a;

  // Fetch the new length of the array in this dimension, and the old length
  newLength := lengthVec^;
  if newLength <= 0 then
  begin
    if newLength < 0 then
      Error(reRangeError);
    _DynArrayClear(a, typeInfo);
    exit;
  end;

  oldLength := 0;
  if p <> nil then
  begin
    Dec(PByte(p), SizeOf(TDynArrayRec));
    oldLength := PDynArrayRec(p).Length;
  end;

  // Calculate the needed size of the heap object
  t := PDynArrayTypeInfo( PByte(typeInfo) + PDynArrayTypeInfo(typeInfo).name );
  elSize := t.elSize;
  if t.elType <> nil then
    ElTypeInfo := t.elType^
  else
    ElTypeInfo := nil;
  neededSize := newLength*elSize;
  if neededSize div newLength <> elSize then
    Error(reRangeError);
  Inc(neededSize, SizeOf(TDynArrayRec));
  if neededSize < 0 then
    Error(reRangeError);

  // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy
  if (p = nil) or (PDynArrayRec(p).RefCnt = 1) then
  begin
    pp := p;
{$IF not Defined(WEAKREF)}
    if (newLength < oldLength) and (ElTypeInfo <> nil) then
      FinalizeArray(PByte(p) + SizeOf(TDynArrayRec) + newLength*elSize, ElTypeInfo, oldLength - newLength);
    ReallocMem(pp, neededSize);
{$ELSE}
    if (ElTypeInfo <> nil) then
    begin
      if SysHasWeakRef(PTypeInfo(ElTypeInfo)) then
      begin
        if newLength < oldLength then
          minLength := newLength
        else
          minLength := oldLength;
        GetMem(pp, neededSize);
        FillChar((PByte(pp) + SizeOf(TDynArrayRec))^, minLength * elSize, 0);
        if p <> nil then
        begin
          MoveArray(PByte(pp) + SizeOf(TDynArrayRec),
                     PByte(p) + SizeOf(TDynArrayRec), ElTypeInfo, minLength);
          if newLength < oldLength then
            FinalizeArray(PByte(p) + SizeOf(TDynArrayRec) + newLength*elSize, ElTypeInfo, oldLength - newLength);
          FreeMem(p);
        end;
      end
      else
      begin
        if (newLength < oldLength) then
          FinalizeArray(PByte(p) + SizeOf(TDynArrayRec) + newLength*elSize, ElTypeInfo, oldLength - newLength);
        ReallocMem(pp, neededSize);
      end;
    end
    else
      ReallocMem(pp, neededSize);
{$ENDIF}
    p := pp;
  end
  else
  begin
    GetMem(p, neededSize);
    minLength := oldLength;
    if minLength > newLength then
      minLength := newLength;
    if ElTypeInfo <> nil then
    begin
      FillChar((PByte(p) + SizeOf(TDynArrayRec))^, minLength*elSize, 0);
      __CopyArray(PByte(p) + SizeOf(TDynArrayRec), a, ElTypeInfo, minLength)
    end
    else
      Move(PByte(a)^, (PByte(p) + SizeOf(TDynArrayRec))^, minLength*elSize);
    _DynArrayClear(a, typeInfo);
  end;

  // The heap object will now have a ref count of 1 and the new length
  PDynArrayRec(p).RefCnt := 1;
  PDynArrayRec(p).Length := newLength;
  Inc(PByte(p), SizeOf(TDynArrayRec));

  // Set the new memory to all zero bits
  if newLength > oldLength then
    FillChar((PByte(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0);

  // Take care of the inner dimensions, if any
  if dimCnt > 1 then
  begin
    Inc(lengthVec);
    Dec(dimCnt);
    i := 0;
    try
      while i < newLength do
        begin
          DynArraySetLength(PPointerArray(p)[i], ElTypeInfo, dimCnt, lengthVec);
          Inc(i);
        end;
    except
      // Free arrays on exception
      for j := 0 to i  do
        _DynArrayClear(PPointerArray(p)[j], ElTypeInfo);
      _DynArrayClear(p, typeInfo);
      raise;
    end;
  end;
  a := p;
end;

program Project1;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  windows, System.SysUtils, FastListArray, System.Generics.Collections;

function sprintf(S: PAnsiChar; const Format: PAnsiChar): Integer; cdecl;
  varargs; external 'msvcrt.dll';

function PrintTime(T: Int64): AnsiString;
var
  A, b: Int64;
begin
  Result := '';
  if QueryPerformanceCounter(A) and QueryPerformanceFrequency(b) then
  begin
    SetLength(Result, 25);
    SetLength(Result, sprintf(PAnsiChar(Result), '%f', single((A - T) / b)));
  end;
end;

procedure Start(func: Pointer);
var
  T: Int64;
type
  call = procedure();
begin
  QueryPerformanceCounter(T);
  call(func)();
  Writeln(PrintTime(T));
end;

const
  N = 250000; //

var
  arr: array [0 .. 1023] of TArrayEx<Integer>;
  arra: array [0 .. 1023] of TList<Integer>;
  i, j: Integer;
  T: Int64;

procedure TListTestInit;
begin
  for i := Low(arra) to High(arra) do
    arra[i] := TList<Integer>.Create;
end;

procedure TArrayExTestInit;
begin
  for i := Low(arr) to High(arr) do
    arr[i].init;
end;

procedure TListTestAdd;
begin
  for j := Low(arra) to High(arra) do
    for i := 0 to N do
      arra[j].add(i);
end;

procedure TArrayExTestAdd;
begin
  for j := Low(arr) to High(arr) do
    for i := 0 to N do
      arr[j].add(i);
end;

procedure TListTestFree;
begin
  for j := Low(arra) to High(arra) do
    arra[j].Free;
end;

procedure TArrayExTestFree;
begin
  for j := Low(arr) to High(arr) do
    arr[j].Free;
end;

begin
  try
    Writeln('TList: ');
    Writeln('Init: ');
    Start(@TListTestInit);

    Writeln('Add: ');
    Start(@TListTestAdd);

    Writeln('Free: ');
    Start(@TListTestFree);

    Writeln('TArrayEx: ');
    Writeln('Init: ');
    Start(@TArrayExTestInit);

    Writeln('Add: ');
    Start(@TArrayExTestAdd);

    Writeln('Free: ');
    Start(@TArrayExTestFree);

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;

end.