+ added currency support based on int64

  + is_64bit for use in cg units instead of is_64bitint
  * removed cgmessage from n386add, replace with internalerrors

compiler/cg64f32.pas

@@ -569,7 +569,7 @@ unit cg64f32;
          from_signed := is_signed(fromdef);
          to_signed := is_signed(todef);
 
-         if not is_64bitint(todef) then
+         if not is_64bit(todef) then
            begin
              oldregisterdef := registerdef;
              registerdef := false;
@@ -688,7 +688,7 @@ unit cg64f32;
                { in all cases, there is only a problem if the higest bit is set }
                if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
                  begin
-                   if is_64bitint(fromdef) then
+                   if is_64bit(fromdef) then
                      begin
                        hreg := p.location.registerhigh;
                        opsize := OS_32;
@@ -836,7 +836,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.39  2003-04-22 10:09:34  daniel
+  Revision 1.40  2003-04-23 20:16:03  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.39  2003/04/22 10:09:34  daniel
     + Implemented the actual register allocator
     + Scratch registers unavailable when new register allocator used
     + maybe_save/maybe_restore unavailable when new register allocator used

compiler/cgobj.pas

@@ -1423,7 +1423,7 @@ unit cgobj;
         if not(cs_check_range in aktlocalswitches) or
            not(todef.deftype in [orddef,enumdef,arraydef]) then
           exit;
-        if is_64bitint(p.resulttype.def) or is_64bitint(todef) then
+        if is_64bit(p.resulttype.def) or is_64bit(todef) then
           begin
              cg64.g_rangecheck64(list,p,todef);
              exit;
@@ -1842,7 +1842,12 @@ finalization
 end.
 {
   $Log$
-  Revision 1.87  2003-04-23 14:42:07  daniel
+  Revision 1.88  2003-04-23 20:16:03  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.87  2003/04/23 14:42:07  daniel
     * Further register allocator work. Compiler now smaller with new
       allocator than without.
     * Somebody forgot to adjust ppu version number

compiler/defcmp.pas

@@ -57,6 +57,7 @@ interface
           tc_bool_2_int,
           tc_real_2_real,
           tc_int_2_real,
+          tc_real_2_currency,
           tc_proc_2_procvar,
           tc_arrayconstructor_2_set,
           tc_load_smallset,
@@ -150,7 +151,7 @@ implementation
            bint,bint,bint,bint,
            bint,bint,bint,bint,
            bbool,bbool,bbool,
-           bchar,bchar);
+           bchar,bchar,bint);
 
         basedefconvertsimplicit : array[tbasedef,tbasedef] of tconverttype =
           { void, char, int, bool }
@@ -241,6 +242,14 @@ implementation
                         eq:=te_convert_l1;
                       end;
                    end;
+                 floatdef :
+                   begin
+                     if is_currency(def_to) then
+                      begin
+                        doconv:=tc_real_2_currency;
+                        eq:=te_convert_l2;
+                      end;
+                   end;
                  classrefdef,
                  procvardef,
                  pointerdef :
@@ -370,7 +379,8 @@ implementation
                case def_from.deftype of
                  orddef :
                    begin { ordinal to real }
-                     if is_integer(def_from) then
+                     if is_integer(def_from) or
+                        is_currency(def_from) then
                        begin
                          doconv:=tc_int_2_real;
                          eq:=te_convert_l1;
@@ -1183,7 +1193,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.22  2003-04-23 11:37:33  peter
+  Revision 1.23  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.22  2003/04/23 11:37:33  peter
     * po_comp for proc to procvar fixed
 
   Revision 1.21  2003/04/10 17:57:52  peter

compiler/defutil.pas

@@ -161,6 +161,9 @@ interface
     {# Returns true, if def is a 64 bit integer type }
     function is_64bitint(def : tdef) : boolean;
 
+    {# Returns true, if def is a 64 bit type }
+    function is_64bit(def : tdef) : boolean;
+
     {# If @var(l) isn't in the range of def a range check error (if not explicit) is generated and
       the value is placed within the range
     }
@@ -194,11 +197,20 @@ implementation
     { returns true, if def is a currency type }
     function is_currency(def : tdef) : boolean;
       begin
-         is_currency:=(def.deftype=floatdef) and (tfloatdef(def).typ=s64currency);
+         case s64currencytype.def.deftype of
+           orddef :
+             result:=(def.deftype=orddef) and
+                     (torddef(s64currencytype.def).typ=torddef(def).typ);
+           floatdef :
+             result:=(def.deftype=floatdef) and
+                     (tfloatdef(s64currencytype.def).typ=tfloatdef(def).typ);
+           else
+             internalerror(200304222);
+         end;
       end;
 
 
-      function range_to_basetype(low,high:TConstExprInt):tbasetype;
+    function range_to_basetype(low,high:TConstExprInt):tbasetype;
       begin
         { generate a unsigned range if high<0 and low>=0 }
         if (low>=0) and (high<0) then
@@ -302,7 +314,7 @@ implementation
            orddef :
              begin
                dt:=torddef(def).typ;
-               is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]);
+               is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit,scurrency]);
              end;
            enumdef :
              is_signed:=tenumdef(def).min < 0;
@@ -519,6 +531,13 @@ implementation
       end;
 
 
+    { true, if def is a 64 bit type }
+    function is_64bit(def : tdef) : boolean;
+      begin
+         is_64bit:=(def.deftype=orddef) and (torddef(def).typ in [u64bit,s64bit,scurrency])
+      end;
+
+
     { if l isn't in the range of def a range check error (if not explicit) is generated and
       the value is placed within the range }
     procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
@@ -739,7 +758,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.3  2003-03-17 19:05:08  peter
+  Revision 1.4  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.3  2003/03/17 19:05:08  peter
     * dynamic array is also a special array
 
   Revision 1.2  2002/12/23 20:58:03  peter

compiler/i386/n386add.pas

@@ -570,13 +570,13 @@ interface
                         falselabel:=ofl;
                      end;
                    else
-                     CGMessage(type_e_mismatch);
+                     internalerror(2003042212);
                  end;
                  secondpass(right);
                  maketojumpbool(exprasmlist,right,lr_load_regvars);
                end;
              else
-               CGMessage(type_e_mismatch);
+               internalerror(2003042213);
            end;
          end;
       end;
@@ -613,7 +613,7 @@ interface
               cmpop:=true;
             end;
           else
