diff --git a/.gitattributes b/.gitattributes index 7c7fbaff8b..ce67de85a2 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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/tverify.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/gencomptest.dpr svneol=native#text/plain tests/test/units/fpcunit/lists.pp svneol=native#text/plain diff --git a/rtl/objpas/fmtbcd.pp b/rtl/objpas/fmtbcd.pp index 7e8c48a892..4e005dfed4 100644 --- a/rtl/objpas/fmtbcd.pp +++ b/rtl/objpas/fmtbcd.pp @@ -1079,15 +1079,16 @@ IMPLEMENTATION WITH BCD, bh do begin - lnzf := FDig < 0; - while lnzf do + lnzf := FDig <= 0; + while lnzf do // skip leading 0 if Singles[FDig] = 0 then begin Inc ( FDig ); - if FDig = 0 + if FDig > 0 then lnzf := False; end else lnzf := False; + if FDig > 1 then FDig := 1; pre := LDig - FDig + 1; fra := Plac; doround := False; @@ -1144,7 +1145,7 @@ IMPLEMENTATION lnzf := False; i := LDig; - while ( i >= FDig ) AND ( NOT lnzf ) do + while ( i >= FDig ) AND ( NOT lnzf ) do // skip trailing 0 begin if Singles[i] <> 0 then begin @@ -1412,7 +1413,7 @@ IMPLEMENTATION WITH lvars, bh do begin - while ( pfnb < lav ) AND ( NOT nbf ) do + while ( pfnb < lav ) AND ( NOT nbf ) do // skip leading spaces begin Inc ( pfnb ); nbf := aValue[pfnb] <> ' '; @@ -1421,7 +1422,7 @@ IMPLEMENTATION then begin if aValue[pfnb] IN [ '+', '-' ] then begin - ps := pfnb; + ps := pfnb; // position of sign Inc ( pfnb ); end; inife := low ( inife ); @@ -1461,7 +1462,7 @@ IMPLEMENTATION else inife := inexp; '+', '-': if ( inife = inexp ) AND ( fp[inexp] = 0 ) - then pse := i + then pse := i // position of exponent sign else result := False; else begin result := False; @@ -1472,7 +1473,7 @@ IMPLEMENTATION if not result then begin result := True; - for i := errp TO lav do + for i := errp TO lav do // skip trailing spaces if aValue[i] <> ' ' then result := False; end; @@ -2205,9 +2206,7 @@ writeln; bh1[True] := null_.bh; FlipFlop := False; fdset := p > 0; - if fdset - then bh.FDig := 0; - add := 0; + Add := 0; nz := True; while nz do WITH bh1[FlipFlop] do @@ -2284,9 +2283,6 @@ if p > 3 then halt; nLDig := 0; ue := 0; dd := Singles[lFDig] DIV ( bh2.Singles[lFDig - p] + 1 ); -{ - dd := 1; -} if dd < 1 then dd := 1; { @@ -2316,21 +2312,10 @@ writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig ); end; } end; - sf := False; - nfdig := lfdig; - nldig := lldig; + sf := False; + nFDig := lFDig; + nLDig := lLDig; 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 then nz := False else begin @@ -2344,8 +2329,22 @@ writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig ); end; end; end; + if Add <> 0 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; while ( Add <> 0 ) AND ( i4 >= bh.FDig ) do begin diff --git a/tests/test/units/fmtbcd/tfmtbcd.pp b/tests/test/units/fmtbcd/tfmtbcd.pp new file mode 100644 index 0000000000..8fcc58e6f1 --- /dev/null +++ b/tests/test/units/fmtbcd/tfmtbcd.pp @@ -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.