浏览代码

* might_have_sideeffects in gen_c_style_operator as proposed by runewalsh, resolves #39206

git-svn-id: trunk@49608 -
florian 4 年之前
父节点
当前提交
0d6a1d24bd
共有 3 个文件被更改,包括 57 次插入8 次删除
  1. 1 0
      .gitattributes
  2. 1 8
      compiler/pexpr.pas
  3. 55 0
      tests/webtbs/tw39206.pp

+ 1 - 0
.gitattributes

@@ -18892,6 +18892,7 @@ tests/webtbs/tw3900.pp svneol=native#text/plain
 tests/webtbs/tw39030.pp svneol=native#text/pascal
 tests/webtbs/tw39030.pp svneol=native#text/pascal
 tests/webtbs/tw3913.pp svneol=native#text/plain
 tests/webtbs/tw3913.pp svneol=native#text/plain
 tests/webtbs/tw39178.pp svneol=native#text/pascal
 tests/webtbs/tw39178.pp svneol=native#text/pascal
+tests/webtbs/tw39206.pp svneol=native#text/pascal
 tests/webtbs/tw3930.pp svneol=native#text/plain
 tests/webtbs/tw3930.pp svneol=native#text/plain
 tests/webtbs/tw3931a.pp svneol=native#text/plain
 tests/webtbs/tw3931a.pp svneol=native#text/plain
 tests/webtbs/tw3939.pp svneol=native#text/plain
 tests/webtbs/tw3939.pp svneol=native#text/plain

+ 1 - 8
compiler/pexpr.pas

@@ -225,7 +225,6 @@ implementation
 
 
      function gen_c_style_operator(ntyp:tnodetype;p1,p2:tnode) : tnode;
      function gen_c_style_operator(ntyp:tnodetype;p1,p2:tnode) : tnode;
        var
        var
-         hp    : tnode;
          hdef  : tdef;
          hdef  : tdef;
          temp  : ttempcreatenode;
          temp  : ttempcreatenode;
          newstatement : tstatementnode;
          newstatement : tstatementnode;
@@ -240,13 +239,7 @@ implementation
                result can be wrong }
                result can be wrong }
            end;
            end;
 
 
-         hp:=p1;
-         while assigned(hp) and
-               (hp.nodetype in [derefn,subscriptn,vecn,typeconvn]) do
-           hp:=tunarynode(hp).left;
-         if not assigned(hp) then
-           internalerror(200410121);
-         if (hp.nodetype=calln) then
+         if might_have_sideeffects(p1,[mhs_exceptions]) then
            begin
            begin
              typecheckpass(p1);
              typecheckpass(p1);
              result:=internalstatements(newstatement);
              result:=internalstatements(newstatement);

+ 55 - 0
tests/webtbs/tw39206.pp

@@ -0,0 +1,55 @@
+{$mode objfpc} {$h+} {$coperators on}
+
+var
+    a: array[0 .. 3] of uint32;
+    whatToIncrementNext: SizeUint;
+
+    procedure Reset;
+    begin
+        whatToIncrementNext := 0;
+        FillChar(pUint32(a)^, length(a) * sizeof(a[0]), 0);
+        writeln('Before: ', a[0], ' ', a[1], ' ', a[2], ' ', a[3], LineEnding);
+    end;
+
+    function NextIndex: SizeUint;
+    begin
+        result := whatToIncrementNext;
+        writeln('Incrementing ', whatToIncrementNext, 'th element');
+        whatToIncrementNext := (whatToIncrementNext + 1) mod length(a);
+    end;
+
+    function NextPtr: pUint32;
+    begin
+        result := @a[whatToIncrementNext];
+        writeln('Incrementing ', whatToIncrementNext, 'th element');
+        whatToIncrementNext := (whatToIncrementNext + 1) mod length(a);
+    end;
+
+var
+    incr: uint32;
+
+begin
+    Reset;
+    for incr in specialize TArray<uint32>.Create(1, 2, 4, 8) do
+    begin
+        writeln('a[NextIndex()] += ', incr, '...');
+        a[NextIndex] += incr;
+        writeln(a[0], ' ', a[1], ' ', a[2], ' ', a[3], LineEnding);
+    end;
+
+    if (a[0]<>1) or (a[1]<>2) or (a[2]<>4) or (a[3]<>8) then
+      halt(1);
+
+    Reset;
+    for incr in specialize TArray<uint32>.Create(1, 2, 4, 8) do
+    begin
+        writeln('NextPtr()^ += ', incr, '...');
+        NextPtr^ += incr;
+        writeln(a[0], ' ', a[1], ' ', a[2], ' ', a[3], LineEnding);
+    end;
+
+    if (a[0]<>1) or (a[1]<>2) or (a[2]<>4) or (a[3]<>8) then
+      halt(1);
+
+    writeln('ok');
+end.