-            CGMessage(type_e_mismatch);
+            internalerror(2003042214);
         end;
 
         if (right.location.loc<>LOC_FPUREGISTER) then
@@ -845,10 +845,7 @@ interface
           andn :
             op:=A_AND;
           else
-            begin
-              { no < or > support for sets }
-              CGMessage(type_e_mismatch);
-            end;
+            internalerror(2003042215);
         end;
         { left must be a register }
         left_must_be_reg(opsize,noswap);
@@ -988,13 +985,11 @@ interface
             op:=OP_OR;
           andn:
             op:=OP_AND;
-          muln:
+          else
             begin
-              { should be handled in pass_1 (JM) }
+              { everything should be handled in pass_1 (JM) }
               internalerror(200109051);
             end;
-          else
-            CGMessage(type_e_mismatch);
         end;
 
         { left and right no register?  }
@@ -1246,7 +1241,7 @@ interface
           andn:
             op:=A_PAND;
           else
-            CGMessage(type_e_mismatch);
+            internalerror(2003042214);
         end;
 
         { left and right no register?  }
@@ -1508,7 +1503,7 @@ interface
                    exit;
                  end
                { 64bit operations }
-               else if is_64bitint(left.resulttype.def) then
+               else if is_64bit(left.resulttype.def) then
                  begin
                    second_add64bit;
                    exit;
@@ -1605,7 +1600,7 @@ interface
               andn :
                 op:=A_AND;
               else
-                CGMessage(type_e_mismatch);
+                internalerror(200304229);
             end;
 
             { filter MUL, which requires special handling }
@@ -1647,7 +1642,7 @@ interface
                equaln,unequaln :
                  cmpop:=true;
                else
-                 CGMessage(type_e_mismatch);
+                 internalerror(2003042210);
              end;
              left_must_be_reg(opsize,false);
              emit_op_right_left(A_CMP,opsize);
@@ -1661,7 +1656,7 @@ interface
              set_result_location(true,true);
            end
          else
-           CGMessage(type_e_mismatch);
+           internalerror(2003042211);
       end;
 
 begin
@@ -1669,7 +1664,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.64  2003-04-23 09:51:16  daniel
+  Revision 1.65  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.64  2003/04/23 09:51:16  daniel
     * Removed usage of edi in a lot of places when new register allocator used
     + Added newra versions of g_concatcopy and secondadd_float
 

compiler/i386/n386cnv.pas

@@ -171,6 +171,7 @@ implementation
                 emit_ref(A_FILD,S_IQ,href);
                 emit_const_reg(A_ADD,S_L,8,r);
              end;
+           scurrency,
            s64bit:
              begin
                 emit_ref(A_FILD,S_IQ,href);
@@ -359,38 +360,39 @@ implementation
 {$ifdef fpc}
       const
          secondconvert : array[tconverttype] of pointer = (
-           {$ifdef fpc}@{$endif}second_nothing, {equal}
-           {$ifdef fpc}@{$endif}second_nothing, {not_possible}
-           {$ifdef fpc}@{$endif}second_nothing, {second_string_to_string, handled in resulttype pass }
-           {$ifdef fpc}@{$endif}second_char_to_string,
-           {$ifdef fpc}@{$endif}second_nothing, {char_to_charray}
-           {$ifdef fpc}@{$endif}second_nothing, { pchar_to_string, handled in resulttype pass }
-           {$ifdef fpc}@{$endif}second_nothing, {cchar_to_pchar}
-           {$ifdef fpc}@{$endif}second_cstring_to_pchar,
-           {$ifdef fpc}@{$endif}second_ansistring_to_pchar,
-           {$ifdef fpc}@{$endif}second_string_to_chararray,
-           {$ifdef fpc}@{$endif}second_nothing, { chararray_to_string, handled in resulttype pass }
-           {$ifdef fpc}@{$endif}second_array_to_pointer,
-           {$ifdef fpc}@{$endif}second_pointer_to_array,
-           {$ifdef fpc}@{$endif}second_int_to_int,
-           {$ifdef fpc}@{$endif}second_int_to_bool,
-           {$ifdef fpc}@{$endif}second_bool_to_bool,
-           {$ifdef fpc}@{$endif}second_bool_to_int,
-           {$ifdef fpc}@{$endif}second_real_to_real,
-           {$ifdef fpc}@{$endif}second_int_to_real,
-           {$ifdef fpc}@{$endif}second_proc_to_procvar,
-           {$ifdef fpc}@{$endif}second_nothing, { arrayconstructor_to_set }
-           {$ifdef fpc}@{$endif}second_nothing, { second_load_smallset, handled in first pass }
-           {$ifdef fpc}@{$endif}second_cord_to_pointer,
-           {$ifdef fpc}@{$endif}second_nothing, { interface 2 string }
-           {$ifdef fpc}@{$endif}second_nothing, { interface 2 guid   }
-           {$ifdef fpc}@{$endif}second_class_to_intf,
-           {$ifdef fpc}@{$endif}second_char_to_char,
-           {$ifdef fpc}@{$endif}second_nothing,  { normal_2_smallset }
-           {$ifdef fpc}@{$endif}second_nothing,  { dynarray_2_openarray }
-           {$ifdef fpc}@{$endif}second_nothing,  { pwchar_2_string }
-           {$ifdef fpc}@{$endif}second_nothing,  { variant_2_dynarray }
-           {$ifdef fpc}@{$endif}second_nothing   { dynarray_2_variant}
+           @second_nothing, {equal}
+           @second_nothing, {not_possible}
+           @second_nothing, {second_string_to_string, handled in resulttype pass }
+           @second_char_to_string,
+           @second_nothing, {char_to_charray}
+           @second_nothing, { pchar_to_string, handled in resulttype pass }
+           @second_nothing, {cchar_to_pchar}
+           @second_cstring_to_pchar,
+           @second_ansistring_to_pchar,
+           @second_string_to_chararray,
+           @second_nothing, { chararray_to_string, handled in resulttype pass }
+           @second_array_to_pointer,
+           @second_pointer_to_array,
+           @second_int_to_int,
+           @second_int_to_bool,
+           @second_bool_to_bool,
+           @second_bool_to_int,
+           @second_real_to_real,
+           @second_int_to_real,
+           @second_nothing, { real_to_currency, handled in resulttype pass }
+           @second_proc_to_procvar,
+           @second_nothing, { arrayconstructor_to_set }
+           @second_nothing, { second_load_smallset, handled in first pass }
+           @second_cord_to_pointer,
+           @second_nothing, { interface 2 string }
+           @second_nothing, { interface 2 guid   }
+           @second_class_to_intf,
+           @second_char_to_char,
+           @second_nothing,  { normal_2_smallset }
+           @second_nothing,  { dynarray_2_openarray }
+           @second_nothing,  { pwchar_2_string }
+           @second_nothing,  { variant_2_dynarray }
+           @second_nothing   { dynarray_2_variant}
          );
       type
          tprocedureofobject = procedure of object;
