--- Merging r14690 into '.':

U    compiler/ncnv.pas
--- Merging r14736 into '.':
A    tests/webtbs/tw14388.pp
U    compiler/ncgmem.pas
--- Merging r14755 into '.':
G    compiler/ncnv.pas
--- Merging r14892 into '.':
A    tests/tbs/tb0570.pp
U    compiler/ncgcnv.pas
U    compiler/defutil.pas
U    compiler/nutils.pas
G    compiler/ncnv.pas
U    compiler/nadd.pas
--- Merging r14895 through r14896 into '.':
U    compiler/ncgutil.pas
G    compiler/nadd.pas
--- Merging r14904 into '.':
G    compiler/nadd.pas
--- Merging r14909 into '.':
G    compiler/defutil.pas
--- Merging r14911 into '.':
G    compiler/ncnv.pas
--- Merging r14925 into '.':
A    tests/webtbs/tw15812.pp
G    compiler/ncgmem.pas
--- Merging r15041 into '.':
A    tests/webtbs/tw15843.pp
U    compiler/x86/rax86int.pas
--- Merging r15101 into '.':
A    tests/webtbs/tw16163.pp
U    compiler/nmem.pas
G    compiler/ncgmem.pas
--- Merging r15218 into '.':
A    tests/webtbs/tw16018.pp
U    compiler/ncal.pas
--- Merging r15221 into '.':
A    tests/webtbs/tw16377.pp
G    compiler/ncgmem.pas
--- Merging r15223 into '.':
A    tests/webtbs/tw15610.pp
U    compiler/pdecvar.pas

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

.gitattributes

@@ -7725,6 +7725,7 @@ 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/tb0570.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
@@ -9450,6 +9451,7 @@ tests/webtbs/tw1430.pp svneol=native#text/plain
 tests/webtbs/tw14307.pp svneol=native#text/plain
 tests/webtbs/tw1433.pp svneol=native#text/plain
 tests/webtbs/tw14363.pp svneol=native#text/plain
+tests/webtbs/tw14388.pp svneol=native#text/pascal
 tests/webtbs/tw14403.pp svneol=native#text/plain
 tests/webtbs/tw14418.pp svneol=native#text/plain
 tests/webtbs/tw1445.pp svneol=native#text/plain
@@ -9496,21 +9498,27 @@ 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/tw15599.pp svneol=native#text/plain
+tests/webtbs/tw15610.pp svneol=native#text/plain
 tests/webtbs/tw1567.pp svneol=native#text/plain
 tests/webtbs/tw15690.pp svneol=native#text/plain
 tests/webtbs/tw15693.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/tw15812.pp svneol=native#text/plain
 tests/webtbs/tw15821.pp svneol=native#text/plain
+tests/webtbs/tw15843.pp svneol=native#text/plain
 tests/webtbs/tw15909.pp svneol=native#text/plain
 tests/webtbs/tw1592.pp svneol=native#text/plain
+tests/webtbs/tw16018.pp svneol=native#text/plain
 tests/webtbs/tw16161.pp svneol=native#text/pascal
+tests/webtbs/tw16163.pp svneol=native#text/plain
 tests/webtbs/tw1617.pp svneol=native#text/plain
 tests/webtbs/tw1622.pp svneol=native#text/plain
 tests/webtbs/tw1623.pp svneol=native#text/plain
 tests/webtbs/tw16326.pp svneol=native#text/plain
 tests/webtbs/tw1634.pp svneol=native#text/plain
+tests/webtbs/tw16377.pp svneol=native#text/plain
 tests/webtbs/tw1658.pp svneol=native#text/plain
 tests/webtbs/tw1677.pp svneol=native#text/plain
 tests/webtbs/tw1681.pp svneol=native#text/plain

compiler/defutil.pas

@@ -246,6 +246,11 @@ interface
     { # returns true if the procdef has no parameters and no specified return type }
     function is_bareprocdef(pd : tprocdef): boolean;
 
+    { # returns the smallest base integer type whose range encompasses that of
+        both ld and rd; if keep_sign_if_equal, then if ld and rd have the same
+        signdness, the result will also get that signdness }
+    function get_common_intdef(ld, rd: torddef; keep_sign_if_equal: boolean): torddef;
+
 implementation
 
     uses
@@ -1037,4 +1042,60 @@ implementation
                  (pd.proctypeoption = potype_constructor));
       end;
 
