--- Merging r14468 into '.':

A    tests/webtbs/tw15391.pp
A    tests/webtbf/tw15391a.pp
U    compiler/htypechk.pas
--- Merging r14527 into '.':
A    tests/webtbs/tw15446.pp
U    compiler/ncnv.pas
--- Merging r14532 through r14533 into '.':
U    rtl/i386/mathu.inc
U    rtl/inc/sstrings.inc
U    rtl/objpas/math.pp
U    tests/test/units/math/tdivmod.pp
A    tests/tbs/tb0566.pp
--- Merging r14535 through r14537 into '.':
A    tests/webtbs/tw14566.pp
A    tests/tbs/tb0567.pp
U    compiler/ninl.pas
U    compiler/ncgbas.pas
--- Merging r14563 into '.':
U    rtl/inc/real2str.inc
A    tests/webtbs/tw15308.pp
--- Merging r14602 into '.':
A    tests/webtbs/tw14941a.pp
A    tests/webtbs/tw14941.pp
A    tests/tbf/tb0217.pp
U    compiler/pdecsub.pas
--- Merging r14880 through r14882 into '.':
U    rtl/inc/system.inc
U    tests/test/tlibrary1.pp
U    tests/test/tlibrary2.pp
A    tests/webtbs/tw15728.pp
A    tests/webtbs/tw15727a.pp
A    tests/webtbf/tw15727b.pp
U    compiler/pexpr.pas
U    compiler/pstatmnt.pas
G    compiler/ncnv.pas
--- Merging r14926 into '.':
G    compiler/ninl.pas
--- Merging r15011 into '.':
U    compiler/systems/t_bsd.pas
--- Merging r15014 into '.':
G    compiler/systems/t_bsd.pas
--- Merging r15017 into '.':
A    tests/webtbs/tw15909.pp
A    tests/webtbs/uw15909.pp
U    compiler/ncon.pas
U    compiler/symsym.pas
U    compiler/widestr.pas
--- Merging r15030 into '.':
A    tests/webtbf/tw16022.pp
U    compiler/ncal.pas

git-svn-id: branches/fixes_2_4@15201 -

.gitattributes

@@ -7161,6 +7161,7 @@ tests/tbf/tb0215c.pp svneol=native#text/plain
 tests/tbf/tb0215d.pp svneol=native#text/plain
 tests/tbf/tb0215e.pp svneol=native#text/plain
 tests/tbf/tb0216.pp svneol=native#text/plain
+tests/tbf/tb0217.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -7721,6 +7722,8 @@ tests/tbs/tb0561a.pp svneol=native#text/plain
 tests/tbs/tb0561b.pp svneol=native#text/plain
 tests/tbs/tb0564.pp svneol=native#text/plain
 tests/tbs/tb0565.pp svneol=native#text/plain
+tests/tbs/tb0566.pp svneol=native#text/plain
+tests/tbs/tb0567.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
@@ -8851,8 +8854,11 @@ tests/webtbf/tw1483.pp svneol=native#text/plain
 tests/webtbf/tw14849.pp svneol=native#text/plain
 tests/webtbf/tw15287.pp svneol=native#text/plain
 tests/webtbf/tw15288.pp svneol=native#text/plain
+tests/webtbf/tw15391a.pp svneol=native#text/plain
+tests/webtbf/tw15727b.pp svneol=native#text/plain
 tests/webtbf/tw1599.pp svneol=native#text/plain
 tests/webtbf/tw1599b.pp svneol=native#text/plain
+tests/webtbf/tw16022.pp svneol=native#text/plain
 tests/webtbf/tw1633.pp svneol=native#text/plain
 tests/webtbf/tw1642.pp svneol=native#text/plain
 tests/webtbf/tw1655.pp svneol=native#text/plain
@@ -9447,6 +9453,7 @@ tests/webtbs/tw1451.pp svneol=native#text/plain
 tests/webtbs/tw14514.pp svneol=native#text/plain
 tests/webtbs/tw14536.pp svneol=native#text/plain
 tests/webtbs/tw14553.pp svneol=native#text/pascal
+tests/webtbs/tw14566.pp svneol=native#text/pascal
 tests/webtbs/tw14617.pp svneol=native#text/plain
 tests/webtbs/tw1470.pp svneol=native#text/plain
 tests/webtbs/tw1472.pp svneol=native#text/plain
@@ -9459,6 +9466,8 @@ tests/webtbs/tw14812.pp svneol=native#text/plain
 tests/webtbs/tw14841.pp svneol=native#text/plain
 tests/webtbs/tw1485.pp svneol=native#text/plain
 tests/webtbs/tw1489.pp svneol=native#text/plain
+tests/webtbs/tw14941.pp svneol=native#text/plain
+tests/webtbs/tw14941a.pp svneol=native#text/plain
 tests/webtbs/tw14958a.pp svneol=native#text/plain
 tests/webtbs/tw14958b.pp svneol=native#text/plain
 tests/webtbs/tw14992a.pp svneol=native#text/pascal
@@ -9472,16 +9481,22 @@ tests/webtbs/tw15293.pp svneol=native#text/plain
 tests/webtbs/tw15293a.pp svneol=native#text/plain
 tests/webtbs/tw15296.pp svneol=native#text/plain
 tests/webtbs/tw15304.pp svneol=native#text/plain
