Merged revisions 6960,7008-7011,7013-7014,7017,7019 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
r6960 | pierre | 2007-03-23 07:52:29 +0100 (Fri, 23 Mar 2007) | 1 line

 * fix threadvar stabstr handling in internal assembler
........
r7008 | peter | 2007-03-27 19:43:28 +0200 (Tue, 27 Mar 2007) | 2 lines

  * fix symbol substraction in stabs

........
r7009 | peter | 2007-03-27 20:33:04 +0200 (Tue, 27 Mar 2007) | 2 lines

  * simplify integer operations with constnat 0 or 1

........
r7010 | peter | 2007-03-27 20:37:30 +0200 (Tue, 27 Mar 2007) | 2 lines

  * also try to convert non-set nodes to a set in set operations

........
r7011 | peter | 2007-03-27 20:38:03 +0200 (Tue, 27 Mar 2007) | 2 lines

  * test for set=nonset operation

........
r7013 | pierre | 2007-03-28 01:54:30 +0200 (Wed, 28 Mar 2007) | 1 line

* fix register parameters for GDB
........
r7014 | jonas | 2007-03-28 15:17:38 +0200 (Wed, 28 Mar 2007) | 2 lines

  * "too much registers" -> "too many registers"

........
r7017 | jonas | 2007-03-28 20:05:40 +0200 (Wed, 28 Mar 2007) | 2 lines

  * savefpuexceptions directive renamed to safefpuexceptions

........
r7019 | peter | 2007-03-29 08:08:58 +0200 (Thu, 29 Mar 2007) | 2 lines

  * support relative symbol calculation for uleb128/sleb128

........

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

.gitattributes

@@ -7163,6 +7163,7 @@ tests/webtbf/tw8150g.pp svneol=native#text/plain
 tests/webtbf/tw8264a.pp svneol=native#text/plain
 tests/webtbf/tw8398.pp svneol=native#text/plain
 tests/webtbf/tw8528.pp svneol=native#text/plain
+tests/webtbf/tw8583.pp svneol=native#text/plain
 tests/webtbf/uw0744.pp svneol=native#text/plain
 tests/webtbf/uw0840a.pp svneol=native#text/plain
 tests/webtbf/uw0840b.pp svneol=native#text/plain
@@ -8041,6 +8042,7 @@ tests/webtbs/tw8391.pp svneol=native#text/plain
 tests/webtbs/tw8434.pp svneol=native#text/plain
 tests/webtbs/tw8462.pp svneol=native#text/plain
 tests/webtbs/tw8513.pp svneol=native#text/plain
+tests/webtbs/tw8573.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/assemble.pas

@@ -680,12 +680,16 @@ Implementation
           sym       : tobjsymbol;
           exprvalue : longint;
           gotmin,
+          have_first_symbol,
+          have_second_symbol,
           dosub     : boolean;
         begin
           result:=false;
           value:=0;
           relocsym:=nil;
           gotmin:=false;
+          have_first_symbol:=false;
+          have_second_symbol:=false;
           repeat
             dosub:=false;
             exprvalue:=0;
@@ -728,16 +732,35 @@ Implementation
                   move(pstart^,hs[1],len);
                   hs[0]:=chr(len);
                   sym:=objdata.symbolref(hs);
+                  have_first_symbol:=true;
                   { Second symbol? }
                   if assigned(relocsym) then
                     begin
+                      if have_second_symbol then
+                        internalerror(2007032201);
+                      have_second_symbol:=true;
+                      if not have_first_symbol then
+                        internalerror(2007032202);
+                      { second symbol should substracted to first }
+                      if not dosub then
+                        internalerror(2007032203);
                       if (relocsym.objsection<>sym.objsection) then
                         internalerror(2005091810);
+                      exprvalue:=relocsym.address-sym.address;
                       relocsym:=nil;
+                      dosub:=false;
                     end
                   else