@@ -406,9 +408,9 @@ implementation
          { and should be quite portable too        }
          r.proc:=secondconvert[c];
          r.obj:=self;
-         tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
+         tprocedureofobject(r)();
       end;
-{$else}
+{$else fpc}
      begin
         case c of
           tc_equal,
@@ -430,6 +432,7 @@ implementation
           tc_bool_2_int : second_bool_to_int;
           tc_real_2_real : second_real_to_real;
           tc_int_2_real : second_int_to_real;
+          tc_real_2_currency : second_nothing;
           tc_proc_2_procvar : second_proc_to_procvar;
           tc_arrayconstructor_2_set : second_nothing;
           tc_load_smallset : second_nothing;
@@ -446,14 +449,19 @@ implementation
           else internalerror(2002101101);
         end;
      end;
-{$endif}
+{$endif fpc}
 
 begin
    ctypeconvnode:=ti386typeconvnode;
 end.
 {
   $Log$
-  Revision 1.59  2003-04-22 23:50:23  peter
+  Revision 1.60  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.59  2003/04/22 23:50:23  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/nadd.pas

@@ -190,6 +190,17 @@ implementation
                (left.resulttype.def.deftype=floatdef) and
                (tfloatdef(left.resulttype.def).typ=tfloatdef(right.resulttype.def).typ) then
               resultrealtype:=left.resulttype
+            { when there is a currency type then use currency, but
+              only when currency is defined as float }
+            else
+             if (s64currencytype.def.deftype=floatdef) and
+                (is_currency(right.resulttype.def) or
+                 is_currency(left.resulttype.def)) then
+              begin
+                resultrealtype:=s64currencytype;
+                inserttypeconv(right,resultrealtype);
+                inserttypeconv(left,resultrealtype);
+              end
             else
              begin
                inserttypeconv(right,resultrealtype);
@@ -765,6 +776,14 @@ implementation
                      end;
                   end;
                end
+             { is there a currency type ? }
+             else if ((torddef(rd).typ=scurrency) or (torddef(ld).typ=scurrency)) then
+               begin
+                  if (torddef(ld).typ<>scurrency) then
+                   inserttypeconv(left,s64currencytype);
+                  if (torddef(rd).typ<>scurrency) then
+                   inserttypeconv(right,s64currencytype);
+               end
              { is there a signed 64 bit type ? }
              else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
                begin
@@ -1240,13 +1259,17 @@ implementation
             case nodetype of
               slashn :
                 begin
-                  hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,resultrealtype));
+                  { slashn will only work with floats }
+                  hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,s64currencytype));
                   include(hp.flags,nf_is_currency);
                   result:=hp;
                 end;
               muln :
                 begin
-                  hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,resultrealtype));
+                  if s64currencytype.def.deftype=floatdef then
+                    hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype))
+                  else
+                    hp:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,s64currencytype,false));
                   include(hp.flags,nf_is_currency);
                   result:=hp
                 end;
@@ -1497,12 +1520,22 @@ implementation
             exit;
           end;
 
+        { when currency is used set the result of the
+          parameters to s64bit, so they are not converted }
+        if is_currency(resulttype.def) then
+          begin
+            left.resulttype:=cs64bittype;
+            right.resulttype:=cs64bittype;
+          end;
+
         { otherwise, create the parameters for the helper }
         right := ccallparanode.create(
           cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype,true),
           ccallparanode.create(right,ccallparanode.create(left,nil)));
         left := nil;
-        if torddef(resulttype.def).typ = s64bit then
+        { only qword needs the unsigned code, the
+          signed code is also used for currency }
+        if is_signed(resulttype.def) then
           procname := 'fpc_mul_int64'
         else
           procname := 'fpc_mul_qword';
@@ -1647,7 +1680,7 @@ implementation
                  calcregisters(self,1,0,0);
                end
               { is there a 64 bit type ? }
-             else if (torddef(ld).typ in [s64bit,u64bit]) then
+             else if (torddef(ld).typ in [s64bit,u64bit,scurrency]) then
                begin
                  result := first_add64bitint;
                  if assigned(result) then
@@ -1917,7 +1950,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.83  2003-04-23 10:10:07  peter
+  Revision 1.84  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.83  2003/04/23 10:10:07  peter
     * expectloc fixes
 
   Revision 1.82  2003/04/22 23:50:22  peter

compiler/ncal.pas

@@ -2145,7 +2145,7 @@ type
                        else
                         begin
                           expectloc:=LOC_REGISTER;
-                          if is_64bitint(resulttype.def) then
+                          if is_64bit(resulttype.def) then
                             registers32:=2
                           else
                             registers32:=1;
@@ -2250,7 +2250,7 @@ type
              newcall := self.getcopy;
              tcallnode(newcall).left := paras;
              tcallnode(newcall).right := oldright;
-             
+
              newblock := internalstatements(statement);
              addstatement(statement,callparatemps);
              { add the copy of the call node after the callparatemps block    }
@@ -2483,7 +2483,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.141  2003-04-23 13:21:06  peter
+  Revision 1.142  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.141  2003/04/23 13:21:06  peter
     * fix warning for calling constructor inside constructor
 
   Revision 1.140  2003/04/23 12:35:34  florian

compiler/ncgadd.pas

@@ -116,7 +116,7 @@ interface
               if not cmpop then
                 begin
                   location.register := n.location.register;
-                  if is_64bitint(n.resulttype.def) then
+                  if is_64bit(n.resulttype.def) then
                     location.registerhigh := n.location.registerhigh;
                 end;
             LOC_REFERENCE,LOC_CREFERENCE:
@@ -125,7 +125,7 @@ interface
                 if not cmpop then
                   begin
                     location.register := n.location.register;
-                    if is_64bitint(n.resulttype.def) then
+                    if is_64bit(n.resulttype.def) then
                       location.registerhigh := n.location.registerhigh;
                   end;
               end;
