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

+ support multiple inheritance for obj-c protocols

Browse Source 
* don't allocate tobjectdef.implementedinterfaces for corba interfaces
    since the compiler doesn't support multiple inheritance for them
  * extended/corrected related tobjc22 test
  * increased ppu version, because implementedinterfaces is now
    present in different cases

git-svn-id: branches/objc@13738 -
This commit is contained in:
Jonas Maebe 2009-09-18 11:35:13 +00:00
parent e41c06391b
commit 4c57a5f504
5 changed files with 105 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
compiler/nobj.pas
View File

@ -37,12 +37,14 @@ interface
TVMTBuilder=class
private
_Class : tobjectdef;
handledprotocols: tfpobjectlist;
function is_new_vmt_entry(pd:tprocdef):boolean;
procedure add_new_vmt_entry(pd:tprocdef);
function check_msg_str(vmtpd, pd: tprocdef):boolean;
function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
procedure prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef);
procedure intf_optimize_vtbls;
procedure intf_allocate_vtbls;
public
@ -497,6 +499,20 @@ implementation
end;
procedure TVMTBuilder.prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef);
var
i: longint;
begin
{ don't check the same protocol twice }
if handledprotocols.IndexOf(ProtDef)<>-1 then
exit;
handledprotocols.add(ProtDef);
for i:=0 to ProtDef.ImplementedInterfaces.count-1 do
prot_get_procdefs_recursive(ImplProt,TImplementedInterface(ProtDef.ImplementedInterfaces[i]).intfdef);
intf_get_procdefs(ImplProt,ProtDef);
end;
procedure TVMTBuilder.intf_optimize_vtbls;
type
tcompintfentry = record
@ -687,14 +703,35 @@ implementation
i: longint;
begin
{ Find Procdefs implementing the interfaces }
if assigned(_class.ImplementedInterfaces) then
if assigned(_class.ImplementedInterfaces) and
(_class.objecttype<>odt_objcprotocol) then
begin
{ Collect implementor functions into the tImplementedInterface.procdefs }
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
end;
case _class.objecttype of
odt_class:
begin
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef)
end;
end;
odt_objcclass:
begin
{ Object Pascal interfaces are afterwards optimized via the
intf_optimize_vtbls() method, but we can't do this for
protocols -> check for duplicates here already. }
handledprotocols:=tfpobjectlist.create(false);
for i:=0 to _class.ImplementedInterfaces.count-1 do
begin
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
prot_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
end;
handledprotocols.free;
end
else
internalerror(2009091801);
end
end;
end;

10
compiler/pdecobj.pas
View File

@ -324,8 +324,12 @@ implementation
Message(parser_e_mix_of_classes_and_objects);
end;
odt_objcprotocol:
if not(is_objcprotocol(childof)) then
Message(parser_e_mix_of_classes_and_objects);
begin
if not(is_objcprotocol(childof)) then
Message(parser_e_mix_of_classes_and_objects);
intfchildof:=childof;
childof:=nil;
end;
odt_object:
if not(is_object(childof)) then
Message(parser_e_mix_of_classes_and_objects);
@ -376,7 +380,7 @@ implementation
if hasparentdefined then
begin
if current_objectdef.objecttype in [odt_class,odt_objcclass] then
if current_objectdef.objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
begin
if assigned(intfchildof) then
if current_objectdef.objecttype=odt_class then

2
compiler/ppu.pas
View File

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

29
compiler/symdef.pas
View File

@ -3740,7 +3740,7 @@ implementation
if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
prepareguid;
{ setup implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba,odt_objcclass] then
if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
ImplementedInterfaces:=TFPObjectList.Create(true)
else
ImplementedInterfaces:=nil;
@ -3794,7 +3794,7 @@ implementation
end;
{ load implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba,odt_objcclass] then
if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
begin
ImplementedInterfaces:=TFPObjectList.Create(true);
implintfcount:=ppufile.getlongint;
@ -4168,11 +4168,36 @@ implementation
end;
{ true if prot implements d (or if they are equal) }
function is_related_protocol(prot: tobjectdef; d : tdef) : boolean;
var
i : longint;
begin
{ objcprotocols have multiple inheritance, all protocols from which
the current protocol inherits are stored in implementedinterfaces }
result:=prot=d;
if result then
exit;
for i:=0 to prot.ImplementedInterfaces.count-1 do
begin
result:=is_related_protocol(tobjectdef(prot.ImplementedInterfaces[i]),d);
if result then
exit;
end;
end;
{ true, if self inherits from d (or if they are equal) }
function tobjectdef.is_related(d : tdef) : boolean;
var
hp : tobjectdef;
begin
if (objecttype=odt_objcprotocol) then
begin
is_related:=is_related_protocol(self,d);
exit
end;
hp:=self;
while assigned(hp) do
begin

38
tests/test/tobjc22.pp
View File

@ -1,3 +1,6 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
program protocoltest;
{$mode objfpc}{$H+}
@ -5,44 +8,48 @@ program protocoltest;
type
MyProtocolA = objcprotocol
procedure newMethod; message 'newMethod';
function newMethod: longint; message 'newMethod';
end;
MyProtocolB = objcprotocol(MyProtocolA)
class procedure newClassMethod; message 'newClassMethod';
class function newClassMethod: longint; message 'newClassMethod';
end;
{ TMyObject }
TMyObjectA = objcclass(NSObject, MyProtocolA, MyProtocolB)
procedure newMethod;
class procedure newClassMethod;
TMyObjectA = objcclass(NSObject, MyProtocolB)
function newMethod: longint;
class function newClassMethod: longint;
end;
TMyObjectB = objcclass(NSObject,MyProtocolA)
procedure newMethod; message 'newMethod';
class procedure newClassMethod; message 'newClassMethod';
function newMethod: longint; message 'newMethod';
class function newClassMethod: longint; message 'newClassMethod';
end;
{ TMyObjectA }
procedure TMyObjectA.newMethod;
function TMyObjectA.newMethod: longint;
begin
result:=1;
end;
class procedure TMyObjectA.newClassMethod;
class function TMyObjectA.newClassMethod: longint;
begin
result:=2;
end;
{ TMyObjectB }
procedure TMyObjectB.newMethod;
function TMyObjectB.newMethod: longint;
begin
result:=3;
end;
class procedure TMyObjectB.newClassMethod;
class function TMyObjectB.newClassMethod: longint;
begin
result:=4;
end;
@ -72,6 +79,11 @@ begin
if TMyObjectA.classconformsToProtocol_(pNSProxy) then
halt(5);
if TMyObjectA.newClassMethod<>2 then
halt(11);
if TMyObjectB.newClassMethod<>4 then
halt(12);
a := TMyObjectA.alloc;
writeln('TMyObjectA instance conforms to MyProtocolA protocol: ', a.classconformsToProtocol_(pMyProtocolA)); {true}
if not a.classconformsToProtocol_(pMyProtocolA) then
@ -82,6 +94,8 @@ begin
writeln('TMyObjectA instance conforms to NSProxy protocol: ', a.classconformsToProtocol_(pNSProxy)); {false}
if a.classconformsToProtocol_(pNSProxy) then
halt(8);
if a.newMethod<>1 then
halt(21);
a.Release;
b := TMyObjectB.alloc;
@ -91,6 +105,8 @@ begin
writeln('TMyObjectB instance conforms to MyProtocolB protocol: ', b.conformsToProtocol_(pMyProtocolB)); {false}
if b.conformsToProtocol_(pMyProtocolB) then
halt(7);
if b.newMethod<>3 then
halt(31);
b.Release;
end.