diff --git a/compiler/nobj.pas b/compiler/nobj.pas index 2eccb7675b..ef076ae168 100644 --- a/compiler/nobj.pas +++ b/compiler/nobj.pas @@ -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; diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas index 162363029f..135ad56c80 100644 --- a/compiler/pdecobj.pas +++ b/compiler/pdecobj.pas @@ -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 diff --git a/compiler/ppu.pas b/compiler/ppu.pas index 4c9ab96c01..4c9095efaf 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 101; + CurrentPPUVersion = 102; { buffer sizes } maxentrysize = 1024; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 3e52744873..cbb8bd7635 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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 diff --git a/tests/test/tobjc22.pp b/tests/test/tobjc22.pp index ef31fff8b3..81527a6b48 100644 --- a/tests/test/tobjc22.pp +++ b/tests/test/tobjc22.pp @@ -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.