mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-19 09:51:50 +02:00
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 -
This commit is contained in:
paul
parent
c6ffbe9eda
commit
ba3744b38e
@ -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;
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user