+tests/webtbs/tw15308.pp svneol=native#text/plain
 tests/webtbs/tw1532.pp svneol=native#text/plain
 tests/webtbs/tw15364.pp svneol=native#text/plain
 tests/webtbs/tw15377.pp svneol=native#text/pascal
 tests/webtbs/tw1539.pp svneol=native#text/plain
+tests/webtbs/tw15391.pp svneol=native#text/plain
+tests/webtbs/tw15446.pp svneol=native#text/plain
 tests/webtbs/tw15453a.pp svneol=native#text/plain
 tests/webtbs/tw15467.pp svneol=native#text/pascal
 tests/webtbs/tw1567.pp svneol=native#text/plain
 tests/webtbs/tw15690.pp svneol=native#text/plain
+tests/webtbs/tw15727a.pp svneol=native#text/plain
+tests/webtbs/tw15728.pp svneol=native#text/plain
 tests/webtbs/tw1573.pp svneol=native#text/plain
 tests/webtbs/tw15821.pp svneol=native#text/plain
+tests/webtbs/tw15909.pp svneol=native#text/plain
 tests/webtbs/tw1592.pp svneol=native#text/plain
 tests/webtbs/tw1617.pp svneol=native#text/plain
 tests/webtbs/tw1622.pp svneol=native#text/plain
@@ -10349,6 +10364,7 @@ tests/webtbs/uw13345y.pp svneol=native#text/plain
 tests/webtbs/uw13583.pp svneol=native#text/plain
 tests/webtbs/uw14124.pp svneol=native#text/plain
 tests/webtbs/uw14958.pp svneol=native#text/plain
+tests/webtbs/uw15909.pp svneol=native#text/plain
 tests/webtbs/uw2004.inc svneol=native#text/plain
 tests/webtbs/uw2040.pp svneol=native#text/plain
 tests/webtbs/uw2266a.inc svneol=native#text/plain

compiler/htypechk.pas

@@ -1554,6 +1554,9 @@ implementation
 
 
     procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef);
+      var
+        acn: tarrayconstructornode;
+        tmpeq: tequaltype;
       begin
         { Note: eq must be already valid, it will only be updated! }
         case def_to.typ of
@@ -1605,6 +1608,34 @@ implementation
                    is_procvar_load(p.left) then
                   eq:=te_convert_l2;
             end;
+          arraydef :
+            begin
+              { an arrayconstructor of proccalls may have to be converted to
+                an array of procvars }
+              if ((m_tp_procvar in current_settings.modeswitches) or
+                  (m_mac_procvar in current_settings.modeswitches)) and
+                 (tarraydef(def_to).elementdef.typ=procvardef) and
+                 is_array_constructor(p.resultdef) and
+                 not is_variant_array(p.resultdef) then
+                begin
+                  acn:=tarrayconstructornode(p.left);
+                  if assigned(acn.left) then
+                    begin
+                      eq:=te_exact;
+                      while assigned(acn) and
+                            (eq<>te_incompatible) do
+                        begin
+                          if (acn.left.nodetype=calln) then
+                            tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef))
+                          else
+                            tmpeq:=compare_defs(acn.left.resultdef,tarraydef(def_to).elementdef,acn.left.nodetype);
+                          if tmpeq<eq then
+                            eq:=tmpeq;
+                          acn:=tarrayconstructornode(acn.right);
+                        end;
+                    end
+                end;
+            end;
         end;
       end;
 
@@ -1965,6 +1996,7 @@ implementation
         def_to   : tdef;
         currpt,
         pt       : tcallparanode;
+        tmpeq,
         eq       : tequaltype;
         convtype : tconverttype;
         pdtemp,

compiler/ncal.pas

@@ -1312,11 +1312,18 @@ implementation
         len : integer;
         loadconst : boolean;
         hightree,l,r : tnode;
+        defkind: tdeftyp;
       begin
         len:=-1;
         loadconst:=true;
         hightree:=nil;
-        case p.resultdef.typ of
+        { constant strings are internally stored as array of char, but if the
+          parameter is a string also treat it like one  }
+        defkind:=p.resultdef.typ;
+        if (p.nodetype=stringconstn) and
+           (paradef.typ=stringdef) then
+          defkind:=stringdef;
+        case defkind of
           arraydef :
             begin
               if (paradef.typ<>arraydef) then
@@ -1405,7 +1412,14 @@ implementation
             begin
               if is_open_string(paradef) then
                begin
-                 maybe_load_in_temp(p);
+                 { a stringconstn is not a simple parameter and hence would be
+                   loaded in a temp, but in that case the high() node
+                     a) goes wrong (it cannot deal with a temp node)
+                     b) would give a generic result instead of one specific to
+                        this constant string
+                 }
+                 if p.nodetype<>stringconstn then
+                   maybe_load_in_temp(p);
                  { handle via a normal inline in_high_x node }
                  loadconst := false;
                  hightree := geninlinenode(in_high_x,false,p.getcopy);

compiler/ncgbas.pas

@@ -206,6 +206,21 @@ interface
                         op.reg:=sym.localloc.register;
                       end;
                   end;
