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

* Fix for #21636, TFPSList.Pack several fixes.

Browse Source 
git-svn-id: trunk@21039 -
This commit is contained in:
marco 2012-04-25 17:25:00 +00:00
parent 69fbbcedf3
commit 6b93cbcbea
1 changed files with 21 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
rtl/objpas/fgl.pp
View File

@ -654,26 +654,42 @@ begin
Delete(Result);
end;
const LocalThreshold = 64;
procedure TFPSList.Pack;
var
LItemSize : integer;
NewCount,
i : integer;
pdest,
psrc : Pointer;
localnul : array[0..LocalThreshold-1] of byte;
pnul : pointer;
begin
LItemSize:=FItemSize;
pnul:=@localnul;
if LItemSize>Localthreshold then
getmem(pnul,LItemSize);
fillchar(pnul^,LItemSize,#0);
NewCount:=0;
psrc:=First;
pdest:=psrc;
For I:=0 To FCount-1 Do
begin
if assigned(pointer(psrc^)) then
if not CompareMem(psrc,pnul,LItemSize) then
begin
System.Move(psrc^, pdest^, FItemSize);
inc(pdest);
System.Move(psrc^, pdest^, LItemSize);
inc(pdest,LItemSIze);
inc(NewCount);
end;
inc(psrc);
end
else
deref(psrc);
inc(psrc,LitemSize);
end;
if LItemSize>Localthreshold then
FreeMem(pnul,LItemSize);
FCount:=NewCount;
end;