-- Zusammenführen von r43620 in ».«:

U    compiler/nadd.pas
U    compiler/ncnv.pas
U    compiler/ncon.pas
U    compiler/node.pas
A    tests/test/tcurrency1.pp
A    tests/webtbs/tw33963.pp
A    tests/webtbs/tw36179.pp
-- Aufzeichnung der Informationen für Zusammenführung von r43620 in ».«:
 U   .

git-svn-id: branches/fixes_3_2@43621 -

.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

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);

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;

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;
 
 

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 }

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.

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.

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.