* fixed calling inherited methods in Objective-C + test

git-svn-id: branches/objc@13686 -

.gitattributes

@@ -8227,6 +8227,7 @@ tests/test/tobjc14.pp svneol=native#text/plain
 tests/test/tobjc15.pp svneol=native#text/plain
 tests/test/tobjc16.pp svneol=native#text/plain
 tests/test/tobjc17.pp svneol=native#text/plain
+tests/test/tobjc18.pp svneol=native#text/plain
 tests/test/tobjc2.pp svneol=native#text/plain
 tests/test/tobjc3.pp svneol=native#text/plain
 tests/test/tobjc4.pp svneol=native#text/plain

compiler/nobjc.pas

@@ -72,6 +72,7 @@ uses
   defutil,
   symtype,symtable,symdef,symconst,symsym,
   paramgr,
+  nutils,
   nbas,nld,ncnv,ncon,ncal,nmem,
   objcutil,
   cgbase;
@@ -231,7 +232,8 @@ function tobjcmessagesendnode.pass_1: tnode;
     msgsendname: string;
     newparas,
     para: tcallparanode;
-    block: tnode;
+    block,
+    selftree  : tnode;
     statements: tstatementnode;
     temp: ttempcreatenode;
     objcsupertype: tdef;
@@ -286,18 +288,8 @@ function tobjcmessagesendnode.pass_1: tnode;
     if not assigned(msgselpara) then
       internalerror(2009051802);
     { Handle self }
-    { 1) If we're calling a class method, use a class ref.  }
-    if (po_classmethod in tcallnode(left).procdefinition.procoptions) and
-       ((tcallnode(left).methodpointer.nodetype=typen) or
-        (tcallnode(left).methodpointer.resultdef.typ<>classrefdef)) then
-      begin
-        tcallnode(left).methodpointer:=cloadvmtaddrnode.create(tcallnode(left).methodpointer);
-        firstpass(tcallnode(left).methodpointer);
-      end;
-    { 2) convert parameter to id to match objc_MsgSend* signatures }
-    inserttypeconv_internal(tcallnode(left).methodpointer,objc_idtype);
-    { in case of sending a message to a superclass, self is a pointer to
-      an objc_super record
+    { 1) in case of sending a message to a superclass, self is a pointer to
+         an objc_super record
     }
     if (cnf_inherited in tcallnode(left).callnodeflags) then
       begin
@@ -308,31 +300,60 @@ function tobjcmessagesendnode.pass_1: tnode;
          { temp for the for the objc_super record }
          temp:=ctempcreatenode.create(objcsupertype,objcsupertype.size,tt_persistent,false);
          addstatement(statements,temp);
-         { initialize objc_super record: first the destination object instance }
+         { initialize objc_super record }
+         selftree:=load_self_node;
+
+         { we can call an inherited class static/method from a regular method
+           -> self node must change from instance pointer to vmt pointer)
+         }
+         if (po_classmethod in tcallnode(left).procdefinition.procoptions) and
+            (selftree.resultdef.typ<>classrefdef) then
+           begin
+             selftree:=cloadvmtaddrnode.create(selftree);
+             typecheckpass(selftree);
+           end;
          field:=tfieldvarsym(trecorddef(objcsupertype).symtable.find('RECEIVER'));
          if not assigned(field) then
            internalerror(2009032902);
+        { first the destination object/class instance }
          addstatement(statements,
            cassignmentnode.create(
              csubscriptnode.create(field,ctemprefnode.create(temp)),
-             tcallnode(left).methodpointer
+             selftree
            )
          );
-         { and secondly, the destination class type }
+         { and secondly, the class type in which the selector must be looked
+           up (the parent class in case of an instance method, the parent's
+           metaclass in case of a class method) }
          field:=tfieldvarsym(trecorddef(objcsupertype).symtable.find('_CLASS'));
          if not assigned(field) then
            internalerror(2009032903);
          addstatement(statements,
            cassignmentnode.create(
              csubscriptnode.create(field,ctemprefnode.create(temp)),
-             objcsuperclassnode(tobjectdef(tcallnode(left).methodpointer.resultdef))
+             objcsuperclassnode(selftree.resultdef)
            )
          );
          { result of this block is the address of this temp }
          addstatement(statements,caddrnode.create_internal(ctemprefnode.create(temp)));
          { replace the method pointer with the address of this temp }
+         tcallnode(left).methodpointer.free;
          tcallnode(left).methodpointer:=block;
          typecheckpass(block);
+      end
+    else
+    { 2) regular call (not inherited) }
+      begin
+        { a) If we're calling a class method, use a class ref.  }
+        if (po_classmethod in tcallnode(left).procdefinition.procoptions) and
+           ((tcallnode(left).methodpointer.nodetype=typen) or
+            (tcallnode(left).methodpointer.resultdef.typ<>classrefdef)) then
+          begin
+            tcallnode(left).methodpointer:=cloadvmtaddrnode.create(tcallnode(left).methodpointer);
+            firstpass(tcallnode(left).methodpointer);
+          end;
+        { b) convert methodpointer parameter to match objc_MsgSend* signatures }
+        inserttypeconv_internal(tcallnode(left).methodpointer,objc_idtype);
       end;
     { replace self parameter }
     selfpara.left.free;

