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

    values with inequal length. Mantis #20505

git-svn-id: trunk@19508 -

rtl/objpas/fmtbcd.pp

@@ -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;

tests/test/units/fmtbcd/tfmtbcd.pp

@@ -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