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

* fmtbcd divide fix (and others), Mantis #19636, fix by Lacak2. + Test

Browse Source 
git-svn-id: trunk@19220 -
This commit is contained in:
marco 2011-09-24 21:34:39 +00:00
parent 09a2f07d5d
commit b0b12d3a64
3 changed files with 144 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -10663,6 +10663,7 @@ tests/test/units/dos/tidos.pp svneol=native#text/plain
tests/test/units/dos/tidos2.pp svneol=native#text/plain tests/test/units/dos/tidos2.pp svneol=native#text/plain
tests/test/units/dos/tverify.pp svneol=native#text/plain tests/test/units/dos/tverify.pp svneol=native#text/plain
tests/test/units/dos/tversion.pp svneol=native#text/plain tests/test/units/dos/tversion.pp svneol=native#text/plain
tests/test/units/fmtbcd/tfmtbcd.pp svneol=native#text/plain
tests/test/units/fpcunit/fplists.pp svneol=native#text/plain tests/test/units/fpcunit/fplists.pp svneol=native#text/plain
tests/test/units/fpcunit/gencomptest.dpr svneol=native#text/plain tests/test/units/fpcunit/gencomptest.dpr svneol=native#text/plain
tests/test/units/fpcunit/lists.pp svneol=native#text/plain tests/test/units/fpcunit/lists.pp svneol=native#text/plain

55
rtl/objpas/fmtbcd.pp
View File

@ -1079,15 +1079,16 @@ IMPLEMENTATION
WITH BCD, WITH BCD,
bh do bh do
begin begin
lnzf := FDig < 0; lnzf := FDig <= 0;
while lnzf do while lnzf do // skip leading 0
if Singles[FDig] = 0 if Singles[FDig] = 0
then begin then begin
Inc ( FDig ); Inc ( FDig );
if FDig = 0 if FDig > 0
then lnzf := False; then lnzf := False;
end end
else lnzf := False; else lnzf := False;
if FDig > 1 then FDig := 1;
pre := LDig - FDig + 1; pre := LDig - FDig + 1;
fra := Plac; fra := Plac;
doround := False; doround := False;
@ -1144,7 +1145,7 @@ IMPLEMENTATION
lnzf := False; lnzf := False;
i := LDig; i := LDig;
while ( i >= FDig ) AND ( NOT lnzf ) do while ( i >= FDig ) AND ( NOT lnzf ) do // skip trailing 0
begin begin
if Singles[i] <> 0 if Singles[i] <> 0
then begin then begin
@ -1412,7 +1413,7 @@ IMPLEMENTATION
WITH lvars, WITH lvars,
bh do bh do
begin begin
while ( pfnb < lav ) AND ( NOT nbf ) do while ( pfnb < lav ) AND ( NOT nbf ) do // skip leading spaces
begin begin
Inc ( pfnb ); Inc ( pfnb );
nbf := aValue[pfnb] <> ' '; nbf := aValue[pfnb] <> ' ';
@ -1421,7 +1422,7 @@ IMPLEMENTATION
then begin then begin
if aValue[pfnb] IN [ '+', '-' ] if aValue[pfnb] IN [ '+', '-' ]
then begin then begin
ps := pfnb; ps := pfnb; // position of sign
Inc ( pfnb ); Inc ( pfnb );
end; end;
inife := low ( inife ); inife := low ( inife );
@ -1461,7 +1462,7 @@ IMPLEMENTATION
else inife := inexp; else inife := inexp;
'+', '+',
'-': if ( inife = inexp ) AND ( fp[inexp] = 0 ) '-': if ( inife = inexp ) AND ( fp[inexp] = 0 )
then pse := i then pse := i // position of exponent sign
else result := False; else result := False;
else begin else begin
result := False; result := False;
@ -1472,7 +1473,7 @@ IMPLEMENTATION
if not result if not result
then begin then begin
result := True; result := True;
for i := errp TO lav do for i := errp TO lav do // skip trailing spaces
if aValue[i] <> ' ' if aValue[i] <> ' '
then result := False; then result := False;
end; end;
@ -2205,9 +2206,7 @@ writeln;
bh1[True] := null_.bh; bh1[True] := null_.bh;
FlipFlop := False; FlipFlop := False;
fdset := p > 0; fdset := p > 0;
if fdset Add := 0;
then bh.FDig := 0;
add := 0;
nz := True; nz := True;
while nz do while nz do
WITH bh1[FlipFlop] do WITH bh1[FlipFlop] do
@ -2284,9 +2283,6 @@ if p > 3 then halt;
nLDig := 0; nLDig := 0;
ue := 0; ue := 0;
dd := Singles[lFDig] DIV ( bh2.Singles[lFDig - p] + 1 ); dd := Singles[lFDig] DIV ( bh2.Singles[lFDig - p] + 1 );
{
dd := 1;
}
if dd < 1 if dd < 1
then dd := 1; then dd := 1;
{ {
@ -2316,21 +2312,10 @@ writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig );
end; end;
} }
end; end;
sf := False; sf := False;
nfdig := lfdig; nFDig := lFDig;
nldig := lldig; nLDig := lLDig;
Inc ( Add, dd ); Inc ( Add, dd );
if NOT fdset
then begin
bh.FDig := p;
fdset := True;
end;
if bh.LDig < p
then begin
bh.LDig := p;
if ( bh.LDig - bh.FDig ) > Succ ( MaxFmtBCDFractionSize )
then nz := False;
end;
if sf if sf
then nz := False then nz := False
else begin else begin
@ -2344,8 +2329,22 @@ writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig );
end; end;
end; end;
end; end;
if Add <> 0 if Add <> 0
then begin then begin
if NOT fdset
then begin
bh.FDig := p;
fdset := True;
end;
if bh.LDig < p
then begin
bh.LDig := p;
if ( bh.LDig - bh.FDig ) > Succ ( MaxFmtBCDFractionSize )
then nz := False;
end;
i4 := p; i4 := p;
while ( Add <> 0 ) AND ( i4 >= bh.FDig ) do while ( Add <> 0 ) AND ( i4 >= bh.FDig ) do
begin begin