+
+    function get_common_intdef(ld, rd: torddef; keep_sign_if_equal: boolean): torddef;
+      var
+        llow, lhigh: tconstexprint;
+      begin
+        llow:=rd.low;
+        if llow<ld.low then
+          llow:=ld.low;
+        lhigh:=rd.high;
+        if lhigh<ld.high then
+          lhigh:=ld.high;
+        case range_to_basetype(llow,lhigh) of
+          s8bit:
+            result:=torddef(s8inttype);
+          u8bit:
+            result:=torddef(u8inttype);
+          s16bit:
+            result:=torddef(s16inttype);
+          u16bit:
+            result:=torddef(u16inttype);
+          s32bit:
+            result:=torddef(s32inttype);
+          u32bit:
+            result:=torddef(u32inttype);
+          s64bit:
+            result:=torddef(s64inttype);
+          u64bit:
+            result:=torddef(u64inttype);
+          else
+            begin
+              { avoid warning }
+              result:=nil;
+              internalerror(200802291);
+            end;
+        end;
+        if keep_sign_if_equal and
+           (is_signed(ld)=is_signed(rd)) and
+           (is_signed(result)<>is_signed(ld)) then
+          case result.ordtype of
+            s8bit:
+              result:=torddef(u8inttype);
+            u8bit:
+              result:=torddef(s16inttype);
+            s16bit:
+              result:=torddef(u16inttype);
+            u16bit:
+              result:=torddef(s32inttype);
+            s32bit:
+              result:=torddef(u32inttype);
+            u32bit:
+              result:=torddef(s64inttype);
+            s64bit:
+              result:=torddef(u64inttype);
+          end;
+      end;
+
 end.

compiler/nadd.pas

@@ -370,9 +370,14 @@ implementation
               t:=nil;
               hp:=right;
               realdef:=hp.resultdef;
+              { stop with finding the real def when we either encounter
+                 a) an explicit type conversion (then the value has to be
+                    re-interpreted)
+                 b) an "absolute" type conversion (also requires
+                    re-interpretation)
+              }
               while (hp.nodetype=typeconvn) and
-                    ([nf_internal,nf_explicit] * hp.flags = []) and
-                    is_in_limit(ttypeconvnode(hp).left.resultdef,realdef) do
+                    ([nf_internal,nf_explicit,nf_absolute] * hp.flags = []) do
                 begin
                   hp:=ttypeconvnode(hp).left;
                   realdef:=hp.resultdef;
@@ -421,8 +426,7 @@ implementation
               hp:=left;
               realdef:=hp.resultdef;
               while (hp.nodetype=typeconvn) and
-                    ([nf_internal,nf_explicit] * hp.flags = []) and
-                    is_in_limit(ttypeconvnode(hp).left.resultdef,realdef) do
+                    ([nf_internal,nf_explicit,nf_absolute] * hp.flags = []) do
                 begin
                   hp:=ttypeconvnode(hp).left;
                   realdef:=hp.resultdef;
