compiler: translate_disp_call:

  - fix arguments description if the first argument is empty
  - fix restype field value (describes result value type in variant types)

git-svn-id: trunk@14790 -

compiler/ncal.pas

@@ -201,7 +201,7 @@ interface
        tcallparanodeclass = class of tcallparanode;
 
     function reverseparameters(p: tcallparanode): tcallparanode;
-    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
 
     var
       ccallnode : tcallnodeclass;
@@ -255,7 +255,7 @@ implementation
       end;
 
 
-    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
       const
         DISPATCH_METHOD = $1;
         DISPATCH_PROPERTYGET = $2;
@@ -277,6 +277,8 @@ implementation
         vardatadef,
         pvardatadef : tdef;
         dispatchbyref : boolean;
+        useresult: boolean;
+        restype: byte;
 
         calldesc : packed record
             calltype,argcount,namedargcount : byte;
@@ -306,6 +308,23 @@ implementation
           }
         end;
 
+      function getvardef(sourcedef: TDef): longint;
+        begin
+          if is_ansistring(sourcedef) then
+            result:=varStrArg
+          else
+          if is_interface(sourcedef) then
+            begin
+              { distinct IDispatch and IUnknown interfaces }
+              if tobjectdef(sourcedef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
+                result:=vardispatch
+              else
+                result:=varunknown;
+            end
+          else
+            result:=sourcedef.getvardef;
+        end;
+
       begin
         variantdispatch:=selfnode.resultdef.typ=variantdef;
         dispintfinvoke:=not(variantdispatch);
@@ -313,6 +332,7 @@ implementation
         result:=internalstatements(statements);
         fillchar(calldesc,sizeof(calldesc),0);
 
+        useresult := assigned(resultdef) and not is_void(resultdef);
         if useresult then
           begin
             { get temp for the result }
@@ -329,9 +349,12 @@ implementation
           begin
             typecheckpass(para.left);
 
-            { if it is not a parameter then break the loop }
+            { skip non parameters }
             if para.left.nodetype=nothingn then
-              break;
+            begin
+              para:=tcallparanode(para.nextpara);
+              continue;
+            end;
             inc(paracount);
 
             { insert some extra casts }
@@ -388,9 +411,14 @@ implementation
 
         if dispintfinvoke then
         begin
+          { dispid  }
           calldescnode.append(dispid,sizeof(dispid));
-          // add dymmy restype byte which is not used by fpc
-          calldescnode.append(dispid,sizeof(byte));
+          { restype }
+          if useresult then
+            restype:=getvardef(resultdef)
+          else
+            restype:=0;
+          calldescnode.append(restype,sizeof(restype));
         end;
         { build up parameters and description }
         para:=tcallparanode(parametersnode);
@@ -399,8 +427,12 @@ implementation
         names := '';
         while assigned(para) do
           begin
+            { skip non parameters }
             if para.left.nodetype=nothingn then
-              break;
+            begin
+              para:=tcallparanode(para.nextpara);
+              continue;
+            end;
 
             if assigned(para.parametername) then
               begin
@@ -440,20 +472,7 @@ implementation
                   ctypeconvnode.create_internal(para.left,assignmenttype)));
               end;
 
-            if is_ansistring(para.left.resultdef) then
-              calldesc.argtypes[currargpos]:=varStrArg
-            else
-            if is_interface(para.left.resultdef) then
-              begin
-                { distinct IDispatch and IUnknown interfaces }
-                if tobjectdef(para.left.resultdef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
-                  calldesc.argtypes[currargpos]:=vardispatch
-                else
-                  calldesc.argtypes[currargpos]:=varunknown;
-              end
-            else
-              calldesc.argtypes[currargpos]:=para.left.resultdef.getvardef;
-
+            calldesc.argtypes[currargpos]:=getvardef(para.left.resultdef);
             if dispatchbyref then
               calldesc.argtypes[currargpos]:=calldesc.argtypes[currargpos] or $80;
 
@@ -2865,13 +2884,13 @@ implementation
                  converted_result_data:=ctempcreatenode.create(procdefinition.returndef,sizeof(procdefinition.returndef),tt_persistent,true);
                  addstatement(statements,converted_result_data);
                  addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
-                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,true),
+                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,procdefinition.returndef),
                    procdefinition.returndef)));
                  addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
                  addstatement(statements,ctemprefnode.create(converted_result_data));
                end
              else