@@ -136,7 +136,7 @@ interface
                     location_force_reg(exprasmlist,n.location,def_cgsize(n.resulttype.def),false);
                     if not cmpop then
                       location.register := n.location.register;
-                      if is_64bitint(n.resulttype.def) then
+                      if is_64bit(n.resulttype.def) then
                         location.registerhigh := n.location.registerhigh;
                   end;
               end;
@@ -156,7 +156,7 @@ interface
             (location.register.enum <> right.location.register.enum)) then
           begin
             rg.ungetregister(exprasmlist,right.location.register);
-            if is_64bitint(right.resulttype.def) then
+            if is_64bit(right.resulttype.def) then
               rg.ungetregister(exprasmlist,right.location.registerhigh);
           end;
         if (left.location.loc in [LOC_REGISTER,LOC_FPUREGISTER]) and
@@ -164,7 +164,7 @@ interface
             (location.register.enum <> left.location.register.enum)) then
           begin
             rg.ungetregister(exprasmlist,left.location.register);
-            if is_64bitint(left.resulttype.def) then
+            if is_64bit(left.resulttype.def) then
               rg.ungetregister(exprasmlist,left.location.registerhigh);
           end;
       end;
@@ -753,7 +753,7 @@ interface
                    exit;
                  end
                { 64bit operations }
-               else if is_64bitint(left.resulttype.def) then
+               else if is_64bit(left.resulttype.def) then
                  begin
                    second_op64bit;
                    exit;
@@ -816,7 +816,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2003-04-22 23:50:22  peter
+  Revision 1.8  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.7  2003/04/22 23:50:22  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/ncgld.pas

@@ -831,7 +831,7 @@ implementation
                    enumdef,
                    orddef :
                      begin
-                       if is_64bitint(lt) then
+                       if is_64bit(lt) then
                          begin
                             case torddef(lt).typ of
                                s64bit:
@@ -1009,7 +1009,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.50  2003-04-23 10:12:14  peter
+  Revision 1.51  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.50  2003/04/23 10:12:14  peter
     * allow multi pass2 changed to global boolean instead of node flag
 
   Revision 1.49  2003/04/22 23:50:22  peter

compiler/ncgmat.pas

@@ -158,7 +158,7 @@ implementation
 
 
       begin
-         if is_64bitint(left.resulttype.def) then
+         if is_64bit(left.resulttype.def) then
            begin
               secondpass(left);
 
@@ -268,7 +268,7 @@ implementation
           exit;
          location_copy(location,left.location);
 
-         if is_64bitint(resulttype.def) then
+         if is_64bit(resulttype.def) then
            begin
              { this code valid for 64-bit cpu's only ,
                otherwise helpers are called in pass_1
@@ -367,7 +367,7 @@ implementation
            shrn: op:=OP_SHR;
          end;
 
-         if is_64bitint(left.resulttype.def) then
+         if is_64bit(left.resulttype.def) then
            begin
               { already hanled in 1st pass }
               internalerror(2002081501);
@@ -467,7 +467,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.8  2003-04-22 10:09:35  daniel
+  Revision 1.9  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.8  2003/04/22 10:09:35  daniel
     + Implemented the actual register allocator
     + Scratch registers unavailable when new register allocator used
     + maybe_save/maybe_restore unavailable when new register allocator used

compiler/ncnv.pas

@@ -51,6 +51,7 @@ interface
           procedure mark_write;override;
           function docompare(p: tnode) : boolean; override;
        private
+          function resulttype_int_to_int : tnode;
           function resulttype_cord_to_pointer : tnode;
           function resulttype_chararray_to_string : tnode;
           function resulttype_string_to_chararray : tnode;
@@ -59,6 +60,7 @@ interface
           function resulttype_char_to_chararray : tnode;
           function resulttype_int_to_real : tnode;
           function resulttype_real_to_real : tnode;
+          function resulttype_real_to_currency : tnode;
           function resulttype_cchar_to_pchar : tnode;
           function resulttype_cstring_to_pchar : tnode;
           function resulttype_char_to_char : tnode;
@@ -103,7 +105,7 @@ interface
           function _first_nothing : tnode;
           function _first_array_to_pointer : tnode;
           function _first_int_to_real : tnode;
-          function _first_real_to_real : tnode;
+          function _first_real_to_real: tnode;
           function _first_pointer_to_array : tnode;
           function _first_cchar_to_pchar : tnode;
           function _first_bool_to_int : tnode;
@@ -767,10 +769,42 @@ implementation
       end;
 
 
-    function ttypeconvnode.resulttype_int_to_real : tnode;
+    function ttypeconvnode.resulttype_int_to_int : tnode;
+      var
+        v : TConstExprInt;
+      begin
+        result:=nil;
+        if left.nodetype=ordconstn then
+         begin
+           v:=tordconstnode(left).value;
+           if is_currency(resulttype.def) then
+             v:=v*10000
+           else if is_currency(left.resulttype.def) then
+             v:=v div 10000;
+           result:=cordconstnode.create(v,resulttype,false);
+         end
+        else
+         begin
+           { multiply by 10000 for currency. We need to use getcopy to pass
+             the argument because the current node is always disposed. Only
+             inserting the multiply in the left node is not possible because
+             it'll get in an infinite loop to convert int->currency }
+           if is_currency(resulttype.def) then
+            begin
+              result:=caddnode.create(muln,getcopy,cordconstnode.create(10000,resulttype,false));
+              include(result.flags,nf_is_currency);
+            end
+           else if is_currency(left.resulttype.def) then
+            begin
+              result:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,resulttype,false));
+              include(result.flags,nf_is_currency);
+            end;
+         end;
+      end;
+
 
+    function ttypeconvnode.resulttype_int_to_real : tnode;
       var
-        t : trealconstnode;
         rv : bestreal;
       begin
         result:=nil;
@@ -778,9 +812,10 @@ implementation
          begin
            rv:=tordconstnode(left).value;
            if is_currency(resulttype.def) then
-             rv:=rv*10000.0;
-           t:=crealconstnode.create(rv,resulttype);
-           result:=t;
+             rv:=rv*10000.0
+           else if is_currency(left.resulttype.def) then
+             rv:=rv/10000.0;
+           result:=crealconstnode.create(rv,resulttype);
          end
         else
          begin
