mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-10 12:29:15 +02:00
compiler: auto generate method/property dispid if it is not set explicitly
git-svn-id: trunk@14766 -
This commit is contained in:
parent
29961c1b8c
commit
bd6f1d7447
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -8916,6 +8916,7 @@ tests/test/tcmp0.pp svneol=native#text/plain
|
||||
tests/test/tdel1.pp svneol=native#text/plain
|
||||
tests/test/tdispinterface1a.pp svneol=native#text/pascal
|
||||
tests/test/tdispinterface1b.pp svneol=native#text/pascal
|
||||
tests/test/tdispinterface2.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
|
||||
|
@ -730,6 +730,13 @@ implementation
|
||||
begin
|
||||
parse_object_proc_directives(pd);
|
||||
|
||||
{ check if dispid is set }
|
||||
if is_dispinterface(pd._class) and not (po_dispid in pd.procoptions) then
|
||||
begin
|
||||
pd.dispid:=pd._class.get_next_dispid;
|
||||
include(pd.procoptions, po_dispid);
|
||||
end;
|
||||
|
||||
{ all Macintosh Object Pascal methods are virtual. }
|
||||
{ this can't be a class method, because macpas mode }
|
||||
{ has no m_class }
|
||||
|
@ -277,7 +277,9 @@ implementation
|
||||
else
|
||||
Message(parser_e_dispid_must_be_ord_const);
|
||||
pt.free;
|
||||
end;
|
||||
end
|
||||
else
|
||||
p.dispid:=aclass.get_next_dispid;
|
||||
end;
|
||||
|
||||
var
|
||||
|
@ -235,6 +235,8 @@ interface
|
||||
pmvcallstaticinfo = ^tmvcallstaticinfo;
|
||||
tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
|
||||
tobjectdef = class(tabstractrecorddef)
|
||||
private
|
||||
fcurrent_dispid: longint;
|
||||
public
|
||||
dwarf_struct_lab : tasmsymbol;
|
||||
childof : tobjectdef;
|
||||
@ -301,6 +303,8 @@ interface
|
||||
function FindDestructor : tprocdef;
|
||||
function implements_any_interfaces: boolean;
|
||||
procedure reset; override;
|
||||
{ dispinterface support }
|
||||
function get_next_dispid: longint;
|
||||
{ enumerator support }
|
||||
function search_enumerator_get: tprocdef;
|
||||
function search_enumerator_move: tprocdef;
|
||||
@ -3792,6 +3796,7 @@ implementation
|
||||
constructor tobjectdef.create(ot : tobjecttyp;const n : string;c : tobjectdef);
|
||||
begin
|
||||
inherited create(objectdef);
|
||||
fcurrent_dispid:=0;
|
||||
objecttype:=ot;
|
||||
objectoptions:=[];
|
||||
childof:=nil;
|
||||
@ -4553,6 +4558,12 @@ implementation
|
||||
classref_created_in_current_module:=false;
|
||||
end;
|
||||
|
||||
function tobjectdef.get_next_dispid: longint;
|
||||
begin
|
||||
inc(fcurrent_dispid);
|
||||
result:=fcurrent_dispid;
|
||||
end;
|
||||
|
||||
function tobjectdef.search_enumerator_get: tprocdef;
|
||||
var
|
||||
objdef : tobjectdef;
|
||||
|
44
tests/test/tdispinterface2.pp
Normal file
44
tests/test/tdispinterface2.pp
Normal file
@ -0,0 +1,44 @@
|
||||
{ %TARGET=win32,win64,wince}
|
||||
|
||||
program tdispinterface2;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$mode objfpc}
|
||||
{$endif}
|
||||
|
||||
type
|
||||
|
||||
{ IIE }
|
||||
|
||||
IIE = dispinterface
|
||||
['{0002DF05-0000-0000-C000-000000000046}']
|
||||
procedure Disp300; dispid 300;
|
||||
property Disp1: integer;
|
||||
procedure Disp2;
|
||||
property Disp402: wordbool dispid 402;
|
||||
end;
|
||||
|
||||
var
|
||||
cur_dispid: longint;
|
||||
|
||||
{$HINTS OFF}
|
||||
procedure DoDispCallByID(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
|
||||
begin
|
||||
if desc^.dispid <> cur_dispid then
|
||||
halt(cur_dispid);
|
||||
end;
|
||||
{$HINTS ON}
|
||||
|
||||
var
|
||||
II: IIE;
|
||||
begin
|
||||
DispCallByIDProc := @DoDispCallByID;
|
||||
cur_dispid := 300;
|
||||
II.Disp300;
|
||||
cur_dispid := 1;
|
||||
II.Disp1 := 1;
|
||||
cur_dispid := 2;
|
||||
II.Disp2;
|
||||
cur_dispid := 402;
|
||||
II.Disp402 := True;
|
||||
end.
|
Loading…
Reference in New Issue
Block a user