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

+ disp. var. property setting, resolves #10133 and #9134

Browse Source 
git-svn-id: trunk@9189 -
This commit is contained in:
florian 2007-11-11 14:14:05 +00:00
parent 01f2667f0c
commit a5ccf16016
5 changed files with 101 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -7043,6 +7043,7 @@ tests/test/tclass7.pp svneol=native#text/plain
tests/test/tclass8.pp svneol=native#text/plain
tests/test/tclrprop.pp svneol=native#text/plain
tests/test/tcmp.pp svneol=native#text/plain
tests/test/tdispvar1.pp svneol=native#text/plain
tests/test/tendian1.pp svneol=native#text/plain
tests/test/tenum1.pp svneol=native#text/plain
tests/test/tenum2.pp svneol=native#text/plain

16
compiler/ncal.pas
View File

@ -186,7 +186,7 @@ interface
tcallparanodeclass = class of tcallparanode;
function reverseparameters(p: tcallparanode): tcallparanode;
function translate_disp_call(selfnode,parametersnode : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
var
ccallnode : tcallnodeclass;
@ -238,7 +238,7 @@ implementation
end;
function translate_disp_call(selfnode,parametersnode : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring = '';dispid : longint = 0;useresult : boolean = false) : tnode;
const
DISPATCH_METHOD = $1;
DISPATCH_PROPERTYGET = $2;
@ -352,8 +352,10 @@ implementation
para:=tcallparanode(para.nextpara);
end;
calldesc.calltype:=DISPATCH_METHOD;
if assigned(putvalue) then
calldesc.calltype:=DISPATCH_PROPERTYPUT
else
calldesc.calltype:=DISPATCH_METHOD;
calldesc.argcount:=paracount;
{ allocate space }
@ -381,8 +383,8 @@ implementation
end;
dispatchbyref:=para.left.resultdef.typ in [variantdef];
{ assign the argument/parameter to the temporary location }
{ assign the argument/parameter to the temporary location }
if para.left.nodetype<>nothingn then
if dispatchbyref then
addstatement(statements,cassignmentnode.create(
@ -2400,13 +2402,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,'',tprocdef(procdefinition).dispid,true),
ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,true),
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,'',tprocdef(procdefinition).dispid,false);
result:=translate_disp_call(methodpointer,parameters,nil,'',tprocdef(procdefinition).dispid,false);
{ don't free reused nodes }
methodpointer:=nil;

22
compiler/pexpr.pas
View File

@ -2078,10 +2078,24 @@ implementation
end
else
p2:=nil;
p1:=translate_disp_call(p1,p2,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));
{ property setter? }
if (token=_ASSIGNMENT) and not(afterassignment) then
begin
consume(_ASSIGNMENT);
{ read the expression }
p3:=comp_expr(true);
{ 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);
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;
end
else { Error }
Consume(_ID);

7
packages/base/winunits/comobj.pp
View File

@ -803,7 +803,12 @@ implementation
case InvokeKind of
DISPATCH_PROPERTYPUT:
begin
{ !! FIXME}
if (Arguments[0].VType and varDispatch)<>0 then
InvokeKind:=DISPATCH_PROPERTYPUTREF;
{ first name is actually the name of the property to set }
DispIDs^[0]:=DISPATCH_PROPERTYPUT;
DispParams.rgdispidNamedArgs:=@DispIDs^[0];
inc(DispParams.cNamedArgs);
end;
DISPATCH_METHOD:
if assigned(Result) and (CallDesc^.ArgCount=0) then

67
tests/test/tdispvar1.pp Normal file
View File

@ -0,0 +1,67 @@
{ %TARGET=win32,win64 }
{ %NOTE=This test requires an installed OpenOffice }
program ttt;
{$ifdef fpc}
{$mode delphi}
{$endif fpc}
uses
Windows, SysUtils, Classes, ComObj, ActiveX, Variants;
var StarOffice : Variant;
Document : Variant;
function TSampleCode_Connect() : boolean;
begin
if VarIsEmpty(StarOffice) then
StarOffice := CreateOleObject('com.sun.star.ServiceManager');
Result := not (VarIsEmpty(StarOffice) or VarIsNull(StarOffice));
end;
function TSampleCode_CreateDocument(bReadOnly : boolean) : boolean;
var
StarDesktop : Variant;
LoadParams : Variant;
CoreReflection : Variant;
PropertyValue : Variant;
AutoObject : Variant;
TextObject : Variant;
Cursor : Variant;
begin
StarDesktop := StarOffice.createInstance('com.sun.star.frame.Desktop');
if (bReadOnly) then begin
LoadParams := VarArrayCreate([0, 0], varVariant);
CoreReflection := StarOffice.createInstance('com.sun.star.reflection.CoreReflection');
CoreReflection.forName('com.sun.star.beans.PropertyValue').
createObject(PropertyValue); // CoreReflection().forName().createObject() bring to "Illegal qualifier"
AutoObject := CoreReflection.forName('com.sun.star.beans.PropertyValue');
AutoObject.createObject(PropertyValue);
PropertyValue.Name := 'ReadOnly'; // "Arg cant be assigned" and
PropertyValue.Value := true; // "Incompatimle types: const string, untyped expected"
LoadParams[0] := PropertyValue;
end
else
LoadParams := VarArrayCreate([0, -1], varVariant);
Document := StarDesktop.LoadComponentFromURL( 'private:factory/swriter', '_blank', 0, LoadParams);
if not bReadOnly then begin
TextObject := Document.Text;
Cursor := TextObject.createTextCursor;
TextObject.insertString(Cursor,'Output of FPC Test tdispvar1.pp',False);
// works with D7, but not FPC
end;
Result := not (VarIsEmpty(Document) or VarIsNull(Document));
end;
begin
CoInitialize(nil);
TSampleCode_Connect();
TSampleCode_CreateDocument(false);
end.