-                    relocsym:=sym;
-                  exprvalue:=sym.address;
+                    begin
+                      relocsym:=sym;
+                      if assigned(sym.objsection) then
+                        begin
+                          { first symbol should be + }
+                          if not have_first_symbol and dosub then
+                            internalerror(2007032204);
+                          have_first_symbol:=true;
+                        end;
+                    end;
                 end;
               '+' :
                 begin
@@ -760,8 +783,6 @@ Implementation
           result:=true;
         end;
 
-      const
-        N_Function = $24; { function or const }
       var
         stabstrlen,
         ofs,
@@ -780,6 +801,8 @@ Implementation
         pcurr:=nil;
         pstr:=nil;
         pendquote:=nil;
+        relocsym:=nil;
+        ofs:=0;
 
         { Parse string part }
         if (p[0]='"') then
@@ -820,15 +843,7 @@ Implementation
             if not consumenumber(pcurr,nline) then
               internalerror(200509186);
             if consumecomma(pcurr) then
-              consumeoffset(pcurr,relocsym,ofs)
-            else
-              begin
-                ofs:=0;
-                relocsym:=nil;
-              end;
-            if assigned(relocsym) and
-               (relocsym.bind<>AB_LOCAL) then
-              ofs:=0;
+              consumeoffset(pcurr,relocsym,ofs);
 
             { Generate stab entry }
             if assigned(pstr) and (pstr[0]<>#0) then
@@ -1137,19 +1152,32 @@ Implementation
                          ObjData.writebytes(Tai_const(hp).value,tai_const(hp).size);
                      end;
                    aitconst_rva_symbol :
-                     { PE32+? }
-                     if target_info.system=system_x86_64_win64 then
-                       ObjData.writereloc(Tai_const(hp).value,sizeof(longint),Objdata.SymbolRef(tai_const(hp).sym),RELOC_RVA)
-                     else
-                       ObjData.writereloc(Tai_const(hp).value,sizeof(aint),Objdata.SymbolRef(tai_const(hp).sym),RELOC_RVA);
-                   aitconst_uleb128bit :
                      begin
-                       leblen:=EncodeUleb128(Tai_const(hp).value,lebbuf);
-                       ObjData.writebytes(lebbuf,leblen);
+                       { PE32+? }
+                       if target_info.system=system_x86_64_win64 then
+                         ObjData.writereloc(Tai_const(hp).value,sizeof(longint),Objdata.SymbolRef(tai_const(hp).sym),RELOC_RVA)
+                       else
+                         ObjData.writereloc(Tai_const(hp).value,sizeof(aint),Objdata.SymbolRef(tai_const(hp).sym),RELOC_RVA);
                      end;
+                   aitconst_uleb128bit,
                    aitconst_sleb128bit :
                      begin
-                       leblen:=EncodeSleb128(Tai_const(hp).value,lebbuf);
+                       if assigned(tai_const(hp).sym) then
+                         begin
+                           if not assigned(tai_const(hp).endsym) then
+                             internalerror(200703291);
+                           objsym:=Objdata.SymbolRef(tai_const(hp).sym);
+                           objsymend:=Objdata.SymbolRef(tai_const(hp).endsym);
+                           if objsymend.objsection<>objsym.objsection then
+                             internalerror(200703292);
+                           v:=objsymend.address-objsym.address+Tai_const(hp).value;
+                         end
+                       else
+                         v:=Tai_const(hp).value;
+                       if tai_const(hp).consttype=aitconst_uleb128bit then
+                         leblen:=EncodeUleb128(v,lebbuf)
+                       else
+                         leblen:=EncodeSleb128(v,lebbuf);
                        ObjData.writebytes(lebbuf,leblen);
                      end;
                    else

compiler/dbgstabs.pas

@@ -737,7 +737,7 @@ implementation
           recorddef :
             result:=recorddef_stabstr(trecorddef(def));
           variantdef :
-            result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
+            result:=def_stabstr_evaluate(def,'${numberstring};',[]);
           pointerdef :
             result:=strpnew('*'+def_stab_number(tpointerdef(def).pointeddef));
           classrefdef :
@@ -745,7 +745,7 @@ implementation
           setdef :
             result:=def_stabstr_evaluate(def,'@s$1;S$2',[tostr(def.size*8),def_stab_number(tsetdef(def).elementdef)]);
           formaldef :
-            result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
+            result:=def_stabstr_evaluate(def,'${numberstring};',[]);
           arraydef :
             if not is_packed_array(def) then
               result:=def_stabstr_evaluate(def,'ar$1;$2;$3;$4',[def_stab_number(tarraydef(def).rangedef),
@@ -765,7 +765,7 @@ implementation
           objectdef :
             result:=objectdef_stabstr(tobjectdef(def));
           undefineddef :
-            result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
+            result:=def_stabstr_evaluate(def,'${numberstring};',[]);
         end;
         if result=nil then
           internalerror(200512203);
@@ -1259,9 +1259,9 @@ implementation
                 if paramanager.push_addr_param(sym.varspez,sym.vardef,tprocdef(sym.owner.defowner).proccalloption) and
                    not(vo_has_local_copy in sym.varoptions) and
                    not is_open_string(sym.vardef) then
-                  st := 'v'+st { should be 'i' but 'i' doesn't work }
+                  c:='v' { should be 'i' but 'i' doesn't work }
                 else
-                  st := 'p'+st;
+                  c:='p';
                 case sym.localloc.loc of
                   LOC_REGISTER,
                   LOC_CREGISTER,
@@ -1270,16 +1270,24 @@ implementation
                   LOC_FPUREGISTER,
                   LOC_CFPUREGISTER :
                     begin
+                      if c='p' then
+                        c:='R'
+                      else
+                        c:='a';
+                      st:=c+st;
                       regidx:=findreg_by_number(sym.localloc.register);
                       { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
                       { this is the register order for GDB}
                       if regidx<>0 then
-                        result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(longint(regstabs_table[regidx]))]);
+                        result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_RSYM},0,${line},$2',[st,tostr(longint(regstabs_table[regidx]))]);
                     end;
                   LOC_REFERENCE :
-                    { offset to ebp => will not work if the framepointer is esp
-                      so some optimizing will make things harder to debug }
-                    result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)])
+                    begin
+                      st:=c+st;
+                      { offset to ebp => will not work if the framepointer is esp
+                        so some optimizing will make things harder to debug }
+                      result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)])
+                    end;
                   else
                     internalerror(2003091814);
                 end;