+                LOC_MMREGISTER :
+                  begin
+                    if getoffset then
+                      Message(asmr_e_invalid_reference_syntax);
+                    { Subscribed access }
+                    if forceref or (sofs<>0) then
+                      internalerror(201001032)
+                    else
+                      begin
+                        op.typ:=top_reg;
+                        op.reg:=sym.localloc.register;
+                      end;
+                  end;
+                else
+                  internalerror(201001031);
               end;
             end;
         end;

compiler/ncnv.pas

@@ -562,6 +562,10 @@ implementation
 
     procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
       begin
+        { procvars without arguments in variant arrays are always called by
+          Delphi }
+        if not(iscvarargs) then
+          maybe_call_procvar(p,true);
         if not(iscvarargs) and
            (p.nodetype=stringconstn) then
           p:=ctypeconvnode.create_internal(p,cansistringtype)
@@ -583,7 +587,16 @@ implementation
               begin
                 if is_integer(p.resultdef) and
                    not(is_64bitint(p.resultdef)) then
-                  p:=ctypeconvnode.create(p,s32inttype)
+                  if not(m_delphi in current_settings.modeswitches) then
+                    p:=ctypeconvnode.create(p,s32inttype)
+                  else
+                    { delphi doesn't generate a range error when passing a
+                      cardinal >= $80000000, but since these are seen as
+                      longint on the callee side, this causes data loss;
+                      as a result, we require an explicit longint()
+                      typecast in FPC mode on the caller side if range
+                      checking should be disabled, but not in Delphi mode }
+                    p:=ctypeconvnode.create_internal(p,s32inttype)
                 else if is_void(p.resultdef) then
                   CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename)
                 else if iscvarargs and is_currency(p.resultdef)

compiler/ncon.pas

@@ -779,6 +779,7 @@ implementation
     constructor tstringconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
       var
         pw : pcompilerwidestring;
+        i : longint;
       begin
         inherited ppuload(t,ppufile);
         cst_type:=tconststringtype(ppufile.getbyte);
@@ -787,7 +788,18 @@ implementation
           begin
             initwidestring(pw);
             setlengthwidestring(pw,len);
-            ppufile.getdata(pw^.data,pw^.len*sizeof(tcompilerwidechar));
+            { don't use getdata, because the compilerwidechars may have to
+              be byteswapped
+            }
+{$if sizeof(tcompilerwidechar) = 2}
+            for i:=0 to pw^.len-1 do
+              pw^.data[i]:=ppufile.getword;
+{$elseif sizeof(tcompilerwidechar) = 4}
+            for i:=0 to pw^.len-1 do
+              pw^.data[i]:=cardinal(ppufile.getlongint);
+{$else}
+           {$error Unsupported tcompilerwidechar size}
+{$endif}
             pcompilerwidestring(value_str):=pw
           end
         else
@@ -806,7 +818,7 @@ implementation
         ppufile.putbyte(byte(cst_type));
         ppufile.putlongint(len);
         if cst_type in [cst_widestring,cst_unicodestring] then
-          ppufile.putdata(pcompilerwidestring(value_str)^.data,len*sizeof(tcompilerwidechar))
+          ppufile.putdata(pcompilerwidestring(value_str)^.data^,len*sizeof(tcompilerwidechar))
         else
           ppufile.putdata(value_str^,len);
         ppufile.putasmsymbol(lab_str);

compiler/ninl.pas

@@ -1412,7 +1412,6 @@ implementation
         hp        : tnode;
         vl,vl2    : TConstExprInt;
         vr        : bestreal;
-        checkrange: boolean;
 
       begin { simplify }
          result:=nil;
@@ -1634,16 +1633,20 @@ implementation
               in_pred_x,
               in_succ_x:
                 begin
-                  { only perform range checking if the result is an enum }
-                  checkrange:=(resultdef.typ=enumdef);
-
                   if (left.nodetype=ordconstn) then
-                   begin
-                     if (inlinenumber=in_succ_x) then
-                       result:=cordconstnode.create(tordconstnode(left).value+1,left.resultdef,checkrange)
-                     else
-                       result:=cordconstnode.create(tordconstnode(left).value-1,left.resultdef,checkrange);
-                   end;
+                    begin
+                      if (inlinenumber=in_succ_x) then
+                        vl:=tordconstnode(left).value+1
+                      else
+                        vl:=tordconstnode(left).value-1;
+                      if is_integer(left.resultdef) then
+                      { the type of the original integer constant is irrelevant,
+                        it should be automatically adapted to the new value }
+                        result:=genintconstnode(vl)
+                      else
+                        { check the range for enums, chars, booleans }
+                        result:=cordconstnode.create(vl,left.resultdef,true)
+                    end
                 end;
               in_low_x,
               in_high_x:
@@ -2936,6 +2939,7 @@ implementation
 
      function tinlinenode.first_abs_long : tnode;
       begin
+        expectloc:=LOC_REGISTER;
         result:=nil;
       end;
 

compiler/pdecsub.pas

@@ -538,11 +538,29 @@ implementation
                   end;
 
                 { open string ? }
