paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 20:29:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Applied patch from Manfred Hahn to fic bcdSubtract (bug ID 29207)

Browse Source 
git-svn-id: trunk@32722 -
This commit is contained in:
michael 2015-12-26 11:23:44 +00:00
parent a7f1ce2e98
commit dcefe41fe3
1 changed files with 7 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
packages/rtl-objpas/src/inc/fmtbcd.pp
View File

@ -1642,7 +1642,7 @@ IMPLEMENTATION
{$else} {$else}
BCD.Places := 4; BCD.Places := 4;
{$endif} {$endif}
if Decimals <> 4 then if (Decimals <> 4) or (Decimals > BCD.Precision) then
Result := NormalizeBCD ( BCD, BCD, Precision, Decimals ) Result := NormalizeBCD ( BCD, BCD, Precision, Decimals )
else else
Result := True; Result := True;
@ -2010,15 +2010,14 @@ IMPLEMENTATION
var var
bh : tBCD_helper; bh : tBCD_helper;
tm : {$ifopt r+} 1..maxfmtbcdfractionsize - 1 {$else} Integer {$endif}; tm : {$ifopt r+} __lo_bh..__hi_bh {$else} Integer {$endif};
begin begin
{$ifopt r+} {$ifopt r+}
if ( Precision < 0 ) OR ( Precision > MaxFmtBCDFractionSize ) then RangeError; if ( Precision < 0 ) OR ( Precision > MaxFmtBCDFractionSize ) then RangeError;
if ( Places < 0 ) OR ( Precision >= MaxFmtBCDFractionSize ) then RangeError; if ( Places < 0 ) OR ( Precision >= MaxFmtBCDFractionSize ) then RangeError;
{$endif} {$endif}
NormalizeBCD := True; if (BCDScale(InBCD) > Places) or (BCDPrecision(InBCD) < Places) then
if BCDScale ( InBCD ) > Places then
begin begin
unpack_BCD ( InBCD, bh ); unpack_BCD ( InBCD, bh );
tm := bh.Plac - Places; tm := bh.Plac - Places;
@ -2027,12 +2026,15 @@ IMPLEMENTATION
bh.Prec := bh.Prec - tm; bh.Prec := bh.Prec - tm;
{ dec ( LDig, tm ); Dec/Inc error? } { dec ( LDig, tm ); Dec/Inc error? }
bh.LDig := bh.LDig - tm; bh.LDig := bh.LDig - tm;
NormalizeBCD := False; NormalizeBCD := tm <= 0;
if NOT pack_BCD ( bh, OutBCD ) then if NOT pack_BCD ( bh, OutBCD ) then
RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' ); RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' );
end end
else else
begin
OutBCD := InBCD; OutBCD := InBCD;
NormalizeBCD := True;
end
end; end;
procedure BCDMultiply ( const BCDin1, procedure BCDMultiply ( const BCDin1,