compiler/msg/errore.msg

@@ -1021,7 +1021,7 @@ parser_e_goto_outside_proc=03201_E_Goto statements aren't allowed between differ
 % ...
 %
 % \end{verbatim}
-parser_f_too_complex_proc=03202_F_Procedure too complex, it requires too much registers
+parser_f_too_complex_proc=03202_F_Procedure too complex, it requires too many registers
 % Your procedure body is too long for the compiler. You should split the
 % procedure into multiple smaller procedures.
 parser_e_illegal_expression=03203_E_Illegal expression

compiler/msgtxt.inc

@@ -319,7 +319,7 @@ const msgtxt : array[0..000179,1..240] of char=(
   '03200_E_32 Bit-Integer or pointer variable expected'#000+
   '03201_E_Goto statements aren'#039't',' allowed between different procedu'+
   'res'#000+
-  '03202_F_Procedure too complex, it requires too much registers'#000+
+  '03202_F_Procedure too complex, it requires too many registers'#000+
   '03203_E_Illegal expression'#000+
   '03204_E_Invalid integer expression'#000+
   '03205_E_Illegal qualifier'#000+

compiler/nadd.pas

@@ -428,6 +428,52 @@ implementation
              exit;
           end;
 
+        { Add,Sub,Mul with constant 0 or 1?  }
+        if is_constintnode(right) then
+          begin
+            if tordconstnode(right).value = 0 then
+              begin
+                case nodetype of
+                  addn,subn:
+                   result := left.getcopy;
+                  muln:
+                   result:=cordconstnode.create(0,left.resultdef,true);
+                end;
+              end
+            else if tordconstnode(right).value = 1 then
+              begin
+                case nodetype of
+                  muln:
+                   result := left.getcopy;
+                end;
+              end;
+            if assigned(result) then
+              exit;
+          end;
+        if is_constintnode(left) then
+          begin
+            if tordconstnode(left).value = 0 then
+              begin
+                case nodetype of
+                  addn:
+                   result := right.getcopy;
+                  subn:
+                   result := cunaryminusnode.create(right.getcopy);
+                  muln:
+                   result:=cordconstnode.create(0,right.resultdef,true);
+                end;
+              end
+            else if tordconstnode(left).value = 1 then
+              begin
+                case nodetype of
+                  muln:
+                   result := right.getcopy;
+                end;
+              end;
+            if assigned(result) then
+              exit;
+          end;
+
       { both real constants ? }
         if (lt=realconstn) and (rt=realconstn) then
           begin
@@ -1102,10 +1148,10 @@ implementation
              begin
                if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
                 CGMessage(type_e_set_operation_unknown);
-               { if the right side is also a setdef then the settype must
-                 be the same as the left setdef }
-               if (rd.typ=setdef) and
-                  not(equal_defs(ld,rd)) then
+               { make operands the same setdef, if right is a normalset or varset then
+                 force the left side to be the same. General fallback also for non-set nodes
+                 is to convert right to a set }
+               if not(equal_defs(ld,rd)) then
                 begin
                   if is_varset(rd) or is_normalset(rd) then
                     inserttypeconv(left,right.resultdef)

compiler/scandir.pas

@@ -948,7 +948,7 @@ implementation
         do_localswitch(cs_mmx_saturation);
       end;
 
-    procedure dir_savefpuexceptions;
+    procedure dir_safefpuexceptions;
       begin
         do_localswitch(cs_fpu_fwait);
       end;
@@ -1304,7 +1304,7 @@ implementation
         AddDirective('REFERENCEINFO',directive_all, @dir_referenceinfo);
         AddDirective('RESOURCE',directive_all, @dir_resource);
         AddDirective('SATURATION',directive_all, @dir_saturation);
-        AddDirective('SAVEFPUEXCEPTIONS',directive_all, @dir_savefpuexceptions);
+        AddDirective('SAFEFPUEXCEPTIONS',directive_all, @dir_safefpuexceptions);
         AddDirective('SETPEFLAGS', directive_all, @dir_setpeflags);
         AddDirective('SCREENNAME',directive_all, @dir_screenname);
         AddDirective('SMARTLINK',directive_all, @dir_smartlink);

tests/webtbf/tw8583.pp

@@ -0,0 +1,23 @@
+{ %fail }
+
+program testbug;
+
+{$mode objfpc}{$H+}
+
+type
+  TState = (a, b, c, d);
+  TStates = set of TState;
+
+var
+  s : TStates;
+begin
+  s := [a];
+  if s = a then
+    writeln('Should give a compile time error');
+
+  if s = b then halt(1);
+
+  if s = [a] then
+    writeln('OK');
+end.
+

tests/webtbs/tw8573.pp

@@ -0,0 +1,23 @@
+program overflowbug;
+
+{$mode objfpc}{$Q+}
+
+const
+  zero=0;
+  one=1;
+
+var
+  x,y,z: cardinal;
+
+begin
+  x := 0;
+  y := one + x;
+
+  // the next line sets the carry flag, so a overflow error will be generated
+  if x>y then;
+  // here the overflow error will be generated.
+  // the addition of zero is optimized away, but the check for the carry flag
+  // is not removed, so it is using the result of the compile in line 17
+  z := zero + y;
+end.
+