+ extend Delete() intrinsics with Delphi compatible support for dynamic arrays. Also fixes Mantis #30306

git-svn-id: trunk@34455 -

.gitattributes

@@ -11958,6 +11958,7 @@ tests/test/targ1a.pp svneol=native#text/plain
 tests/test/targ1b.pp svneol=native#text/plain
 tests/test/tarray1.pp svneol=native#text/plain
 tests/test/tarray10.pp svneol=native#text/plain
+tests/test/tarray11.pp svneol=native#text/pascal
 tests/test/tarray2.pp svneol=native#text/plain
 tests/test/tarray3.pp svneol=native#text/plain
 tests/test/tarray4.pp svneol=native#text/plain

compiler/ninl.pas

@@ -4309,9 +4309,12 @@ implementation
        var
          procname : String;
          first : tdef;
+         firstn,
+         newn : tnode;
        begin
          { determine the correct function based on the first parameter }
-         first:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left.resultdef;
+         firstn:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left;
+         first:=firstn.resultdef;
          if is_shortstring(first) then
            procname:='fpc_shortstr_delete'
          else if is_unicodestring(first) then
@@ -4320,6 +4323,21 @@ implementation
            procname:='fpc_widestr_delete'
          else if is_ansistring(first) then
            procname:='fpc_ansistr_delete'
+         else if is_dynamic_array(first) then
+           begin
+             procname:='fpc_dynarray_delete';
+             { recreate the parameters as array pointer, src, count, typeinfo }
+             newn:=ccallparanode.create(caddrnode.create_internal
+                  (crttinode.create(tstoreddef(first),initrtti,rdt_normal)),
+                    ccallparanode.create(tcallparanode(left).left,
+                      ccallparanode.create(tcallparanode(tcallparanode(left).right).left,
+                        ccallparanode.create(ctypeconvnode.create_internal(firstn,voidpointertype),nil))));
+             tcallparanode(tcallparanode(tcallparanode(left).right).right).left:=nil;
+             tcallparanode(tcallparanode(left).right).left:=nil;
+             tcallparanode(left).left:=nil;
+             left.free;
+             left:=newn;
+           end
          else if first.typ=undefineddef then
            { just pick one }
            procname:='fpc_ansistr_delete'
@@ -4331,6 +4349,7 @@ implementation
              if tf_winlikewidestring in target_info.flags then
                write_system_parameter_lists('fpc_widestr_delete');
              write_system_parameter_lists('fpc_ansistr_delete');
+             MessagePos1(fileinfo,sym_e_param_list,'Delete(var Dynamic Array;'+sinttype.typename+';'+sinttype.typename+');');
              exit(cerrornode.create);
            end;
          result:=ccallnode.createintern(procname,left);

rtl/inc/compproc.inc

@@ -76,6 +76,10 @@ procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); compilerproc;
 procedure fpc_dynarray_incr_ref(p : pointer); compilerproc;
 procedure fpc_dynarray_setlength(var p : pointer;pti : pointer; dimcount : sizeint;dims : pdynarrayindex); compilerproc;
 procedure fpc_dynarray_assign(var dest : pointer; src : pointer; ti: pointer); compilerproc;
+{$ifndef VER3_0}
+{ no reference to the Delete() intrinsic, due to typeinfo parameter }
+procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : pointer);compilerproc;
+{$endif VER3_0}
 {$endif FPC_HAS_FEATURE_DYNARRAYS}
 
 { Str() support }

rtl/inc/dynarr.inc

