diff --git a/.gitattributes b/.gitattributes index 3106c63156..3a7f64af14 100644 --- a/.gitattributes +++ b/.gitattributes @@ -13024,6 +13024,7 @@ tests/test/tcptypedconst2.pp svneol=native#text/plain tests/test/tcptypedconst3.pp svneol=native#text/plain tests/test/tcstring1.pp svneol=native#text/pascal tests/test/tcstring2.pp svneol=native#text/pascal +tests/test/tcurrency1.pp svneol=native#text/pascal tests/test/tdefault1.pp svneol=native#text/pascal tests/test/tdefault10.pp svneol=native#text/pascal tests/test/tdefault11.pp svneol=native#text/pascal @@ -16396,6 +16397,7 @@ tests/webtbs/tw33839b.pp -text svneol=native#text/pascal tests/webtbs/tw33840.pp -text svneol=native#text/pascal tests/webtbs/tw33875.pp svneol=native#text/plain tests/webtbs/tw33898.pp -text svneol=native#text/pascal +tests/webtbs/tw33963.pp svneol=native#text/pascal tests/webtbs/tw3402.pp svneol=native#text/plain tests/webtbs/tw34021.pp -text svneol=native#text/pascal tests/webtbs/tw34055.pp svneol=native#text/plain @@ -16466,6 +16468,7 @@ tests/webtbs/tw3595.pp svneol=native#text/plain tests/webtbs/tw35955.pp svneol=native#text/pascal tests/webtbs/tw3612.pp svneol=native#text/plain tests/webtbs/tw3617.pp svneol=native#text/plain +tests/webtbs/tw36179.pp svneol=native#text/pascal tests/webtbs/tw3619.pp svneol=native#text/plain tests/webtbs/tw3621.pp svneol=native#text/plain tests/webtbs/tw3628.pp svneol=native#text/plain diff --git a/compiler/nadd.pas b/compiler/nadd.pas index bb89c9682b..7a45fc4dff 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -700,6 +700,8 @@ implementation internalerror(2008022102); end; result:=t; + if nf_is_currency in flags then + include(result.flags,nf_is_currency); exit; end; {$if (FPC_FULLVERSION>20700) and not defined(FPC_SOFT_FPUX80)} @@ -1195,6 +1197,7 @@ implementation b : boolean; lt,rt : tnodetype; ot : tnodetype; + i64 : int64; {$ifdef state_tracking} factval : Tnode; change : boolean; @@ -2454,24 +2457,23 @@ implementation hp:=nil; if s64currencytype.typ=floatdef then begin -{$ifndef VER3_0} + move(trealconstnode(right).value_currency,i64,sizeof(i64)); { if left is a currency integer constant, we can get rid of the factor 10000 } { int64(...) causes a cast on currency, so it is the currency value multiplied by 10000 } - if (left.nodetype=realconstn) and (is_currency(left.resultdef)) and ((int64(trealconstnode(left).value_currency) mod 10000)=0) then + if (left.nodetype=realconstn) and (is_currency(left.resultdef)) and (not(nf_is_currency in left.flags)) and ((trunc(trealconstnode(left).value_real) mod 10000)=0) then begin { trealconstnode expects that value_real and value_currency contain valid values } trealconstnode(left).value_currency:=trealconstnode(left).value_currency {$ifdef FPC_CURRENCY_IS_INT64}div{$else}/{$endif} 10000; trealconstnode(left).value_real:=trealconstnode(left).value_real/10000; end { or if right is an integer constant, we can get rid of its factor 10000 } - else if (right.nodetype=realconstn) and (is_currency(right.resultdef)) and ((int64(trealconstnode(right).value_currency) mod 10000)=0) then + else if (right.nodetype=realconstn) and (is_currency(right.resultdef)) and (not(nf_is_currency in right.flags)) and ((trunc(trealconstnode(right).value_real) mod 10000)=0) then begin { trealconstnode expects that value and value_currency contain valid values } trealconstnode(right).value_currency:=trealconstnode(right).value_currency {$ifdef FPC_CURRENCY_IS_INT64}div{$else}/{$endif} 10000; trealconstnode(right).value_real:=trealconstnode(right).value_real/10000; end else -{$endif VER3_0} begin hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype)); include(hp.flags,nf_is_currency); diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index db5e65548b..e678fc74cc 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -1550,7 +1550,6 @@ implementation result:=nil; left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef)); include(left.flags,nf_is_currency); - typecheckpass(left); { Convert constants directly, else call Round() } if left.nodetype=realconstn then result:=cordconstnode.create(round(trealconstnode(left).value_real),resultdef,false) @@ -1578,6 +1577,7 @@ implementation begin left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef)); include(left.flags,nf_is_currency); + include(flags,nf_is_currency); typecheckpass(left); end; end; @@ -2961,6 +2961,8 @@ implementation begin hp:=result; result:=crealconstnode.create(trealconstnode(hp).value_real,resultdef); + if nf_is_currency in hp.flags then + include(result.flags,nf_is_currency); if ([nf_explicit,nf_internal] * flags <> []) then include(result.flags, nf_explicit); hp.free; diff --git a/compiler/ncon.pas b/compiler/ncon.pas index abfe4928e7..db842a9e61 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -497,7 +497,11 @@ implementation procedure Trealconstnode.printnodedata(var t:text); begin inherited printnodedata(t); - writeln(t,printnodeindention,'value = ',value_real); + write(t,printnodeindention,'value = ',value_real); + if is_currency(resultdef) then + writeln(', value_currency = ',value_currency) + else + writeln; end; diff --git a/compiler/node.pas b/compiler/node.pas index b5debaba72..aabfc5fc14 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -239,8 +239,10 @@ interface nf_absolute, { taddnode } + { if the result type of a node is currency, then this flag denotes, that the value is already mulitplied by 10000 } nf_is_currency, nf_has_pointerdiv, + { the node shall be short boolean evaluated, this flag has priority over localswitches } nf_short_bool, { tmoddivnode } diff --git a/tests/test/tcurrency1.pp b/tests/test/tcurrency1.pp new file mode 100644 index 0000000000..e601484b44 --- /dev/null +++ b/tests/test/tcurrency1.pp @@ -0,0 +1,116 @@ +program tcurrency; + +{ test basic mathematical operations (+,-,*,/) using currency data type } + +var + c1, c2: Currency; + d: Double; + i: Integer; + i64: int64; + +begin + write('Currency and Double ...'); + // addition double + d := 1; + c1 := 2; + c2 := 3; + if c1+d <> c2 then begin + writeln('Invalid currency+double=', c1+d, ', but expected ', c2); + halt(1); + end; + // subtraction double + d := 3; + c1 := 2; + c2 := -1; + if c1-d <> c2 then begin + writeln('Invalid currency-double=', c1-d, ', but expected ', c2); + halt(1); + end; + // multiplication double + d := -100; + c1 := 12.34; + c2 := -1234; + if d*c1 <> c2 then begin + writeln('Invalid currency*double=', d*c1, ', but expected ', c2); + halt(1); + end; + // division double + d := 100; + c1 := 12.34; + c2 := 0.1234; + if c1/d <> c2 then begin + writeln('Invalid currency/double=', c1/d, ', but expected ', c2); + halt(1); + end; + writeln(' Passed'); + + write('Currency and Integer ...'); + // addition integer + i := 1; + c1 := 2; + c2 := 3; + if c1+i <> c2 then begin + writeln('Invalid currency+integer=', c1+i, ', but expected ', c2); + halt(2); + end; + // subtraction integer + i := 10; + c1 := -2; + c2 := -12; + if c1-i <> c2 then begin + writeln('Invalid currency-integer=', c1-i, ', but expected ', c2); + halt(2); + end; + // multiplication integer + i := 100; + c1 := 12.34; + c2 := 1234; + if i*c1 <> c2 then begin + writeln('Invalid currency*integer=', i*c1, ', but expected ', c2); + halt(2); + end; + // division integer + i := 1000; + c1 := 123.4; + c2 := 0.1234; + if c1/i <> c2 then begin + writeln('Invalid currency/integer=', c1/i, ', but expected ', c2); + halt(2); + end; + writeln(' Passed'); + + write('Currency and Int64 ...'); + // addition int64 + i64 := 1; + c1 := 12.3456; + c2 := 13.3456; + if c1+i64 <> c2 then begin + writeln('Invalid currency+int64=', c1+i64, ', but expected ', c2); + halt(3); + end; + // subtraction int64 + i64 := 100; + c1 := 12.3456; + c2 := -87.6544; + if c1-i64 <> c2 then begin + writeln('Invalid currency-int64=', c1-i64, ', but expected ', c2); + halt(3); + end; + // multiplication int64 + i64 := -10000; + c1 := 12.3456; + c2 := -123456; + if i64*c1 <> c2 then begin + writeln('Invalid currency*int64=', i64*c1, ', but expected ', c2); + halt(3); + end; + // division int64 + i64 := -10000; + c1 := 123456; + c2 := -12.3456; + if c1/i64 <> c2 then begin + writeln('Invalid currency/int64=', c1/i64, ', but expected ', c2); + halt(3); + end; + writeln(' Passed'); +end. diff --git a/tests/webtbs/tw33963.pp b/tests/webtbs/tw33963.pp new file mode 100644 index 0000000000..d0ffb7f325 --- /dev/null +++ b/tests/webtbs/tw33963.pp @@ -0,0 +1,11 @@ +{$ifdef fpc}{$mode delphi}{$H+}{$endif} +var C: Currency; +begin + c:= 1000; + c:= c*1.05; + // at this point C=1050 + writeln(c:4:2); + if c<>1050 then + halt(1); + writeln('ok'); +end. diff --git a/tests/webtbs/tw36179.pp b/tests/webtbs/tw36179.pp new file mode 100644 index 0000000000..a9a4fb4962 --- /dev/null +++ b/tests/webtbs/tw36179.pp @@ -0,0 +1,16 @@ +var + c: currency; + s: string; +begin + c:=922337203685.47; + writeln(c:18:4,' = ', ' Trunc(c*10000)=', Trunc(c*10000)); // expected 9223372036854700, but get -75 + str(trunc(c*10000),s); + if s<>'9223372036854700' then + halt(1); + c:=-92233720368547; + writeln(c:18:4,' = ', ' Trunc(c*10000)=', Trunc(c*10000)); // expected -922337203685470000, but get 7580 + str(trunc(c*10000),s); + if s<>'-922337203685470000' then + halt(1); + writeln('ok'); +end.