Merged revisions 7245,7251,7257,7260,7334,7336 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r7245 | jonas | 2007-05-02 19:31:02 +0200 (Wed, 02 May 2007) | 2 lines

  * don't use inc/dec on a property with a write method

........
r7251 | jonas | 2007-05-03 17:05:44 +0200 (Thu, 03 May 2007) | 3 lines

  + support for refcounted records returned by functions in 2 registers
    (mantis #8685)

........
r7257 | jonas | 2007-05-04 12:53:25 +0200 (Fri, 04 May 2007) | 2 lines

  - removed caretn and related code

........
r7260 | jonas | 2007-05-04 16:21:39 +0200 (Fri, 04 May 2007) | 4 lines

  * do not require exactly the same range type for indexed properties
    referring to an array field, but instead simply convert the index
    to the array range type (mantis #8810)

........
r7334 | jonas | 2007-05-14 21:24:33 +0200 (Mon, 14 May 2007) | 3 lines

  * handle mod/div between a cardinal/qword and a smaller unsigned variable
    (byte, word, postive subrange) as an unsigned operation (mantis #8870)

........
r7336 | jonas | 2007-05-14 22:37:42 +0200 (Mon, 14 May 2007) | 4 lines

  * don't change a sequence of shifts and sub/adds into a lea() in case
    the flags are read afterwards (broke shldl/sub/sbb sequence generated
    for 64 bit "*2", which appears in bitpacked size calculation)

........

git-svn-id: branches/fixes_2_2@7345 -

.gitattributes

@@ -6792,6 +6792,7 @@ tests/test/tprec10.pp svneol=native#text/plain
 tests/test/tprec11.pp svneol=native#text/plain
 tests/test/tprec12.pp svneol=native#text/plain
 tests/test/tprec13.pp svneol=native#text/plain
+tests/test/tprec14.pp svneol=native#text/plain
 tests/test/tprec2.pp svneol=native#text/plain
 tests/test/tprec3.pp svneol=native#text/plain
 tests/test/tprec4.pp svneol=native#text/plain
@@ -8087,9 +8088,12 @@ tests/webtbs/tw8573.pp svneol=native#text/plain
 tests/webtbs/tw8615.pp svneol=native#text/plain
 tests/webtbs/tw8660.pp svneol=native#text/plain
 tests/webtbs/tw8664.pp svneol=native#text/plain
+tests/webtbs/tw8685.pp svneol=native#text/plain
 tests/webtbs/tw8757.pp svneol=native#text/plain
+tests/webtbs/tw8810.pp svneol=native#text/plain
 tests/webtbs/tw8838.pp svneol=native#text/plain
 tests/webtbs/tw8861.pp svneol=native#text/plain
+tests/webtbs/tw8870.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -80,7 +80,7 @@ interface
       end;
 
     const
-      tok2nodes=25;
+      tok2nodes=24;
       tok2node:array[1..tok2nodes] of ttok2noderec=(
         (tok:_PLUS    ;nod:addn;op_overloading_supported:true),      { binary overloading supported }
         (tok:_MINUS   ;nod:subn;op_overloading_supported:true),      { binary and unary overloading supported }
@@ -105,7 +105,6 @@ interface
         (tok:_OP_SHR    ;nod:shrn;op_overloading_supported:true),    { binary overloading supported }
         (tok:_OP_XOR    ;nod:xorn;op_overloading_supported:true),    { binary overloading supported }
         (tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported }
-        (tok:_CARET   ;nod:caretn;op_overloading_supported:false),    { binary overloading NOT supported }
         (tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false)   { binary overloading NOT supported  overload = instead }
       );
     const

compiler/i386/popt386.pas

@@ -1472,7 +1472,9 @@ begin
                                  (((taicpu(hp1).opcode = A_INC) or
                                    (taicpu(hp1).opcode = A_DEC)) and
                                   (taicpu(hp1).oper[0]^.typ = Top_Reg) and
-                                  (taicpu(hp1).oper[0]^.reg = taicpu(p).oper[1]^.reg))) Do
+                                  (taicpu(hp1).oper[0]^.reg = taicpu(p).oper[1]^.reg))) and
+                                (not GetNextInstruction(hp1,hp2) or
+                                 not instrReadsFlags(hp2)) Do
                             begin
                               TmpBool1 := False;
                               if (taicpu(hp1).oper[0]^.typ = Top_Const) then

compiler/nadd.pas