@@ -346,6 +346,103 @@ function fpc_dynarray_copy(psrc : pointer;ti : pointer;
   end;
 
 
+{$ifndef VER3_0}
+procedure fpc_dynarray_delete(var p : pointer;source,count : SizeInt;pti : pointer);
+   var
+      newhigh,
+      i : tdynarrayindex;
+      size : sizeint;
+      { contains the "fixed" pointers where the refcount }
+      { and high are at positive offsets                 }
+      realp,newp : pdynarray;
+      ti : pointer;
+      elesize : sizeint;
+      eletype,eletypemngd : pointer;
+
+   begin
+     { if source > high then nothing to do }
+     if not assigned(p) or
+         (source>pdynarray(p-sizeof(tdynarray))^.high) or
+         (count<=0) or
+         (source<=0) then
+       exit;
+     { cap count }
+     if source+count-1>pdynarray(p-sizeof(tdynarray))^.high then
+       count:=pdynarray(p-sizeof(tdynarray))^.high-count+1;
+
+     { fast path: delete whole array }
+     if (source=0) and (count=pdynarray(p-sizeof(tdynarray))^.high+1) then
+       begin
+         fpc_dynarray_clear(p,pti);
+         exit;
+       end;
+
+     { skip kind and name }
+     ti:=aligntoptr(Pointer(pti)+2+PByte(pti)[1]);
+
+     elesize:=pdynarraytypedata(ti)^.elSize;
+     eletype:=pdynarraytypedata(ti)^.elType2^;
+     { only set if type needs finalization }
+     if assigned(pdynarraytypedata(ti)^.elType) then
+       eletypemngd:=pdynarraytypedata(ti)^.elType^
+     else
+       eletypemngd:=nil;
+
+     realp:=pdynarray(p-sizeof(tdynarray));
+     newp:=realp;
+
+     { determine new memory size }
+     newhigh:=realp^.high-count;
+     size:=elesize*(newhigh+1)+sizeof(tdynarray);
+
+     if realp^.refcount<>1 then
+       begin
+          { make an unique copy }
+          getmem(newp,size);
+          fillchar(newp^,sizeof(tdynarray),0);
+          { copy the elements that we still need }
+          if source>0 then
+            move(p^,(pointer(newp)+sizeof(tdynarray))^,source*elesize);
+          if source+count-1<realp^.high then
+            move((p+(source+count)*elesize)^,(pointer(newp)+sizeof(tdynarray)+source*elesize)^,(realp^.high-(source+count)+1)*elesize);
+
+          { increment ref. count of managed members }
+          if assigned(eletypemngd) then
+            for i:=0 to newhigh do
+              int_addref(pointer(newp)+sizeof(tdynarray)+elesize*i,eletypemngd);
+
+          { a declock(ref. count) isn't enough here }
+          { it could be that the in MT environments  }
+          { in the mean time the refcount was       }
+          { decremented                             }
+
+          { it is, because it doesn't really matter }
+          { if the array is now removed             }
+          fpc_dynarray_clear(p,pti);
+        end
+      else
+        begin
+          { finalize the elements that will be removed }
+          if assigned(eletypemngd) then
+            begin
+              for i:=source to source+count-1 do
+                int_finalize(p+i*elesize,eletype);
+            end;
+
+          { close the gap by moving the trailing elements to the front }
+          move((p+(source+count)*elesize)^,(p+source*elesize)^,(realp^.high-(source+count)+1)*elesize);
+
+          { resize the array }
+          reallocmem(realp,size);
+          newp:=realp;
+        end;
+    p:=pointer(newp)+sizeof(tdynarray);
+    newp^.refcount:=1;
+    newp^.high:=newhigh;
+  end;
+{$endif VER3_0}
+
+
 procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: SizeInt; lengthVec: PSizeInt);
   external name 'FPC_DYNARR_SETLENGTH';
 

tests/test/tarray11.pp

@@ -0,0 +1,189 @@
+program tarray11;
+
+{$mode objfpc}
+
+type
+  TLongIntArray = array of LongInt;
+
+  ITest = interface
+  end;
+
+  TITestArray = array of ITest;
+
+  TTest = class(TInterfacedObject, ITest)
+  private
+    fValue: LongInt;
+  public
+    constructor Create(aValue: LongInt);
+    destructor Destroy; override;
+  end;
+
+var
+  freed: array of LongInt;
+
+constructor TTest.Create(aValue: LongInt);
+begin
+  fValue := aValue;
+end;
+
+destructor TTest.Destroy;
+begin
+  SetLength(freed, Length(freed) + 1);
+  freed[High(freed)] := fValue;
+  inherited;
+end;
+
+procedure CheckArray(a, b: array of LongInt; err: LongInt);
+var
+  i: LongInt;
+begin
+  if Length(a) <> Length(b) then
+    Halt(err);
+  for i := Low(a) to High(a) do begin
+    if a[i] <> b[i] then
+      Halt(err + 1);
+  end;
+end;
+
+function CreateArray(len: LongInt): TLongIntArray;
+var
+  i: LongInt;
+begin
+  SetLength(Result, len);
+  for i := 0 to len - 1 do
+    Result[i] := i;
+end;
+
+procedure CreateArrayTest(len: LongInt; out arr: TITestArray);
+var
+  i: LongInt;
+begin
+  SetLength(arr, len);
+  for i := 0 to len - 1 do
+    arr[i] := TTest.Create(i);
+end;
+
+procedure CheckFreedArray(arr: array of LongInt; err: LongInt);
+var
+  l, f: LongInt;
+  found: Boolean;
+begin
+  if Length(freed) <> Length(arr) then
+    Halt(err);
+  for f in freed do begin
+    found := false;
+    for l in arr do
+      if l = f then begin
+        found := true;
+        break;
+      end;
+    if not found then
+      Halt(err + 1);
+  end;
+end;
+
+{procedure PrintArray(a: array of LongInt);
+var
+  i: LongInt;
+begin
+  Writeln('Length: ', Length(a));
+  Write('Data: ');
+  for i := Low(a) to High(a) do begin
+    if i > Low(a) then
+      Write(', ');
+    Write(a[i]);
+  end;
+  Writeln;
+end;}
+
+var
+  code: LongInt;
+
+function next: LongInt;
+begin
+  code := code + 2;
+  next := code;
+end;
+
+var
+  a, b: TLongIntArray;
+  c, d: TITestArray;
+begin
+  code := 0;
+
+  { remove from the middle }
+  a := CreateArray(10);
+  Delete(a, 2, 4);
+  CheckArray(a, [0, 1, 6, 7, 8, 9], next);
+
+  { remove from the beginning }
+  a := CreateArray(10);
+  Delete(a, 0, 4);
+  CheckArray(a, [4, 5, 6, 7, 8, 9], next);
+
+  { remove from the end }
+  a := CreateArray(10);
+  Delete(a, 6, 4);
+  CheckArray(a, [0, 1, 2, 3, 4, 5], next);
+
+  { delete whole array }
+  a := CreateArray(10);
+  Delete(a, 0, 10);
+  CheckArray(a, [], next);
+
+  { out of bounds start and count are ignored }
+  a := CreateArray(5);
+  Delete(a, -1, 0);
+  CheckArray(a, [0, 1, 2, 3, 4], next);
+  a := CreateArray(5);
+  Delete(a, -1, 2);
+  PrintArray(a);
+  CheckArray(a, [0, 1, 2, 3, 4], next);
+  a := CreateArray(5);
+  Delete(a, -1, -1);
+  CheckArray(a, [0, 1, 2, 3, 4], next);
+  a := CreateArray(5);
+  Delete(a, 2, -1);
+  CheckArray(a, [0, 1, 2, 3, 4], next);
+  a := CreateArray(5);
+  Delete(a, 5, 1);
+  CheckArray(a, [0, 1, 2, 3, 4], next);
+  a := CreateArray(5);
+
+  { count is capped to the array's end }
+  a := CreateArray(5);
+  Delete(a, 3, 4);
+  CheckArray(a, [0, 1, 2], next);
+
+  { check that Delete does not influence copies }
+  a := CreateArray(5);
+  b := a;
+  Delete(a, 2, 2);
+  CheckArray(a, [0, 1, 4], next);
+  CheckArray(b, [0, 1, 2, 3, 4], next);
+  Delete(b, 1, 3);
+  CheckArray(a, [0, 1, 4], next);
+  CheckArray(b, [0, 4], next);
+
+  { ensure that reference counted types are freed correctly }
+  CreateArrayTest(5, c);
+  Delete(c, 2, 2);
+  CheckFreedArray([2, 3], next);
+  freed := nil;
+  c := nil;
+  CheckFreedArray([0, 1, 4], next);
+  freed := nil;
+
+  { ensure that reference counted types are not destroyed if there's still a
+    reference to them }
+  CreateArrayTest(5, c);
+  d := c;
+  Delete(c, 2, 2);
+  CheckFreedArray([], next);
+  freed := nil;
+  c := nil;
+  CheckFreedArray([], next);
+  freed := nil;
+  d := nil;
+  CheckFreedArray([0, 1, 2, 3, 4], next);
+end.