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

--- Merging r48876 into '.':

Browse Source 
U    packages/rtl-objpas/src/inc/fmtbcd.pp
--- Recording mergeinfo for merge of r48876 into '.':
 G   .
--- Merging r49021 into '.':
U    packages/fcl-process/src/win/process.inc
--- Recording mergeinfo for merge of r49021 into '.':
 G   .

# revisions: 48876,49021
r48876 | marco | 2021-03-04 11:37:50 +0100 (Thu, 04 Mar 2021) | 1 line
Changed paths:
   M /trunk/packages/rtl-objpas/src/inc/fmtbcd.pp

 * Patch from Lacak. Better fix for mantis 30853
r49021 | marco | 2021-03-20 22:45:19 +0100 (Sat, 20 Mar 2021) | 1 line
Changed paths:
   M /trunk/packages/fcl-process/src/win/process.inc

 * also assign threadid. mantis 38645

git-svn-id: branches/fixes_3_2@49039 -
This commit is contained in:
marco 2021-03-23 13:06:59 +00:00
parent 994797ef11
commit ae86b74955
5 changed files with 159 additions and 17 deletions
.gitattributes
packages
fcl-process/src/win
process.inc
fcl-stl/src
gdeque.pp
rtl-objpas/src/inc
fmtbcd.pp
tests/webtbs
tw38306.pp

1
.gitattributes vendored
View File

@ -17834,6 +17834,7 @@ tests/webtbs/tw38151.pp svneol=native#text/pascal
tests/webtbs/tw38238.pp svneol=native#text/pascal
tests/webtbs/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain
tests/webtbs/tw38306.pp -text svneol=native#text/pascal
tests/webtbs/tw3833.pp svneol=native#text/plain
tests/webtbs/tw38337.pp svneol=native#text/plain
tests/webtbs/tw3840.pp svneol=native#text/plain

1
packages/fcl-process/src/win/process.inc
View File

@ -285,6 +285,7 @@ Var
Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]);
FProcessHandle:=FProcessInformation.hProcess;
FThreadHandle:=FProcessInformation.hThread;
FThreadId:=FProcessInformation.dwThreadId;
FProcessID:=FProcessINformation.dwProcessID;
Finally
if POUsePipes in Options then

113
packages/fcl-stl/src/gdeque.pp
View File