@@ -486,8 +486,7 @@ implementation
                   t:=crealconstnode.create(lvd-rvd,resultrealdef);
                 muln :
                   t:=crealconstnode.create(lvd*rvd,resultrealdef);
-                starstarn,
-                caretn :
+                starstarn:
                   begin
                     if lvd<0 then
                      begin

compiler/ncgcal.pas

@@ -527,24 +527,40 @@ implementation
               if procdefinition.funcretloc[callerside].loc<>LOC_REGISTER then
                 internalerror(200409261);
 
-              { the FUNCTION_RESULT_REG is already allocated }
-              if getsupreg(procdefinition.funcretloc[callerside].register)<first_int_imreg then
-                cg.ungetcpuregister(current_asmdata.CurrAsmList,procdefinition.funcretloc[callerside].register);
-              if not assigned(funcretnode) then
+              retloc:=procdefinition.funcretloc[callerside];
+{$ifndef cpu64bit}
+              if cgsize in [OS_64,OS_S64] then
                 begin
+                  { the function result registers are already allocated }
+                  if getsupreg(retloc.register64.reglo)<first_int_imreg then
+                    cg.ungetcpuregister(current_asmdata.CurrAsmList,retloc.register64.reglo);
+                  retloc.register64.reglo:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
+                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,procdefinition.funcretloc[callerside].register64.reglo,retloc.register64.reglo);
+                  if getsupreg(retloc.register64.reghi)<first_int_imreg then
+                    cg.ungetcpuregister(current_asmdata.CurrAsmList,retloc.register64.reghi);
+                  retloc.register64.reghi:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
+                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,procdefinition.funcretloc[callerside].register64.reghi,retloc.register64.reghi);
+                end
+              else
+{$endif cpu64bit}
+                begin
+                  { the FUNCTION_RESULT_REG is already allocated }
+                  if getsupreg(retloc.register)<first_int_imreg then
+                    cg.ungetcpuregister(current_asmdata.CurrAsmList,retloc.register);
+
                   { reg_ref could generate two instrcutions and allocate a register so we've to
                     save the result first before releasing it }
-                  hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,procdefinition.funcretloc[callerside].register,hregister);
+                  retloc.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,procdefinition.funcretloc[callerside].register,retloc.register);
+                end;
 
-                  location_reset(location,LOC_REFERENCE,OS_ADDR);
+              if not assigned(funcretnode) then
+                begin
+                  location_reset(location,LOC_REFERENCE,cgsize);
                   location.reference:=refcountedtemp;
-                  cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,hregister,location.reference);
                 end
               else
                 begin
