* macpas procvar merged

  * macpas fourcharcodes merged
  * rtl pos() fixes merged

git-svn-id: branches/fixes_2_0@1298 -

.gitattributes

@@ -4959,6 +4959,7 @@ tests/test/cg/tloadvmt.pp svneol=native#text/plain
 tests/test/cg/tlohi.pp svneol=native#text/plain
 tests/test/cg/tmanypar.pp svneol=native#text/plain
 tests/test/cg/tmoddiv.pp svneol=native#text/plain
+tests/test/cg/tmoddiv2.pp svneol=native#text/plain
 tests/test/cg/tneg.pp svneol=native#text/plain
 tests/test/cg/tnot.pp svneol=native#text/plain
 tests/test/cg/tobjsiz2.pp svneol=native#text/plain
@@ -6037,6 +6038,7 @@ tests/webtbs/tw4202.pp svneol=native#text/plain
 tests/webtbs/tw4215.pp svneol=native#text/plain
 tests/webtbs/tw4219.pp svneol=native#text/plain
 tests/webtbs/tw4233.pp svneol=native#text/plain
+tests/webtbs/tw4234.pp svneol=native#text/plain
 tests/webtbs/tw4240.pp svneol=native#text/plain
 tests/webtbs/tw4247.pp svneol=native#text/plain
 tests/webtbs/tw4253.pp svneol=native#text/plain
@@ -6048,6 +6050,7 @@ tests/webtbs/tw4308.pp svneol=native#text/plain
 tests/webtbs/tw4336.pp svneol=native#text/plain
 tests/webtbs/tw4350.pp svneol=native#text/plain
 tests/webtbs/tw4388.pp svneol=native#text/plain
+tests/webtbs/tw4390.pp svneol=native#text/plain
 tests/webtbs/tw4398.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain

compiler/defcmp.pas

@@ -49,6 +49,7 @@ interface
           tc_pchar_2_string,
           tc_cchar_2_pchar,
           tc_cstring_2_pchar,
+          tc_cstring_2_int,
           tc_ansistring_2_pchar,
           tc_string_2_chararray,
           tc_chararray_2_string,
@@ -266,6 +267,15 @@ implementation
                          doconv:=tc_int_2_int;
                       end;
                    end;
+                 stringdef :
+                   begin
+                     if (m_mac in aktmodeswitches) and
+                        (fromtreetype=stringconstn) then
+                       begin
+                         eq:=te_convert_l3;
+                         doconv:=tc_cstring_2_int;
+                       end;
+                   end;
                end;
              end;
 
@@ -285,14 +295,11 @@ implementation
                            { Don't prefer conversions from widestring to a
                              normal string as we can loose information }
                            if tstringdef(def_from).string_typ=st_widestring then
-                             eq:=te_convert_l1
+                             eq:=te_convert_l3
+                           else if tstringdef(def_to).string_typ=st_widestring then
+                             eq:=te_convert_l2
                            else
-                             begin
-                               if tstringdef(def_to).string_typ=st_widestring then
-                                 eq:=te_convert_l1
-                               else
-                                 eq:=te_equal; { we can change the stringconst node }
-                             end;
+                             eq:=te_equal;
                          end;
                       end
                      else
@@ -350,36 +357,55 @@ implementation
                      { array of char to string, the length check is done by the firstpass of this node }
                      if is_chararray(def_from) or is_open_chararray(def_from) then
                       begin
-                        doconv:=tc_chararray_2_string;
-                        if is_open_array(def_from) then
+                        { "Untyped" stringconstn is an array of char }
+                        if fromtreetype=stringconstn then
                           begin
-                            if is_ansistring(def_to) then
-                              eq:=te_convert_l1
-                            else if is_widestring(def_to) then
+                            doconv:=tc_string_2_string;
+                            { prefered string type depends on the $H switch }
+                            if not(cs_ansistrings in aktlocalswitches) and
+                               (tstringdef(def_to).string_typ=st_shortstring) then
+                              eq:=te_equal
+                            else if (cs_ansistrings in aktlocalswitches) and
+                               (tstringdef(def_to).string_typ=st_ansistring) then
+                              eq:=te_equal
+                            else if tstringdef(def_to).string_typ=st_widestring then
                               eq:=te_convert_l3
                             else
-                              eq:=te_convert_l2;
+                              eq:=te_convert_l1;
                           end
                         else
                           begin
-                            if is_shortstring(def_to) then
-                              begin
-                                { Only compatible with arrays that fit
-                                  smaller than 255 chars }
-                                if (def_from.size <= 255) then
-                                  eq:=te_convert_l1;
-                              end
-                            else if is_ansistring(def_to) then
-                              begin
-                                if (def_from.size > 255) then
-                                  eq:=te_convert_l1
-                                else
-                                  eq:=te_convert_l2;
-                              end
-                            else if is_widestring(def_to) then
-                              eq:=te_convert_l3
-                            else
-                              eq:=te_convert_l2;
+                          doconv:=tc_chararray_2_string;
+                          if is_open_array(def_from) then
+                            begin
+                              if is_ansistring(def_to) then
+                                eq:=te_convert_l1
+                              else if is_widestring(def_to) then
+                                eq:=te_convert_l3
+                              else
+                                eq:=te_convert_l2;
+                            end
+                          else
+                            begin
+                              if is_shortstring(def_to) then
+                                begin
+                                  { Only compatible with arrays that fit
+                                    smaller than 255 chars }
+                                  if (def_from.size <= 255) then
+                                    eq:=te_convert_l1;
+                                end
+                              else if is_ansistring(def_to) then
+                                begin
+                                  if (def_from.size > 255) then
+                                    eq:=te_convert_l1
+                                  else
+                                    eq:=te_convert_l2;
+                                end
+                              else if is_widestring(def_to) then
+                                eq:=te_convert_l3
+                              else
+                                eq:=te_convert_l2;
+                            end;
                           end;
                       end
                      else
@@ -629,6 +655,14 @@ implementation
                                 eq:=te_convert_l1;
                               end;
                           end
+                        else
+                          { to array of char, from "Untyped" stringconstn (array of char) }
+                          if (fromtreetype=stringconstn) and
+                             is_chararray(def_to) then
+                            begin
+                              eq:=te_convert_l1;
+                              doconv:=tc_string_2_chararray;
+                            end
                         else
                          { other arrays }
                           begin
