paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 15:49:23 +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); Delete(Result);
end; end;
const LocalThreshold = 64;
procedure TFPSList.Pack; procedure TFPSList.Pack;
var var
LItemSize : integer;
NewCount, NewCount,
i : integer; i : integer;
pdest, pdest,
psrc : Pointer; psrc : Pointer;
localnul : array[0..LocalThreshold-1] of byte;
pnul : pointer;
begin begin
LItemSize:=FItemSize;
pnul:=@localnul;
if LItemSize>Localthreshold then
getmem(pnul,LItemSize);
fillchar(pnul^,LItemSize,#0);
NewCount:=0; NewCount:=0;
psrc:=First; psrc:=First;
pdest:=psrc; pdest:=psrc;
For I:=0 To FCount-1 Do For I:=0 To FCount-1 Do
begin begin
if assigned(pointer(psrc^)) then if not CompareMem(psrc,pnul,LItemSize) then
begin begin
System.Move(psrc^, pdest^, FItemSize); System.Move(psrc^, pdest^, LItemSize);
inc(pdest); inc(pdest,LItemSIze);
inc(NewCount); inc(NewCount);
end
else
deref(psrc);
inc(psrc,LitemSize);
end; end;
inc(psrc); if LItemSize>Localthreshold then
end; FreeMem(pnul,LItemSize);
FCount:=NewCount; FCount:=NewCount;
end; end;