paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 07:43:04 +01:00
Code Issues Packages Projects Releases Wiki Activity

Improvements to dispinterface property handling:

Browse Source 
* Create implicit access methods, which hold type information for property parameters and allow parsing/typechecking occur the same way as for regular (non-dispinterface) properties.
+ Introduce separate proctypeoptions for property access methods. They are translated into correct dispatch call types and used to distinguish property access from regular method calls.
* Bump PPU version because new information has been introduced.
- Code specific to dispinterface properties in expression parser is no longer necessary, removed.
* Allow access to default property with [] for dispinterfaces.
+ Extended the test with basic correctness checks for property dispatching.

git-svn-id: trunk@16810 -
This commit is contained in:
sergei 2011-01-24 20:30:48 +00:00
parent ba74d47081
commit 58f37dc952
6 changed files with 117 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/ncal.pas
View File

@ -2601,6 +2601,7 @@ implementation
is_const : boolean;
statements : tstatementnode;
converted_result_data : ttempcreatenode;
calltype: tdispcalltype;
label
errorexit;
begin
@ -2994,6 +2995,12 @@ implementation
{ dispinterface methode invoke? }
if assigned(methodpointer) and is_dispinterface(methodpointer.resultdef) then
begin
case procdefinition.proctypeoption of
potype_propgetter: calltype:=dct_propget;
potype_propsetter: calltype:=dct_propput;
else
calltype:=dct_method;
end;
{ if the result is used, we've to insert a call to convert the type to be on the "safe side" }
if (cnf_return_value_used in callnodeflags) and not is_void(procdefinition.returndef) then
begin
@ -3001,13 +3008,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,dct_method,'',tprocdef(procdefinition).dispid,procdefinition.returndef),
ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,calltype,'',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,dct_method,'',tprocdef(procdefinition).dispid,voidtype);
result:=translate_disp_call(methodpointer,parameters,calltype,'',tprocdef(procdefinition).dispid,voidtype);
{ don't free reused nodes }
methodpointer:=nil;

90
compiler/pdecvar.pas
View File

@ -241,13 +241,30 @@ implementation
(ppo_hasparameters in p.propoptions);
end;
procedure parse_dispinterface(p : tpropertysym);
procedure create_accessor_procsym(p: tpropertysym; pd: tprocdef; const prefix: string;
accesstype: tpropaccesslisttypes);
var
sym: tprocsym;
begin
handle_calling_convention(pd);
sym:=tprocsym.create(prefix+lower(p.realname));
symtablestack.top.insert(sym);
pd.procsym:=sym;
include(pd.procoptions,po_dispid);
include(pd.procoptions,po_global);
pd.visibility:=vis_private;
proc_add_definition(pd);
p.propaccesslist[accesstype].addsym(sl_call,sym);
p.propaccesslist[accesstype].procdef:=pd;
end;
procedure parse_dispinterface(p : tpropertysym; readpd,writepd: tprocdef;
var paranr: word);
var
{procsym: tprocsym;
procdef: tprocdef;
valuepara: tparavarsym;}
hasread, haswrite: boolean;
pt: tnode;
hdispid: longint;
hparavs: tparavarsym;
begin
p.propaccesslist[palt_read].clear;
p.propaccesslist[palt_write].clear;
@ -260,12 +277,6 @@ implementation
else if try_to_consume(_WRITEONLY) then
hasread:=false;
if hasread then
include(p.propoptions, ppo_dispid_read);
if haswrite then
include(p.propoptions, ppo_dispid_write);
if try_to_consume(_DISPID) then
begin
pt:=comp_expr(true,false);
@ -273,16 +284,39 @@ implementation
if (Tordconstnode(pt).value<int64(low(longint))) or (Tordconstnode(pt).value>int64(high(longint))) then
message(parser_e_range_check_error)
else
p.dispid:=Tordconstnode(pt).value.svalue
hdispid:=Tordconstnode(pt).value.svalue
else
Message(parser_e_dispid_must_be_ord_const);
pt.free;
end
else
p.dispid:=tobjectdef(astruct).get_next_dispid;
hdispid:=tobjectdef(astruct).get_next_dispid;
{ COM property is simply a pair of methods, tagged with 'propertyget'
and 'propertyset' flags (or a single method if access is restricted).
Creating these implicit accessor methods also allows the rest of compiler
to handle dispinterface properties the same way as regular ones. }
if hasread then
begin
readpd.returndef:=p.propdef;
readpd.dispid:=hdispid;
readpd.proctypeoption:=potype_propgetter;
create_accessor_procsym(p,readpd,'get$',palt_read);
end;
if haswrite then
begin
{ add an extra parameter, a placeholder of the value to set }
inc(paranr);
hparavs:=tparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
writepd.parast.insert(hparavs);
writepd.proctypeoption:=potype_propsetter;
writepd.dispid:=hdispid;
create_accessor_procsym(p,writepd,'put$',palt_write);
end;
end;
procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef: tprocvardef);
procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef: tprocdef);
var
hparavs: tparavarsym;
begin
@ -310,21 +344,23 @@ implementation
found : boolean;
hreadparavs,
hparavs : tparavarsym;
storedprocdef,
storedprocdef: tprocvardef;
readprocdef,
writeprocdef : tprocvardef;
writeprocdef : tprocdef;
begin
{ Generate temp procvardefs to search for matching read/write
{ Generate temp procdefs to search for matching read/write
procedures. the readprocdef will store all definitions }
paranr:=0;
readprocdef:=tprocvardef.create(normal_function_level);
writeprocdef:=tprocvardef.create(normal_function_level);
readprocdef:=tprocdef.create(normal_function_level);
writeprocdef:=tprocdef.create(normal_function_level);
{ make them method pointers }
if assigned(astruct) and not is_classproperty then
readprocdef.struct:=astruct;
writeprocdef.struct:=astruct;
if assigned(astruct) and is_classproperty then
begin
include(readprocdef.procoptions,po_methodpointer);
include(writeprocdef.procoptions,po_methodpointer);
readprocdef.procoptions:=[po_staticmethod,po_classmethod];
writeprocdef.procoptions:=[po_staticmethod,po_classmethod];
end;
if token<>_ID then
@ -577,7 +613,7 @@ implementation
end;
end
else
parse_dispinterface(p);
parse_dispinterface(p,readprocdef,writeprocdef,paranr);
{ stored is not allowed for dispinterfaces, records or class properties }
if assigned(astruct) and not(is_dispinterface(astruct) or is_record(astruct)) and not is_classproperty then
@ -835,9 +871,11 @@ implementation
message1(parser_e_implements_uses_non_implemented_interface,def.typename);
end;
{ remove temporary procvardefs }
readprocdef.owner.deletedef(readprocdef);
writeprocdef.owner.deletedef(writeprocdef);
{ remove unneeded procdefs }
if readprocdef.proctypeoption<>potype_propgetter then
readprocdef.owner.deletedef(readprocdef);
if writeprocdef.proctypeoption<>potype_propsetter then
writeprocdef.owner.deletedef(writeprocdef);
result:=p;
end;

29
compiler/pexpr.pas
View File

@ -1053,8 +1053,6 @@ implementation
callflags : tcallnodeflags;
propaccesslist : tpropaccesslist;
sym: tsym;
statements : tstatementnode;
converted_result_data : ttempcreatenode;
begin
{ property parameters? read them only if the property really }
{ has parameters }
@ -1121,16 +1119,6 @@ implementation
end;
end;
end
else
if (ppo_dispid_write in propsym.propoptions) then
begin
consume(_ASSIGNMENT);
p2:=comp_expr(true,false);
{ concat value parameter too }
p2:=ccallparanode.create(p2,paras);
paras:=nil;
p1:=translate_disp_call(p1,p2,dct_propput,'',propsym.dispid,voidtype);
end
else
begin
p1:=cerrornode.create;
@ -1168,20 +1156,6 @@ implementation
end;
end;
end
else
if (ppo_dispid_read in propsym.propoptions) then
begin
p2:=internalstatements(statements);
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,paras,dct_propget,'',propsym.dispid,propsym.propdef),
propsym.propdef)));
addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
addstatement(statements,ctemprefnode.create(converted_result_data));
p1:=p2;
paras:=nil;
end
else
begin
{ error, no function to read property }
@ -1932,7 +1906,8 @@ implementation
_LECKKLAMMER:
begin
if is_class_or_interface_or_object(p1.resultdef) then
if is_class_or_interface_or_object(p1.resultdef) or
is_dispinterface(p1.resultdef) then
begin
{ default property }
protsym:=search_default_property(tobjectdef(p1.resultdef));

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 126;
CurrentPPUVersion = 127;
{ buffer sizes }
maxentrysize = 1024;

