Bläddra i källkod

* explicitly check whether the methodpointer isn't the same as the result
before optimising function result assignment, because at this point the
hidden self parameter is not yet inserted (mantis #12597)
* changed ttypeconvnode.actualtargetnode to use the same logic as what
is used to determine whether something can be assigned to the result
of a type conversion (so the above check also works if the methodpointer
contains a typecast to a different object type)

git-svn-id: trunk@12038 -

Jonas Maebe 16 år sedan
förälder
incheckning
1e178d324f
4 ändrade filer med 61 tillägg och 3 borttagningar
  1. 1 0
      .gitattributes
  2. 9 0
      compiler/ncal.pas
  3. 9 3
      compiler/ncnv.pas
  4. 42 0
      tests/webtbs/tw12597.pp

+ 1 - 0
.gitattributes

@@ -8614,6 +8614,7 @@ tests/webtbs/tw12508a.pp svneol=native#text/plain
 tests/webtbs/tw1251b.pp svneol=native#text/plain
 tests/webtbs/tw1251b.pp svneol=native#text/plain
 tests/webtbs/tw1255.pp svneol=native#text/plain
 tests/webtbs/tw1255.pp svneol=native#text/plain
 tests/webtbs/tw12575.pp svneol=native#text/plain
 tests/webtbs/tw12575.pp svneol=native#text/plain
+tests/webtbs/tw12597.pp svneol=native#text/plain
 tests/webtbs/tw1269.pp svneol=native#text/plain
 tests/webtbs/tw1269.pp svneol=native#text/plain
 tests/webtbs/tw1275.pp svneol=native#text/plain
 tests/webtbs/tw1275.pp svneol=native#text/plain
 tests/webtbs/tw1279.pp svneol=native#text/plain
 tests/webtbs/tw1279.pp svneol=native#text/plain

+ 9 - 0
compiler/ncal.pas

@@ -1697,6 +1697,15 @@ implementation
             exit;
             exit;
           end;
           end;
 
 
+        { if the result is the same as the self parameter (in case of objects),
+          we can't optimise. We have to check this explicitly becaise
+          hidden parameters such as self have not yet been inserted at this
+          point
+        }
+        if assigned(methodpointer) and
+           realassignmenttarget.isequal(methodpointer.actualtargetnode) then
+          exit;
+
         { when we substitute a function result inside an inlined function,
         { when we substitute a function result inside an inlined function,
           we may take the address of this function result. Therefore the
           we may take the address of this function result. Therefore the
           substituted function result may not be in a register, as we cannot
           substituted function result may not be in a register, as we cannot

+ 9 - 3
compiler/ncnv.pas

@@ -54,6 +54,7 @@ interface
           function simplify:tnode; override;
           function simplify:tnode; override;
           procedure mark_write;override;
           procedure mark_write;override;
           function docompare(p: tnode) : boolean; override;
           function docompare(p: tnode) : boolean; override;
+          function retains_value_location:boolean;
           function assign_allowed:boolean;
           function assign_allowed:boolean;
           procedure second_call_helper(c : tconverttype);
           procedure second_call_helper(c : tconverttype);
        private
        private
@@ -1595,8 +1596,7 @@ implementation
       begin
       begin
         result:=self;
         result:=self;
         while (result.nodetype=typeconvn) and
         while (result.nodetype=typeconvn) and
-              (nf_absolute in result.flags) and
-              (resultdef.size=left.resultdef.size) do
+              ttypeconvnode(result).retains_value_location do
           result:=ttypeconvnode(result).left;
           result:=ttypeconvnode(result).left;
       end;
       end;
 
 
@@ -2931,7 +2931,7 @@ implementation
       end;
       end;
 
 
 
 
-    function ttypeconvnode.assign_allowed:boolean;
+    function ttypeconvnode.retains_value_location:boolean;
       begin
       begin
         result:=(convtype=tc_equal) or
         result:=(convtype=tc_equal) or
                 { typecasting from void is always allowed }
                 { typecasting from void is always allowed }
@@ -2951,6 +2951,12 @@ implementation
                 ((convtype in [tc_int_2_bool,tc_bool_2_int,tc_bool_2_bool]) and
                 ((convtype in [tc_int_2_bool,tc_bool_2_int,tc_bool_2_bool]) and
                  (nf_explicit in flags) and
                  (nf_explicit in flags) and
                  (resultdef.size=left.resultdef.size));
                  (resultdef.size=left.resultdef.size));
+      end;
+
+
+    function ttypeconvnode.assign_allowed:boolean;
+      begin
+        result:=retains_value_location;
 
 
         { When using only a part of the value it can't be in a register since
         { When using only a part of the value it can't be in a register since
           that will load the value in a new register first }
           that will load the value in a new register first }

+ 42 - 0
tests/webtbs/tw12597.pp

@@ -0,0 +1,42 @@
+program Project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils;
+
+type
+
+  { TFoo }
+
+  TFoo = Object
+    a : integer;
+    function b : TFoo;
+  end;
+
+  tfoo2 = object(tfoo)
+  end;
+
+{ TFoo }
+
+function TFoo.b: TFoo;
+begin
+  result.a := 5;
+  writeln(IntToStr(self.a));
+  if (self.a<>2) then
+    halt(1);
+end;
+
+procedure t;
+var x : TFoo;
+begin
+  x.a := 2;
+  x := tfoo2(x).b;
+  writeln(IntToStr(x.a));
+  if (x.a<>5) then
+    halt(2);
+end;
+
+begin
+  t;
+end.