@@ -792,16 +827,35 @@ implementation
             begin
               result:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,resulttype));
               include(result.flags,nf_is_currency);
+            end
+           else if is_currency(left.resulttype.def) then
+            begin
+              result:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,resulttype));
+              include(result.flags,nf_is_currency);
             end;
          end;
       end;
 
 
-    function ttypeconvnode.resulttype_real_to_real : tnode;
+    function ttypeconvnode.resulttype_real_to_currency : tnode;
+      begin
+        if not is_currency(resulttype.def) then
+          internalerror(200304221);
+        result:=nil;
+        left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resulttype));
+        include(left.flags,nf_is_currency);
+        resulttypepass(left);
+        { Convert constants directly, else call Round() }
+        if left.nodetype=realconstn then
+          result:=cordconstnode.create(round(trealconstnode(left).value_real),resulttype,false)
+        else
+          result:=ccallnode.createinternres('fpc_round',
+                      ccallparanode.create(left,nil),resulttype);
+        left:=nil;
+      end;
 
-      var
-        t : tnode;
 
+    function ttypeconvnode.resulttype_real_to_real : tnode;
       begin
          result:=nil;
          if is_currency(left.resulttype.def) and not(is_currency(resulttype.def)) then
@@ -818,10 +872,7 @@ implementation
                resulttypepass(left);
              end;
          if left.nodetype=realconstn then
-           begin
-             t:=crealconstnode.create(trealconstnode(left).value_real,resulttype);
-             result:=t;
-           end;
+           result:=crealconstnode.create(trealconstnode(left).value_real,resulttype);
       end;
 
 
@@ -944,12 +995,13 @@ implementation
           { chararray_2_string } @ttypeconvnode.resulttype_chararray_to_string,
           { array_2_pointer } nil,
           { pointer_2_array } nil,
-          { int_2_int } nil,
+          { int_2_int } @ttypeconvnode.resulttype_int_to_int,
           { int_2_bool } nil,
           { bool_2_bool } nil,
           { bool_2_int } nil,
           { real_2_real } @ttypeconvnode.resulttype_real_to_real,
           { int_2_real } @ttypeconvnode.resulttype_int_to_real,
+          { real_2_currency } @ttypeconvnode.resulttype_real_to_currency,
           { proc_2_procvar } nil,
           { arrayconstructor_2_set } @ttypeconvnode.resulttype_arrayconstructor_to_set,
           { load_smallset } nil,
@@ -978,7 +1030,7 @@ implementation
          r.proc:=resulttypeconvert[c];
          r.obj:=self;
          if assigned(r.proc) then
-          result:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
+          result:=tprocedureofobject(r)();
       end;
 {$else}
       begin
@@ -993,6 +1045,7 @@ implementation
           tc_chararray_2_string : resulttype_chararray_to_string;
           tc_real_2_real : resulttype_real_to_real;
           tc_int_2_real : resulttype_int_to_real;
+          tc_real_2_currency : resulttype_real_to_currency;
           tc_arrayconstructor_2_set : resulttype_arrayconstructor_to_set;
           tc_cord_2_pointer : resulttype_cord_to_pointer;
           tc_intf_2_guid : resulttype_interface_to_guid;
@@ -1328,7 +1381,7 @@ implementation
            expectloc:=LOC_REGISTER
         else
            expectloc:=left.expectloc;
-        if is_64bitint(resulttype.def) then
+        if is_64bit(resulttype.def) then
           registers32:=max(registers32,2)
         else
           registers32:=max(registers32,1);
@@ -1387,7 +1440,7 @@ implementation
         }
         typname := lower(pbestrealtype^.def.gettypename);
         { converting a 64bit integer to a float requires a helper }
-        if is_64bitint(left.resulttype.def) then
+        if is_64bit(left.resulttype.def) then
           begin
             if is_signed(left.resulttype.def) then
               fname := 'fpc_int64_to_'+typname
@@ -1705,6 +1758,7 @@ implementation
            @ttypeconvnode._first_bool_to_int,
            @ttypeconvnode._first_real_to_real,
            @ttypeconvnode._first_int_to_real,
+           nil, { removed in resulttype_real_to_currency }
            @ttypeconvnode._first_proc_to_procvar,
            @ttypeconvnode._first_arrayconstructor_to_set,
            @ttypeconvnode._first_load_smallset,
@@ -1733,7 +1787,7 @@ implementation
          { and should be quite portable too        }
          r.proc:=firstconvert[c];
          r.obj:=self;
-         first_call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
+         first_call_helper:=tprocedureofobject(r){$ifdef FPC}(){$endif FPC}
       end;
 
 
@@ -2037,7 +2091,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.107  2003-04-23 13:13:08  peter
+  Revision 1.108  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.107  2003/04/23 13:13:08  peter
     * fix checking of procdef type which was broken since loadn returned
       pointertype for tp procvar
 

compiler/ncon.pas

@@ -45,6 +45,9 @@ interface
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
           function docompare(p: tnode) : boolean; override;
+       {$ifdef extdebug}
+          procedure _dowrite;override;
+       {$endif}
        end;
        trealconstnodeclass = class of trealconstnode;
 
@@ -410,6 +413,15 @@ implementation
           (value_real = trealconstnode(p).value_real);
       end;
 