@@ -752,7 +786,7 @@ implementation
                         (is_pchar(def_to) or is_pwidechar(def_to)) then
                       begin
                         doconv:=tc_cstring_2_pchar;
-                        eq:=te_convert_l1;
+                        eq:=te_convert_l2;
                       end
                      else
                       if cdo_explicit in cdoptions then
@@ -811,21 +845,35 @@ implementation
                    end;
                  arraydef :
                    begin
-                     { chararray to pointer }
-                     if (is_zero_based_array(def_from) or
-                         is_open_array(def_from)) and
-                        equal_defs(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
+                     { string constant (which can be part of array constructor)
+                       to zero terminated string constant }
+                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
+                        (is_pchar(def_to) or is_pwidechar(def_to)) then
                       begin
-                        doconv:=tc_array_2_pointer;
-                        eq:=te_convert_l1;
+                        doconv:=tc_cstring_2_pchar;
+                        eq:=te_convert_l2;
                       end
                      else
-                      { dynamic array to pointer, delphi only }
-                      if (m_delphi in aktmodeswitches) and
-                         is_dynamic_array(def_from) then
-                       begin
-                         eq:=te_equal;
-                       end;
+                      { chararray to pointer }
+                      if (is_zero_based_array(def_from) or
+                          is_open_array(def_from)) and
+                          equal_defs(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
+                        begin
+                          doconv:=tc_array_2_pointer;
+                          { don't prefer the pchar overload when a constant
+                            string was passed }
+                          if fromtreetype=stringconstn then
+                            eq:=te_convert_l2
+                          else
+                            eq:=te_convert_l1;
+                        end
+                     else
+                       { dynamic array to pointer, delphi only }
+                       if (m_delphi in aktmodeswitches) and
+                          is_dynamic_array(def_from) then
+                        begin
+                          eq:=te_equal;
+                        end;
                    end;
                  pointerdef :
                    begin
@@ -893,13 +941,25 @@ implementation
                    begin
                      { procedure variable can be assigned to an void pointer,
                        this not allowed for methodpointers }
-                     if is_void(tpointerdef(def_to).pointertype.def) and
+                     if (is_void(tpointerdef(def_to).pointertype.def) or
+                         (m_mac_procvar in aktmodeswitches)) and
                         tprocvardef(def_from).is_addressonly then
                       begin
                         doconv:=tc_equal;
                         eq:=te_convert_l1;
                       end;
                    end;
+                 procdef :
+                   begin
+                     { procedure variable can be assigned to an void pointer,
+                       this not allowed for methodpointers }
+                     if (m_mac_procvar in aktmodeswitches) and
+                        tprocdef(def_from).is_addressonly then
+                      begin
+                        doconv:=tc_proc_2_procvar;
+                        eq:=te_convert_l2;
+                      end;
+                   end;
                  classrefdef,
                  objectdef :
                    begin
@@ -954,7 +1014,8 @@ implementation
                  procdef :
                    begin
                      { proc -> procvar }
-                     if (m_tp_procvar in aktmodeswitches) then
+                     if (m_tp_procvar in aktmodeswitches) or
+                        (m_mac_procvar in aktmodeswitches) then
                       begin
                         subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),true);
                         if subeq>te_incompatible then

compiler/globals.pas

@@ -65,7 +65,7 @@ interface
        gpcmodeswitches    : tmodeswitches=
          [m_gpc,m_all,m_tp_procvar];
        macmodeswitches : tmodeswitches=
-         [m_mac,m_all,m_result,m_cvar_support,m_tp_procvar];
+         [m_mac,m_all,m_result,m_cvar_support,m_mac_procvar];
 
 
        { maximum nesting of routines }

compiler/globtype.pas

@@ -144,6 +144,7 @@ than 255 characters. That's why using Ansi Strings}
          m_cvar_support,        { cvar variable directive }
          m_nested_comment,      { nested comments }
          m_tp_procvar,          { tp style procvars (no @ needed) }
+         m_mac_procvar,         { macpas style procvars }
          m_repeat_forward,      { repeating forward declarations is needed }
          m_pointer_2_procedure, { allows the assignement of pointers to
                                   procedure variables                     }
@@ -161,6 +162,7 @@ than 255 characters. That's why using Ansi Strings}
        { Win32, OS/2 & MacOS application types }
        tapptype = (
          app_none,
+         app_native,
          app_gui,               { graphic user-interface application}
          app_cui,       { console application}
          app_fs,        { full-screen type application (OS/2 and EMX only) }

compiler/htypechk.pas

@@ -714,7 +714,8 @@ implementation
       begin
         result:=false;
         { remove voidpointer typecast for tp procvars }
-        if (m_tp_procvar in aktmodeswitches) and
+        if ((m_tp_procvar in aktmodeswitches) or
+            (m_mac_procvar in aktmodeswitches)) and
            (p.nodetype=typeconvn) and
            is_voidpointer(p.resulttype.def) then
           p:=tunarynode(p).left;
@@ -1362,10 +1363,15 @@ implementation
           procvardef :
             begin
               { in tp7 mode proc -> procvar is allowed }
-              if (m_tp_procvar in aktmodeswitches) and
+              if ((m_tp_procvar in aktmodeswitches) or
+                  (m_mac_procvar in aktmodeswitches)) and
                  (p.left.nodetype=calln) and
                  (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),true)>=te_equal) then
-               eq:=te_equal;
+                eq:=te_equal
+              else
+                if (m_mac_procvar in aktmodeswitches) and
+                   is_procvar_load(p.left) then
+                  eq:=te_convert_l2;
             end;
         end;
       end;

compiler/ncal.pas

@@ -472,7 +472,8 @@ type
 
     procedure tcallparanode.insert_typeconv(do_count : boolean);
       var
-        oldtype     : ttype;
+        oldtype  : ttype;
+        hp       : tnode;
 {$ifdef extdebug}
         store_count_ref : boolean;
 {$endif def extdebug}
@@ -502,6 +503,21 @@ type
                    resulttype:=left.resulttype;
                end;
 
