paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 23:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed round(currency) so it takes the rounding mode into account on

Browse Source 
platforms where currency is "type int64"
  * inline trunc(currency), trunc(comp) and round(comp) on platforms where
    currency and comp are "type int64"

git-svn-id: trunk@47859 -
This commit is contained in:
Jonas Maebe 2020-12-27 13:19:02 +00:00
parent 514db355b1
commit b359080f42
4 changed files with 116 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -16112,6 +16112,7 @@ tests/test/units/math/tmask2.pp svneol=native#text/plain
tests/test/units/math/tminmaxconst.pp svneol=native#text/pascal
tests/test/units/math/tnaninf.pp svneol=native#text/plain
tests/test/units/math/tpower.pp svneol=native#text/pascal
tests/test/units/math/trndcurr.pp svneol=native#text/plain
tests/test/units/math/troundm.pp svneol=native#text/plain
tests/test/units/math/tsincos.pp svneol=native#text/pascal
tests/test/units/math/ttrig1.pp svneol=native#text/plain

10
rtl/inc/currh.inc
View File

@ -14,16 +14,16 @@
{$ifdef FPC_CURRENCY_IS_INT64}
function trunc(c : currency) : int64;
function trunc(c : currency) : int64; {$ifdef systeminline} inline; {$endif}
{$ifndef FPUNONE}
function round(c : currency) : int64;
{$endif FPUNONE}
{$ifndef cpujvm}
function trunc(c : comp) : int64;
function round(c : comp) : int64;
function trunc(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
function round(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$else not cpujvm}
function trunc_comp(c: comp) : int64;
function round_comp(c : comp) : int64;
function trunc_comp(c: comp) : int64; {$ifdef systeminline} inline; {$endif}
function round_comp(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$endif not cpujvm}
{$endif FPC_CURRENCY_IS_INT64}

48
rtl/inc/gencurr.inc
View File

@ -14,16 +14,16 @@
{$ifdef FPC_CURRENCY_IS_INT64}
function trunc(c : currency) : int64;
function trunc(c : currency) : int64; {$ifdef systeminline} inline; {$endif}
begin
{ the type conversion includes dividing by 10000 }
result := int64(c)
end;
{$ifndef cpujvm}
function trunc(c : comp) : int64;
function trunc(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$else not cpujvm}
function trunc_comp(c : comp) : int64;
function trunc_comp(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$endif cpujvm}
begin
result := c
@ -34,27 +34,43 @@
var
rem, absrem: currency;
begin
{ (int64(tmyrec(c))(+/-)5000) div 10000 can overflow }
result := int64(c);
rem := c - currency(result);
absrem := rem;
if absrem < 0 then
absrem := -absrem;
if (absrem > 0.5) or
((absrem = 0.5) and
(rem > 0)) then
if (rem > 0) then
inc(result)
else
dec(result);
case softfloat_rounding_mode of
rmNearest:
begin
absrem := abs(rem);
if (absrem > 0.5) or
((absrem = 0.5) and
odd(result)) then
if (rem > 0) then
inc(result)
else
dec(result)
end;
rmDown:
begin
if rem < 0 then
dec(result);
end;
rmUp:
begin
if rem > 0 then
inc(result);
end;
rmTruncate:
begin
// result is already ok
end;
end;
end;
{$endif FPUNONE}
{$ifndef cpujvm}
function round(c : comp) : int64;
function round(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$else not cpujvm}
function round_comp(c : comp) : int64;
function round_comp(c : comp) : int64; {$ifdef systeminline} inline; {$endif}
{$endif cpujvm}
begin
result := c

78
tests/test/units/math/trndcurr.pp Normal file
View File

@ -0,0 +1,78 @@
uses
Math;
{$ifndef SKIP_CURRENCY_TEST}
procedure testround(const c, expected: currency; error: longint);
begin
if round(c)<>expected then
begin
writeln('round(',c,') = ',round(c),' instead of ', expected);
halt(error);
end;
end;
{$endif}
begin
{$ifndef SKIP_CURRENCY_TEST}
writeln('Rounding mode: rmNearest (even)');
testround(0.5,0.0,1);
testround(1.5,2.0,2);
testround(-0.5,0.0,3);
testround(-1.5,-2.0,4);
testround(0.6,1.0,101);
testround(1.6,2.0,102);
testround(-0.6,-1.0,103);
testround(-1.6,-2.0,104);
testround(0.4,0.0,151);
testround(1.4,1.0,152);
testround(-0.4,-0.0,153);
testround(-1.4,-1.0,154);
writeln('Rounding mode: rmUp');
SetRoundMode(rmUp);
testround(0.5,1.0,5);
testround(1.5,2.0,6);
testround(-0.5,0.0,7);
testround(-1.5,-1.0,8);
testround(0.6,1.0,105);
testround(1.6,2.0,106);
testround(-0.6,0.0,107);
testround(-1.6,-1.0,108);
testround(0.4,1.0,155);
testround(1.4,2.0,156);
testround(-0.4,0.0,157);
testround(-1.4,-1.0,158);
writeln('Rounding mode: rmDown');
SetRoundMode(rmDown);
testround(0.5,0.0,9);
testround(1.5,1.0,10);
testround(-0.5,-1.0,11);
testround(-1.5,-2.0,12);
testround(0.6,0.0,109);
testround(1.6,1.0,110);
testround(-0.6,-1.0,111);
testround(-1.6,-2.0,112);
testround(0.4,0.0,159);
testround(1.4,1.0,160);
testround(-0.4,-1.0,161);
testround(-1.4,-2.0,162);
writeln('Rounding mode: rmTruncate');
SetRoundMode(rmTruncate);
testround(0.5,0.0,13);
testround(1.5,1.0,14);
testround(-0.5,0.0,15);
testround(-1.5,-1.0,16);
testround(0.6,0.0,113);
testround(1.6,1.0,114);
testround(-0.6,0.0,115);
testround(-1.6,-1.0,116);
testround(0.4,0.0,163);
testround(1.4,1.0,164);
testround(-0.4,0.0,165);
testround(-1.4,-1.0,166);
{$endif}
end.