compiler/objcutil.pas

@@ -33,7 +33,7 @@ interface
 
     { Generate a node loading the superclass structure necessary to call
       an inherited Objective-C method.  }
-    function objcsuperclassnode(def: tobjectdef): tnode;
+    function objcsuperclassnode(def: tdef): tnode;
 
     { The internals of Objective-C's @encode() functionality: encode a
       type into the internal format used by the run time. Returns false
@@ -58,27 +58,32 @@ implementation
       verbose,
       symtable,symconst,symsym,
       defutil,paramgr,
-      nbas,nmem,ncal,nld;
+      nbas,nmem,ncal,nld,ncon;
 
 
 {******************************************************************
                        objcsuperclassnode
 *******************************************************************}
 
-    function objcsuperclassnode(def: tobjectdef): tnode;
+    function objcsuperclassnode(def: tdef): tnode;
       var
-        block: tnode;
-        statements: tstatementnode;
         para: tcallparanode;
       begin
-        { only valid for Objective-C classes }
-        if not is_objcclass(def) then
-          internalerror(2009032904);
-        block:=internalstatements(statements);
-        para:=ccallparanode.create(cloadvmtaddrnode.create(ctypenode.create(def)),nil);
-        addstatement(statements,ccallnode.createinternfromunit('OBJC1','CLASS_GETSUPERCLASS',para));
-        typecheckpass(block);
-        result:=block;
+        { only valid for Objective-C classes and classrefs }
+        if not is_objcclass(def) and
+           not is_objcclassref(def) then
+          internalerror(2009090901);
+        { Can be done a lot more efficiently with direct symbol accesses, but
+          requires extra node types. Maybe later. }
+        if is_objcclassref(def) then
+          begin
+            para:=ccallparanode.create(cstringconstnode.createstr(tobjectdef(tclassrefdef(def).pointeddef).objextname^),nil);
+            para:=ccallparanode.create(ccallnode.createinternfromunit('OBJC1','OBJC_GETMETACLASS',para),nil);
+          end
+        else
+          para:=ccallparanode.create(cloadvmtaddrnode.create(ctypenode.create(def)),nil);
+        result:=ccallnode.createinternfromunit('OBJC1','CLASS_GETSUPERCLASS',para);
+        typecheckpass(result);
       end;
 
 

rtl/inc/objc1.pp

@@ -80,7 +80,8 @@ function  objc_msgSend_fpret (self: id; op: SEL): double; cdecl; varargs; extern
 {$endif cpui386}
 
 function class_getSuperclass(cls: pobjc_class): pobjc_class; cdecl; external libname;
-
+function objc_getMetaClass(name: pchar): id; cdecl; external libname;
+function class_getName(cls: pobjc_class): pchar; cdecl; external 'libname';
 
 implementation
 

tests/test/tobjc18.pp

@@ -0,0 +1,73 @@
+{ %target=darwin }
+{ %cpu=powerpc,i386 }
+
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+type
+  MyOverride = objcclass(NSObject)
+    procedure release; override;
+    class procedure testClassOverride; message 'testClassOverride';
+  end;
+
+  MyOverride2 = objcclass(MyOverride)
+    procedure release; override;
+    class procedure testClassOverride; override;
+  end;
+
+var
+  overridescalled: longint;
+
+procedure MyOverride.release;
+begin
+  writeln('releasing override!');
+  if (overridescalled<>3) then
+    halt(1);
+  inc(overridescalled);
+  inherited release;
+end;
+
+class procedure MyOverride.testClassOverride;
+begin
+  writeln('MyOverride.testClassOverride');
+  if (overridescalled<>1) then
+    halt(3);
+  inc(overridescalled);
+end;
+
+procedure MyOverride2.release;
+begin
+  inherited testClassOverride;
+  writeln('releasing override2!');
+  if (overridescalled<>2) then
+    halt(2);
+  inc(overridescalled);
+  inherited release;
+end;
+
+class procedure MyOverride2.testClassOverride;
+begin
+  if (overridescalled<>0) then
+    halt(5);
+  writeln('MyOverride2.testClassOverride');
+  inc(overridescalled);
+  inherited testClassOverride;
+end;
+
+var
+  a: MyOverride;
+begin
+  a:=MyOverride2.alloc;
+  a:=a.init;
+  MyOverride2.testClassOverride;
+  if (overridescalled<>2) then
+    halt(6);
+  dec(overridescalled);
+  MyOverride.testClassOverride;
+  if (overridescalled<>2) then
+    halt(7);
+  overridescalled:=0;
+  a.testClassOverride;
+  overridescalled:=1;
+  a.release;
+end.