@ -14,6 +14,11 @@
unit gdeque;
{
Implements a generic double ended queue.
(See: https://en.wikipedia.org/wiki/Double-ended_queue)
}
interface
type
@ -30,10 +35,18 @@ type
procedure SetValue(position:SizeUInt; value:T);inline;
function GetValue(position:SizeUInt):T;inline;
function GetMutable(position:SizeUInt):PT;inline;
procedure IncreaseCapacity();inline;
procedure IncreaseCapacity();
protected
procedure MoveSimpleData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
procedure MoveManagedData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
procedure MoveData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
procedure ClearSingleDataEntry(Index: SizeUInt); virtual;
procedure ClearData; virtual;
property Data: TArr read FData;
public
function Size():SizeUInt;inline;
constructor Create();
destructor Destroy(); override;
Procedure Clear;
procedure PushBack(value:T);inline;
procedure PushFront(value:T);inline;
@ -59,8 +72,15 @@ begin
FStart:=0;
end;
destructor TDeque.Destroy();
begin
Clear;
inherited Destroy;
end;
procedure TDeque.Clear;
begin
ClearData;
FDataSize:=0;
FStart:=0;
end;
@ -87,6 +107,7 @@ procedure TDeque.PopFront();inline;
begin
if(FDataSize>0) then
begin
ClearSingleDataEntry(FStart);
inc(FStart);
dec(FDataSize);
if(FStart=FCapacity) then
@ -97,7 +118,10 @@ end;
procedure TDeque.PopBack();inline;
begin
if(FDataSize>0) then
begin
ClearSingleDataEntry((FStart+FDataSize-1)mod FCapacity);
dec(FDataSize);
end;
end;
procedure TDeque.PushFront(value:T);inline;
@ -127,6 +151,7 @@ end;
procedure TDeque.SetValue(position:SizeUInt; value:T);inline;
begin
Assert(position < size, 'Deque access out of range');
ClearSingleDataEntry((FStart+position)mod FCapacity);
FData[(FStart+position)mod FCapacity]:=value;
end;
@ -142,7 +167,68 @@ begin
GetMutable:=@FData[(FStart+position) mod FCapacity];
end;
procedure TDeque.IncreaseCapacity;inline;
procedure TDeque.MoveSimpleData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
begin
Move(FData[StartIndex], FData[StartIndex+Offset], NrElems*SizeOf(T));
if Offset>0 then
FillChar(FData[StartIndex], NrElems*SizeOf(T), 0)
else
FillChar(FData[StartIndex+NrElems+Offset], -Offset*SizeOf(T), 0);
end;
procedure TDeque.MoveManagedData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
var
i: SizeUInt;
begin
//since we always move blocks where Abs(Offset)>=NrElems, there is no need for
//2 seperate loops (1 for ngeative and 1 for positive Offsett)
for i := 0 to NrElems-1 do
begin
Finalize(FData[StartIndex+i+Offset]);
FData[StartIndex+i+Offset] := FData[StartIndex+i];
Finalize(FData[StartIndex+i]);
FillChar(FData[StartIndex+i], SizeOf(T), 0);
end;
end;
procedure TDeque.MoveData(StartIndex: SizeUInt; Offset: SizeInt; NrElems: SizeUInt);
begin
if IsManagedType(T) then
MoveManagedData(StartIndex, Offset, NrElems)
else
MoveSimpleData(StartIndex, Offset, NrElems);
end;
procedure TDeque.ClearSingleDataEntry(Index: SizeUInt);
begin
if IsManagedType(T) then
begin
Finalize(FData[Index]);
FillChar(FData[Index], SizeOf(T), 0);
end
else
FData[Index] := default(T);
end;
procedure TDeque.ClearData;
var
i: SizeUint;
begin
if IsManagedType(T) then
for i := Low(FData) to High(FData) do
Finalize(FData[i]);
FillChar(FData[Low(FData)], SizeUInt(Length(FData))*SizeOf(T), 0);
end;
procedure TDeque.IncreaseCapacity;
function Min(const A,B: SizeUInt): SizeUInt; inline; //no need to drag in the entire Math unit ;-)
begin
if (A<B) then
Result:=A
else
Result:=B;
end;
const
// if size is small, multiply by 2;
// if size bigger but <256M, inc by 1/8*size;
@ -151,7 +237,7 @@ const
cSizeBig = 256*1024*1024;
var
i,OldEnd,
DataSize:SizeUInt;
DataSize,CurLast,EmptyElems,Elems:SizeUInt;
begin
OldEnd:=FCapacity;
DataSize:=FCapacity*SizeOf(T);
@ -165,11 +251,26 @@ begin
FCapacity:=FCapacity+FCapacity div 8
else
FCapacity:=FCapacity+FCapacity div 16;
SetLength(FData, FCapacity);
if (FStart>0) then
for i:=0 to FStart-1 do
FData[OldEnd+i]:=FData[i];
begin
if (FCapacity-OldEnd>=FStart) then //we have room to move all items in one go
begin
MoveData(0, OldEnd ,FStart)
end
else
begin //we have to move things around in chunks: we have more data in front of FStart than we have newly created unused elements
CurLast := OldEnd-1;
EmptyElems:=FCapacity-1-CurLast;
while (FStart>0) do
begin
Elems := Min(EmptyElems, FStart);
MoveData(0, CurLast+1, Elems);
MoveData(Elems, -Elems, FCapacity-Elems);
Dec(FStart, Elems);
end;
end;
end;
end;
procedure TDeque.Reserve(cap:SizeUInt);inline;

22
packages/rtl-objpas/src/inc/fmtbcd.pp
View File

@ -797,10 +797,12 @@ INTERFACE
{$endif}
function __get_null : tBCD; Inline;
function __get_zero : tBCD; Inline;
function __get_one : tBCD; Inline;
PROPERTY
NullBCD : tBCD Read __get_null;
ZeroBCD : tBCD Read __get_zero;
OneBCD : tBCD Read __get_one;
//{$define __lo_bh := 1 * ( -( MaxFmtBCDFractionSize * 1 + 2 ) ) }
@ -887,16 +889,20 @@ IMPLEMENTATION
OneBCD_ : tBCD;
function __get_null : tBCD; Inline;
begin
__get_null := NullBCD_;
end;
end;
function __get_zero : tBCD; Inline;
begin
__get_zero := NullBCD_;
__get_zero.Precision := 1;
end;
function __get_one : tBCD; Inline;
begin
__get_one := OneBCD_;
end;
end;
type
range_digits = 1..maxfmtbcdfractionsize;
@ -1584,7 +1590,7 @@ IMPLEMENTATION
begin
_SELECT
_WHEN aValue = 0
_THEN result := NullBCD;
_THEN result := ZeroBCD;
_WHEN aValue = 1
_THEN result := OneBCD;
_WHEN aValue = low ( myInttype )
@ -4130,12 +4136,6 @@ begin
else { array or something like that }
not_implemented;
end;
// peephole, avoids problems with databases, mantis #30853
if (Result.Precision = 0) and (Result.SignSpecialPlaces = 0) then
begin
Result.Precision := 10;
Result.SignSpecialPlaces := 2;
end;
end;
function VarToBCD ( const aValue : Variant ) : tBCD;

39
tests/webtbs/tw38306.pp Normal file
View File

@ -0,0 +1,39 @@
{ %OPT=-gh }
{$mode objfpc}
program gqueue_test;
uses
gqueue;
type
TIntQueue = specialize TQueue<Integer>;
var
IntQueue: TIntQueue;
PushCnt: Integer;
procedure Push2Pop1;
var
i: Integer;
begin
for i:= 0 to 1000000 do begin
IntQueue.Push(PushCnt);
inc(PushCnt);
IntQueue.Push(PushCnt);
inc(PushCnt);
IntQueue.Pop();
end;
end;
var
i: Integer;
begin
try
IntQueue:= TIntQueue.Create;
Push2Pop1;
WriteLn('Ready');
finally
IntQueue.Free;
end;
end.