Merged revisions 2843-2844,2854-2855,2952,2957-2959,2968,2973-2976,3002-3003 via svnmerge from

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

........
r2843 | jonas | 2006-03-10 21:59:45 +0100 (Fri, 10 Mar 2006) | 2 lines

+ added

........
r2844 | jonas | 2006-03-10 22:18:21 +0100 (Fri, 10 Mar 2006) | 2 lines

  * fixed tests/test/cg/tformfnc.pp

........
r2854 | jonas | 2006-03-11 14:54:20 +0100 (Sat, 11 Mar 2006) | 2 lines

  * fixed a_param_ref for large parameters

........
r2855 | jonas | 2006-03-11 15:13:47 +0100 (Sat, 11 Mar 2006) | 3 lines

  * don't explicitly us NR_F0 in concatcopy but ask a register from
    the register allocator (since NR_F0 can also be used by the ra)

........
r2952 | jonas | 2006-03-18 12:05:04 +0100 (Sat, 18 Mar 2006) | 3 lines

  * fixed web bug #4913 (don't allow indexing of strings/variants/pointers
    with enums/chars/booleans)

........
r2957 | jonas | 2006-03-18 23:02:37 +0100 (Sat, 18 Mar 2006) | 3 lines

  * don't give range check hints/warnings for conversions of
    realconstnodes to types with less precision than the default (bug 4898)

........
r2958 | jonas | 2006-03-18 23:25:41 +0100 (Sat, 18 Mar 2006) | 2 lines

  * support goto/label by default in tp/delphi/macpas modes (bug 4893)

........
r2959 | jonas | 2006-03-18 23:53:27 +0100 (Sat, 18 Mar 2006) | 2 lines

  * count references to symbols accessed via properties (fixes bug #4826)

........
r2968 | jonas | 2006-03-19 17:44:18 +0100 (Sun, 19 Mar 2006) | 3 lines

  - removed markheap since it doesn't work anymore (since a long
    time already in fact)

........
r2973 | jonas | 2006-03-19 21:01:11 +0100 (Sun, 19 Mar 2006) | 4 lines

  * support subscripting record function results on ABI's that return
    (some) records in registers (+ internalerror if unsupported
    record location). Fixes "make all" in top dir on darwin/x86.

........
r2974 | jonas | 2006-03-19 21:08:21 +0100 (Sun, 19 Mar 2006) | 2 lines

  + nostackframe directive to fix on darwin/x86

........
r2975 | jonas | 2006-03-19 21:26:29 +0100 (Sun, 19 Mar 2006) | 2 lines

  * fixed test

........
r2976 | jonas | 2006-03-19 21:29:15 +0100 (Sun, 19 Mar 2006) | 2 lines

  * fixed loading of -0.0

........
r3002 | jonas | 2006-03-21 16:25:16 +0100 (Tue, 21 Mar 2006) | 3 lines

  * don't change "mov const,ref; mov ref,reg" into "mov const,reg; mov reg,ref"
    if ref depends on reg

........
r3003 | jonas | 2006-03-21 16:44:55 +0100 (Tue, 21 Mar 2006) | 4 lines

  * if we find a constant already loaded in a register and we use that
    register, mark the register as read by the current instruction
    (fixes compilation of tcalfun8 with optimizations)

........

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

.gitattributes

@@ -5241,6 +5241,7 @@ tests/test/cg/tdivz1.pp svneol=native#text/plain
 tests/test/cg/tdivz2.pp svneol=native#text/plain
 tests/test/cg/texit.pp svneol=native#text/plain
 tests/test/cg/tfor.pp svneol=native#text/plain
+tests/test/cg/tformfnc.pp -text
 tests/test/cg/tfuncret.pp svneol=native#text/plain
 tests/test/cg/tin.pp svneol=native#text/plain
 tests/test/cg/tincexc.pp svneol=native#text/plain
@@ -5709,6 +5710,9 @@ tests/webtbf/tw4777.pp svneol=native#text/plain
 tests/webtbf/tw4778a.pp svneol=native#text/plain
 tests/webtbf/tw4781a.pp svneol=native#text/plain
 tests/webtbf/tw4781b.pp svneol=native#text/plain
+tests/webtbf/tw4893d.pp svneol=native#text/plain
+tests/webtbf/tw4893e.pp svneol=native#text/plain
+tests/webtbf/tw4913.pp -text
 tests/webtbf/uw0744.pp svneol=native#text/plain
 tests/webtbf/uw0840a.pp svneol=native#text/plain
 tests/webtbf/uw0840b.pp svneol=native#text/plain
@@ -6445,6 +6449,11 @@ tests/webtbs/tw4781a.pp svneol=native#text/plain
 tests/webtbs/tw4781b.pp svneol=native#text/plain
 tests/webtbs/tw4789.pp svneol=native#text/plain
 tests/webtbs/tw4809.pp svneol=native#text/plain
