mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 11:59:32 +02:00
326 lines
10 KiB
ObjectPascal
326 lines
10 KiB
ObjectPascal
// A basic tests for FmtBCD unit
|
|
|
|
{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
|
|
|
|
uses SysUtils, FmtBCD, Variants;
|
|
|
|
var
|
|
ErrorCount: integer;
|
|
FS, DFS: TFormatSettings;
|
|
bcd: TBCD;
|
|
|
|
procedure testBCDSubtract(bcd1,bcd2,bcd3: TBCD);
|
|
var bcdsub: TBCD;
|
|
begin
|
|
bcdsub:=0;
|
|
BCDSubtract(bcd1,bcd2,bcdsub);
|
|
if (BCDCompare(bcd3,bcdsub) <> 0) or
|
|
(bcdtostr(bcd3) <> bcdtostr(bcdsub)) then
|
|
begin
|
|
writeln(bcdtostr(bcd1), ' - ', bcdtostr(bcd2), ' = ', bcdtostr(bcdsub), ' but expected ', bcdtostr(bcd3));
|
|
inc(ErrorCount);
|
|
end;
|
|
end;
|
|
|
|
procedure testBCDMultiply(bcd1,bcd2,bcd3: TBCD);
|
|
var bcdmul: TBCD;
|
|
begin
|
|
bcdmul:=0;
|
|
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
|
|
bcddiv:=0;
|
|
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 testBCDToStr(const bcd: TBCD; const Output: string);
|
|
var s: string;
|
|
begin
|
|
s := BCDToStr(bcd);
|
|
if s <> Output then
|
|
begin
|
|
writeln('BCDToStr: ', s, ' Expected: ', Output);
|
|
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 testFormatBCD(const Format: string; BCD: TBCD; const Output: string);
|
|
var s: string;
|
|
begin
|
|
s := FormatBCD(Format, BCD);
|
|
if s <> Output then
|
|
begin
|
|
writeln('FormatBCD ''', Format, ''': ', s, ' Expected: ', Output);
|
|
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;
|
|
|
|
procedure testBCDToCurr(const s: string; c1: currency);
|
|
var c2: currency;
|
|
b1, b2: boolean;
|
|
begin
|
|
b1 := c1<>0;
|
|
b2 := BCDToCurr(StrToBCD(s), c2);
|
|
if b1 <> b2 then
|
|
begin
|
|
writeln('BCDToCurr for ', s, ' returned ', b2,' but expected ', b1);
|
|
inc(ErrorCount);
|
|
end
|
|
else if b2 and (c1 <> c2) then
|
|
begin
|
|
writeln('BCDToCurr for ', s, ' returned ', c2,' but expected ', c1);
|
|
inc(ErrorCount);
|
|
end;
|
|
end;
|
|
|
|
procedure testBCDCompare(bcd1,bcd2: TBCD; res: integer);
|
|
var ret: integer;
|
|
begin
|
|
ret := BCDCompare(bcd1,bcd2);
|
|
if ret <> res then
|
|
begin
|
|
writeln('BCDCompare failed; bcd1:', bcdtostr(bcd1), ' bcd2:', bcdtostr(bcd2), ' returned ', ret, ' but expected ', res);
|
|
inc(ErrorCount);
|
|
end;
|
|
end;
|
|
|
|
procedure testNormalizeBCD(const input, expected: string; Precision,Places: integer; res: boolean);
|
|
var outBcd: TBCD;
|
|
begin
|
|
outBcd:=0;
|
|
if NormalizeBCD(StrToBCD(input,FS), outBcd, Precision, Places) <> res then
|
|
begin
|
|
writeln('NormalizeBCD for ', input, ' returned ', not res, ' but expected ', res);
|
|
inc(ErrorCount);
|
|
end;
|
|
if StrToBCD(expected,FS) <> outBcd then
|
|
begin
|
|
writeln('NormalizeBCD for ', input, ' returned ', BCDToStr(outBcd,FS), ' but expected ', expected);
|
|
inc(ErrorCount);
|
|
end;
|
|
end;
|
|
|
|
procedure testVariantOp(v1, v2: variant);
|
|
var v: variant;
|
|
d: double;
|
|
s1: shortstring;
|
|
s2: ansistring;
|
|
s3: unicodestring;
|
|
begin
|
|
//arithmetic op. ... invalid variant operation ?
|
|
v := v1 + v2;
|
|
v := v * v2;
|
|
v := v / v2;
|
|
v := v - v2;
|
|
if VarIsFmtBCD(v1) and not VarIsFmtBCD(v) then inc(ErrorCount);
|
|
|
|
//compare op.
|
|
if not(v1=v) or (v1<>v) then
|
|
begin
|
|
writeln('Original variant: ', vartostr(v1), 'recomputed variant: ', vartostr(v));
|
|
inc(ErrorCount);
|
|
end;
|
|
v := v + 1;
|
|
if (v1 >= v) or not(v1 < v) then
|
|
begin
|
|
writeln('Compare2 failed; v1: ', vartostr(v1), ' v: ', vartostr(v));
|
|
inc(ErrorCount);
|
|
end;
|
|
v := v - 1.1;
|
|
if (v1 <= v) or not(v1 > v) then
|
|
begin
|
|
writeln('Compare3 failed; v1: ', vartostr(v1), ' v: ', vartostr(v));
|
|
inc(ErrorCount);
|
|
end;
|
|
|
|
//assign op. ... invalid variant typecast ?
|
|
//i := v;
|
|
d := v;
|
|
//s1 := v;
|
|
s2 := v;
|
|
//s3 := v;
|
|
end;
|
|
|
|
begin
|
|
ErrorCount := 0;
|
|
|
|
// test BCDToStr:
|
|
DFS:=DefaultFormatSettings;
|
|
|
|
FS.DecimalSeparator:=',';
|
|
FS.ThousandSeparator:=#0;
|
|
DefaultFormatSettings:=FS;
|
|
testBCDToStr(0, '0');
|
|
testBCDToStr(-123, '-123');
|
|
testBCDToStr(0.5, '0,5');
|
|
testBCDToStr(-1.03125, '-1,03125');
|
|
testBCDToStr(CurrToBCD(1.2345), '1,2345');
|
|
testBCDToStr(CurrToBCD(-0.0045), '-0,0045');
|
|
|
|
// test BCDToStrF:
|
|
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
|
|
testBCDToStrF(bcdtostrf(bcd, ffExponent, 9, 2), '1,23456789E+17');
|
|
|
|
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, ffFixed, 30, 0), '123456789123456789');
|
|
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
|
|
testBCDToStrF(bcdtostrf(bcd, ffExponent, 8, 3), '1.2345679E+017');
|
|
bcd:=strtobcd('123456789');
|
|
testBCDToStrF(bcdtostrf(bcd, ffFixed, 10, 0), '123456789');
|
|
testBCDToStrF(bcdtostrf(bcd, ffExponent, 8, 3), '1.2345679E+008');
|
|
bcd:=strtobcd('9.99'); // test rounding
|
|
testBCDToStrF(bcdtostrf(bcd, ffFixed, 10, 1), '10.0');
|
|
testBCDToStrF(bcdtostrf(bcd, ffFixed, 10, 0), '10');
|
|
testBCDToStrF(bcdtostrf(bcd, ffExponent, 8, 3), '9.9900000E+000');
|
|
bcd:=strtobcd('0.09');
|
|
testBCDToStrF(bcdtostrf(bcd, ffFixed, 10, 1), '0.1');
|
|
testBCDToStrF(bcdtostrf(bcd, ffFixed, 10, 0), '0');
|
|
testBCDToStrF(bcdtostrf(bcd, ffExponent, 8, 3), '9.0000000E-002');
|
|
|
|
// test FormatBCD:
|
|
bcd:=strtobcd('123456789123456789.12345');
|
|
testFormatBCD('',bcd, '123456789123456789.12345');
|
|
testFormatBCD('0',bcd, '123456789123456789');
|
|
testFormatBCD('0.',bcd, '123456789123456789');
|
|
testFormatBCD('0.0',bcd, '123456789123456789.1');
|
|
testFormatBCD('#.0000',bcd, '123456789123456789.1235');
|
|
testFormatBCD('#.000000',bcd, '123456789123456789.123450');
|
|
testFormatBCD('# ###.000',bcd, '123456789123456 789.123');
|
|
testFormatBCD('#-#-###.0000',bcd, '12345678912345-6-789.1235');
|
|
testFormatBCD('#,#,###.0000',bcd, '123,456,789,123,456,789.1235');
|
|
testFormatBCD('#,#.0000##',bcd, '123,456,789,123,456,789.12345');
|
|
bcd:=strtobcd('-123.455');
|
|
testFormatBCD('0.0',bcd, '-123.5');
|
|
testFormatBCD('00000.0',bcd, '-00123.5');
|
|
testFormatBCD('#####.#',bcd, '-123.5');
|
|
testFormatBCD('.0000',bcd, '-123.4550');
|
|
testFormatBCD('+0.0',bcd, '+-123.5'); // sign is part of number
|
|
testFormatBCD('0.00" $"',bcd, '-123.46 $');
|
|
testFormatBCD('0.0;(neg)0.00',bcd, '(neg)123.46');
|
|
bcd:=strtobcd('0');
|
|
testFormatBCD('0;;0',bcd, '0');
|
|
testFormatBCD('0;;#',bcd, '');
|
|
testFormatBCD('0;;0.00',bcd, '0.00');
|
|
|
|
// 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);
|
|
|
|
// test BCDToCurr:
|
|
testBCDToCurr( '922337203685477.5807', 922337203685477.5807); // boundary values
|
|
testBCDToCurr('-922337203685477.5807', -922337203685477.5807);
|
|
testBCDToCurr('-922337203685477.5808', StrToCurr('-922337203685477.5808'));
|
|
testBCDToCurr( '922337203685477.5808', 0); // out-of-range values
|
|
testBCDToCurr('-922337203685477.5809', 0);
|
|
|
|
// test BCDSubtract:
|
|
testBCDSubtract(CurrToBCD(0), CurrToBCD(-0.1), 0.1);
|
|
|
|
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);
|
|
|
|
testBCDDivide(StrToBCD('224518.0639999999994919',FS), IntegerToBCD(6615), StrToBCD('33.94075041572184421646258503401360544217687074829931972789115646',FS)); // bug #33795
|
|
|
|
// test BCDCompare:
|
|
testBCDCompare(100, 100, 0);
|
|
testBCDCompare(-100.1, -100.1, 0);
|
|
testBCDCompare(-100.1, 100.1, -1);
|
|
testBCDCompare(-100.1, -100.2, 1);
|
|
testBCDCompare(100, 100.1, -1);
|
|
testBCDCompare(CurrToBcd(0.01), CurrToBcd(0.001), 1); // BCD values with Precision<Scale
|
|
testBCDCompare(CurrToBcd(0.01), 0.01, 0);
|
|
|
|
// test NormalizeBCD:
|
|
testNormalizeBCD('100.17', '100.17', 5, 3, True);
|
|
testNormalizeBCD('100.17', '100.17', 5, 2, True);
|
|
testNormalizeBCD('100.17', '100.1' , 5, 1, False); // truncate, not round
|
|
|
|
// test Variant support:
|
|
testVariantOp(varFmtBcdCreate(100), varFmtBcdCreate(-100));
|
|
testVariantOp(double(2.5), varFmtBcdCreate(100)); //double on left side
|
|
testVariantOp(varFmtBcdCreate(100), integer(-10));
|
|
testVariantOp(varFmtBcdCreate(-100), shortstring(floattostr(10.2)));
|
|
testVariantOp(varFmtBcdCreate(-100), ansistring(floattostr(0.2)));
|
|
testVariantOp(varFmtBcdCreate(-100), unicodestring(floattostr(-0.2)));
|
|
|
|
if ErrorCount<>0 then
|
|
begin
|
|
writeln('FmtBCD test program found ', ErrorCount, ' errors!');
|
|
Halt(ErrorCount);
|
|
end;
|
|
end.
|