paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-07 15:29:35 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Applied patch from Lacak2 that improved compare() functionality for

Browse Source 
values with inequal length. Mantis #20505

git-svn-id: trunk@19508 -
This commit is contained in:
marco 2011-10-18 20:21:34 +00:00
parent 5955d90a40
commit 94e03df0e1
2 changed files with 81 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
rtl/objpas/fmtbcd.pp
View File

@ -1306,17 +1306,11 @@ IMPLEMENTATION
if pr1 < pr2
then pr := pr1
else pr := pr2;
res := 0;
i := __low_Fraction;
while ( res = 0 ) AND ( i < ( __low_Fraction + ( pr DIV 2 ) ) ) do
begin
{
if BCD1.Fraction[i] < BCD2.Fraction[i]
then res := -1
else
if BCD1.Fraction[i] > BCD2.Fraction[i]
then res := +1;
}
_SELECT
_WHEN BCD1.Fraction[i] < BCD2.Fraction[i]
_THEN res := -1
@ -1326,19 +1320,13 @@ IMPLEMENTATION
_endSELECT;
Inc ( i );
end;
if res = 0
then begin
if Odd ( pr )
then begin
f1 := BCD1.Fraction[i] AND $f0;
f2 := BCD2.Fraction[i] AND $f0;
{
if f1 < f2
then res := -1
else
if f1 > f2
then res := +1;
}
_SELECT
_WHEN f1 < f2
_THEN res := -1
@ -1346,7 +1334,14 @@ IMPLEMENTATION
_THEN res := +1;
_endSELECT;
end;
if res = 0 then
if pr1 > pr2 then
res := +1
else if pr1 < pr2 then
res := -1;
end;
if neg1
then result := 0 - res
else result := res;
@ -3846,6 +3841,8 @@ begin
varInt64 : Result := vInt64;
varQword : Result := vQWord;
varString : Result := AnsiString(vString);
varOleStr : Result := WideString(vOleStr);
varUString : Result := UnicodeString(vString);
else
if vType=VarFmtBCD then
Result := TFMTBcdVarData(vPointer).BCD
@ -3919,8 +3916,10 @@ procedure TFMTBcdFactory.BinaryOp(var Left: TVarData; const Right: TVarData; con
RaiseInvalidOp;
end;
if Left.vType=VarType then
if Left.vType = VarType then
TFMTBcdVarData(Left.VPointer).BCD := l
else if Left.vType = varDouble then
Left.vDouble := l
else
RaiseInvalidOp;
end;

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

@ -2,7 +2,7 @@
{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
uses SysUtils, FmtBCD;
uses SysUtils, FmtBCD, Variants;
var
ErrorCount: integer;
@ -55,6 +55,57 @@ begin
end;
end;
procedure testBCDCompare(bcd1,bcd2: TBCD; res: integer);
begin
if (BCDCompare(bcd1,bcd2) <> res) then
begin
writeln('BCDCompare failed; bcd1:', bcdtostr(bcd1), ' bcd2:', bcdtostr(bcd2));
inc(ErrorCount);
end;
end;
procedure testVariantOp(v1, v2: variant);
var v: variant;
i: integer;
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;
@ -110,6 +161,21 @@ begin
testBCDDivide(100, -2, -50);
testBCDDivide(1007, 5, 201.4);
// 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);
// 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