+tests/webtbs/tw4826.pp svneol=native#text/plain
+tests/webtbs/tw4893a.pp svneol=native#text/plain
+tests/webtbs/tw4893b.pp svneol=native#text/plain
+tests/webtbs/tw4893c.pp svneol=native#text/plain
+tests/webtbs/tw4898.pp -text
 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/cgobj.pas

@@ -778,7 +778,7 @@ implementation
                  ref.offset:=cgpara.location^.reference.offset;
                  { use concatcopy, because it can also be a float which fails when
                    load_ref_ref is used }
-                 g_concatcopy(list,r,ref,tcgsize2size[size]);
+                 g_concatcopy(list,r,ref,cgpara.intsize);
               end
             else
               internalerror(2002071004);

compiler/htypechk.pas

@@ -2222,7 +2222,8 @@ implementation
           not is_boolean(destdef) and
           assigned(source.resulttype.def) and
           (source.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
-          not is_boolean(source.resulttype.def) then
+          not is_boolean(source.resulttype.def) and
+          not is_constrealnode(source) then
          begin
            if (destdef.size < source.resulttype.def.size) then
              begin

compiler/i386/csopt386.pas

@@ -1981,6 +1981,10 @@ begin
                                findRegWithConst(hp1,taicpu(p).opsize,taicpu(p).oper[0]^.val,memreg) then
                               begin
                                 taicpu(p).loadreg(0,memreg);
+                                { mark the used register as read }
+                                incstate(ptaiprop(p.optinfo)^.
+                                   regs[getsupreg(memreg)].rstate,20);
+                                updateState(getsupreg(memreg),p);
                                 allocRegBetween(asml,memreg,
                                   ptaiprop(hp1.optinfo)^.regs[getsupreg(memreg)].startMod,p,
                                   ptaiprop(ptaiprop(hp1.optinfo)^.regs[getsupreg(memreg)].startMod.optinfo)^.usedregs);

compiler/i386/n386con.pas

@@ -73,6 +73,8 @@ implementation
              else if (value_real=0.0) then
                begin
                   emit_none(A_FLDZ,S_NO);
+                  if (get_real_sign(value_real) < 0) then
+                    emit_none(A_FCHS,S_NO);
                   location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
                   location.register:=NR_ST;
                   tcgx86(cg).inc_fpu_stack;

compiler/i386/popt386.pas

@@ -1164,7 +1164,8 @@ begin
                                  (taicpu(hp1).oper[0]^.typ = top_ref) and
                                  (taicpu(hp1).oper[1]^.typ = top_reg) and
                                  (taicpu(p).opsize = taicpu(hp1).opsize) and
-                                 RefsEqual(taicpu(hp1).oper[0]^.ref^,taicpu(p).oper[1]^.ref^) then
+                                 RefsEqual(taicpu(hp1).oper[0]^.ref^,taicpu(p).oper[1]^.ref^) and
+                                 not(reginref(getsupreg(taicpu(hp1).oper[1]^.reg),taicpu(hp1).oper[0]^.ref^)) then
                                 begin
                                   allocregbetween(asml,taicpu(hp1).oper[1]^.reg,p,hp1,usedregs);
                                   taicpu(hp1).LoadReg(0,taicpu(hp1).oper[1]^.reg);

compiler/ncgcal.pas

@@ -399,7 +399,7 @@ implementation
                begin
                   { allow passing of a constant to a const formaldef }
                   if (parasym.varspez=vs_const) and
-                     (left.location.loc=LOC_CONSTANT) then
+                     (left.location.loc in [LOC_CONSTANT,LOC_REGISTER]) then
                     location_force_mem(exprasmlist,left.location);
                   push_addr_para;
                end

compiler/ncgmem.pas

@@ -302,7 +302,22 @@ implementation
               end;
            end
          else
-           location_copy(location,left.location);
+           begin
+             location_copy(location,left.location);
+             { some abi's require that functions return (some) records in }
+             { registers                                                  }
+             case location.loc of
+               LOC_REGISTER:
+                 location_force_mem(exprasmlist,location);
+               LOC_REFERENCE,
+               LOC_CREFERENCE:
+                 ;
+{              record regvars are not supported yet 
+               LOC_CREGISTER:                        }
+               else
+                 internalerror(2006031901);
+             end;
+           end;
 
          inc(location.reference.offset,vs.fieldoffset);
          { also update the size of the location }

compiler/nmem.pas

@@ -668,9 +668,10 @@ implementation
 
          { maybe type conversion for the index value, but
            do not convert enums,booleans,char }
-         if (right.resulttype.def.deftype<>enumdef) and
-            not(is_char(right.resulttype.def) or is_widechar(right.resulttype.def)) and
-            not(is_boolean(right.resulttype.def)) then
+         if ((right.resulttype.def.deftype<>enumdef) and
+             not(is_char(right.resulttype.def) or is_widechar(right.resulttype.def)) and
+             not(is_boolean(right.resulttype.def))) or
+            (left.resulttype.def.deftype <> arraydef) then
            begin
              inserttypeconv(right,sinttype);
            end;

compiler/pexpr.pas

@@ -164,6 +164,7 @@ implementation
            case plist^.sltype of
              sl_load :
                begin
+                 inc(plist^.sym.refs);
                  if not assigned(st) then
                    st:=plist^.sym.owner;
                  { p1 can already contain the loadnode of
@@ -184,7 +185,10 @@ implementation
                   p1:=cloadnode.create(plist^.sym,st);
                end;
              sl_subscript :
-               p1:=csubscriptnode.create(plist^.sym,p1);
+               begin
+                 inc(plist^.sym.refs);
+                 p1:=csubscriptnode.create(plist^.sym,p1);
+               end;
              sl_typeconv :
                p1:=ctypeconvnode.create_explicit(p1,plist^.tt);
              sl_absolutetype :
@@ -1044,6 +1048,7 @@ implementation
                          if membercall then
                            include(callflags,cnf_member_call);
                          p1:=ccallnode.create(paras,tprocsym(tpropertysym(sym).writeaccess.firstsym^.sym),st,p1,callflags);
+                         inc(tpropertysym(sym).writeaccess.firstsym^.sym.refs);
                          paras:=nil;
                          consume(_ASSIGNMENT);
                          { read the expression }

compiler/powerpc/cgcpu.pas

@@ -1838,6 +1838,7 @@ const
         lab: tasmlabel;
         count, count2: aint;
         size: tcgsize;
+        copyreg: tregister;
 
       begin
 {$ifdef extdebug}
@@ -1856,10 +1857,9 @@ const
               end
             else
               begin
-                a_reg_alloc(list,NR_F0);
-                a_loadfpu_ref_reg(list,OS_F64,source,NR_F0);
-                a_loadfpu_reg_ref(list,OS_F64,NR_F0,dest);
-                a_reg_dealloc(list,NR_F0);
+                copyreg := getfpuregister(list,OS_F64);
+                a_loadfpu_ref_reg(list,OS_F64,source,copyreg);
+                a_loadfpu_reg_ref(list,OS_F64,copyreg,dest);
               end;
             exit;
           end;
@@ -1909,16 +1909,15 @@ const
             list.concat(taicpu.op_reg_reg_const(A_SUBI,dst.base,dst.base,8));
             countreg := rg[R_INTREGISTER].getregister(list,R_SUBWHOLE);
             a_load_const_reg(list,OS_32,count,countreg);
-            { explicitely allocate R_0 since it can be used safely here }
-            { (for holding date that's being copied)                    }
-            a_reg_alloc(list,NR_F0);
+            copyreg := getfpuregister(list,OS_F64);
+            a_reg_sync(list,copyreg);
             objectlibrary.getlabel(lab);
             a_label(list, lab);
             list.concat(taicpu.op_reg_reg_const(A_SUBIC_,countreg,countreg,1));
-            list.concat(taicpu.op_reg_ref(A_LFDU,NR_F0,src));
-            list.concat(taicpu.op_reg_ref(A_STFDU,NR_F0,dst));
+            list.concat(taicpu.op_reg_ref(A_LFDU,copyreg,src));
+            list.concat(taicpu.op_reg_ref(A_STFDU,copyreg,dst));
             a_jmp(list,A_BC,C_NE,0,lab);
-            a_reg_dealloc(list,NR_F0);
+            a_reg_sync(list,copyreg);
             len := len mod 8;
           end;
 
@@ -1926,15 +1925,14 @@ const
         if count > 0 then
           { unrolled loop }
           begin
-            a_reg_alloc(list,NR_F0);
+            copyreg := getfpuregister(list,OS_F64);
             for count2 := 1 to count do
               begin
-                a_loadfpu_ref_reg(list,OS_F64,src,NR_F0);
-                a_loadfpu_reg_ref(list,OS_F64,NR_F0,dst);
+                a_loadfpu_ref_reg(list,OS_F64,src,copyreg);
+                a_loadfpu_reg_ref(list,OS_F64,copyreg,dst);
                 inc(src.offset,8);
                 inc(dst.offset,8);
               end;
-            a_reg_dealloc(list,NR_F0);
             len := len mod 8;
           end;
 

compiler/scanner.pas

@@ -307,6 +307,15 @@ implementation
               if changeinit then
                exclude(initlocalswitches,cs_ansistrings);
             end;
+
+           { support goto/label by default in delphi/tp7/mac modes }
+           if ([m_delphi,m_tp7,m_mac] * aktmodeswitches <> []) then
+             begin
+               include(aktmoduleswitches,cs_support_goto);
+               if changeinit then
+                 include(initmoduleswitches,cs_support_goto);
+             end;
+
            { Default enum packing for delphi/tp7 }
            if (m_tp7 in aktmodeswitches) or
               (m_delphi in aktmodeswitches) then

rtl/inc/heaptrc.pp

@@ -18,7 +18,6 @@ interface
 {$goto on}
 
 Procedure DumpHeap;
-Procedure MarkHeap;
 
 { define EXTRA to add more
   tests :
@@ -952,19 +951,6 @@ begin
 end;
 
 
-procedure markheap;
-var
-  pp : pheap_mem_info;
-begin
-  pp:=heap_mem_root;
-  while pp<>nil do
-   begin
-     pp^.sig:=$AAAAAAAA;
-     pp:=pp^.previous;
-   end;
-end;
-
-
 {*****************************************************************************
                                 AllocMem
 *****************************************************************************}

tests/test/cg/tformfnc.pp

@@ -0,0 +1,13 @@
+function f: longint;
+begin
+  f := 1;
+end;
+
+procedure t(const c);
+begin
+end;
+
+begin
+  t(f);
+end.
+

tests/webtbf/tw4893d.pp

@@ -0,0 +1,10 @@
+{ %fail }
+
+{$mode fpc}
+
+label a;
+
+begin
+  goto a;
+ a:
+end.

tests/webtbf/tw4893e.pp

@@ -0,0 +1,10 @@
+{ %fail }
+
+{$mode objfpc}
+
+label a;
+
+begin
+  goto a;
+ a:
+end.

tests/webtbf/tw4913.pp

@@ -0,0 +1,22 @@
+{ %fail }
+
+{ Source provided for Free Pascal Bug Report 4913 }
+{ Submitted by "Vinzent Hoefler" on  2006-03-17 }
+{ e-mail: [email protected] }
+const
+   Some_String : String = '0123456789';
+
+type
+   Some_Enum = (Zero, One, Two, Three);
+
+var
+   i : Some_Enum;
+
+begin
+   WriteLn (Some_String[2]);   // Should fail if "Some_String = '...'";
+   WriteLn (Some_String[Two]); // Should fail with type error.
+
+   i := Three;
+   WriteLn (Some_String[i]);
+end.
+

tests/webtbs/tw1229.pp

@@ -5,7 +5,7 @@
 
 {$asmmode intel }
 
-procedure SomePostScript; assembler;
+procedure SomePostScript; assembler;nostackframe;
   asm
     db '/pop2 { pop pop } def',0;
   end;

tests/webtbs/tw4534.pp

@@ -12,8 +12,10 @@ begin
     begin
       if (p1^ xor p2^) = $80 then
         halt(0);
-      halt(1);
+      inc(p1); 
+      inc(p2);
     end;
+  halt(1);
 end;
 
 var x,y:extended;

tests/webtbs/tw4826.pp

@@ -0,0 +1,31 @@
+{ %OPT=-vn -Sen }
+
+{ Source provided for Free Pascal Bug Report 4826 }
+{ Submitted by "Ivo Steinmann" on  2006-02-20 }
+{ e-mail: [email protected] }
+program bug;
+
+{$mode delphi}
+
+type
+  TTest = class
+  private
+    FFoobar: Integer;
+  protected
+    property Foobar: Integer read FFoobar write FFoobar;
+  public
+    constructor Create;
+  end;
+
+constructor TTest.Create;
+begin
+  inherited Create;
+  Foobar := 0;
+end;
+
+var
+  Test: TTest;
+begin
+  Test := TTest.Create;
+  Test.Free;
+end.

tests/webtbs/tw4893a.pp

@@ -0,0 +1,8 @@
+{$mode delphi}
+
+label a;
+
+begin
+  goto a;
+ a:
+end.

tests/webtbs/tw4893b.pp

@@ -0,0 +1,8 @@
+{$mode tp}
+
+label a;
+
+begin
+  goto a;
+ a:
+end.

tests/webtbs/tw4893c.pp

@@ -0,0 +1,8 @@
+{$mode macpas}
+
+label a;
+
+begin
+  goto a;
+ a:
+end.

tests/webtbs/tw4898.pp

@@ -0,0 +1,12 @@
+{ %OPT=-Sewh -vwh}
+
+{ Source provided for Free Pascal Bug Report 4898 }
+{ Submitted by "Naj Kejah" on  2006-03-13 }
+{ e-mail: [email protected] }
+program aFP211p; 
+var R : real;
+begin
+  R:=0.0;
+  writeln(r);
+end.
+