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

* Patch from Laco to fix issue #39261

Browse Source 
git-svn-id: trunk@49623 -
This commit is contained in:
michael 2021-07-21 15:08:53 +00:00
parent e6a593c5fa
commit 573917706f
2 changed files with 23 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1278,6 +1278,25 @@ IMPLEMENTATION
neg1,
neg2 : Boolean;
// real/reduced precision if there are on left side insignificant zero digits
function BCDPrec(const BCD: tBCD): word;
var scale: word;
begin
Result := BCD.Precision;
scale := BCDScale(BCD);
i := Low(BCD.Fraction);
while (Result>0) and (Result>scale) do begin
// high nibble
if BCD.Fraction[i] shr 4 <> 0 then Exit;
Dec(Result);
if Result <= scale then Exit;
// low nibble
if BCD.Fraction[i] <> 0 then Exit;
Dec(Result);
Inc(i);
end;
end;
begin
{$ifndef bigger_BCD}
neg1 := ( BCD1.SignSpecialPlaces AND NegBit ) <> 0;
@ -1292,8 +1311,8 @@ IMPLEMENTATION
_WHEN ( NOT neg1 ) AND neg2
_THEN result := +1;
_WHENOTHER
pr1 := BCD1.Precision;
pr2 := BCD2.Precision;
pr1 := BCDPrec(BCD1);
pr2 := BCDPrec(BCD2);
{$ifndef bigger_BCD}
pl1 := BCD1.SignSpecialPlaces AND PlacesMask;
pl2 := BCD2.SignSpecialPlaces AND PlacesMask;

3
tests/test/units/fmtbcd/tfmtbcd.pp
View File

@ -253,7 +253,6 @@ begin
bcd:=strtobcd('0');
testFormatBCD('0;;0',bcd, '0');
testFormatBCD('0;;#',bcd, '');
testFormatBCD('0;;0.#',bcd, '0');
testFormatBCD('0;;0.00',bcd, '0.00');
// test StrToBCD:
@ -302,6 +301,8 @@ begin
testBCDCompare(-100.1, 100.1, -1);
testBCDCompare(-100.1, -100.2, 1);
testBCDCompare(100, 100.1, -1);
testBCDCompare(DoubleToBcd(0), 0, 0);
testBCDCompare(CurrToBcd(0), 0, 0);
testBCDCompare(CurrToBcd(0.01), CurrToBcd(0.001), 1); // BCD values with Precision<Scale
testBCDCompare(CurrToBcd(0.01), 0.01, 0);