--- Merging r32357 into '.':

U    packages/rtl-objpas/src/inc/fmtbcd.pp
--- Recording mergeinfo for merge of r32357 into '.':
 U   .
--- Merging r32358 into '.':
U    tests/test/units/fmtbcd/tfmtbcd.pp
--- Recording mergeinfo for merge of r32358 into '.':
 G   .
--- Merging r32722 into '.':
G    packages/rtl-objpas/src/inc/fmtbcd.pp
--- Recording mergeinfo for merge of r32722 into '.':
 G   .
--- Merging r32723 into '.':
G    tests/test/units/fmtbcd/tfmtbcd.pp
--- Recording mergeinfo for merge of r32723 into '.':
 G   .

# revisions: 32357,32358,32722,32723


git-svn-id: http://svn.freepascal.org/svn/fpc/branches/fixes_3_0@33813 3ad0048d-3df7-0310-abae-a5850022a9f2

2 files changed, 77 insertions, 35 deletions

diff --git a/packages/rtl-objpas/src/inc/fmtbcd.pp b/packages/rtl-objpas/src/inc/fmtbcd.pp
index 3ea2a7d691..8ff1897dbe 100644
--- a/packages/rtl-objpas/src/inc/fmtbcd.pp
+++ b/packages/rtl-objpas/src/inc/fmtbcd.pp
@@ -247,8 +247,8 @@ INTERFACE
 { Returns True if successful, False if Int Digits needed to be truncated }
   function NormalizeBCD ( const InBCD : tBCD;
                             var OutBCD : tBCD;
-                          const Prec,
-                                Scale : Word ) : Boolean;
+                          const Precision,
+                                Places : Integer ) : Boolean;
 
   procedure BCDAdd ( const BCDin1,
                            BCDin2 : tBCD;
@@ -1642,7 +1642,7 @@ IMPLEMENTATION
 {$else}
       BCD.Places := 4;
 {$endif}
-      if Decimals <> 4 then
+      if (Decimals <> 4) or (Decimals > BCD.Precision) then
         Result := NormalizeBCD ( BCD, BCD, Precision, Decimals )
       else
         Result := True;
@@ -2005,38 +2005,37 @@ IMPLEMENTATION
 { Returns True if successful, False if Int Digits needed to be truncated }
   function NormalizeBCD ( const InBCD : tBCD;
                             var OutBCD : tBCD;
-                          const Prec,
-                                Scale : Word ) : Boolean;
+                          const Precision,
+                                Places : Integer ) : Boolean;
 
     var
       bh : tBCD_helper;
-      tm : {$ifopt r+} 1..maxfmtbcdfractionsize - 1 {$else} Integer {$endif};
+      tm : {$ifopt r+} __lo_bh..__hi_bh {$else} Integer {$endif};
 
     begin
-      NormalizeBCD := True;
 {$ifopt r+}
-      if ( Prec < 0 ) OR ( Prec > MaxFmtBCDFractionSize ) then RangeError;
-      if ( Scale < 0 ) OR ( Prec >= MaxFmtBCDFractionSize ) then RangeError;
+      if ( Precision < 0 ) OR ( Precision > MaxFmtBCDFractionSize ) then RangeError;
+      if ( Places < 0 ) OR ( Precision >= MaxFmtBCDFractionSize ) then RangeError;
 {$endif}
-      if BCDScale ( InBCD ) > Scale
-        then begin
-          unpack_BCD ( InBCD, bh );
-          WITH bh do
-            begin
-              tm := Plac - Scale;
-              Plac := Scale;
-{             dec ( prec, tm );   Dec/Inc error? }
-              Prec := Prec - tm;
-{             dec ( ldig, tm );   Dec/Inc error? }
-              LDig := LDig - tm;
-              NormalizeBCD := False;
-             end;
-          if NOT pack_BCD ( bh, OutBCD )
-            then begin
-              RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' );
-             end;
-         end;
-     end;
+      if (BCDScale(InBCD) > Places) or (BCDPrecision(InBCD) < Places) then
+        begin
+        unpack_BCD ( InBCD, bh );
+        tm := bh.Plac - Places;
+        bh.Plac := Places;
+{       dec ( prec, tm );   Dec/Inc error? }
+        bh.Prec := bh.Prec - tm;
+{       dec ( LDig, tm );   Dec/Inc error? }
+        bh.LDig := bh.LDig - tm;
+        NormalizeBCD := tm <= 0;
+        if NOT pack_BCD ( bh, OutBCD ) then
+          RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' );
+        end
+      else
+        begin
+        OutBCD := InBCD;
+        NormalizeBCD := True;
+        end
+    end;
 
   procedure BCDMultiply ( const BCDin1,
                                 BCDin2 : tBCD;
@@ -2298,9 +2297,11 @@ if p > 3 then halt;
 {
 writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig );
 }
+                                                                  
                                 for i2 := lLdig DOWNTO lFDig do
                                   begin
-                                    v3 := Singles[i2] - bh2.Singles[i2 - p] * dd - ue;
+                                    // Typecase needed on 64-bit because evaluation happens using qword... 
+                                    v3 := Longint(Singles[i2]) - Longint(bh2.Singles[i2 - p] * dd) - Longint(ue);
                                     ue := 0;
                                     while v3 < 0 do
                                       begin
diff --git a/tests/test/units/fmtbcd/tfmtbcd.pp b/tests/test/units/fmtbcd/tfmtbcd.pp
index 824d657962..bd0d4aa965 100644
--- a/tests/test/units/fmtbcd/tfmtbcd.pp
+++ b/tests/test/units/fmtbcd/tfmtbcd.pp
@@ -9,9 +9,23 @@ var
   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
@@ -25,6 +39,7 @@ 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
@@ -96,17 +111,34 @@ begin
 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
-  if (BCDCompare(bcd1,bcd2) <> res) then
+  outBcd:=0;
+  if NormalizeBCD(StrToBCD(input,FS), outBcd, Precision, Places) <> res then
   begin
-    writeln('BCDCompare failed; bcd1:', bcdtostr(bcd1), ' bcd2:', bcdtostr(bcd2));
+    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;
-    i: integer;
     d: double;
     s1: shortstring;
     s2: ansistring;
@@ -231,12 +263,15 @@ begin
   testBCDPrecScale('1001.1001', 8, 4);
 
   // test BCDToCurr:
-  testBCDToCurr( '922337203685477.5807', MaxCurrency); // test boundary values
-  testBCDToCurr('-922337203685477.5807', MinCurrency);
+  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:
@@ -264,6 +299,13 @@ begin
   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));
@@ -273,7 +315,6 @@ begin
   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!');