-                  hregister := cg.getaddressregister(current_asmdata.CurrAsmList);
-                  cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,procdefinition.funcretloc[callerside].register,hregister);
                   { in case of a regular funcretnode with ret_in_param, the }
                   { original funcretnode isn't touched -> make sure it's    }
                   { the same here (not sure if it's necessary)              }
@@ -553,8 +569,13 @@ implementation
                   location := tempnode.location;
                   tempnode.free;
                   cg.g_decrrefcount(current_asmdata.CurrAsmList,resultdef,location.reference);
-                  cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,hregister,location.reference);
                end;
+{$ifndef cpu64bit}
+              if cgsize in [OS_64,OS_S64] then
+                cg64.a_load64_reg_ref(current_asmdata.CurrAsmList,retloc.register64,location.reference)
+              else
+{$endif}
+                cg.a_load_reg_ref(current_asmdata.CurrAsmList,cgsize,cgsize,retloc.register,location.reference);
             end
         else
           { normal (ordinal,float,pointer) result value }

compiler/nmat.pas

@@ -209,16 +209,23 @@ implementation
          { Do the same for qwords and positive constants as well, otherwise things like   }
          { "qword mod 10" are evaluated with int64 as result, which is wrong if the       }
          { "qword" was > high(int64) (JM)                                                 }
+         { Additionally, do the same for cardinal/qwords and other positive types, but    }
+         { always in a way that a smaller type is converted to a bigger type              }
+         { (webtbs/tw8870)                                                                }
          if (rd.ordtype in [u32bit,u64bit]) and
-            is_constintnode(left) and
-            (tordconstnode(left).value >= 0) then
+            ((is_constintnode(left) and
+              (tordconstnode(left).value >= 0)) or
+             (not is_signed(ld) and
+              (rd.size >= ld.size))) then
            begin
              inserttypeconv(left,right.resultdef);
              ld:=torddef(left.resultdef);
            end;
          if (ld.ordtype in [u32bit,u64bit]) and
-            is_constintnode(right) and
-            (tordconstnode(right).value >= 0) then
+            ((is_constintnode(right) and
+              (tordconstnode(right).value >= 0)) or
+             (not is_signed(rd) and
+              (ld.size >= rd.size))) then
           begin
             inserttypeconv(right,left.resultdef);
             rd:=torddef(right.resultdef);

compiler/node.pas

@@ -96,7 +96,6 @@ interface
           onn,              {For an on statement in exception code}
           isn,              {Represents the is operator}
           asn,              {Represents the as typecast}
-          caretn,           {Represents the ^ operator}
           starstarn,        {Represents the ** operator exponentiation }
           arrayconstructorn, {Construction node for [...] parsing}
           arrayconstructorrangen, {Range element to allow sets in array construction tree}
@@ -178,7 +177,6 @@ interface
           'onn',
           'isn',
           'asn',
-          'caretn',
           'starstarn',
           'arrayconstructn',
           'arrayconstructrangen',

compiler/pass_2.pas

@@ -122,7 +122,6 @@ implementation
              'on',    {onn}
              'is',    {isn}
              'as',    {asn}
-             'error-caret',       {caretn}
              'add-starstar',  {starstarn}
              'arrayconstruc', {arrayconstructn}
              'noth-arrcnstr',     {arrayconstructrangen}

compiler/pdecvar.pas

@@ -176,10 +176,9 @@ implementation
                              begin
                                if (p.nodetype=ordconstn) then
                                  begin
-                                   if compare_defs(p.resultdef,tarraydef(def).rangedef,nothingn)>=te_equal then
-                                     idx:=tordconstnode(p).value
-                                   else
-                                     IncompatibleTypes(p.resultdef,tarraydef(def).rangedef);
+                                   { type/range checking }
+                                   inserttypeconv(p,tarraydef(def).rangedef);
+                                   idx:=tordconstnode(p).value
                                  end
                                else
                                 Message(type_e_ordinal_expr_expected)

compiler/pexpr.pas

@@ -2803,8 +2803,6 @@ implementation
                  p1:=caddnode.create(xorn,p1,p2);
                _ASSIGNMENT :
                  p1:=cassignmentnode.create(p1,p2);
-               _CARET :
-                 p1:=caddnode.create(caretn,p1,p2);
                _UNEQUAL :
                  p1:=caddnode.create(unequaln,p1,p2);
              end;

compiler/psystem.pas

@@ -467,7 +467,6 @@ implementation
         nodeclass[onn]:=connode;
         nodeclass[isn]:=cisnode;
         nodeclass[asn]:=casnode;
-        nodeclass[caretn]:=caddnode;
         nodeclass[starstarn]:=caddnode;
         nodeclass[arrayconstructorn]:=carrayconstructornode;
         nodeclass[arrayconstructorrangen]:=carrayconstructorrangenode;

compiler/symdef.pas

@@ -3836,10 +3836,13 @@ implementation
              if not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then
                begin
                   { add the data of the anchestor class }
-                  inc(tObjectSymtable(symtable).datasize,tObjectSymtable(c.symtable).datasize);
+                  tObjectSymtable(symtable).datasize:=
+                    tObjectSymtable(symtable).datasize+
+                    tObjectSymtable(c.symtable).datasize;
                   if (oo_has_vmt in objectoptions) and
                      (oo_has_vmt in c.objectoptions) then
-                    dec(tObjectSymtable(symtable).datasize,sizeof(aint));
+                    tObjectSymtable(symtable).datasize:=
+                      tObjectSymtable(symtable).datasize-sizeof(aint);
                   { if parent has a vmt field then
                     the offset is the same for the child PM }
                   if (oo_has_vmt in c.objectoptions) or is_class(self) then
@@ -3868,7 +3871,8 @@ implementation
 {$endif cpurequiresproperalignment}
 
              vmt_offset:=tObjectSymtable(symtable).datasize;
-             inc(tObjectSymtable(symtable).datasize,sizeof(aint));
+             tObjectSymtable(symtable).datasize:=
+               tObjectSymtable(symtable).datasize+sizeof(aint);
              include(objectoptions,oo_has_vmt);
           end;
      end;

tests/test/tprec14.pp

@@ -0,0 +1,9 @@
+type
+  tr = bitpacked record
+    l: longint;
+  end;
+
+begin
+  if bitsizeof(tr) <> 32 then
+    halt(1);
+end.

tests/webtbs/tw8685.pp

@@ -0,0 +1,95 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+program test;
+
+uses
+  SysUtils;
+  
+type
+  vecteurF = array of extended;
+  matriceF = array of vecteurF;
+  matriceE = record
+    err     :integer;
+    x       :matriceF;
+  end;
+
+var
+  A,B,C :matriceE;  
+
+function copyM(A:matriceE):matriceE;
+var
+  i,j,nl,nc :integer;
+  C   :matriceE;
+begin
+  nl:=succ(high(A.x));nc:=succ(high(A.x[0]));
+  setlength(C.x,nl,nc);
+  for i:=0 to pred(nl) do
+    begin
+      for j:=0 to pred(nc) do C.x[i,j]:=A.x[i,j];
+    end;
+  C.err:=A.err;
+  Result:=C;
+end;
+
+procedure copyM2(A:matriceE;var C:matriceE);
+var
+  i,j,nl,nc :integer;
+begin
+  nl:=succ(high(A.x));nc:=succ(high(A.x[0]));
+  setlength(C.x,nl,nc);
+  for i:=0 to pred(nl) do
+    begin
+      for j:=0 to pred(nc) do C.x[i,j]:=A.x[i,j];
+    end;
+  C.err:=A.err;
+end;
+
+procedure writeM(A:matriceE;str:string);
+var
+  i,j :integer;
+begin
+  for i:=0 to high(A.x) do
+    begin
+      for j:=0 to high(A.x[i]) do write(format(str,[A.x[i,j]]));
+      writeln;
+    end;
+end;
+
+procedure checkM(const A,B:matriceE);
+var
+  i,j :integer;
+begin
+  if (high(A.x) <> high(B.x)) then
+    halt(1);
+  for i:=0 to high(A.x) do
+    begin
+      if (high(A.x[i]) <> high(B.x[i])) then
+        halt(2);
+      for j:=0 to high(A.x[i]) do
+        if (A.x[i,j] <> B.x[i,j]) then
+          halt(3);
+    end;
+end;
+
+
+begin
+  setlength(A.x,3,3);
+  A.err:=0;
+  A.x[0,0]:=0.5;A.x[0,1]:=0.2;A.x[0,2]:=0.8;
+  A.x[1,0]:=0.2;A.x[1,1]:=0.2;A.x[1,2]:=0.9;
+  A.x[2,0]:=0.8;A.x[2,1]:=0.9;A.x[2,2]:=3.1;
+  writeln('matrix A,  number of lines : ',succ(high(A.x)));
+  writeM(A,'%6.3f');
+  writeln;
+  B:=copyM(A);
+  writeln('matrix B,  number of lines : ',succ(high(B.x)));
+  checkM(A,B);
+  writeln;
+  copyM2(A,C);
+  writeln('matrix C,  number of lines : ',succ(high(C.x)));
+  checkM(A,C);
+  writeln;
+  writeln('end');
+end.
+

tests/webtbs/tw8810.pp

@@ -0,0 +1,38 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$r+}
+
+CONST MaxBitmaps=129;
+
+TYPE  tbitmap = longint;
+      TBack =CLASS
+                 constructor create;
+                 PRIVATE
+                   FBitmaps :ARRAY [0..MaxBitmaps] OF TBitmap;
+
+                 PUBLIC
+                   PROPERTY Bitmap :TBitmap READ FBitmaps[0];
+                   PROPERTY LightBitmap :TBitmap READ FBitmaps[1];
+                   PROPERTY ShadowBitmap:TBitmap READ FBitmaps[2];
+            end;
+
+constructor tback.create;
+var
+  i: longint;
+begin
+  for i := low(fbitmaps) to high(fbitmaps) do
+    fbitmaps[i] := i;
+end;
+
+var
+  b: tback;
+begin
+  b:=tback.create;
+  if (b.Bitmap <> 0) or
+     (b.LightBitmap <> 1) or
+     (b.ShadowBitmap <> 2) then
+    halt(1);
+  b.free;
+end.

tests/webtbs/tw8870.pp

@@ -0,0 +1,14 @@
+{$q+}
+{$r+}
+
+type
+   range = 0..32;
+var
+   a,b : Cardinal;
+   one : range;
+begin
+   a := $80000000;
+   one := 1;
+   b := a div one;
+   WriteLn(b);
+end.