-                if (varspez in [vs_out,vs_var]) and
-                   (cs_openstring in current_settings.moduleswitches) and
-                   is_shortstring(hdef) then
-                  hdef:=openshortstringtype;
-
+                if is_shortstring(hdef) then
+                  begin
+                    case varspez of
+                      vs_var,vs_out:
+                        begin
+                          { not 100% Delphi-compatible: type xstr=string[255] cannot
+                            become an openstring there, while here it can }
+                          if (cs_openstring in current_settings.moduleswitches) and
+                             (tstringdef(hdef).len=255) then
+                            hdef:=openshortstringtype
+                        end;
+                      vs_value:
+                       begin
+                         { value "openstring" parameters don't make sense (the
+                            original string can never be modified, so there's no
+                            use in passing its original length), so change these
+                            into regular shortstring parameters (seems to be what
+                            Delphi also does) }
+                        if is_open_string(hdef) then
+                          hdef:=cshortstringtype;
+                       end;
+                    end;
+                  end;
                 if (target_info.system in [system_powerpc_morphos,system_m68k_amiga]) then
                   begin
                     if (idtoken=_LOCATION) then

compiler/pexpr.pas

@@ -1953,6 +1953,10 @@ implementation
                         p1:=cderefnode.create(p1);
                         do_typecheckpass(p1);
                       end;
+                    { procvar.<something> can never mean anything so always
+                      try to call it in case it returns a record/object/... }
+                    maybe_call_procvar(p1,false);
+
                     case p1.resultdef.typ of
                       recorddef:
                         begin

compiler/pstatmnt.pas

@@ -508,6 +508,10 @@ implementation
          if (p.nodetype=vecn) and
             (nf_memseg in p.flags) then
            CGMessage(parser_e_no_with_for_variable_in_other_segments);
+         
+         { "with procvar" can never mean anything, so always try
+           to call it in case it returns a record/object/... }
+         maybe_call_procvar(p,false);
 
          if (p.resultdef.typ in [objectdef,recorddef,classrefdef]) then
           begin

compiler/symsym.pas

@@ -1609,7 +1609,6 @@ implementation
              begin
                initwidestring(pw);
                setlengthwidestring(pw,ppufile.getlongint);
-               pw^.len:=pw^.maxlen;
                { don't use getdata, because the compilerwidechars may have to
                  be byteswapped
                }

compiler/systems/t_bsd.pas

@@ -166,9 +166,9 @@ begin
              ExeCmd[1]:='ld $PRTOBJ $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP -multiply_defined suppress -L. -o $EXE `cat $RES`';
 {$endif ndef cpu64bitaddr}
              if (apptype<>app_bundle) then
-               DllCmd[1]:='ld $PRTOBJ $OPT -dynamic -dylib -multiply_defined suppress -L. -o $EXE `cat $RES`'
+               DllCmd[1]:='ld $PRTOBJ $OPT $GCSECTIONS -dynamic -dylib -multiply_defined suppress -L. -o $EXE `cat $RES`'
              else
-               DllCmd[1]:='ld $PRTOBJ $OPT -dynamic -bundle -multiply_defined suppress -L. -o $EXE `cat $RES`'
+               DllCmd[1]:='ld $PRTOBJ $OPT $GCSECTIONS -dynamic -bundle -multiply_defined suppress -L. -o $EXE `cat $RES`'
            end
        end
      else
@@ -618,16 +618,26 @@ var
   cmdstr,
   extdbgbinstr,
   extdbgcmdstr  : TCmdStr;
+  GCSectionsStr : string[63];
   exportedsyms: text;
   success : boolean;
 begin
   MakeSharedLibrary:=false;
+  GCSectionsStr:='';
   if not(cs_link_nolink in current_settings.globalswitches) then
    Message1(exec_i_linking,current_module.sharedlibfilename^);
 
 { Write used files and libraries }
   WriteResponseFile(true);
 
+  if (cs_link_smart in current_settings.globalswitches) and
+     (tf_smartlink_sections in target_info.flags) then
+    if not(target_info.system in systems_darwin) then
+     { disabled because not tested
+      GCSectionsStr:='--gc-sections' }
+    else
+      GCSectionsStr:='-dead_strip -no_dead_strip_inits_and_terms';
+
   InitStr:='-init FPC_LIB_START';
   FiniStr:='-fini FPC_LIB_EXIT';
   SoNameStr:='-soname '+ExtractFileName(current_module.sharedlibfilename^);
@@ -643,6 +653,7 @@ begin
   Replace(cmdstr,'$RES',maybequoted(outputexedir+Info.ResName));
   Replace(cmdstr,'$INIT',InitStr);
   Replace(cmdstr,'$FINI',FiniStr);
+  Replace(cmdstr,'$GCSECTIONS',GCSectionsStr);
   Replace(cmdstr,'$SONAME',SoNameStr);
   if (target_info.system in systems_darwin) then
     Replace(cmdstr,'$PRTOBJ',GetDarwinPrtobjName(true));

compiler/widestr.pas

@@ -97,7 +97,7 @@ unit widestr;
          getlengthwidestring:=r^.len;
       end;
 