-               result:=translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,false);
+               result:=translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,voidtype);
 
              { don't free reused nodes }
              methodpointer:=nil;

compiler/pexpr.pas

@@ -1118,7 +1118,7 @@ implementation
                   { concat value parameter too }
                   p2:=ccallparanode.create(p2,nil);
                   { passing p3 here is only for information purposes }
-                  p1:=translate_disp_call(p1,p2,p2,'',propsym.dispid,false);
+                  p1:=translate_disp_call(p1,p2,p2,'',propsym.dispid,voidtype);
                 end
               else
                 begin
@@ -1175,7 +1175,7 @@ implementation
                   converted_result_data:=ctempcreatenode.create(propsym.propdef,sizeof(propsym.propdef),tt_persistent,true);
                   addstatement(statements,converted_result_data);
                   addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
-                    ctypeconvnode.create_internal(translate_disp_call(p1,nil,nil,'',propsym.dispid,true),
+                    ctypeconvnode.create_internal(translate_disp_call(p1,nil,nil,'',propsym.dispid,propsym.propdef),
                     propsym.propdef)));
                   addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
                   addstatement(statements,ctemprefnode.create(converted_result_data));
@@ -2069,15 +2069,15 @@ implementation
                                    { concat value parameter too }
                                    p2:=ccallparanode.create(p3,p2);
                                    { passing p3 here is only for information purposes }
-                                   p1:=translate_disp_call(p1,p2,p3,dispatchstring,0,false);
+                                   p1:=translate_disp_call(p1,p2,p3,dispatchstring,0,voidtype);
                                  end
                                else
-                                 begin
-                                   p1:=translate_disp_call(p1,p2,nil,dispatchstring,0,
-                                     { this is only an approximation
-                                       setting useresult if not necessary is only a waste of time, no more, no less (FK) }
-                                     afterassignment or in_args or (token<>_SEMICOLON));
-                                 end;
+                               { this is only an approximation
+                                 setting useresult if not necessary is only a waste of time, no more, no less (FK) }
+                               if afterassignment or in_args or (token<>_SEMICOLON) then
+                                 p1:=translate_disp_call(p1,p2,nil,dispatchstring,0,cvarianttype)
+                               else
+                                 p1:=translate_disp_call(p1,p2,nil,dispatchstring,0,voidtype);
                              end
                            else { Error }
                              Consume(_ID);

tests/test/tdispinterface2.pp

@@ -18,12 +18,13 @@ type
     property Disp402: wordbool dispid 402;
     procedure DispArg1(Arg: IUnknown);
     procedure DispArg2(Arg: IDispatch);
-    procedure DispArg3(var Arg: wordbool);
+    function DispArg3(var Arg: wordbool): widestring;
   end;
 
 var
   cur_dispid: longint;
   cur_argtype: byte;
+  cur_restype: byte;
 
 {$HINTS OFF}
   procedure DoDispCallByID(res: Pointer; const disp: IDispatch; desc: PDispDesc;
@@ -40,6 +41,8 @@ var
       halt(4);
     if desc^.calldesc.argtypes[0] <> cur_argtype then
       halt(cur_argtype);
+    if desc^.restype <> cur_restype then
+      halt($FF);
   end;
 
 
@@ -61,10 +64,12 @@ begin
   II.Disp402 := True;
   // check arguments
   DispCallByIDProc := @DoDispCallByIDArg;
+  cur_restype := varempty;
   cur_argtype := varunknown;
   II.DispArg1(nil);
   cur_argtype := vardispatch;
   II.DispArg2(nil);
+  cur_restype := varolestr;
   cur_argtype := varboolean or $80;
   B := False;
   II.DispArg3(B);