8
compiler/symconst.pas
View File

@ -239,7 +239,9 @@ type
potype_procedure,
potype_function,
potype_class_constructor, { class constructor }
potype_class_destructor { class destructor }
potype_class_destructor, { class destructor }
potype_propgetter, { Dispinterface property accessors }
potype_propsetter
);
tproctypeoptions=set of tproctypeoption;
@ -388,8 +390,8 @@ type
ppo_hasparameters,
ppo_implements,
ppo_enumerator_current,
ppo_dispid_read,
ppo_dispid_write
ppo_dispid_read, { no longer used }
ppo_dispid_write { no longer used }
);
tpropertyoptions=set of tpropertyoption;

36
tests/test/tdispinterface2.pp
View File

@ -22,12 +22,14 @@ type
procedure DispArg1(Arg: IUnknown);
procedure DispArg2(Arg: IDispatch);
function DispArg3(var Arg: wordbool): widestring;
property DispProp[index: OleVariant]: Integer;
end;
var
cur_dispid: longint;
cur_argtype: byte;
cur_restype: byte;
cur_calltype: byte;
{$HINTS OFF}
procedure DoDispCallByID(res: Pointer; const disp: IDispatch; desc: PDispDesc;
@ -48,6 +50,25 @@ var
halt($FF);
end;
procedure DoDispCallByIDProp(res: Pointer; const disp: IDispatch; desc: PDispDesc;
params: Pointer);
begin
if desc^.calldesc.calltype <> cur_calltype then
halt(5);
// put: arg #0 is value, arg #1 is index (in Delphi: vice-versa)
// get: arg #0 is index
if desc^.calldesc.argtypes[ord(cur_calltype=4)] <> cur_argtype then
halt(6);
if cur_calltype=4 then
begin
if desc^.calldesc.argcount <> 2 then
halt(7);
if desc^.calldesc.argtypes[0] <> cur_restype then
halt(8);
if desc^.restype <> 0 then
halt(9);
end;
end;
{$HINTS ON}
@ -56,6 +77,7 @@ var
B: wordbool;
begin
// check dispid values
writeln('Testing dispid values...');
DispCallByIDProc := @DoDispCallByID;
cur_dispid := 300;
II.Disp300;
@ -66,6 +88,7 @@ begin
cur_dispid := 402;
II.Disp402 := True;
// check arguments
writeln('Testing arguments...');
DispCallByIDProc := @DoDispCallByIDArg;
cur_restype := varempty;
cur_argtype := varunknown;
@ -76,4 +99,17 @@ begin
cur_argtype := varboolean or $80;
B := False;
II.DispArg3(B);
writeln('Testing properties...');
DispCallByIDProc := @DoDispCallByIDProp;
cur_calltype := 2; // propertyget
cur_argtype := varvariant;
cur_restype := varinteger;
II.DispProp[1];
II.DispProp['abc'];
cur_calltype := 4; // propertyput
II.DispProp[1] := 11;
II.DispProp['abc'] := 12;
end.