+             { Remove implicitly inserted typecast to pointer for
+               @procvar in macpas }
+             if (m_mac_procvar in aktmodeswitches) and
+                (parasym.vartype.def.deftype=procvardef) and
+                (left.nodetype=typeconvn) and
+                is_voidpointer(left.resulttype.def) and
+                (ttypeconvnode(left).left.nodetype=typeconvn) and
+                (ttypeconvnode(ttypeconvnode(left).left).convtype=tc_proc_2_procvar) then
+               begin
+                 hp:=left;
+                 left:=ttypeconvnode(left).left;
+                 ttypeconvnode(hp).left:=nil;
+                 hp.free;
+               end;
+
              { Handle varargs and hidden paras directly, no typeconvs or }
              { typechecking needed                                       }
              if (cpf_varargs_para in callparaflags) then
@@ -613,7 +629,8 @@ type
                  if (parasym.vartype.def.deftype=formaldef) then
                    begin
                      { load procvar if a procedure is passed }
-                     if (m_tp_procvar in aktmodeswitches) and
+                     if ((m_tp_procvar in aktmodeswitches) or
+                         (m_mac_procvar in aktmodeswitches)) and
                         (left.nodetype=calln) and
                         (is_void(left.resulttype.def)) then
                        load_procvar_from_calln(left);
@@ -1649,7 +1666,8 @@ type
                             loadnode will give a strange error }
                           if not(assigned(left)) and
                              not(cnf_inherited in callnodeflags) and
-                             (m_tp_procvar in aktmodeswitches) and
+                             ((m_tp_procvar in aktmodeswitches) or
+                              (m_mac_procvar in aktmodeswitches)) and
                              (symtableprocentry.procdef_count=1) then
                             begin
                               hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc);
@@ -2112,12 +2130,33 @@ type
                 { const parameters which are passed by value instead of by reference }
                 { we need to take care that we use the type of the defined parameter and not of the
                   passed parameter, because these can be different in case of a formaldef (PFV) }
