diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 3a00b47447..71d83ef610 100644 --- a/compiler/ncal.pas +++ b/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; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index b0651a1d22..7c091f6d4f 100644 --- a/compiler/pexpr.pas +++ b/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); diff --git a/tests/test/tdispinterface2.pp b/tests/test/tdispinterface2.pp index bacc4fcff1..5bb30d63f3 100644 --- a/tests/test/tdispinterface2.pp +++ b/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);