+ support multiple inheritance for obj-c protocols

  * 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 -

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;
 

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

compiler/ppu.pas

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

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

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.