* fixed web bug #4086: do not create a refcounted temp for

    interface temps created for complex callnodes

git-svn-id: trunk@2165 -

.gitattributes

@@ -6594,6 +6594,7 @@ tests/webtbs/tw4058.pp svneol=native#text/plain
 tests/webtbs/tw4068.pp svneol=native#text/plain
 tests/webtbs/tw4078.pp svneol=native#text/plain
 tests/webtbs/tw4080.pp svneol=native#text/plain
+tests/webtbs/tw4086.pp svneol=native#text/plain
 tests/webtbs/tw4089.pp svneol=native#text/plain
 tests/webtbs/tw4093.pp svneol=native#text/plain
 tests/webtbs/tw4098.pp svneol=native#text/plain

compiler/ncal.pas

@@ -233,6 +233,7 @@ type
         htype : ttype;
         ptemp : ttempcreatenode;
         usederef : boolean;
+        usevoidpointer : boolean;
         newinitstatement,
         newdonestatement : tstatementnode;
       begin
@@ -264,20 +265,33 @@ type
             usederef:=(p.resulttype.def.deftype in [arraydef,recorddef]) or
                       is_shortstring(p.resulttype.def) or
                       is_object(p.resulttype.def);
+            { avoid refcount increase }
+            usevoidpointer:=is_interface(p.resulttype.def);
+ 
             if usederef then
               htype.setdef(tpointerdef.create(p.resulttype))
             else
               htype:=p.resulttype;
-            ptemp:=ctempcreatenode.create(htype,htype.def.size,tt_persistent,true);
-            if usederef then
+
+            if usevoidpointer then
               begin
-                loadp:=caddrnode.create_internal(p);
-                refp:=cderefnode.create(ctemprefnode.create(ptemp));
+                ptemp:=ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,true);
+                loadp := ctypeconvnode.create_internal(p,voidpointertype);
+                refp:=ctypeconvnode.create_internal(ctemprefnode.create(ptemp),htype);
               end
             else
               begin
-                loadp:=p;
-                refp:=ctemprefnode.create(ptemp);
+                ptemp:=ctempcreatenode.create(htype,htype.def.size,tt_persistent,true);
+                if usederef then
+                  begin
+                    loadp:=caddrnode.create_internal(p);
+                    refp:=cderefnode.create(ctemprefnode.create(ptemp));
+                  end
+                else
+                  begin
+                    loadp:=p;
+                    refp:=ctemprefnode.create(ptemp)
+                  end
               end;
             addstatement(newinitstatement,ptemp);
             addstatement(newinitstatement,cassignmentnode.create(
@@ -295,7 +309,11 @@ type
               temp and converting it first from a persistent temp to
               normal temp }
             addstatement(newdonestatement,ctempdeletenode.create_normal_temp(ptemp));
-            addstatement(newdonestatement,ctemprefnode.create(ptemp));
+            if usevoidpointer then
+              addstatement(newdonestatement,ctypeconvnode.create_internal(
+                ctemprefnode.create(ptemp),htype))
+            else
+              addstatement(newdonestatement,ctemprefnode.create(ptemp));
             { call resulttypepass for new nodes }
             resulttypepass(p);
             resulttypepass(aktcallnode.methodpointerinit);

tests/webtbs/tw4086.pp

@@ -0,0 +1,78 @@
+{ Source provided for Free Pascal Bug Report 4086 }
+{ Submitted by "Martin Schreiber" on  2005-06-14 }
+{ e-mail:  }
+program project1;
+{$ifdef FPC}
+{$mode objfpc}{$H+}
+{$else}
+{$apptype console}
+{$endif}
+
+uses
+ Classes,SysUtils;
+
+type
+
+ itest = interface
+  procedure testproc;
+ end;
+ 
+ ttestclass1 = class(tobject,itest)
+  public
+   function queryinterface(const guid: tguid; out obj): hresult; stdcall;
+   function _addref: integer; stdcall;
+   function _release: integer; stdcall;
+   procedure testproc;
+ end;
+
+ ttestclass2 = class
+  public
+   intf: pointer;
+ end;
+ 
+{ ttestclass1 }
+
+function ttestclass1.queryinterface(const guid: tguid; out obj): hresult; stdcall;
+begin
+ result:= integer(e_nointerface);
+end;
+
+function ttestclass1._addref: integer; stdcall;
+begin
+ writeln('addref called');
+// result:= inherited _addref;
+ result:= -1;
+end;
+
+function ttestclass1._release: integer; stdcall;
+begin
+ writeln('release called');
+// result:= inherited _release;
+ result:= -1;
+end;
+
+procedure ttestclass1.testproc;
+begin
+ writeln('testproc called');
+end;
+
+var
+ po1: pointer;
+ test1: ttestclass1;
+ test2: ttestclass2;
+
+begin
+  test1:= ttestclass1.create;
+  test2:= ttestclass2.create;
+  writeln('*** global variable');
+  po1:= pointer(itest(test1));
+  itest(po1).testproc;
+  writeln('*** object field');
+  test2.intf:= pointer(itest(test1));
+  itest(test2.intf).testproc;
+
+  test1.free;
+  test2.free;
+end.
+
+