paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 14:09:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* some variant dispatching stuff fixed

Browse Source 
git-svn-id: trunk@5254 -
This commit is contained in:
florian 2006-11-05 21:07:59 +00:00
parent a993ddbe5c
commit 5cbc15b339
2 changed files with 48 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/ncal.pas
View File

@ -279,7 +279,10 @@ implementation
addstatement(statements,result_data); addstatement(statements,result_data);
{ build parameters } { build parameters }
{ first, count and check parameters } { first, count and check parameters }
// p2:=reverseparameters(tcallparanode(p2));
para:=tcallparanode(p2); para:=tcallparanode(p2);
paracount:=0; paracount:=0;
namedparacount:=0; namedparacount:=0;
@ -340,7 +343,7 @@ implementation
internalerror(200611041); internalerror(200611041);
end; end;
dispatchbyref:=para.value.resultdef.typ in [stringdef]; dispatchbyref:=para.value.resultdef.typ in [{stringdef}];
{ assign the argument/parameter to the temporary location } { assign the argument/parameter to the temporary location }
if para.value.nodetype<>nothingn then if para.value.nodetype<>nothingn then
@ -379,7 +382,7 @@ implementation
{ actual call } { actual call }
vardatadef:=trecorddef(search_system_type('TVARDATA').typedef); vardatadef:=trecorddef(search_system_type('TVARDATA').typedef);
pvardatadef:=trecorddef(search_system_type('PVARDATA').typedef); pvardatadef:=ppointerdef(search_system_type('PVARDATA').typedef);
addstatement(statements,ccallnode.createintern('fpc_dispinvoke_variant', addstatement(statements,ccallnode.createintern('fpc_dispinvoke_variant',
{ parameters are passed always reverted, i.e. the last comes first } { parameters are passed always reverted, i.e. the last comes first }

58
packages/extra/winunits/comobj.pp
View File

@ -224,7 +224,7 @@ implementation
raise EOleSysError.Create('',Status,0); raise EOleSysError.Create('',Status,0);
end; end;
{$define DEBUG_COMDISPATCH} { $define DEBUG_COMDISPATCH}
procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc; procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
DispIDs: PDispIDList; Params: Pointer; Result: PVariant); DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
@ -247,11 +247,14 @@ implementation
fillchar(dispparams,sizeof(dispparams),0); fillchar(dispparams,sizeof(dispparams),0);
try try
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
writeln('Got ',CallDesc^.ArgCount,' arguments'); writeln('DispatchInvoke: Got ',CallDesc^.ArgCount,' arguments NamedArgs = ',CallDesc^.NamedArgCount);
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
{ copy and prepare arguments } { copy and prepare arguments }
for i:=0 to CallDesc^.ArgCount-1 do for i:=0 to CallDesc^.ArgCount-1 do
begin begin
{$ifdef DEBUG_COMDISPATCH}
writeln('DispatchInvoke: Params = ',hexstr(PtrInt(Params),SizeOf(Pointer)*2));
{$endif DEBUG_COMDISPATCH}
{ get plain type } { get plain type }
CurrType:=CallDesc^.ArgTypes[i] and $3f; CurrType:=CallDesc^.ArgTypes[i] and $3f;
{ by reference? } { by reference? }
@ -276,7 +279,14 @@ implementation
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
else else
begin begin
writeln('Got ref argument with type ',CurrType); {$ifdef DEBUG_COMDISPATCH}
write('DispatchInvoke: Got ref argument with type = ',CurrType);
case CurrType of
varOleStr:
write(' Value = ',pwidestring(PPointer(Params)^)^);
end;
writeln;
{$endif DEBUG_COMDISPATCH}
Arguments[i].VType:=CurrType or VarByRef; Arguments[i].VType:=CurrType or VarByRef;
Arguments[i].VPointer:=PPointer(Params)^; Arguments[i].VPointer:=PPointer(Params)^;
inc(PPointer(Params)); inc(PPointer(Params));
@ -318,7 +328,14 @@ implementation
else else
begin begin
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
writeln('Got argument with type ',CurrType); write('DispatchInvoke: Got argument with type ',CurrType);
case CurrType of
varOleStr:
write(' Value = ',pwidestring(Params)^);
else
write(' Value = ',hexstr(PtrInt(PPointer(Params)^),SizeOf(Pointer)*2));
end;
writeln;
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
Arguments[i].VType:=CurrType; Arguments[i].VType:=CurrType;
Arguments[i].VPointer:=PPointer(Params)^; Arguments[i].VPointer:=PPointer(Params)^;
@ -331,17 +348,20 @@ implementation
with DispParams do with DispParams do
begin begin
rgvarg:=@Arguments; rgvarg:=@Arguments;
rgdispidNamedArgs:=@DispIDs[1];
cArgs:=CallDesc^.ArgCount;
cNamedArgs:=CallDesc^.NamedArgCount; cNamedArgs:=CallDesc^.NamedArgCount;
if cNamedArgs=0 then
rgdispidNamedArgs:=nil
else
rgdispidNamedArgs:=@DispIDs^[1];
cArgs:=CallDesc^.ArgCount;
end; end;
InvokeKind:=CallDesc^.CallType; InvokeKind:=CallDesc^.CallType;
MethodID:=DispIDs^[0]; MethodID:=DispIDs^[0];
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
writeln('MethodID: ',MethodID); writeln('DispatchInvoke: MethodID: ',MethodID,' InvokeKind: ',InvokeKind);
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
{ do the call and check the result } { do the call and check the result }
invokeresult:=Dispatch.Invoke(MethodID,GUID_NULL,0,InvokeKind,DispParams,result,@exceptioninfo,nil);; invokeresult:=Dispatch.Invoke(MethodID,GUID_NULL,0,InvokeKind,DispParams,result,@exceptioninfo,nil);
if invokeresult<>0 then if invokeresult<>0 then
DispatchInvokeError(invokeresult,exceptioninfo); DispatchInvokeError(invokeresult,exceptioninfo);
@ -362,6 +382,7 @@ implementation
res : HRESULT; res : HRESULT;
NamesArray : ^PWideChar; NamesArray : ^PWideChar;
NamesData : PWideChar; NamesData : PWideChar;
OrigNames : PChar;
NameCount, NameCount,
NameLen, NameLen,
NewNameLen, NewNameLen,
@ -372,8 +393,9 @@ implementation
getmem(NamesArray,Count*sizeof(PWideChar)); getmem(NamesArray,Count*sizeof(PWideChar));
CurrentNameDataSize:=256; CurrentNameDataSize:=256;
CurrentNameDataUsed:=0; CurrentNameDataUsed:=0;
getmem(NamesData,CurrentNameDataSize*2); getmem(NamesData,CurrentNameDataSize);
NameCount:=0; NameCount:=0;
OrigNames:=Names;
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
writeln('SearchIDs: Searching ',Count,' IDs'); writeln('SearchIDs: Searching ',Count,' IDs');
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
@ -384,24 +406,29 @@ implementation
writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen); writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen);
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1; NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1;
if CurrentNameDataUsed+NewNameLen*2>CurrentNameDataSize then if (CurrentNameDataUsed+NewNameLen)*2>CurrentNameDataSize then
begin begin
inc(CurrentNameDataSize,256); inc(CurrentNameDataSize,256);
reallocmem(NamesData,CurrentNameDataSize*2); reallocmem(NamesData,CurrentNameDataSize);
end; end;
NamesArray[i-1]:=@NamesData[CurrentNameDataUsed]; NamesArray[i-1]:=@NamesData[CurrentNameDataUsed];
MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen); MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen);
NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0; NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0;
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
{ we should write a widestring here writeln('SearchIDs: Translated name: ',NamesData[CurrentNameDataUsed]); } writeln('SearchIDs: Translated name: ',WideString(PWideChar(@NamesData[CurrentNameDataUsed])));
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
inc(CurrentNameDataUsed,NewNameLen); inc(CurrentNameDataUsed,NewNameLen);
inc(Names,NameLen+1); inc(Names,NameLen+1);
inc(NameCount); inc(NameCount);
end; end;
res:=DispatchInterface.GetIDsOfNames(GUID_NULL,NamesArray,NameCount,GetThreadLocale,IDs); res:=DispatchInterface.GetIDsOfNames(GUID_NULL,NamesArray,NameCount,GetThreadLocale,IDs);
{$ifdef DEBUG_COMDISPATCH}
writeln('SearchIDs: GetIDsOfNames result = ',hexstr(res,SizeOf(HRESULT)*2));
for i:=0 to Count-1 do
writeln('SearchIDs: ID[',i,'] = ',ids^[i]);
{$endif DEBUG_COMDISPATCH}
if res=DISP_E_UNKNOWNNAME then if res=DISP_E_UNKNOWNNAME then
raise EOleError.createresfmt(@snomethod,[names]) raise EOleError.createresfmt(@snomethod,[OrigNames])
else else
OleCheck(res); OleCheck(res);
freemem(NamesArray); freemem(NamesArray);
@ -413,11 +440,12 @@ implementation
calldesc : pcalldesc;params : pointer);cdecl; calldesc : pcalldesc;params : pointer);cdecl;
var var
dispatchinterface : pointer; dispatchinterface : pointer;
ids : array[0..255] of longint; ids : array[0..255] of TDispID;
begin begin
fillchar(ids,sizeof(ids),sizeof(ids));
{$ifdef DEBUG_COMDISPATCH} {$ifdef DEBUG_COMDISPATCH}
writeln('ComObjDispatchInvoke called'); writeln('ComObjDispatchInvoke called');
writeln('ComObjDispatchInvoke: CallDesc^.ArgCount = ',CallDesc^.ArgCount); writeln('ComObjDispatchInvoke: @CallDesc = $',hexstr(PtrInt(CallDesc),SizeOf(Pointer)*2),' CallDesc^.ArgCount = ',CallDesc^.ArgCount);
{$endif DEBUG_COMDISPATCH} {$endif DEBUG_COMDISPATCH}
if tvardata(source).vtype=VarDispatch then if tvardata(source).vtype=VarDispatch then
dispatchinterface:=tvardata(source).vdispatch dispatchinterface:=tvardata(source).vdispatch