-                if (vo_is_funcret in tparavarsym(para.parasym).varoptions) or
+                if
+                  (
+                   { the problem is that we can't take the address of a function result :( }
+                   (vo_is_funcret in tparavarsym(para.parasym).varoptions) or
                    (para.parasym.varspez = vs_value) or
                    ((para.parasym.varspez = vs_const) and
-                    (not paramanager.push_addr_param(vs_const,para.parasym.vartype.def,procdefinition.proccalloption) or
-                    { the problem is that we can't take the address of a function result :( }
-                     (node_complexity(para.left) >= NODE_COMPLEXITY_INF))) then
+                    (para.parasym.vartype.def.deftype<>formaldef) and
+                   { the compiler expects that it can take the address of parameters passed by reference in
+                     the case of const so we can't replace the node simply by a constant node
+                     When playing with this code, ensure that
+                     function f(const a,b  : longint) : longint;inline;
+                       begin
+                         result:=a*b;
+                       end;
+
+                     [...]
+                     ...:=f(10,20));
+                     [...]
+
+                     is still folded. (FK)
+                     }
+                    (
+                      { this must be a not ... of course }
+                      not(paramanager.push_addr_param(vs_const,para.parasym.vartype.def,procdefinition.proccalloption)) or
+                      (node_complexity(para.left) >= NODE_COMPLEXITY_INF)
+                    ))
+                   ) then
                   begin
                     { in theory, this is always regable, but ncgcall can't }
                     { handle it yet in all situations (JM)                 }
@@ -2291,53 +2330,10 @@ type
 
          { procedure variable ? }
          if assigned(right) then
-           begin
-              firstpass(right);
+           firstpass(right);
 
-              { procedure does a call }
-              if not (block_type in [bt_const,bt_type]) then
-                include(current_procinfo.flags,pi_do_call);
-           end
-         else
-         { not a procedure variable }
-           begin
-              if procdefinition.deftype<>procdef then
-                internalerror(200411071);
-{$ifdef PASS2INLINE}
-              { calc the correture value for the register }
-              { handle predefined procedures }
-              if (po_inline in procdefinition.procoptions) then
-                begin
-                   { inherit flags }
-                   current_procinfo.flags := current_procinfo.flags + (tprocdef(procdefinition).inlininginfo^.flags*inherited_inlining_flags);
-
-                   if assigned(methodpointer) then
-                     CGMessage(cg_e_unable_inline_object_methods);
-                   if assigned(right) then
-                     CGMessage(cg_e_unable_inline_procvar);
-                   if not assigned(inlinecode) then
-                     begin
-                       if assigned(tprocdef(procdefinition).inlininginfo^.code) then
-                         inlinecode:=tprocdef(procdefinition).inlininginfo^.code.getcopy
-                       else
-                         CGMessage(cg_e_no_code_for_inline_stored);
-                       if assigned(inlinecode) then
-                         begin
-                           { consider it has not inlined if called
-                             again inside the args }
-                           procdefinition.proccalloption:=pocall_default;
-                           firstpass(inlinecode);
-                         end;
-                     end;
-                end
-              else
-{$endif PASS2INLINE}
-                begin
-                  if not (block_type in [bt_const,bt_type]) then
-                    include(current_procinfo.flags,pi_do_call);
-                end;
-
-           end;
+         if not (block_type in [bt_const,bt_type]) then
+           include(current_procinfo.flags,pi_do_call);
 
          { implicit finally needed ? }
          if resulttype.def.needs_inittable and
@@ -2440,18 +2436,6 @@ type
                end;
            end;
 
-{$ifdef PASS2INLINE}
-         { determine the registers of the procedure variable }
-         { is this OK for inlined procs also ?? (PM)     }
-         if assigned(inlinecode) then
-           begin
-              registersfpu:=max(inlinecode.registersfpu,registersfpu);
-              registersint:=max(inlinecode.registersint,registersint);
-  {$ifdef SUPPORT_MMX}
-              registersmmx:=max(inlinecode.registersmmx,registersmmx);
-  {$endif SUPPORT_MMX}
-           end;
-{$endif PASS2INLINE}
          { determine the registers of the procedure variable }
          { is this OK for inlined procs also ?? (PM)     }
          if assigned(right) then
@@ -2471,10 +2455,6 @@ type
               registersmmx:=max(left.registersmmx,registersmmx);
 {$endif SUPPORT_MMX}
            end;
-{$ifdef PASS2INLINE}
-         if assigned(inlinecode) then
-           include(procdefinition.procoptions,po_inline);
-{$endif PASS2INLINE}
       end;
 
 {$ifdef state_tracking}

compiler/ncnv.pas

@@ -65,6 +65,7 @@ interface
           function resulttype_real_to_currency : tnode;
           function resulttype_cchar_to_pchar : tnode;
           function resulttype_cstring_to_pchar : tnode;
+          function resulttype_cstring_to_int : tnode;
           function resulttype_char_to_char : tnode;
           function resulttype_arrayconstructor_to_set : tnode;
           function resulttype_pchar_to_string : tnode;
@@ -83,6 +84,7 @@ interface
        protected
           function first_int_to_int : tnode;virtual;
           function first_cstring_to_pchar : tnode;virtual;
+          function first_cstring_to_int : tnode;virtual;
           function first_string_to_chararray : tnode;virtual;
           function first_char_to_string : tnode;virtual;
           function first_nothing : tnode;virtual;
@@ -108,6 +110,7 @@ interface
           { any effect                                                       }
           function _first_int_to_int : tnode;
           function _first_cstring_to_pchar : tnode;
+          function _first_cstring_to_int : tnode;
           function _first_string_to_chararray : tnode;
           function _first_char_to_string : tnode;
           function _first_nothing : tnode;
@@ -130,6 +133,7 @@ interface
           procedure _second_int_to_int;virtual;
           procedure _second_string_to_string;virtual;
           procedure _second_cstring_to_pchar;virtual;
+          procedure _second_cstring_to_int;virtual;
           procedure _second_string_to_chararray;virtual;
           procedure _second_array_to_pointer;virtual;
           procedure _second_pointer_to_array;virtual;
@@ -151,6 +155,7 @@ interface
           procedure second_int_to_int;virtual;abstract;
           procedure second_string_to_string;virtual;abstract;
           procedure second_cstring_to_pchar;virtual;abstract;
+          procedure second_cstring_to_int;virtual;abstract;
           procedure second_string_to_chararray;virtual;abstract;
           procedure second_array_to_pointer;virtual;abstract;
           procedure second_pointer_to_array;virtual;abstract;
@@ -610,6 +615,7 @@ implementation
           'tc_pchar_2_string',
           'tc_cchar_2_pchar',
           'tc_cstring_2_pchar',
+          'tc_cstring_2_int',
           'tc_ansistring_2_pchar',
           'tc_string_2_chararray',
           'tc_chararray_2_string',
@@ -700,13 +706,14 @@ implementation
         arrsize  : aint;
         chartype : string[8];
       begin
-         with tarraydef(resulttype.def) do
+        result := nil;
+        with tarraydef(resulttype.def) do
           begin
             if highrange<lowrange then
              internalerror(200501051);
             arrsize := highrange-lowrange+1;
           end;
-         if (left.nodetype = stringconstn) and
+        if (left.nodetype = stringconstn) and
             { left.length+1 since there's always a terminating #0 character (JM) }
             (tstringconstnode(left).len+1 >= arrsize) and
             (tstringdef(left.resulttype.def).string_typ=st_shortstring) then
@@ -1053,6 +1060,25 @@ implementation
       end;
 
 
+    function ttypeconvnode.resulttype_cstring_to_int : tnode;
+      var
+        fcc : cardinal;
+        pb  : pbyte;
+      begin
+         result:=nil;
+         if left.nodetype<>stringconstn then
+           internalerror(200510012);
+         if tstringconstnode(left).len=4 then
+           begin
+             pb:=pbyte(tstringconstnode(left).value_str);
+             fcc:=(pb[0] shl 24) or (pb[1] shl 16) or (pb[2] shl 8) or pb[3];
+             result:=cordconstnode.create(fcc,u32inttype,false);
+           end
+         else
+           CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
+      end;
+
+
     function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
 
       var
@@ -1292,7 +1318,6 @@ implementation
 
 
     function ttypeconvnode.resulttype_call_helper(c : tconverttype) : tnode;
-{$ifdef fpc}
       const
          resulttypeconvert : array[tconverttype] of pointer = (
           {none} nil,
@@ -1304,6 +1329,7 @@ implementation
           { pchar_2_string } @ttypeconvnode.resulttype_pchar_to_string,
           { cchar_2_pchar } @ttypeconvnode.resulttype_cchar_to_pchar,
           { cstring_2_pchar } @ttypeconvnode.resulttype_cstring_to_pchar,
+          { cstring_2_int } @ttypeconvnode.resulttype_cstring_to_int,
           { ansistring_2_pchar } nil,
           { string_2_chararray } @ttypeconvnode.resulttype_string_to_chararray,
           { chararray_2_string } @ttypeconvnode.resulttype_chararray_to_string,
@@ -1351,38 +1377,13 @@ implementation
          if assigned(r.proc) then
           result:=tprocedureofobject(r)();
       end;
-{$else}
-      begin
-        case c of
-          tc_string_2_string: resulttype_string_to_string;
-          tc_char_2_string : resulttype_char_to_string;
-          tc_char_2_chararray: resulttype_char_to_chararray;
-          tc_pchar_2_string : resulttype_pchar_to_string;
-          tc_cchar_2_pchar : resulttype_cchar_to_pchar;
-          tc_cstring_2_pchar : resulttype_cstring_to_pchar;
-          tc_string_2_chararray : resulttype_string_to_chararray;
-          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;
-          tc_char_2_char : resulttype_char_to_char;
-          tc_dynarray_2_openarray : resulttype_dynarray_to_openarray;
-          tc_pwchar_2_string : resulttype_pwchar_to_string;
-          tc_variant_2_dynarray : resulttype_variant_to_dynarray;
-          tc_dynarray_2_variant : resulttype_dynarray_to_variant;
-        end;
-      end;
-{$Endif fpc}
 
 
     function ttypeconvnode.det_resulttype:tnode;
 
       var
         htype : ttype;
-        hp,hp2 : tnode;
+        hp : tnode;
         currprocdef : tabstractprocdef;
         aprocdef : tprocdef;
         eq : tequaltype;
@@ -1495,45 +1496,46 @@ implementation
                     own resulttype.def. They will therefore always be incompatible with
                     a procvar. Because isconvertable cannot check for procedures we
                     use an extra check for them.}
-                  if (m_tp_procvar in aktmodeswitches) and
-                     (resulttype.def.deftype=procvardef) then
+                  if (left.nodetype=calln) and
+                     (tcallnode(left).para_count=0) and
+                     (resulttype.def.deftype=procvardef) and
+                     (
+                      (m_tp_procvar in aktmodeswitches) or
+                      (m_mac_procvar in aktmodeswitches)
+                     ) then
                    begin
-                      if (left.nodetype=calln) and
-                         (tcallnode(left).para_count=0) then
-                       begin
-                         if assigned(tcallnode(left).right) then
-                          begin
-                            { this is already a procvar, if it is really equal
-                              is checked below }
-                            convtype:=tc_equal;
-                            hp:=tcallnode(left).right.getcopy;
-                            currprocdef:=tabstractprocdef(hp.resulttype.def);
-                          end
-                         else
-                          begin
-                            convtype:=tc_proc_2_procvar;
-                            currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).search_procdef_byprocvardef(Tprocvardef(resulttype.def));
-                            hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
-                                tprocdef(currprocdef),tcallnode(left).symtableproc);
-                            if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
-                             begin
-                               if assigned(tcallnode(left).methodpointer) then
-                                 tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
-                               else
-                                 tloadnode(hp).set_mp(load_self_node);
-                             end;
-                            resulttypepass(hp);
-                          end;
-                         left.free;
-                         left:=hp;
-                         { Now check if the procedure we are going to assign to
-                           the procvar, is compatible with the procvar's type }
-                         if not(nf_explicit in flags) and
-                            (proc_to_procvar_equal(currprocdef,
-                                                   tprocvardef(resulttype.def),true)=te_incompatible) then
-                           IncompatibleTypes(left.resulttype.def,resulttype.def);
-                         exit;
-                       end;
+                     if assigned(tcallnode(left).right) then
+                      begin
+                        { this is already a procvar, if it is really equal
+                          is checked below }
+                        convtype:=tc_equal;
+                        hp:=tcallnode(left).right.getcopy;
+                        currprocdef:=tabstractprocdef(hp.resulttype.def);
+                      end
+                     else
+                      begin
+                        convtype:=tc_proc_2_procvar;
+                        currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).search_procdef_byprocvardef(Tprocvardef(resulttype.def));
+                        hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
+                            tprocdef(currprocdef),tcallnode(left).symtableproc);
+                        if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
+                         begin
+                           if assigned(tcallnode(left).methodpointer) then
+                             tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
+                           else
+                             tloadnode(hp).set_mp(load_self_node);
+                         end;
+                        resulttypepass(hp);
+                      end;
+                     left.free;
+                     left:=hp;
+                     { Now check if the procedure we are going to assign to
+                       the procvar, is compatible with the procvar's type }
+                     if not(nf_explicit in flags) and
+                        (proc_to_procvar_equal(currprocdef,
+                                               tprocvardef(resulttype.def),true)=te_incompatible) then
+                       IncompatibleTypes(left.resulttype.def,resulttype.def);
+                     exit;
                    end;
 
                   { Handle explicit type conversions }
@@ -1775,12 +1777,20 @@ implementation
     function ttypeconvnode.first_cstring_to_pchar : tnode;
 
       begin
-         first_cstring_to_pchar:=nil;
+         result:=nil;
          registersint:=1;
          expectloc:=LOC_REGISTER;
       end;
 
 
+    function ttypeconvnode.first_cstring_to_int : tnode;
+
+      begin
+        result:=nil;
+        internalerror(200510014);
+      end;
+
+
     function ttypeconvnode.first_string_to_chararray : tnode;
 
       begin
@@ -1856,11 +1866,48 @@ implementation
 
     function ttypeconvnode.first_real_to_real : tnode;
       begin
-         first_real_to_real:=nil;
-        { comp isn't a floating type }
-         if registersfpu<1 then
-           registersfpu:=1;
-         expectloc:=LOC_FPUREGISTER;
+{$ifdef cpufpemu}
+        if cs_fp_emulation in aktmoduleswitches then
+          begin
+            if target_info.system in system_wince then
+              begin
+                case tfloatdef(left.resulttype.def).typ of
+                  s32real:
+                    case tfloatdef(resulttype.def).typ of
+                      s64real:
+                        result:=ccallnode.createintern('STOD',ccallparanode.create(left,nil));
+                      else
+                        internalerror(2005082704);
+                    end;
+                  s64real:
+                    case tfloatdef(resulttype.def).typ of
+                      s32real:
+                        result:=ccallnode.createintern('DTOS',ccallparanode.create(left,nil));
+                      else
+                        internalerror(2005082703);
+                    end;
+                  else
+                    internalerror(2005082702);
+                end;
+                left:=nil;
+                firstpass(result);
+                exit;
+              end
+            else
+              begin
+                {!! FIXME }
+                internalerror(2005082701);
+              end;
+          end
+        else
+{$endif cpufpemu}
+          begin
+            first_real_to_real:=nil;
+            { comp isn't a floating type }
+            if registersfpu<1 then
+              registersfpu:=1;
+            expectloc:=LOC_FPUREGISTER;
+          end;
       end;
 
 
@@ -2021,6 +2068,11 @@ implementation
          result:=first_cstring_to_pchar;
       end;
 
+    function ttypeconvnode._first_cstring_to_int : tnode;
+      begin
+         result:=first_cstring_to_int;
+      end;
+
     function ttypeconvnode._first_string_to_chararray : tnode;
       begin
          result:=first_string_to_chararray;
@@ -2124,6 +2176,7 @@ implementation
            nil, { removed in resulttype_chararray_to_string }
            @ttypeconvnode._first_cchar_to_pchar,
            @ttypeconvnode._first_cstring_to_pchar,
+           @ttypeconvnode._first_cstring_to_int,
            @ttypeconvnode._first_ansistring_to_pchar,
            @ttypeconvnode._first_string_to_chararray,
            nil, { removed in resulttype_chararray_to_string }
@@ -2248,6 +2301,12 @@ implementation
       end;
 
 
+    procedure ttypeconvnode._second_cstring_to_int;
+      begin
+        second_cstring_to_int;
+      end;
+
+
     procedure ttypeconvnode._second_string_to_chararray;
       begin
         second_string_to_chararray;
@@ -2361,6 +2420,7 @@ implementation
            @ttypeconvnode._second_nothing, { pchar_to_string, handled in resulttype pass }
            @ttypeconvnode._second_nothing, {cchar_to_pchar}
            @ttypeconvnode._second_cstring_to_pchar,
+           @ttypeconvnode._second_cstring_to_int,
            @ttypeconvnode._second_ansistring_to_pchar,
            @ttypeconvnode._second_string_to_chararray,
            @ttypeconvnode._second_nothing, { chararray_to_string, handled in resulttype pass }

compiler/nmem.pas

@@ -354,8 +354,11 @@ implementation
         { Handle @proc special, also @procvar in tp-mode needs
           special handling }
         if (left.resulttype.def.deftype=procdef) or
-           ((left.resulttype.def.deftype=procvardef) and
-            (m_tp_procvar in aktmodeswitches)) then
+           (
+            (left.resulttype.def.deftype=procvardef) and
+            ((m_tp_procvar in aktmodeswitches) or
+             (m_mac_procvar in aktmodeswitches))
+           ) then
           begin
             isprocvar:=(left.resulttype.def.deftype=procvardef);
 
@@ -368,7 +371,8 @@ implementation
             { In tp procvar mode the result is always a voidpointer. Insert
               a typeconversion to voidpointer. For methodpointers we need
               to load the proc field }
-            if (m_tp_procvar in aktmodeswitches) then
+            if (m_tp_procvar in aktmodeswitches) or
+               (m_mac_procvar in aktmodeswitches) then
               begin
                 if tabstractprocdef(left.resulttype.def).is_addressonly then
                   begin

compiler/pexpr.pas

@@ -674,18 +674,24 @@ implementation
             begin
               consume(_LKLAMMER);
               in_args:=true;
+              { Translate to x:=x+y[+z]. The addnode will do the
+                type checking }
               p2:=nil;
               repeat
                 p1:=comp_expr(true);
-                set_varstate(p1,vs_used,[vsf_must_be_valid]);
-                if not((p1.resulttype.def.deftype=stringdef) or
-                       ((p1.resulttype.def.deftype=orddef) and
-                        (torddef(p1.resulttype.def).typ=uchar))) then
-                  Message(parser_e_illegal_parameter_list);
                 if p2<>nil then
                   p2:=caddnode.create(addn,p2,p1)
                 else
-                  p2:=p1;
+                  begin
+                    { Force string type if it isn't yet }
+                    if not(
+                           (p1.resulttype.def.deftype=stringdef) or
+                           is_chararray(p1.resulttype.def) or
+                           is_char(p1.resulttype.def)
+                          ) then
+                      inserttypeconv(p1,cshortstringtype);
+                    p2:=p1;
+                  end;
               until not try_to_consume(_COMMA);
               consume(_RKLAMMER);
               statement_syssym:=p2;
@@ -845,7 +851,8 @@ implementation
                getaddr:=true;
              end
             else
-             if (m_tp_procvar in aktmodeswitches) then
+             if (m_tp_procvar in aktmodeswitches) or
+                (m_mac_procvar in aktmodeswitches) then
               begin
                 aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
                 if assigned(aprocdef) then
@@ -925,7 +932,8 @@ implementation
       begin
         if not assigned(pv) then
          internalerror(200301121);
-        if (m_tp_procvar in aktmodeswitches) then
+        if (m_tp_procvar in aktmodeswitches) or
+           (m_mac_procvar in aktmodeswitches) then
          begin
            hp:=p2;
            hpp:=@p2;

rtl/inc/astrings.inc

@@ -495,6 +495,32 @@ begin
   Pointer(fpc_ansistr_Copy):=ResultAddress;
 end;
 
+Function Pos (Const Substr : ShortString; Const Source : AnsiString) : SizeInt;
+
+var
+  i,MaxLen : SizeInt;
+  pc : pchar;
+begin
+  Pos:=0;
+  if Length(SubStr)>0 then
+   begin
+     MaxLen:=Length(source)-Length(SubStr);
+     i:=0;
+     pc:=@source[1];
+     while (i<=MaxLen) do
+      begin
+        inc(i);
+        if (SubStr[1]=pc^) and
+           (CompareByte(Substr[1],pc^,Length(SubStr))=0) then
+         begin
+           Pos:=i;
+           exit;
+         end;
+        inc(pc);
+      end;
+   end;
+end;
+
 
 Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : SizeInt;
 var

rtl/inc/lineinfo.pp

@@ -84,6 +84,10 @@ var
   {$endif}
 {$endif}
 
+{$if defined(win32) or defined(wince)}
+  {$define PE32}
+{$endif}
+
 {$ifdef netwlibc}
 {$define netware}
 {$endif}
@@ -294,7 +298,7 @@ end;
 {$endif Go32v2}
 
 
-{$ifdef win32}
+{$ifdef PE32}
 function LoadPeCoff:boolean;
 type
   tdosheader = packed record
@@ -409,7 +413,7 @@ begin
    end;
   LoadPeCoff:=(stabofs<>-1) and (stabstrofs<>-1);
 end;
-{$endif Win32}
+{$endif PE32}
 
 
 {$IFDEF EMX}
@@ -911,7 +915,7 @@ begin
      exit;
    end;
 {$ENDIF EMX}
-{$ifdef win32}
+{$ifdef PE32}
   if LoadPECoff then
    begin
      OpenStabs:=true;

rtl/inc/mathh.inc

@@ -23,11 +23,13 @@
 {$endif cpui386}
 
 {$ifdef cpux86_64}
+{$ifndef WIN64}
     const
       Default8087CW : word = $1332;
 
     procedure Set8087CW(cw:word);
     function Get8087CW:word;
+{$endif WIN64}
 {$endif cpux86_64}
 
    { declarations of the math routines }

rtl/inc/pagemem.pp

@@ -882,6 +882,3 @@ finalization
   setmemorymanager(oldmemman);
 end.
 
-{
- $Log: $
-}

rtl/inc/systemh.inc

@@ -79,14 +79,24 @@ Type
 {$endif CPUI386}
 
 {$ifdef CPUX86_64}
+{$ifndef WIN64}
+  { win64 doesn't support the legacy fpu }
   {$define DEFAULT_EXTENDED}
+  {$define SUPPORT_EXTENDED}
+  {$define SUPPORT_COMP}
+  ValReal = Extended;
+{$else WIN64}
+  {$define DEFAULT_DOUBLE}
+  ValReal = Double;
+
+  { map comp to int64, but this doesn't mean we compile the comp support in! }
+  Comp = Int64;
+  PComp = ^Comp;
+{$endif WIN64}
 
   {$define SUPPORT_SINGLE}
   {$define SUPPORT_DOUBLE}
-  {$define SUPPORT_EXTENDED}
-  {$define SUPPORT_COMP}
 
-  ValReal = Extended;
 {$endif CPUX86_64}
 
 {$ifdef CPUM68K}
@@ -447,6 +457,7 @@ Procedure Insert(const source:shortstring;Var s:shortstring;index:SizeInt);
 Procedure Insert(source:Char;Var s:shortstring;index:SizeInt);
 Function  Pos(const substr:shortstring;const s:shortstring):SizeInt;
 Function  Pos(C:Char;const s:shortstring):SizeInt;
+Function  Pos (Const Substr : ShortString; Const Source : AnsiString) : SizeInt;
 Procedure SetString (Var S : Shortstring; Buf : PChar; Len : SizeInt);
 Procedure SetString (Var S : AnsiString; Buf : PChar; Len : SizeInt);
 Function  upCase(const s:shortstring):shortstring;

rtl/inc/thread.inc

@@ -74,6 +74,12 @@ begin
   Result:=CurrentTM.BeginThread(sa,stacksize,threadfunction,P,creationflags,ThreadID);
 end;
 
+function BeginThread(sa : Pointer;stacksize : qword; ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword;  var ThreadId : TThreadID) : TThreadID;
+
+begin
+  Result:=CurrentTM.BeginThread(sa,stacksize,threadfunction,P,creationflags,ThreadID);
+end;
+
 procedure EndThread(ExitCode : DWord);
 
 begin
@@ -282,7 +288,7 @@ begin
   RunError(232)
 end;
 
-function NoBeginThread(sa : Pointer;stacksize : dword;
+function NoBeginThread(sa : Pointer;stacksize : PtrUInt;
                      ThreadFunction : tthreadfunc;p : pointer;
                      creationFlags : dword; var ThreadId : TThreadID) : TThreadID;
 begin

rtl/inc/threadh.inc

@@ -25,7 +25,7 @@ type
   trtlmethod  = procedure of object;
 
   // Function prototypes for TThreadManager Record.
-  TBeginThreadHandler = Function (sa : Pointer;stacksize : dword; ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword; var ThreadId : TThreadID) : TThreadID;
+  TBeginThreadHandler = Function (sa : Pointer;stacksize : PtrUInt; ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword; var ThreadId : TThreadID) : TThreadID;
   TEndThreadHandler = Procedure (ExitCode : DWord);
   // Used for Suspend/Resume/Kill
   TThreadHandler = Function (threadHandle : TThreadID) : dword;

tests/tbs/tb0429.pp

@@ -10,11 +10,11 @@ end;
 procedure lowercase(c:shortstring);overload;
 begin
   writeln('short');
-  err:=false;
 end;
 procedure lowercase(c:ansistring);overload;
 begin
   writeln('ansi');
+  err:=false;
 end;
 
 var
@@ -23,7 +23,9 @@ var
   i : longint;
 begin
   err:=true;
-  { this should choosse the shortstring version }
+  { this should choosse the ansistring version }
+  w:='';
+  for i:=1 to 300 do w:=w+'.';
   lowercase(w);
   if err then
    begin

tests/test/cg/tmoddiv2.pp

@@ -0,0 +1,343 @@
+program mymodtest;
+
+{$MODE DELPHI}
+{$ASSERTIONS ON}
+
+// Pascal implementation of signed modulus by power of 2 constant algorithm
+function my_modulus(x, m : integer) : integer;
+var
+	temp, mask1, mask2 : integer;
+begin
+	m := abs(m-1);
+	
+	temp := x and m;
+
+	if (x < 0) then begin // = sign bit
+		mask2 := -1;
+	end else begin
+		mask2 := 0;
+	end;
+
+	if (temp <> 0) then begin // note: temp >= 0
+		mask1 := -1;
+	end else begin
+		mask1 := 0;
+	end;
+	
+	my_modulus := temp or ((not m) and mask1 and mask2);	
+end;
+
+function i32_modulus(x, m : integer) : integer; 
+var
+    temp : integer;
+begin
+    temp := x div m;
+    i32_modulus := x - (temp*m);
+end;
+
+function u32_modulus(x, m : dword) : dword;
+var
+	temp : dword;
+begin
+	temp := x div m;
+	u32_modulus := x - (temp*m);
+end;
+
+var
+	i : integer; 
+	j, k : longint;
+	res, res2 : longint;
+	
+	y, z : dword;
+
+begin
+	randseed := 1; // just take any, but repeatable
+	write('positive int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 19;
+		assert((j div 19) = (j div k), 'Wrong int32 division by 19 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('Negative int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -19;
+		assert((j div -19) = (j div k), 'Wrong int32 division by -19 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+
+	write('positive int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 3;
+		assert((j div 3) = (j div k), 'Wrong int32 division by 3 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('Negative int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -3;
+		assert((j div -3) = (j div k), 'Wrong int32 division by -3 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+
+	write('positive int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 7;
+		assert((j div 7) = (j div k), 'Wrong int32 division by 7 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('Negative int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -7;
+		assert((j div -7) = (j div k), 'Wrong int32 division by -7 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 5;
+		assert((j div 5) = (j div k), 'Wrong int32 division by 5 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('Negative int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -5;
+		assert((j div -5) = (j div k), 'Wrong int32 division by -5 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 512;
+		assert((j div 512) = (j div k), 'Wrong int32 division by 512 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+	write('Negative int32 division test...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -512;
+		assert((j div -512) = (j div k), 'Wrong int32 division by -512 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+//-----------------------------------------------------------------
+	
+	write('positive int32 modulus test (19)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 19;
+		assert((j mod 19) = (i32_modulus(j,k)), 'Wrong int32 modulus by 19 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+
+	write('Negative int32 modulus test (-19)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -19;
+		res := j mod -19;
+		res2 := i32_modulus(j, k);
+		assert((res = res2), 'Int32 mod by -19 j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2) + ' is ' + hexstr(res, 8) + ' ' + hexstr(res2, 8));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 modulus test (3)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 3;
+		assert((j mod 3) = (i32_modulus(j,k)), 'Wrong int32 modulus by 3 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+
+	write('Negative int32 modulus test (-3)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -3;
+		res := j mod -3;
+		res2 := i32_modulus(j, k);
+		assert((res = res2), 'Int32 mod by -3 j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2) + ' is ' + hexstr(res, 8) + ' ' + hexstr(res2, 8));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 modulus test (5)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 5;
+		assert((j mod 5) = (i32_modulus(j,k)), 'Wrong int32 modulus by 5 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+
+	write('Negative int32 modulus test (-5)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -5;
+		res := j mod -5;
+		res2 := i32_modulus(j, k);
+		assert((res = res2), 'Int32 mod by -5 j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2) + ' is ' + hexstr(res, 8) + ' ' + hexstr(res2, 8));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 modulus test (7)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 7;
+		assert((j mod 7) = (i32_modulus(j,k)), 'Wrong int32 modulus by 7 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+
+	write('Negative int32 modulus test (-7)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -7;
+		res := j mod -7;
+		res2 := i32_modulus(j, k);
+		assert((res = res2), 'Int32 mod by -7 j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2) + ' is ' + hexstr(res, 8) + ' ' + hexstr(res2, 8));
+	end;
+	writeln('Success.');
+	
+	write('positive int32 modulus test (512)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := 512;
+		assert((j mod 512) = (i32_modulus(j,k)), 'Wrong int32 modulus by 512 for j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2));
+	end;
+	writeln('Success.');
+	
+
+	write('Negative int32 modulus test (-512)...');
+	for i := -10000 to 10000 do begin
+		j := random(high(integer));
+		if (random(2) = 1) then j := -j;
+		k := -512;
+		res := j mod -512;
+		res2 := i32_modulus(j, k);
+		assert((res = res2), 'Int32 mod by -512 j=' + hexstr(j,sizeof(j)*2) + ' k=' + hexstr(k, sizeof(k)*2) + ' is ' + hexstr(res, 8) + ' ' + hexstr(res2, 8));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 division test (19)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 19;
+		assert((y div 19) = (y div z), 'Wrong uint32 division by 19 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 modulus test (19)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 19;
+		assert((y mod 19) = (u32_modulus(y,z)), 'Wrong uint32 modulus by 19 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 division test (3)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 3;
+		assert((y div 3) = (y div z), 'Wrong uint32 division by 3 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 modulus test (3)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 3;
+		assert((y mod 3) = (u32_modulus(y,z)), 'Wrong uint32 modulus by 3 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 division test (5)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 5;
+		assert((y div 5) = (y div z), 'Wrong uint32 division by 5 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 modulus test (5)...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 5;
+		assert((y mod 5) = (u32_modulus(y,z)), 'Wrong uint32 modulus by 5 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 division test...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 7;
+		assert((y div 7) = (y div z), 'Wrong uint32 division by 7 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 modulus test...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 7;
+		assert((y mod 7) = (u32_modulus(y,z)), 'Wrong uint32 modulus by 7 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');	
+	
+	
+	write('positive uint32 division test...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 512;
+		assert((y div 512) = (y div z), 'Wrong uint32 division by 512 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');
+	
+	write('positive uint32 modulus test...');
+	for i := -10000 to 10000 do begin
+		y := random(high(integer));
+		if (random(2) = 1) then y := 2 * y;
+		z := 512;
+		assert((y mod 512) = (u32_modulus(y,z)), 'Wrong uint32 modulus by 512 for y=' + hexstr(y,sizeof(y)*2) + ' z=' + hexstr(z, sizeof(z)*2));
+	end;
+	writeln('Success.');		
+end.
+

tests/test/tmacpas2.pp

@@ -23,7 +23,7 @@ end;
 procedure TestFourCharCode(myFCC: MyFourCharCodeType);
 
 begin
-  Writeln('FPC creator code as number: ', myFCC);
+  Writeln('FPC creator code as number: ', hexstr(myFCC,8));
   if myFCC <> $46506173 then
     success := false;
 end;

tests/webtbs/tw4234.pp

@@ -0,0 +1,38 @@
+{ %cpu=i386 }
+{ %opt=-O2 }
+
+{$mode objfpc}
+
+type
+  TFPColor = record
+    red,green,blue,alpha : word;
+  end;
+  TColorData = qword;
+
+  tcl=class
+    function ColorColorAlpha16 (CD:TColorData) : TFPColor;
+  end;
+
+function tcl.ColorColorAlpha16 (CD:TColorData) : TFPColor;
+var c : qword;
+begin
+with result do
+begin
+red := CD and $FFFF;
+c := qword($FFFF0000);
+green := (CD and c) shr 16;
+c := c shl 16;
+blue := (CD and c) shr 32;
+c := c shl 16;
+alpha := (CD and c) shr 48;
+end;
+end;
+
+var
+  cd  : tcolordata;
+  c : tcl;
+begin
+  cd:=$1234;
+  c:=tcl.create;
+  c.colorcoloralpha16(cd);
+end.

tests/webtbs/tw4390.pp

@@ -0,0 +1,23 @@
+{ Source provided for Free Pascal Bug Report 4390 }
+{ Submitted by "Benjamin Rosseaux" on  2005-09-28 }
+{ e-mail: [email protected] }
+PROGRAM Test;
+{$APPTYPE CONSOLE}
+{$IFDEF FPC}
+ {$MODE DELPHI}
+{$ENDIF}
+
+PROCEDURE WriteToFile(CONST Buf;Size:INTEGER);
+var
+  s : shortstring;
+BEGIN
+  move(Buf,s[1],size);
+  s[0]:=chr(size);
+  writeln('Writing: "',s,'"');
+  if s<>'TEST' then
+    halt(1);
+END;
+
+BEGIN
+ WriteToFile('TEST',4);
+END.