+{$ifdef extdebug}
+    procedure Trealconstnode._dowrite;
+
+    begin
+        inherited _dowrite;
+        writeln(',');
+        system.write(writenodeindention,'value = ',value_real);
+    end;
+{$endif}
 
 {*****************************************************************************
                               TORDCONSTNODE
@@ -491,7 +503,8 @@ implementation
 
     begin
         inherited _dowrite;
-        system.write(',value = ',value);
+        writeln(',');
+        system.write(writenodeindention,'value = ',value);
     end;
 {$endif}
 
@@ -925,7 +938,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.46  2003-04-22 23:50:23  peter
+  Revision 1.47  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.46  2003/04/22 23:50:23  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/ninl.pas

@@ -246,6 +246,7 @@ implementation
               procname := procname + 'longword';
             u64bit:
               procname := procname + 'qword';
+            scurrency,
             s64bit:
               procname := procname + 'int64';
             else
@@ -581,6 +582,10 @@ implementation
                     para.left:=p1;
                   end;
 
+                { Currency will be written using the bestreal }
+                if is_currency(para.left.resulttype.def) then
+                  inserttypeconv(para.left,pbestrealtype^);
+
                 case para.left.resulttype.def.deftype of
                   stringdef :
                     begin
@@ -957,8 +962,11 @@ implementation
                   end;
                 u8bit,u16bit,u32bit:
                    suffix := 'uint_';
+                scurrency,
                 s64bit: suffix := 'int64_';
                 u64bit: suffix := 'qword_';
+                else
+                  internalerror(200304225);
               end;
             end;
           floatdef:
@@ -1039,25 +1047,30 @@ implementation
                   { 1.0.x doesn't support int64($ffffffff) correct, it'll expand
                     to -1 instead of staying $ffffffff. Therefor we use $ffff with
                     shl twice (PFV) }
-                  if is_signed(t.def) and
-                     is_64bitint(t.def) then
-                    if (inlinenumber=in_low_x) then
-                      v := int64($80000000) shl 32
-                    else
-                      v := (int64($7fffffff) shl 32) or int64($ffff) shl 16 or int64($ffff)
-                  else
-                    if is_64bitint(t.def) then
-                      { we have to use a dirty trick for high(qword),     }
-                      { because it's bigger than high(tconstexprint) (JM) }
-                      v := 0
+                  case torddef(t.def).typ of
+                    s64bit,scurrency :
+                      begin
+                        if (inlinenumber=in_low_x) then
+                          v := int64($80000000) shl 32
+                        else
+                          v := (int64($7fffffff) shl 32) or int64($ffff) shl 16 or int64($ffff)
+                      end;
+                    u64bit :
+                      begin
+                        { we have to use a dirty trick for high(qword),     }
+                        { because it's bigger than high(tconstexprint) (JM) }
+                        v := 0
+                      end
                     else
-                      if not is_signed(t.def) then
-                        v := cardinal(v);
+                      begin
+                        if not is_signed(t.def) then
+                          v := cardinal(v);
+                      end;
+                  end;
                   hp:=cordconstnode.create(v,t,true);
                   resulttypepass(hp);
                   { fix high(qword) }
-                  if not is_signed(t.def) and
-                     is_64bitint(t.def) and
+                  if (torddef(t.def).typ=u64bit) and
                      (inlinenumber = in_high_x) then
                     tordconstnode(hp).value := -1; { is the same as qword($ffffffffffffffff) }
                   do_lowhigh:=hp;
@@ -1654,12 +1667,12 @@ implementation
                        valid_for_var(tcallparanode(left).left);
 
                        if (left.resulttype.def.deftype in [enumdef,pointerdef]) or
-                          is_ordinal(left.resulttype.def) then
+                          is_ordinal(left.resulttype.def) or
+                          is_currency(left.resulttype.def) then
                         begin
-                           { value of left gets changed -> must be unique }
-                           { (bug 1735) (JM)                              }
-                           set_unique(tcallparanode(left).left);
-                           { two paras ? }
+                          { value of left gets changed -> must be unique }
+                          set_unique(tcallparanode(left).left);
+                          { two paras ? }
                           if assigned(tcallparanode(left).right) then
                            begin
                              if (aktlocalswitches *
@@ -1667,7 +1680,10 @@ implementation
                                begin
                                  { insert a type conversion       }
                                  { the second param is always longint }
-                                 if is_64bitint(left.resulttype.def) then
+                                 if is_currency(left.resulttype.def) then
+                                   inserttypeconv(tcallparanode(tcallparanode(left).right).left,s64currencytype)
+                                 else
+                                  if is_64bitint(left.resulttype.def) then
                                    if is_signed(left.resulttype.def) then
                                      inserttypeconv(tcallparanode(tcallparanode(left).right).left,cs64bittype)
                                    else
@@ -2061,7 +2077,7 @@ implementation
           in_pred_x,
           in_succ_x:
             begin
-              if is_64bitint(resulttype.def) then
+              if is_64bit(resulttype.def) then
                begin
                  if (registers32<2) then
                   registers32:=2
@@ -2090,7 +2106,7 @@ implementation
                expectloc:=LOC_VOID;
 
                { check type }
-               if is_64bitint(left.resulttype.def) or
+               if is_64bit(left.resulttype.def) or
                   { range/overflow checking doesn't work properly }
                   { with the inc/dec code that's generated (JM)   }
                   ((left.resulttype.def.deftype = orddef) and
@@ -2335,7 +2351,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.106  2003-04-22 23:50:23  peter
+  Revision 1.107  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.106  2003/04/22 23:50:23  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/nld.pas

@@ -706,7 +706,6 @@ implementation
            inserttypeconv(right,left.resulttype);
           end;
 
-
         { check if the assignment may cause a range check error }
         { if its not explicit, and only if the values are       }
         { ordinals, enumdef and floatdef                        }
@@ -726,7 +725,6 @@ implementation
               end;
          end;
 
-
         { call helpers for interface }
         if is_interfacecom(left.resulttype.def) then
          begin
@@ -745,9 +743,8 @@ implementation
           test_local_to_procvar(tprocvardef(right.resulttype.def),left.resulttype.def);
       end;
 
-    function tassignmentnode.pass_1 : tnode;
-
 
+    function tassignmentnode.pass_1 : tnode;
       begin
          result:=nil;
          expectloc:=LOC_VOID;
@@ -757,8 +754,6 @@ implementation
          if codegenerror then
            exit;
 
-
-
          registers32:=left.registers32+right.registers32;
          registersfpu:=max(left.registersfpu,right.registersfpu);
 {$ifdef SUPPORT_MMX}
@@ -766,6 +761,7 @@ implementation
 {$endif SUPPORT_MMX}
       end;
 
+
     function tassignmentnode.docompare(p: tnode): boolean;
       begin
         docompare :=
@@ -1025,7 +1021,7 @@ implementation
                    orddef :
                      begin
                        if is_integer(hp.left.resulttype.def) and
-                         not(is_64bitint(hp.left.resulttype.def)) then
+                          not(is_64bitint(hp.left.resulttype.def)) then
                         begin
                           hp.left:=ctypeconvnode.create(hp.left,s32bittype);
                           firstpass(hp.left);
@@ -1264,7 +1260,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.85  2003-04-23 10:10:54  peter
+  Revision 1.86  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.85  2003/04/23 10:10:54  peter
     * procvar is not compared in addrn
 
   Revision 1.84  2003/04/22 23:50:23  peter

compiler/nmat.pas

@@ -94,8 +94,8 @@ implementation
 
     function tmoddivnode.det_resulttype:tnode;
       var
-         t : tnode;
-         rd,ld : tdef;
+         hp,t : tnode;
+         rd,ld : torddef;
          rv,lv : tconstexprint;
       begin
          result:=nil;
@@ -106,6 +106,14 @@ implementation
          if codegenerror then
            exit;
 
+         { we need 2 orddefs always }
+         if (left.resulttype.def.deftype<>orddef) then
+           inserttypeconv(right,s32bittype);
+         if (right.resulttype.def.deftype<>orddef) then
+           inserttypeconv(right,s32bittype);
+         if codegenerror then
+           exit;
+
          { check for division by zero }
          if is_constintnode(right) then
            begin
@@ -120,7 +128,7 @@ implementation
                begin
                  lv:=tordconstnode(left).value;
 
-                  case nodetype of
+                 case nodetype of
                    modn:
                      t:=genintconstnode(lv mod rv);
                    divn:
@@ -139,65 +147,92 @@ implementation
               exit;
            end;
 
+         rd:=torddef(right.resulttype.def);
+         ld:=torddef(left.resulttype.def);
+
          { if one operand is a cardinal and the other is a positive constant, convert the }
          { constant to a cardinal as well so we don't have to do a 64bit division (JM)    }
-
          { Do the same for qwords and positive constants as well, otherwise things like   }
          { "qword mod 10" are evaluated with int64 as result, which is wrong if the       }
          { "qword" was > high(int64) (JM)                                                 }
-         if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=orddef) then
-           if (torddef(right.resulttype.def).typ in [u32bit,u64bit]) and
-              is_constintnode(left) and
-              (tordconstnode(left).value >= 0) then
-             inserttypeconv(left,right.resulttype)
-           else if (torddef(left.resulttype.def).typ in [u32bit,u64bit]) and
-              is_constintnode(right) and
-              (tordconstnode(right).value >= 0) then
-             inserttypeconv(right,left.resulttype);
-
-         if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=orddef) and
-            (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def) or
-             { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
-             ((torddef(right.resulttype.def).typ = u32bit) and
+         if (rd.typ in [u32bit,u64bit]) and
+            is_constintnode(left) and
+            (tordconstnode(left).value >= 0) then
+           inserttypeconv(left,right.resulttype)
+         else
+          if (ld.typ in [u32bit,u64bit]) and
+             is_constintnode(right) and
+             (tordconstnode(right).value >= 0) then
+           inserttypeconv(right,left.resulttype);
+
+         { when there is one currency value, everything is done
+           using currency }
+         if (ld.typ=scurrency) or
+            (rd.typ=scurrency) then
+           begin
+             if (ld.typ<>scurrency) then
+              inserttypeconv(left,s64currencytype);
+             if (rd.typ<>scurrency) then
+              inserttypeconv(right,s64currencytype);
+             resulttype:=left.resulttype;
+           end
+         else
+          { when there is one 64bit value, everything is done
+            in 64bit }
+          if (is_64bitint(left.resulttype.def) or
+              is_64bitint(right.resulttype.def)) then
+           begin
+             if is_signed(rd) or is_signed(ld) then
+               begin
+                  if (torddef(ld).typ<>s64bit) then
+                    inserttypeconv(left,cs64bittype);
+                  if (torddef(rd).typ<>s64bit) then
+                    inserttypeconv(right,cs64bittype);
+               end
+             else
+               begin
+                  if (torddef(ld).typ<>u64bit) then
+                    inserttypeconv(left,cu64bittype);
+                  if (torddef(rd).typ<>u64bit) then
+                    inserttypeconv(right,cu64bittype);
+               end;
+             resulttype:=left.resulttype;
+           end
+         else
+          { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
+          if ((rd.typ = u32bit) and
               is_signed(left.resulttype.def)) or
-             ((torddef(left.resulttype.def).typ = u32bit) and
-              is_signed(right.resulttype.def))) then
+             ((ld.typ = u32bit) and
+              is_signed(right.resulttype.def)) then
            begin
-              rd:=right.resulttype.def;
-              ld:=left.resulttype.def;
-              { issue warning if necessary }
-              if not (is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
-                CGMessage(type_w_mixed_signed_unsigned);
-              if is_signed(rd) or is_signed(ld) then
-                begin
-                   if (torddef(ld).typ<>s64bit) then
-                     inserttypeconv(left,cs64bittype);
-                   if (torddef(rd).typ<>s64bit) then
-                     inserttypeconv(right,cs64bittype);
-                end
-              else
-                begin
-                   if (torddef(ld).typ<>u64bit) then
-                     inserttypeconv(left,cu64bittype);
-                   if (torddef(rd).typ<>u64bit) then
-                     inserttypeconv(right,cu64bittype);
-                end;
+              CGMessage(type_w_mixed_signed_unsigned);
+              if (torddef(ld).typ<>s64bit) then
+                inserttypeconv(left,cs64bittype);
+              if (torddef(rd).typ<>s64bit) then
+                inserttypeconv(right,cs64bittype);
               resulttype:=left.resulttype;
            end
          else
            begin
-              if not(right.resulttype.def.deftype=orddef) or
-                 not(torddef(right.resulttype.def).typ in [s32bit,u32bit]) then
+              { Make everything always 32bit }
+              if not(torddef(right.resulttype.def).typ in [s32bit,u32bit]) then
                 inserttypeconv(right,s32bittype);
-
-              if not(left.resulttype.def.deftype=orddef) or
-                 not(torddef(left.resulttype.def).typ in [s32bit,u32bit]) then
+              if not(torddef(left.resulttype.def).typ in [s32bit,u32bit]) then
                 inserttypeconv(left,s32bittype);
-
-              { the resulttype.def depends on the right side, because the left becomes }
-              { always 64 bit                                                      }
               resulttype:=right.resulttype;
            end;
+
+         { when the result is currency we need some extra code for
+           division. this should not be done when the divn node is
+           created internally }
+         if (nodetype=divn) and
+            not(nf_is_currency in flags) and
+            is_currency(resulttype.def) then
+          begin
+            hp:=caddnode.create(muln,getcopy,cordconstnode.create(10000,s64currencytype,false));
+            include(hp.flags,nf_is_currency);
+            result:=hp;
+          end;
       end;
 
 
@@ -207,11 +242,21 @@ implementation
       begin
         result := nil;
 
+        { when currency is used set the result of the
+          parameters to s64bit, so they are not converted }
+        if is_currency(resulttype.def) then
+          begin
+            left.resulttype:=cs64bittype;
+            right.resulttype:=cs64bittype;
+          end;
+
         { otherwise create a call to a helper }
         if nodetype = divn then
           procname := 'fpc_div_'
         else
           procname := 'fpc_mod_';
+        { only qword needs the unsigned code, the
+          signed code is also used for currency }
         if is_signed(resulttype.def) then
           procname := procname + 'int64'
         else
@@ -400,7 +445,7 @@ implementation
            exit;
 
          { 64 bit ints have their own shift handling }
-         if not(is_64bitint(left.resulttype.def)) then
+         if not(is_64bit(left.resulttype.def)) then
            begin
             regs:=1
            end
@@ -529,7 +574,7 @@ implementation
                  registersmmx:=1;
              end
 {$endif SUPPORT_MMX}
-         else if is_64bitint(left.resulttype.def) then
+         else if is_64bit(left.resulttype.def) then
            begin
               if (left.expectloc<>LOC_REGISTER) and
                  (registers32<2) then
@@ -709,7 +754,7 @@ implementation
              end
          else
 {$endif SUPPORT_MMX}
-           if is_64bitint(left.resulttype.def) then
+           if is_64bit(left.resulttype.def) then
              begin
                 if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
                  begin
@@ -748,7 +793,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.45  2003-04-22 23:50:23  peter
+  Revision 1.46  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.45  2003/04/22 23:50:23  peter
     * firstpass uses expectloc
     * checks if there are differences between the expectloc and
       location.loc from secondpass in EXTDEBUG

compiler/psystem.pas

@@ -304,26 +304,30 @@ implementation
         s32floattype.setdef(tfloatdef.create(s32real));
         s64floattype.setdef(tfloatdef.create(s64real));
         s80floattype.setdef(tfloatdef.create(s80real));
+        s64currencytype.setdef(tfloatdef.create(s64currency));
 {$endif x86}
 {$ifdef powerpc}
         ordpointertype:=u32bittype;
         s32floattype.setdef(tfloatdef.create(s32real));
         s64floattype.setdef(tfloatdef.create(s64real));
         s80floattype.setdef(tfloatdef.create(s80real));
+        s64currencytype.setdef(torddef.create(s64currency));
+        s64currencytype.setdef(torddef.create(scurrency,low(int64),high(int64)));
 {$endif powerpc}
 {$ifdef sparc}
         ordpointertype:=u32bittype;
         s32floattype.setdef(tfloatdef.create(s32real));
         s64floattype.setdef(tfloatdef.create(s64real));
         s80floattype.setdef(tfloatdef.create(s80real));
+        s64currencytype.setdef(torddef.create(scurrency,low(int64),high(int64)));
 {$endif sparc}
 {$ifdef m68k}
         ordpointertype:=u32bittype;
         s32floattype.setdef(tfloatdef.create(s32real));
         s64floattype.setdef(tfloatdef.create(s64real));
         s80floattype.setdef(tfloatdef.create(s80real));
+        s64currencytype.setdef(torddef.create(scurrency,low(int64),high(int64)));
 {$endif}
-        s64currencytype.setdef(tfloatdef.create(s64currency));
         { some other definitions }
         voidpointertype.setdef(tpointerdef.create(voidtype));
         charpointertype.setdef(tpointerdef.create(cchartype));
@@ -479,7 +483,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.44  2002-12-06 16:56:59  peter
+  Revision 1.45  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.44  2002/12/06 16:56:59  peter
     * only compile cs_fp_emulation support when cpufpuemu is defined
     * define cpufpuemu for m68k only
 

compiler/symconst.pas

@@ -146,7 +146,7 @@ type
     u8bit,u16bit,u32bit,u64bit,
     s8bit,s16bit,s32bit,s64bit,
     bool8bit,bool16bit,bool32bit,
-    uchar,uwidechar
+    uchar,uwidechar,scurrency
   );
 
   { float types }
@@ -354,7 +354,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.47  2003-04-23 11:37:33  peter
+  Revision 1.48  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.47  2003/04/23 11:37:33  peter
     * po_comp for proc to procvar fixed
 
   Revision 1.46  2003/01/16 22:13:52  peter

compiler/symdef.pas

@@ -1720,22 +1720,16 @@ implementation
 
 
     procedure torddef.setsize;
+      const
+        sizetbl : array[tbasetype] of longint = (
+          0,
+          1,2,4,8,
+          1,2,4,8,
+          1,2,4,
+          1,2,8
+        );
       begin
-         case typ of
-            u8bit,s8bit,
-            uchar,bool8bit:
-              savesize:=1;
-            u16bit,s16bit,
-            bool16bit,uwidechar:
-              savesize:=2;
-            s32bit,u32bit,
-            bool32bit:
-              savesize:=4;
-            u64bit,s64bit:
-              savesize:=8;
-            else
-              savesize:=0;
-         end;
+        savesize:=sizetbl[typ];
       end;
 
 
@@ -1797,7 +1791,7 @@ implementation
              otUByte,otUWord,otULong,otUByte{otNone},
              otSByte,otSWord,otSLong,otUByte{otNone},
              otUByte,otUWord,otULong,
-             otUByte,otUWord);
+             otUByte,otUWord,otUByte);
         begin
           write_rtti_name;
           rttiList.concat(Tai_const.Create_8bit(byte(trans[typ])));
@@ -1879,7 +1873,7 @@ implementation
           'Byte','Word','DWord','QWord',
           'ShortInt','SmallInt','LongInt','Int64',
           'Boolean','WordBool','LongBool',
-          'Char','WideChar');
+          'Char','WideChar','Currency');
 
       begin
          gettypename:=names[typ];
@@ -4010,7 +4004,7 @@ implementation
              'Uc','Us','Ui','Us',
              'Sc','s','i','x',
              'b','b','b',
-             'c','w');
+             'c','w','x');
 
         var
            s : string;
@@ -5719,7 +5713,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.134  2003-04-23 12:35:34  florian
+  Revision 1.135  2003-04-23 20:16:04  peter
+    + added currency support based on int64
+    + is_64bit for use in cg units instead of is_64bitint
+    * removed cgmessage from n386add, replace with internalerrors
+
+  Revision 1.134  2003/04/23 12:35:34  florian
     * fixed several issues with powerpc
     + applied a patch from Jonas for nested function calls (PowerPC only)
     * ...