-    procedure setlengthwidestring(r : pcompilerwidestring;l : SizeInt);
+    procedure growwidestring(r : pcompilerwidestring;l : SizeInt);
 
       begin
          if r^.maxlen>=l then
@@ -109,18 +109,26 @@ unit widestr;
          r^.maxlen:=l;
       end;
 
+    procedure setlengthwidestring(r : pcompilerwidestring;l : SizeInt);
+
+      begin
+         r^.len:=l;
+         if l>r^.maxlen then
+           growwidestring(r,l);
+      end;
+
     procedure concatwidestringchar(r : pcompilerwidestring;c : tcompilerwidechar);
 
       begin
          if r^.len>=r^.maxlen then
-           setlengthwidestring(r,r^.len+16);
+           growwidestring(r,r^.len+16);
          r^.data[r^.len]:=c;
          inc(r^.len);
       end;
 
     procedure concatwidestrings(s1,s2 : pcompilerwidestring);
       begin
-         setlengthwidestring(s1,s1^.len+s2^.len);
+         growwidestring(s1,s1^.len+s2^.len);
          move(s2^.data^,s1^.data[s1^.len],s2^.len*sizeof(tcompilerwidechar));
          inc(s1^.len,s2^.len);
       end;
@@ -129,7 +137,6 @@ unit widestr;
 
       begin
          setlengthwidestring(d,s^.len);
-         d^.len:=s^.len;
          move(s^.data^,d^.data^,s^.len*sizeof(tcompilerwidechar));
       end;
 
@@ -183,7 +190,6 @@ unit widestr;
          m:=getmap(current_settings.sourcecodepage);
          setlengthwidestring(r,l);
          source:=p;
-         r^.len:=l;
          dest:=tcompilerwidecharptr(r^.data);
          if (current_settings.sourcecodepage <> 'utf8') then
            begin

rtl/i386/mathu.inc

@@ -61,29 +61,27 @@ function cotan(x : float) : float;assembler;
 {$define FPC_MATH_HAS_DIVMOD}
 procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);assembler;
 asm
-  pushw %di
-  movw %dx,%di
-  movl %eax,%edx
-  shrl $16,%edx
-  div %di
-  movw %ax,(%ecx)
-  movl Remainder,%ecx
-  movw %dx,(%ecx)
-  popw %di
+  pushl  %edi
+  movzwl %dx,%edi
+  cltd
+  idiv   %edi
+  movw   %ax,(%ecx)
+  movl   Remainder,%ecx
+  movw   %dx,(%ecx)
+  popl   %edi
 end;
 
 
 procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: SmallInt);assembler;
 asm
-  pushw %di
-  movw %dx,%di
-  movl %eax,%edx
-  shrl $16,%edx
-  div %di
-  movw %ax,(%ecx)
-  movl Remainder,%ecx
-  movw %dx,(%ecx)
-  popw %di
+  pushl  %edi
+  movzwl %dx,%edi
+  cltd
+  idiv   %edi
+  movw   %ax,(%ecx)
+  movl   Remainder,%ecx
+  movw   %dx,(%ecx)
+  popl   %edi
 end;
 
 
@@ -92,7 +90,7 @@ asm
   pushl %edi
   movl %edx,%edi
   xorl %edx,%edx
-  div %edi
+  div  %edi
   movl %eax,(%ecx)
   movl Remainder,%ecx
   movl %edx,(%ecx)