116
tests/test/units/fmtbcd/tfmtbcd.pp Normal file
View File

@ -0,0 +1,116 @@
// A basic tests for FmtBCD unit
{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
uses SysUtils, FmtBCD;
var
ErrorCount: integer;
FS, DFS: TFormatSettings;
bcd: TBCD;
procedure testBCDMultiply(bcd1,bcd2,bcd3: TBCD);
var bcdmul: TBCD;
begin
BCDMultiply(bcd1,bcd2,bcdmul);
if (BCDCompare(bcd3,bcdmul) <> 0) or
(bcdtostr(bcd3) <> bcdtostr(bcdmul)) then
begin
writeln(bcdtostr(bcd1), ' * ', bcdtostr(bcd2), ' = ', bcdtostr(bcdmul), ' but expected ', bcdtostr(bcd3));
writeln('Expected: ', bcd3.Precision,',',bcd3.SignSpecialPlaces, ' but calculated: ', bcdmul.Precision,',',bcdmul.SignSpecialPlaces);
inc(ErrorCount);
end;
end;
procedure testBCDDivide(bcd1,bcd2,bcd3: TBCD);
var bcddiv: TBCD;
begin
BCDDivide(bcd1,bcd2,bcddiv);
if (BCDCompare(bcd3,bcddiv) <> 0) or
(bcdtostr(bcd3) <> bcdtostr(bcddiv)) then
begin
writeln(bcdtostr(bcd1), ' / ', bcdtostr(bcd2), ' = ', bcdtostr(bcddiv), ' but expected ', bcdtostr(bcd3));
//writeln('Expected: ', bcd3.Precision,',',bcd3.SignSpecialPlaces, ' but calculated: ', bcddiv.Precision,',',bcddiv.SignSpecialPlaces);
inc(ErrorCount);
end;
end;
procedure testBCDToStrF(const s1, s2: string);
begin
if s1 <> s2 then
begin
writeln('BCDToStrF: ', s1, ' Expected: ', s2);
inc(ErrorCount);
end;
end;
procedure testBCDPrecScale(const s: string; const prec,scale: integer);
var bcd: TBCD;
begin
bcd := strtobcd(s);
if (bcd.Precision <> prec) or (BCDScale(bcd) <> scale) then
begin
writeln('StrToBcd: ', bcdtostr(bcd), ' (', s, ') Precision:', bcd.Precision, ' Scale: ', BCDScale(bcd));
inc(ErrorCount);
end;
end;
begin
ErrorCount := 0;
// test BCDToStrF:
DFS:=DefaultFormatSettings;
FS.DecimalSeparator:=',';
FS.ThousandSeparator:=' ';
FS.CurrencyDecimals:=2;
FS.CurrencyString:='$';
FS.CurrencyFormat:=3;
DefaultFormatSettings:=FS;
bcd:=strtobcd('123456789123456789,12345');
testBCDToStrF(bcdtostrf(bcd, ffFixed, 30, 4), '123456789123456789,1235'); //no thousand separators
testBCDToStrF(bcdtostrf(bcd, ffNumber, 30, 5), '123 456 789 123 456 789,12345'); //with thousand separators
testBCDToStrF(bcdtostrf(bcd, ffCurrency, 30, 2), '123 456 789 123 456 789,12 $'); //with thousand separators
FS.DecimalSeparator:='.';
FS.ThousandSeparator:=',';
FS.CurrencyFormat:=0;
DefaultFormatSettings:=FS;
bcd:=strtobcd('123456789123456789.12345');
testBCDToStrF(bcdtostr(bcd), '123456789123456789.12345');
testBCDToStrF(bcdtostrf(bcd, ffFixed, 30, 3), '123456789123456789.123'); //no thousand separators
testBCDToStrF(bcdtostrf(bcd, ffNumber, 30, 6), '123,456,789,123,456,789.123450'); //with thousand separators
testBCDToStrF(bcdtostrf(bcd, ffCurrency, 30, 5), '$123,456,789,123,456,789.12345'); //with thousand separators
// test StrToBCD:
testBCDPrecScale(' 1.0000000000000000E-0003 ', 3, 3);
testBCDPrecScale('0.001', 3, 3);
testBCDPrecScale('1.001', 4, 3);
testBCDPrecScale('1001', 4, 0);
testBCDPrecScale('1001.1001', 8, 4);
DefaultFormatSettings := DFS;
// test BCDMultiply:
FS.DecimalSeparator:='.';
FS.ThousandSeparator:=#0;
testBCDMultiply(1000, 1000, 1000000);
testBCDMultiply(1000, 0.001, 1);
testBCDMultiply(1000, 0.0001, 0.1);
testBCDMultiply(strtobcd('12345678901234567890',FS), strtobcd('0.0000000001',FS), strtobcd('1234567890.123456789',FS));
// test BCDDivide:
testBCDDivide(1000, 1000, 1);
testBCDDivide(1000, -100, -10);
testBCDDivide(-1000, 10, -100);
testBCDDivide(-1000, -1, 1000);
testBCDDivide(11000, 11, 1000);
testBCDDivide(11, 11000, 0.001);
testBCDDivide(100, -2, -50);
testBCDDivide(1007, 5, 201.4);
if ErrorCount<>0 then writeln('FmtBCD test program found ', ErrorCount, ' errors!');
Halt(ErrorCount);
end.