paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-02 10:30:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch to fix Bug ID #28993

Browse Source 
git-svn-id: trunk@32357 -
This commit is contained in:
michael 2015-11-18 14:34:56 +00:00
parent 55b32f741d
commit 525982b9ca
1 changed files with 26 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -247,8 +247,8 @@ INTERFACE
{ Returns True if successful, False if Int Digits needed to be truncated } { Returns True if successful, False if Int Digits needed to be truncated }
function NormalizeBCD ( const InBCD : tBCD; function NormalizeBCD ( const InBCD : tBCD;
var OutBCD : tBCD; var OutBCD : tBCD;
const Prec, const Precision,
Scale : Word ) : Boolean; Places : Integer ) : Boolean;
procedure BCDAdd ( const BCDin1, procedure BCDAdd ( const BCDin1,
BCDin2 : tBCD; BCDin2 : tBCD;
@ -2005,38 +2005,35 @@ IMPLEMENTATION
{ Returns True if successful, False if Int Digits needed to be truncated } { Returns True if successful, False if Int Digits needed to be truncated }
function NormalizeBCD ( const InBCD : tBCD; function NormalizeBCD ( const InBCD : tBCD;
var OutBCD : tBCD; var OutBCD : tBCD;
const Prec, const Precision,
Scale : Word ) : Boolean; Places : Integer ) : Boolean;
var var
bh : tBCD_helper; bh : tBCD_helper;
tm : {$ifopt r+} 1..maxfmtbcdfractionsize - 1 {$else} Integer {$endif}; tm : {$ifopt r+} 1..maxfmtbcdfractionsize - 1 {$else} Integer {$endif};
begin begin
NormalizeBCD := True;
{$ifopt r+} {$ifopt r+}
if ( Prec < 0 ) OR ( Prec > MaxFmtBCDFractionSize ) then RangeError; if ( Precision < 0 ) OR ( Precision > MaxFmtBCDFractionSize ) then RangeError;
if ( Scale < 0 ) OR ( Prec >= MaxFmtBCDFractionSize ) then RangeError; if ( Places < 0 ) OR ( Precision >= MaxFmtBCDFractionSize ) then RangeError;
{$endif} {$endif}
if BCDScale ( InBCD ) > Scale NormalizeBCD := True;
then begin if BCDScale ( InBCD ) > Places then
unpack_BCD ( InBCD, bh ); begin
WITH bh do unpack_BCD ( InBCD, bh );
begin tm := bh.Plac - Places;
tm := Plac - Scale; bh.Plac := Places;
Plac := Scale; { dec ( prec, tm ); Dec/Inc error? }
{ dec ( prec, tm ); Dec/Inc error? } bh.Prec := bh.Prec - tm;
Prec := Prec - tm; { dec ( LDig, tm ); Dec/Inc error? }
{ dec ( ldig, tm ); Dec/Inc error? } bh.LDig := bh.LDig - tm;
LDig := LDig - tm; NormalizeBCD := False;
NormalizeBCD := False; if NOT pack_BCD ( bh, OutBCD ) then
end; RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' );
if NOT pack_BCD ( bh, OutBCD ) end
then begin else
RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' ); OutBCD := InBCD;
end; end;
end;
end;
procedure BCDMultiply ( const BCDin1, procedure BCDMultiply ( const BCDin1,
BCDin2 : tBCD; BCDin2 : tBCD;
@ -2298,9 +2295,11 @@ if p > 3 then halt;
{ {
writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig ); writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig );
} }
for i2 := lLdig DOWNTO lFDig do for i2 := lLdig DOWNTO lFDig do
begin 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; ue := 0;
while v3 < 0 do while v3 < 0 do
begin begin