@@ -104,7 +102,7 @@ procedure DivMod(Dividend: Integer; Divisor: Integer; var Result, Remainder: Int
 asm
   pushl %edi
   movl %edx,%edi
-  xorl %edx,%edx
+  cltd
   idiv %edi
   movl %eax,(%ecx)
   movl Remainder,%ecx
@@ -112,6 +110,7 @@ asm
   popl %edi
 end;
 
+
 function GetRoundMode: TFPURoundingMode;
 begin
   Result := TFPURoundingMode((Get8087CW shr 10) and 3);

rtl/inc/real2str.inc

@@ -379,15 +379,6 @@ begin
             begin
               roundStr(temp,spos);
               d := frac(d);
-              if (f < 0) then
-                begin
-                  dec(currprec);
-                  if (currprec=0) then
-                    begin
-                      inc(spos);
-                      temp[spos]:='0';
-                    end;
-                end;
             end;
           { calculate the necessary fractional digits }
           for fracCount := 1 to currPrec do

rtl/inc/sstrings.inc

@@ -1053,12 +1053,14 @@ Function fpc_Val_Real_ShortStr(const s : shortstring; out Code : ValSInt): ValRe
 var
   hd,
   esign,sign : valreal;
-  exponent,i : SizeInt;
+  exponent,
+  decpoint,i : SizeInt;
   flags      : byte;
 begin
   fpc_Val_Real_ShortStr:=0.0;
   code:=1;
   exponent:=0;
+  decpoint:=0;
   esign:=1;
   flags:=0;
   sign:=1;
@@ -1082,17 +1084,15 @@ begin
 { Decimal ? }
   if (length(s)>=code) and (s[code]='.') then
     begin
-      hd:=1.0;
       inc(code);
       while (length(s)>=code) and (s[code] in ['0'..'9']) do
         begin
            { Read fractional part. }
           flags:=flags or 2;
           fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*10+(ord(s[code])-ord('0'));
-          hd:=hd*10.0;
+          inc(decpoint);
           inc(code);
         end;
-      fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
    end;
  { Again, read integer and fractional part}
   if flags=0 then
@@ -1101,7 +1101,7 @@ begin
       exit;
     end;
  { Exponent ? }
-  if (length(s)>=code) and (upcase(s[code])='E') then
+  if (length(s)>=code) and (s[code] in ['e','E']) then
     begin
       inc(code);
       if Length(s) >= code then
@@ -1125,6 +1125,18 @@ begin
           inc(code);
         end;
     end;
+{ adjust exponent based on decimal point }
+  if esign>0 then
+    begin
+      dec(exponent,decpoint);
+      if (exponent<0) then
+        begin
+          esign:=-1;
+          exponent:=-exponent;
+        end
+    end
+  else
+    inc(exponent,decpoint);
 { evaluate sign }
 { (before exponent, because the exponent may turn it into a denormal) }
   fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*sign;

rtl/inc/system.inc

@@ -764,6 +764,8 @@ procedure internal_initializeunits; external name 'FPC_INITIALIZEUNITS';
 procedure fpc_LibInitializeUnits;[public,alias:'FPC_LIBINITIALIZEUNITS'];
 begin
   IsLibrary:=true;
+  { must also be set to true for packages when implemented }
+  ModuleIsLib:=true;
   internal_initializeunits;
 end;
 

rtl/objpas/math.pp

@@ -2221,33 +2221,71 @@ end;
 {$ifndef FPC_MATH_HAS_DIVMOD}
 procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
 begin
-  Result:=Dividend Div Divisor;
-  Remainder:=Dividend -(Result*Divisor);
+  if Dividend < 0 then
+    begin
+      { Use DivMod with >=0 dividend }
+	  Dividend:=-Dividend;
+      { The documented behavior of Pascal's div/mod operators and DivMod
+        on negative dividends is to return Result closer to zero and
+        a negative Remainder. Which means that we can just negate both
+        Result and Remainder, and all it's Ok. }
+      Result:=-(Dividend Div Divisor);
+      Remainder:=-(Dividend+(Result*Divisor));
+    end 
+  else
+    begin
+	  Result:=Dividend Div Divisor;
+      Remainder:=Dividend-(Result*Divisor);
+	end;
 end;
 
 
 procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: SmallInt);
-var
-  UnsignedResult: Word absolute Result;
-  UnsignedRemainder: Word absolute Remainder;
 begin
-  DivMod(Dividend, Divisor, UnsignedResult, UnsignedRemainder);
+  if Dividend < 0 then
+    begin
+      { Use DivMod with >=0 dividend }
+	  Dividend:=-Dividend;
+      { The documented behavior of Pascal's div/mod operators and DivMod
+        on negative dividends is to return Result closer to zero and
+        a negative Remainder. Which means that we can just negate both
+        Result and Remainder, and all it's Ok. }
+      Result:=-(Dividend Div Divisor);
+      Remainder:=-(Dividend+(Result*Divisor));
+    end 
+  else
+    begin
+	  Result:=Dividend Div Divisor;
+      Remainder:=Dividend-(Result*Divisor);
+	end;
 end;
 
 
 procedure DivMod(Dividend: DWord; Divisor: DWord; var Result, Remainder: DWord);
 begin
   Result:=Dividend Div Divisor;
-  Remainder:=Dividend -(Result*Divisor);
+  Remainder:=Dividend-(Result*Divisor);
 end;
 
 
 procedure DivMod(Dividend: Integer; Divisor: Integer; var Result, Remainder: Integer);
-var
-  UnsignedResult: DWord absolute Result;
-  UnsignedRemainder: DWord absolute Remainder;
 begin
-  DivMod(Dividend, Divisor, UnsignedResult, UnsignedRemainder);
+  if Dividend < 0 then
+    begin
+      { Use DivMod with >=0 dividend }
+	  Dividend:=-Dividend;
+      { The documented behavior of Pascal's div/mod operators and DivMod
+        on negative dividends is to return Result closer to zero and
+        a negative Remainder. Which means that we can just negate both
+        Result and Remainder, and all it's Ok. }
+      Result:=-(Dividend Div Divisor);
+      Remainder:=-(Dividend+(Result*Divisor));
+    end 
+  else
+    begin
+	  Result:=Dividend Div Divisor;
+      Remainder:=Dividend-(Result*Divisor);
+	end;
 end;
 {$endif FPC_MATH_HAS_DIVMOD}
 

tests/tbf/tb0217.pp

@@ -0,0 +1,17 @@
+{ %fail }
+
+{$p+}
+{$v+}
+type
+  tstr = string[8];
+
+{ FPC used to convert the following parameter into an openstring }
+procedure test(var str: tstr);
+begin
+end;
+
+var
+  s: string[20];
+begin
+  test(s);
+end.

tests/tbs/tb0566.pp

@@ -0,0 +1,9 @@
+var
+ d1,d2,d3 : extended;
+ err: longint;
+begin
+ d1:=105;
+ d2:=1.05e2;
+ if (d1<>d2) then
+   halt(1);
+end.

tests/tbs/tb0567.pp

@@ -0,0 +1,31 @@
+begin
+  if (pred(-128)<>-129) or
+     (succ(127)<>128) then
+    halt(1);
+  if (pred(0)<>-1) or
+     (succ(255)<>256) then
+    halt(2);
+  if (pred(-32768)<>-32769) or
+     (succ(32767)<>32768) then
+    halt(3);
+  if (succ(65535)<>65536) then
+    halt(4);
+  if (pred(-2147483648)<>-2147483649) or
+     (succ(2147483647)<>2147483648) then
+    halt(5);
+  if (succ(4294967295)<>4294967296) then
+    halt(6);
+
+  if (pred(bytebool(false))<>bytebool(true)) then
+    halt(7);
+  if (succ(bytebool(true))<>bytebool(false)) then
+    halt(8);
+  if (pred(wordbool(false))<>wordbool(true)) then
+    halt(9);
+  if (succ(wordbool(true))<>wordbool(false)) then
+    halt(10);
+  if (pred(longbool(false))<>longbool(true)) then
+    halt(11);
+  if (succ(longbool(true))<>longbool(false)) then
+    halt(12);
+end.

tests/test/tlibrary1.pp

@@ -38,6 +38,8 @@ procedure Test;export;
  begin
    if not islibrary then
      halt(1);
+   if not moduleislib then
+     halt(2);
    writeln('Hoi');
  end;
 

tests/test/tlibrary2.pp

@@ -25,6 +25,10 @@ const
 procedure test;external libname name 'TestName';
 
 begin
+  if islibrary then
+    halt(3);
+  if moduleislib then
+    halt(4);
   test;
 end.
 {$else not supported}

tests/test/units/math/tdivmod.pp

@@ -1,3 +1,4 @@
+{$mode objfpc}
 uses
   math;
 { tests:
@@ -55,5 +56,18 @@ begin
     doerror(3003);
   if RemainderInteger<>15 then
     doerror(3004);
+	
+  DivMod(-9, 5, QuotientInteger,RemainderInteger);
+  if QuotientInteger<>-1 then
+    doerror(3005);
+  if RemainderInteger<>-4 then
+    doerror(3006);
+	
+  DivMod(-9, -5, QuotientInteger,RemainderInteger);
+  if QuotientInteger<>1 then
+    doerror(3007);
+  if RemainderInteger<>-4 then
+    doerror(3008);
+	
 end.
 	

tests/webtbf/tw15391a.pp

@@ -0,0 +1,29 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+type
+  FuncA = function : Integer of object;
+  ObjA = class
+    function Func1: Integer;
+    procedure Proc1(const Arr: Array of char);
+  end;
+
+var A : ObjA;
+
+function ObjA.Func1: Integer;
+begin
+  Result := 1;
+end;
+
+procedure ObjA.Proc1(const Arr: Array of char);
+begin
+end;
+
+begin
+  A := ObjA.Create;
+  A.Proc1([A.Func1]);
+  a.free;
+end.

tests/webtbf/tw15727b.pp

@@ -0,0 +1,25 @@
+{ %fail }
+
+{$mode objfpc}
+{$r+}
+
+uses
+  SysUtils;
+
+procedure test(a: array of const);
+begin
+  if (a[0].vtype<>vtinteger) or
+     (a[0].vinteger<>longint($f0f0f0f0)) then
+    halt(1);
+end;
+
+var
+  z: cardinal;
+begin
+  // next line produces compilation error "Error: range check error while evaluating constants"
+
+  // accepted now in Delphi mode, not in FPC mode because this value is
+  // implicitly converted to a longint, and $f0f0f0f0 is an invalid longint
+  // value (use longint($f0f0f0f0) instead)
+  test([$F0F0F0F0]);
+end.

tests/webtbf/tw16022.pp

@@ -0,0 +1,17 @@
+{ %fail }
+
+PROGRAM test;
+
+{$mode objfpc}
+var a,b: string;
+
+begin
+  a:= 'Test A';
+  b:= 'B Test';
+  system.insert(a,'ing',5);
+  system.insert('H World','allo',2);
+  system.insert('&B',b,2);
+  writeln(a);
+  writeln(b);
+end.
+

tests/webtbs/tw14566.pp

@@ -0,0 +1,9 @@
+{ %cpu=x86_64 }
+{ %norun }
+procedure p(xmm0 : double);assembler;
+asm
+  movaps %xmm0,xmm0
+end;
+
+begin
+end.

tests/webtbs/tw14941.pp

@@ -0,0 +1,21 @@
+program StringTest5;
+{$V+}
+var
+   s    :String;
+
+procedure P( s: OpenString);
+begin
+  writeln(s);
+  if (high(s)<>255) or
+     (s<>'12345') then
+    halt(1);
+end;
+
+begin
+  P('12345');
+  s:='12345';
+  p(s);
+  {Won't compile.
+  FPC or Turbo Pascal mode:  Internal error 200405241
+  Delphi mode:  Signal 291.  Save files and restart IDE.  (Can't save.)}
+end.

tests/webtbs/tw14941a.pp

@@ -0,0 +1,24 @@
+program StringTest5;
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+{$V+}
+var
+   s    :String;
+
+procedure P( s: OpenString);
+begin
+  writeln(s);
+  if (high(s)<>255) or
+     (s<>'12345') then
+    halt(1);
+end;
+
+begin
+  P('12345');
+  s:='12345';
+  p(s);
+  {Won't compile.
+  FPC or Turbo Pascal mode:  Internal error 200405241
+  Delphi mode:  Signal 291.  Save files and restart IDE.  (Can't save.)}
+end.

tests/webtbs/tw15308.pp

@@ -0,0 +1,25 @@
+program testformatfloat;
+
+uses SysUtils;
+
+const
+   val_format: string = '0.0000E+000';
+   
+var
+   input: extended;
+
+begin
+   decimalseparator:='.';
+   input:=1.05e2;
+   if (formatfloat(val_format,input)<>'1.0500E+002') then
+     begin
+       writeln(formatfloat(val_format,input));
+       halt(1);
+     end;
+   input:=1.06e2;
+   if (formatfloat(val_format,input)<>'1.0600E+002') then
+     begin
+       writeln(formatfloat(val_format,input));
+       halt(2);
+     end;
+end.

tests/webtbs/tw15391.pp

@@ -0,0 +1,39 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+type
+  FuncA = function : Integer of object;
+  ObjA = class
+    function Func1: Integer;
+    procedure Proc1(const Arr: Array of FuncA);
+  end;
+
+var A : ObjA;
+
+procedure test(fa: funca);
+begin
+  if fa<>a.func1 then
+    halt(2);
+end;
+
+function ObjA.Func1: Integer;
+begin
+  Result := 1;
+end;
+
+procedure ObjA.Proc1(const Arr: Array of FuncA);
+begin
+  if (low(arr)<>0) or
+     (high(arr)<>1) or
+     assigned(arr[0]) or
+     (arr[1]<>a.func1) then
+    halt(1);
+end;
+
+begin
+  A := ObjA.Create;
+  A.Proc1([nil,A.Func1]);
+  test(a.func1);
+  a.free;
+end.

tests/webtbs/tw15446.pp

@@ -0,0 +1,26 @@
+program varfunc_test;
+
+{$IFDEF FPC}
+  {$mode Delphi}
+{$ELSE}
+  {$APPTYPE CONSOLE}
+{$ENDIF}
+{$H+}
+
+uses sysutils;
+
+function TestFunc1 : Longint;
+begin
+  Result := 100;
+end;
+
+Type Tfunc1 = function : Longint;
+var
+  TestFunc2 : Tfunc1 = TestFunc1;
+
+begin
+  writeln({$IFDEF FPC}'FPC'{$ELSE}'Delphi'{$ENDIF});
+
+  writeln( Format('%d',[TestFunc1]) );
+  writeln( Format('%d',[TestFunc2]) ); 
+end.

tests/webtbs/tw15727a.pp

@@ -0,0 +1,26 @@
+{$mode delphi}
+{$r+}
+
+uses
+  SysUtils;
+
+procedure test(a: array of const);
+begin
+  if (a[0].vtype<>vtinteger) or
+     (a[0].vinteger<>longint($f0f0f0f0)) then
+    halt(1);
+end;
+
+var
+  z: cardinal;
+begin
+  Z:=$F0F0F0F0;
+  // next line works OK
+  writeln('Z=',Z);
+
+  // next line produces compilation error "Error: range check error while evaluating constants"
+  test([$F0F0F0F0]);
+
+  // next line gives run-time error: "ERangeError : Range check error"
+  test([Z]);
+end.

tests/webtbs/tw15728.pp

@@ -0,0 +1,35 @@
+program TT;
+
+{$mode delphi}
+
+uses
+  SysUtils;
+
+type
+  t_R = record
+   R1:integer;
+  end;
+
+t_X = function:t_R;
+
+function A:t_R;
+  begin
+    Result.R1:=123;
+  end;
+
+var X:t_X;
+
+begin
+  X:=A;
+  if x.r1<>123 then
+    halt(1);
+  writeln(X.R1); // Error: Illegal qualifier
+  writeln(X().R1); // OK
+  with X do
+    begin
+      if r1<>123 then
+        halt(2);
+      writeln(R1); //Error: Expression type must be class or record 
+    end;
+  with X() do writeln(R1); // OK
+end.

tests/webtbs/tw15909.pp

@@ -0,0 +1,10 @@
+{ %recompile }
+
+{$inline on}
+
+uses
+  uw15909;
+
+begin
+  foo('abc',5);
+end.

tests/webtbs/uw15909.pp

@@ -0,0 +1,31 @@
+unit uw15909;
+{$mode Delphi}
+
+{$inline on}
+
+interface
+
+    procedure foo(const s: widestring; const n: integer); inline;
+
+    function bar(const s, fmt: widestring): integer;
+
+implementation
+
+procedure foo(const s: widestring; const n: integer);
+begin
+    bar(s, '%d')
+end;
+
+
+    function bar(const s, fmt: widestring): integer;
+      begin
+        if (s<>'abc') or
+           (fmt<>'%d') then
+          begin
+            writeln('"',s,'"');
+            halt(1);
+          end;
+        result:=0;
+      end;
+
+end.