@@ -1116,7 +1120,10 @@ implementation
              { size either as long as both values are signed or unsigned   }
              { "xor" and "or" also don't care about the sign if the values }
              { occupy an entire register                                   }
+             { don't do it if either type is 64 bit, since in that case we }
+             { can't safely find a "common" type                           }
              else if is_integer(ld) and is_integer(rd) and
+                     not is_64bitint(ld) and not is_64bitint(rd) and
                      ((nodetype=andn) or
                       ((nodetype in [orn,xorn,equaln,unequaln,gtn,gten,ltn,lten]) and
                        not(is_signed(ld) xor is_signed(rd)))) then
@@ -1128,17 +1135,28 @@ implementation
                    begin
                      if (rd.size=ld.size) and
                         is_signed(ld) then
-                       inserttypeconv_internal(left,right.resultdef)
+                       inserttypeconv_internal(left,rd)
                      else
-                       inserttypeconv(left,right.resultdef)
+                       begin
+                         { not to left right.resultdef, because that may
+                           cause a range error if left and right's def don't
+                           completely overlap }
+                         nd:=get_common_intdef(torddef(ld),torddef(rd),true);
+                         inserttypeconv(left,nd);
+                         inserttypeconv(right,nd);
+                       end;
                    end
                  else
                    begin
                      if (rd.size=ld.size) and
                         is_signed(rd) then
-                       inserttypeconv_internal(right,left.resultdef)
+                       inserttypeconv_internal(right,ld)
                      else
-                       inserttypeconv(right,left.resultdef)
+                       begin
+                         nd:=get_common_intdef(torddef(ld),torddef(rd),true);
+                         inserttypeconv(left,nd);
+                         inserttypeconv(right,nd);
+                       end;
                    end
                end
              { is there a signed 64 bit type ? }
@@ -1248,33 +1266,8 @@ implementation
                     (nodetype=subn) then
                    begin
 {$ifdef cpunodefaultint}
-                      { for small cpus we use the smallest common type }
-                      llow:=torddef(rd).low;
-                      if llow<torddef(ld).low then
-                        llow:=torddef(ld).low;
-                      lhigh:=torddef(rd).high;
-                      if lhigh<torddef(ld).high then
-                        lhigh:=torddef(ld).high;
-                      case range_to_basetype(llow,lhigh) of
-                        s8bit:
-                          nd:=s8inttype;
-                        u8bit:
-                          nd:=u8inttype;
-                        s16bit:
-                          nd:=s16inttype;
-                        u16bit:
-                          nd:=u16inttype;
-                        s32bit:
-                          nd:=s32inttype;
-                        u32bit:
-                          nd:=u32inttype;
-                        s64bit:
-                          nd:=s64inttype;
-                        u64bit:
-                          nd:=u64inttype;
-                        else
-                          internalerror(200802291);
-                      end;
+                     { for small cpus we use the smallest common type }
+                     nd:=get_common_intdef(torddef(ld),torddef(rd),false);
                      inserttypeconv(right,nd);
                      inserttypeconv(left,nd);
 {$else cpunodefaultint}

compiler/ncal.pas

@@ -3198,7 +3198,12 @@ implementation
                    )
                   ) then
                   begin
-                    if para.left.nodetype<>temprefn then
+                    { don't create a new temp unnecessarily, but make sure we
+                      do create a new one if the old one could be a regvar and
+                      the new one cannot be one }
+                    if (para.left.nodetype<>temprefn) or
+                       (((tparavarsym(para.parasym).varregable in [vr_none,vr_addr])) and
+                        (ti_may_be_in_reg in ttemprefnode(para.left).tempinfo^.flags)) then
                       begin
                         tempnode := ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size,tt_persistent,tparavarsym(para.parasym).is_regvar(false));
                         addstatement(inlineinitstatement,tempnode);

compiler/ncgcnv.pas

@@ -60,7 +60,7 @@ interface
     uses
       cutils,verbose,globtype,globals,
       aasmbase,aasmtai,aasmdata,aasmcpu,symconst,symdef,paramgr,
-      ncon,ncal,
+      nutils,ncon,ncal,
       cpubase,systems,
       procinfo,pass_2,
       cgbase,
@@ -88,7 +88,8 @@ interface
           nothing that we can load in a register }
         ressize := resultdef.size;
         leftsize := left.resultdef.size;
-        if (ressize<>leftsize) and
+        if ((ressize<>leftsize) or
+            is_bitpacked_access(left)) and
            not is_void(left.resultdef) then
           begin
             location_copy(location,left.location);

compiler/ncgmem.pas

@@ -172,7 +172,15 @@ implementation
          location_reset(location,LOC_REGISTER,OS_ADDR);
          location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
          if not(left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
-           internalerror(2006111510);
+           { on x86_64-win64, array of chars can be returned in registers, however,
+             when passing these arrays to other functions, the compiler wants to take
+             the address of the array so when the addrnode has been created internally,
+             we have to force the data into memory, see also tw14388.pp
+           }
+           if nf_internal in flags then
+             location_force_mem(current_asmdata.CurrAsmList,left.location)
+           else
+             internalerror(2006111510);
          cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,location.register);
       end;
 
@@ -192,6 +200,8 @@ implementation
            location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),resultdef.alignment)
          else
            location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),1);
+         if not(left.location.loc in [LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE,LOC_CONSTANT]) then
+           location_force_reg(current_asmdata.CurrAsmList,left.location,OS_ADDR,true);
          case left.location.loc of
             LOC_CREGISTER,
             LOC_REGISTER:
@@ -327,7 +337,13 @@ implementation
                LOC_REGISTER,
                LOC_CREGISTER:
                  begin
-                   if (left.resultdef.size > sizeof(pint)) then
+                   // in case the result is not something that can be put
+                   // into an integer register (e.g.
+                   // function_returning_record().non_regable_field, or
+                   // a function returning a value > sizeof(intreg))
+                   // -> force to memory
+                   if not tstoreddef(left.resultdef).is_intregable or
+                      not tstoreddef(resultdef).is_intregable then
                      location_force_mem(current_asmdata.CurrAsmList,location)
                    else
                      begin
@@ -928,19 +944,15 @@ implementation
               else if (right.location.loc = LOC_JUMP) then
                 internalerror(2006010801);
 
-              { only range check now, we can't range check loc_flags/loc_jump }
-              if cs_check_range in current_settings.localswitches then
-               begin
-                 if left.resultdef.typ=arraydef then
-                   rangecheck_array;
-               end;
-
             { produce possible range check code: }
               if cs_check_range in current_settings.localswitches then
                begin
                  if left.resultdef.typ=arraydef then
                    begin
-                     { done defore (PM) }
+		     { do not do any range checking when this is an array access to a pointer which has been
+		       typecasted from an array }
+		     if (not (ado_isconvertedpointer in tarraydef(left.resultdef).arrayoptions)) then
+                       rangecheck_array
                    end
                  else if (left.resultdef.typ=stringdef) then
                    begin

compiler/ncgutil.pas

@@ -600,7 +600,7 @@ implementation
                     { MSB first in memory and e.g. byte(word_var) should  }
                     { return  the second byte in this case (JM)           }
                     if (target_info.endian = ENDIAN_BIG) and
-                       (l.loc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_SUBSETREF,LOC_CSUBSETREF]) then
+                       (l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
                       begin
                         inc(l.reference.offset,TCGSize2Size[l.size]-TCGSize2Size[dst_size]);
                         l.reference.alignment:=newalignment(l.reference.alignment,TCGSize2Size[l.size]-TCGSize2Size[dst_size]);

compiler/ncnv.pas

@@ -243,8 +243,11 @@ implementation
             exit;
          end;
 
-        { don't insert obsolete type conversions }
-        if equal_defs(p.resultdef,def) then
+        { don't insert superfluous type conversions, but
+          in case of bitpacked accesses, the original type must
+          remain too so that not too many/few bits are laoded }
+        if equal_defs(p.resultdef,def) and
+           not is_bitpacked_access(p) then
           p.resultdef:=def
         else
          begin
@@ -265,8 +268,11 @@ implementation
             exit;
          end;
 
-        { don't insert obsolete type conversions }
-        if equal_defs(p.resultdef,def) then
+        { don't insert superfluous type conversions, but
+          in case of bitpacked accesses, the original type must
+          remain too so that not too many/few bits are laoded }
+        if equal_defs(p.resultdef,def) and
+           not is_bitpacked_access(p) then
           p.resultdef:=def
         else
          begin
@@ -1684,6 +1690,10 @@ implementation
                   if assigned(result) then
                     exit;
 
+                  { in case of bitpacked accesses, the original type must
+                    remain so that not too many/few bits are laoded }
+                  if is_bitpacked_access(left) then
+                    convtype:=tc_int_2_int;
                   { Only leave when there is no conversion to do.
                     We can still need to call a conversion routine,
                     like the routine to convert a stringconstnode }
@@ -2972,6 +2982,7 @@ implementation
                 (
                  (convtype=tc_int_2_int) and
                  (
+                  not is_bitpacked_access(left) and
                   (resultdef.size=left.resultdef.size) or
                   ((m_tp7 in current_settings.modeswitches) and
                    (resultdef.size<left.resultdef.size))
@@ -3005,7 +3016,8 @@ implementation
       begin
         docompare :=
           inherited docompare(p) and
-          (convtype = ttypeconvnode(p).convtype);
+          (convtype = ttypeconvnode(p).convtype) and
+          equal_defs(totypedef,ttypeconvnode(p).totypedef);
       end;
 
 

compiler/nmem.pas

@@ -606,9 +606,10 @@ implementation
         maybe_call_procvar(left,true);
         resultdef:=vs.vardef;
 
-        // don't put records from which we load fields which aren't regable in integer registers
-        if (left.resultdef.typ = recorddef) and
-           not(tstoreddef(resultdef).is_intregable) then
+        // don't put records from which we load float fields
+        // in integer registers
+        if (left.resultdef.typ=recorddef) and
+           (resultdef.typ=floatdef) then
           make_not_regable(left,[ra_addr_regable]);
       end;
 

compiler/nutils.pas

@@ -90,6 +90,12 @@ interface
     procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
     function node_to_propaccesslist(p1:tnode):tpropaccesslist;
 
+    { returns true if n is an array element access of a bitpacked array with
+      elements of the which the vitsize mod 8 <> 0, or if is a field access
+      with bitsize mod 8 <> 0 or bitoffset mod 8 <> 0 of an element in a
+      bitpacked structure }
+    function is_bitpacked_access(n: tnode): boolean;
+
 implementation
 
     uses
@@ -1048,6 +1054,24 @@ implementation
       end;
 
 
+    function is_bitpacked_access(n: tnode): boolean;
+      begin
+        case n.nodetype of
+          vecn:
+            result:=
+              is_packed_array(tvecnode(n).left.resultdef) and
+              (tarraydef(tvecnode(n).left.resultdef).elepackedbitsize mod 8 <> 0);
+          subscriptn:
+            result:=
+              is_packed_record_or_object(tsubscriptnode(n).left.resultdef) and
+              ((tsubscriptnode(n).vs.vardef.packedbitsize mod 8 <> 0) or
+               (tsubscriptnode(n).vs.fieldoffset mod 8 <> 0));
+          else
+            result:=false;
+        end;
+      end;
+
+
     function has_no_code(n : tnode) : boolean;
       begin
         if n=nil then

compiler/pdecvar.pas

@@ -238,6 +238,19 @@ implementation
                (ppo_hasparameters in p.propoptions);
           end;
 
+          procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef, storedprocdef: tprocvardef);
+            var
+              hparavs: tparavarsym;
+            begin
+              inc(paranr);
+              hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
+              readprocdef.parast.insert(hparavs);
+              hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
+              writeprocdef.parast.insert(hparavs);
+              hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
+              storedprocdef.parast.insert(hparavs);
+            end;
+
       var
          sym : tsym;
          srsymtable: tsymtable;
@@ -385,13 +398,7 @@ implementation
                    p.indexdef:=pt.resultdef;
                    include(p.propoptions,ppo_indexed);
                    { concat a longint to the para templates }
-                   inc(paranr);
-                   hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
-                   readprocdef.parast.insert(hparavs);
-                   hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
-                   writeprocdef.parast.insert(hparavs);
-                   hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indexdef,[]);
-                   storedprocdef.parast.insert(hparavs);
+                   add_index_parameter(paranr,p,readprocdef,writeprocdef,storedprocdef);
                    pt.free;
                 end;
            end
@@ -410,6 +417,8 @@ implementation
                   p.index:=tpropertysym(overriden).index;
                   p.default:=tpropertysym(overriden).default;
                   p.propoptions:=tpropertysym(overriden).propoptions;
+                  if ppo_indexed in p.propoptions then
+                    add_index_parameter(paranr,p,readprocdef,writeprocdef,storedprocdef);
                 end
               else
                 begin

compiler/x86/rax86int.pas

@@ -62,7 +62,7 @@ Unit Rax86int;
          function consume(t : tasmtoken):boolean;
          procedure RecoverConsume(allowcomma:boolean);
          procedure BuildRecordOffsetSize(const expr: string;var offset:aint;var size:aint; var mangledname: string; needvmtofs: boolean);
-         procedure BuildConstSymbolExpression(needofs,isref:boolean;var value:aint;var asmsym:string;var asmsymtyp:TAsmsymtype);
+         procedure BuildConstSymbolExpression(needofs,isref,startingminus:boolean;var value:aint;var asmsym:string;var asmsymtyp:TAsmsymtype);
          function BuildConstExpression:aint;
          function BuildRefConstExpression:aint;
          procedure BuildReference(oper : tx86operand);
@@ -746,7 +746,7 @@ Unit Rax86int;
       end;
 
 
-    Procedure tx86intreader.BuildConstSymbolExpression(needofs,isref:boolean;var value:aint;var asmsym:string;var asmsymtyp:TAsmsymtype);
+    Procedure tx86intreader.BuildConstSymbolExpression(needofs,isref,startingminus:boolean;var value:aint;var asmsym:string;var asmsymtyp:TAsmsymtype);
       var
         tempstr,expr,hs,mangledname : string;
         parenlevel : longint;
@@ -768,6 +768,8 @@ Unit Rax86int;
         errorflag:=FALSE;
         tempstr:='';
         expr:='';
+        if startingminus then
+          expr:='-';
         inexpression:=TRUE;
         parenlevel:=0;
         sym:=nil;
@@ -1116,7 +1118,7 @@ Unit Rax86int;
         hs : string;
         hssymtyp : TAsmsymtype;
       begin
-        BuildConstSymbolExpression(false,false,l,hs,hssymtyp);
+        BuildConstSymbolExpression(false,false,false,l,hs,hssymtyp);
         if hs<>'' then
          Message(asmr_e_relocatable_symbol_not_allowed);
         BuildConstExpression:=l;
@@ -1129,7 +1131,7 @@ Unit Rax86int;
         hs : string;
         hssymtyp : TAsmsymtype;
       begin
-        BuildConstSymbolExpression(false,true,l,hs,hssymtyp);
+        BuildConstSymbolExpression(false,true,false,l,hs,hssymtyp);
         if hs<>'' then
          Message(asmr_e_relocatable_symbol_not_allowed);
         BuildRefConstExpression:=l;
@@ -1429,7 +1431,11 @@ Unit Rax86int;
               begin
                 if not GotPlus and not GotStar then
                   Message(asmr_e_invalid_reference_syntax);
-                BuildConstSymbolExpression(true,true,l,tempstr,tempsymtyp);
+                BuildConstSymbolExpression(true,true,GotPlus and negative,l,tempstr,tempsymtyp);
+                { already handled by BuildConstSymbolExpression(); must be
+                  handled there to avoid [reg-1+1] being interpreted as
+                  [reg-(1+1)] }
+                negative:=false;
 
                 if tempstr<>'' then
                  begin
@@ -1453,12 +1459,7 @@ Unit Rax86int;
                            scale:=l;
                        end
                       else
-                       begin
-                         if negative then
-                           Dec(oper.opr.ref.offset,l)
-                         else
-                           Inc(oper.opr.ref.offset,l);
-                       end;
+                       Inc(oper.opr.ref.offset,l);
                     end;
                   OPR_LOCAL :
                     begin
@@ -1472,12 +1473,7 @@ Unit Rax86int;
                            scale:=l;
                        end
                       else
-                       begin
-                         if negative then
-                           Dec(oper.opr.localsymofs,l)
-                         else
-                           Inc(oper.opr.localsymofs,l);
-                       end;
+                        Inc(oper.opr.localsymofs,l);
                     end;
                 end;
                 GotPlus:=(prevasmtoken=AS_PLUS) or
@@ -1514,7 +1510,7 @@ Unit Rax86int;
       begin
         if not (oper.opr.typ in [OPR_NONE,OPR_CONSTANT]) then
           Message(asmr_e_invalid_operand_type);
-        BuildConstSymbolExpression(true,false,l,tempstr,tempsymtyp);
+        BuildConstSymbolExpression(true,false,false,l,tempstr,tempsymtyp);
         if tempstr<>'' then
           begin
             oper.opr.typ:=OPR_SYMBOL;
@@ -2042,7 +2038,7 @@ Unit Rax86int;
             AS_INTNUM,
             AS_ID :
               Begin
-                BuildConstSymbolExpression(false,false,value,asmsym,asmsymtyp);
+                BuildConstSymbolExpression(false,false,false,value,asmsym,asmsymtyp);
                 if asmsym<>'' then
                  begin
                    if constsize<>sizeof(pint) then

tests/tbs/tb0570.pp

@@ -0,0 +1,36 @@
+program rangtest ;
+
+type
+  trange = 0..2030 ;
+  ytrange = 1990..2030 ;
+
+CONST
+  lrange =   low ( trange ) ;
+  hrange =  high ( trange ) ;
+  ylrange =  low ( ytrange ) ;
+  yhrange = high ( ytrange ) ;
+
+var
+  bbb : trange ;
+  kkk : longint ;
+  xyzzy : array [ ytrange, 1..100 ] of
+            record
+              xyzp : longint ;
+              xyzb : boolean ;
+             end ;
+
+begin       (*$r+,s+,o+*)
+  bbb := 0 ;
+  kkk := 1 ;
+  IF ( bbb >= ylrange )                   //  this IFstatement can not be found in the assembler file
+     AND ( bbb <= yhrange )         //  and the program stops with range error
+    THEN begin                             //
+      WITH xyzzy[bbb,kkk] DO
+        BEGIN
+          halt(1);
+          xyzp := 2 ;
+          xyzb := True ;
+         END ;
+     end
+    else writeln ( 'out' ) ;
+ end.

tests/webtbs/tw14388.pp

@@ -0,0 +1,22 @@
+program Project1;
+
+{$mode objfpc}{$H+}
+
+type
+  TID4 = array[0..3] of char;
+
+function GetID: TID4;
+begin
+  result:=#1#3#5#9;
+end;
+
+
+var
+  ChunkID: TID4;
+begin
+  ChunkID:=#1#3#5#9;
+  if GetID=ChunkID then
+    writeln('ok')
+  else
+    halt(1);
+end.

tests/webtbs/tw15610.pp

@@ -0,0 +1,54 @@
+{ %norun }
+
+program a;
+{$ifdef FPC}
+	{$mode delphi}
+{$endif}
+
+type
+    TBase=class
+    private
+	fData:string;
+	procedure Setdata(ndx:integer;const s:string);
+	function GetData(ndx:integer):string;
+	function OldIsStored(ndx:integer):boolean;
+    public
+	property Data:string index 0 read GetData write SetData stored OldIsStored; 
+    end;
+    
+    TDerived=class(TBase)
+    private
+	function IsDataStored(ndx:integer):boolean;
+    published
+	property Data stored IsDataStored;
+    end;
+    
+    
+    procedure TBase.Setdata(ndx:integer;const s:string);
+    begin
+	if ndx=0 then fData:=s;
+    end;
+    
+    function TBase.GetData(ndx:integer):string;
+    begin
+	if ndx=0 then 
+	    Result:=fData
+	else
+	    Result:='';
+    end;
+    
+    function TBase.OldIsStored(ndx:integer):boolean;
+    begin
+	Result:=ndx>1;
+    end;
+    
+    
+    
+    function TDerived.IsDataStored(ndx:integer):boolean;
+    begin
+	Result:=ndx=0;
+    end;
+    
+    
+begin
+end.

tests/webtbs/tw15812.pp

@@ -0,0 +1,27 @@
+{$mode macpas}
+program test;
+
+type
+  Rec1Ptr = ^Rec1;
+  Rec1 =
+    record
+      case boolean of
+        False : ( f1: Integer);
+        True : ( case boolean of
+                    False: ( f2: Integer);
+                    True : ( f3: Integer))
+    end;
+  Rec2 =
+    record
+      case boolean of
+        False : ( p1: Rec1Ptr);
+        True : ( p2: Pointer)
+    end;
+
+procedure PP( theRec2: Rec2; var theRec1: Rec1);
+  begin
+    theRec1 := theRec2.p1^
+  end;
+
+begin
+end.

tests/webtbs/tw15843.pp

@@ -0,0 +1,21 @@
+{ %opt=-Cg- }
+{ %cpu=i386 }
+
+{$asmmode intel}
+var
+  a: array[0..3] of byte;
+  l: longint;
+begin
+  a[0]:=1;
+  a[1]:=2;
+  a[2]:=3;
+  a[2]:=4;
+  asm
+    lea ecx,[a]
+    inc ecx
+    movzx eax, byte ptr[ecx-1+1]  // bug in this line (-2)
+    mov [l],eax
+  end;
+  if l<>2 then
+    halt(1);
+end.

tests/webtbs/tw16018.pp

@@ -0,0 +1,88 @@
+program testbug;
+{$APPTYPE CONSOLE}
+{$ifdef fpc}
+ {$mode delphi}
+ {$ifdef cpui386}
+  {$define cpu386}
+ {$endif}
+ {$ifdef cpu386}
+  {$asmmode intel}
+ {$endif}
+ {$ifdef FPC_LITTLE_ENDIAN}
+  {$define LITTLE_ENDIAN}
+ {$else}
+  {$ifdef FPC_BIG_ENDIAN}
+   {$define BIG_ENDIAN}
+  {$endif}
+ {$endif}
+ {$define caninline}
+{$else}
+ {$define LITTLE_ENDIAN}
+ {$ifndef cpu64}
+  {$define cpu32}
+ {$endif}
+{$endif}
+{$ifdef win32}
+ {$define windows}
+{$endif}
+{$ifdef win64}
+ {$define windows}
+{$endif}
+{$ifdef wince}
+ {$define windows}
+{$endif}
+{$rangechecks off}
+{$extendedsyntax on}
+{$hints off}
+{$j+}
+
+uses SysUtils,Math;
+
+type TBesenNumber=double;
+
+     PBesenDoubleBytes=^TBesenDoubleBytes;
+     TBesenDoubleBytes=array[0..sizeof(double)-1] of byte;
+
+const BesenDoubleZero:TBesenNumber=0.0;
+{$ifdef FPC_BIG_ENDIAN}
+      BesenDoubleNaN:TBesenDoubleBytes=($7f,$ff,$ff,$ff,$ff,$ff,$ff,$ff);
+      BesenDoubleInfPos:TBesenDoubleBytes=($7f,$f0,$00,$00,$00,$00,$00,$00);
+      BesenDoubleInfNeg:TBesenDoubleBytes=($ff,$f0,$00,$00,$00,$00,$00,$00);
+      BesenDoubleMax:TBesenDoubleBytes=($7f,$ef,$ff,$ff,$ff,$ff,$ff,$ff);
+      BesenDoubleMin:TBesenDoubleBytes=($00,$00,$00,$00,$00,$00,$00,$01);
+{$else}
+      BesenDoubleNaN:TBesenDoubleBytes=($ff,$ff,$ff,$ff,$ff,$ff,$ff,$7f);
+      BesenDoubleInfPos:TBesenDoubleBytes=($00,$00,$00,$00,$00,$00,$f0,$7f);
+      BesenDoubleInfNeg:TBesenDoubleBytes=($00,$00,$00,$00,$00,$00,$f0,$ff);
+      BesenDoubleMax:TBesenDoubleBytes=($ff,$ff,$ff,$ff,$ff,$ff,$ef,$7f);
+      BesenDoubleMin:TBesenDoubleBytes=($01,$00,$00,$00,$00,$00,$00,$00);
+{$endif}
+
+function BesenIsNaN(const AValue:TBesenNumber):boolean; {$ifdef caninline}inline;{$endif}
+begin
+ result:=(int64(pointer(@AValue)^)=int64(pointer(@BesenDoubleNaN)^)) or IsNaN(AValue);
+end;
+
+function BesenIsInfinite(const AValue:TBesenNumber):boolean; {$ifdef caninline}inline;{$endif}
+begin
+ result:=(int64(pointer(@AValue)^)=int64(pointer(@BesenDoubleInfPos)^)) or (int64(pointer(@AValue)^)=int64(pointer(@BesenDoubleInfNeg)^)) or IsInfinite(AValue);
+end;
+
+function BesenIsFinite(const AValue:TBesenNumber):boolean; {$ifdef caninline}inline;{$endif}
+begin
+ result:=not (BesenIsNaN(AValue) or BesenIsInfinite(AValue));
+end;
+
+procedure BesenTestProc;
+var x:double;
+begin
+ x:=8;
+ if BesenIsFinite(x) then begin // Here will raise the "Internal error 2006111510" at positon with BesenIsFinite (on every other positon in the real big source code of my EcmaScript 5th edition implementation, where BesenIsFinite is used)
+ end
+ else
+   halt(1);
+end;
+
+begin
+ BesenTestProc;
+end.

tests/webtbs/tw16163.pp

@@ -0,0 +1,36 @@
+{ %norun }
+
+program test;
+
+{$mode objfpc}
+
+type
+  TFColor = record
+    b, g, r : Byte;
+    // m : Byte; // uncomment it to avoid InternalError 200301231
+  end;
+
+  TFColorA = record
+    c : TFColor;
+    a : Byte;
+    // adding some field here, or chaning a type to Word or Interger
+    // also fixed the problem. 
+  end;
+
+function FColorToFColorA(C : TFColor) : TFColorA;
+begin
+  Result.c:=C;
+  Result.a:=255;
+end;
+
+var
+  t : TFColor;
+  a : TFColor;
+begin
+  FillChar(a, sizeof(a), $55);
+  t:=FColorToFColorA(a).c; // IE 200301231 why?
+  if (t.b<>$55) or
+     (t.r<>$55) or
+     (t.g<>$55) then
+    halt(1);
+end.

tests/webtbs/tw16377.pp

@@ -0,0 +1,14 @@
+program project1;
+const
+  S: string = '123';
+var
+  I: Integer;
+  P: PChar;
+begin
+  {$RANGECHECKS ON}
+  P := PChar(@S[2]);
+  I := -1;
+  if (P[-1]<>'1') or
+     (P[I]<>'1') then
+   halt(1);
+end.