* Objective-Pascal inferred result type and improved category method searching

--- Merging r42815 through r42817 into '.':
U    tests/test/tobjc34.pp
U    tests/test/tobjc36.pp
U    tests/test/tobjcl2.pp
A    tests/test/units/cocoaall
A    tests/test/units/cocoaall/tw35994.pp
U    compiler/defcmp.pas
U    compiler/ncal.pas
C    compiler/pdecl.pas
C    compiler/symconst.pas
C    compiler/utils/ppuutils/ppudump.pp
U    compiler/symtable.pas
--- Recording mergeinfo for merge of r42815 through r42817 into '.':
 U   .
--- Merging r42857 into '.':
G    compiler/symtable.pas
--- Recording mergeinfo for merge of r42857 into '.':
 G   .
  

git-svn-id: branches/fixes_3_2@42883 -

.gitattributes

@@ -14062,6 +14062,7 @@ tests/test/units/classes/tsetstream.pp svneol=native#text/plain
 tests/test/units/classes/tstringlistexchange.pp svneol=native#text/pascal
 tests/test/units/classes/ttbits.pp svneol=native#text/pascal
 tests/test/units/classes/tvclcomobject.pp svneol=native#text/plain
+tests/test/units/cocoaall/tw35994.pp svneol=native#text/plain
 tests/test/units/cpu/tcpu1.pp svneol=native#text/pascal
 tests/test/units/crt/tcrt.pp svneol=native#text/plain
 tests/test/units/crt/tctrlc.pp svneol=native#text/plain

compiler/defcmp.pas

@@ -2464,6 +2464,13 @@ implementation
             exit;
           end;
 
+        if (realself.objecttype in [odt_objcclass,odt_objcprotocol]) and
+           (otherdef=objc_idtype) then
+          begin
+            result:=true;
+            exit;
+          end;
+
         if (otherdef.typ<>objectdef) then
           begin
             result:=false;

compiler/ncal.pas

@@ -3816,6 +3816,20 @@ implementation
                exit;
              end;
 
+            { in case this is an Objective-C message that returns a related object type by convention,
+              override the default result type }
+            if po_objc_related_result_type in procdefinition.procoptions then
+              begin
+                { don't crash in case of syntax errors }
+                if assigned(methodpointer) then
+                  begin
+                    include(callnodeflags,cnf_typedefset);
+                    typedef:=methodpointer.resultdef;
+                    if typedef.typ=classrefdef then
+                      typedef:=tclassrefdef(typedef).pointeddef;
+                  end;
+              end;
+
            { ensure that the result type is set }
            if not(cnf_typedefset in callnodeflags) then
             begin

compiler/pdecl.pas

@@ -56,7 +56,7 @@ implementation
        globals,tokens,verbose,widestr,constexp,
        systems,aasmdata,fmodule,compinnr,
        { symtable }
-       symconst,symbase,symtype,symcpu,symcreat,defutil,
+       symconst,symbase,symtype,symcpu,symcreat,defutil,defcmp,
        { pass 1 }
        ninl,ncon,nobj,ngenutil,
        { parser }
@@ -386,6 +386,51 @@ implementation
          consume(_SEMICOLON);
       end;
 
+    { From http://clang.llvm.org/docs/LanguageExtensions.html#objective-c-features :
+      To determine whether a method has an inferred related result type, the first word in the camel-case selector
+      (e.g., “init” in “initWithObjects”) is considered, and the method will have a related result type if its return
+      type is compatible with the type of its class and if:
+        * the first word is "alloc" or "new", and the method is a class method, or
+        * the first word is "autorelease", "init", "retain", or "self", and the method is an instance method.
+
+      If a method with a related result type is overridden by a subclass method, the subclass method must also return
+      a type that is compatible with the subclass type.
+    }
+    procedure pd_set_objc_related_result(def: tobject; para: pointer);
+      var
+        pd: tprocdef;
+        i, firstcamelend: longint;
+        inferresult: boolean;
+      begin
+        if tdef(def).typ<>procdef then
+          exit;
+        pd:=tprocdef(def);
+        if not(po_msgstr in pd.procoptions) then
+          internalerror(2019082401);
+        firstcamelend:=length(pd.messageinf.str^);
+        for i:=1 to length(pd.messageinf.str^) do
+          if pd.messageinf.str^[i] in ['A'..'Z'] then
+            begin
+              firstcamelend:=pred(i);
+              break;
+            end;
+        case copy(pd.messageinf.str^,1,firstcamelend) of
+          'alloc',
+          'new':
+             inferresult:=po_classmethod in pd.procoptions;
+          'autorelease',
+          'init',
+          'retain',
+          'self':
+             inferresult:=not(po_classmethod in pd.procoptions);
+          else
+            inferresult:=false;
+        end;
+        if inferresult and
+           def_is_related(tdef(pd.procsym.owner.defowner),pd.returndef) then
+          include(pd.procoptions,po_objc_related_result_type);
+      end;
+
     procedure types_dec(in_structure: boolean;out had_generic:boolean);
 
       function determine_generic_def(name:tidstring):tstoreddef;
@@ -901,7 +946,10 @@ implementation
                     if is_objc_class_or_protocol(hdef) and
                        (not is_objccategory(hdef) or
                         assigned(tobjectdef(hdef).childof)) then
-                      tobjectdef(hdef).finish_objc_data;
+                      begin
+                        tobjectdef(hdef).finish_objc_data;
+                        tobjectdef(hdef).symtable.DefList.ForEachCall(@pd_set_objc_related_result,nil);
+                      end;
 
                     if is_cppclass(hdef) then
                       tobjectdef(hdef).finish_cpp_data;

compiler/symconst.pas

@@ -413,7 +413,9 @@ type
     { procedure is an automatically generated property getter }
     po_is_auto_getter,
     { procedure is an automatically generated property setter }
-    po_is_auto_setter
+    po_is_auto_setter,
+    { implicitly return same type as the class instance to which the message is sent }
+    po_objc_related_result_type
   );
   tprocoptions=set of tprocoption;
 
@@ -1020,7 +1022,8 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
       'po_is_function_ref',{po_is_function_ref}
       'C-style blocks',{po_is_block}
       'po_is_auto_getter',{po_is_auto_getter}
-      'po_is_auto_setter'{po_is_auto_setter}
+      'po_is_auto_setter',{po_is_auto_setter}
+      'objc-related-result-type' {po_objc_related_result_type}
     );
 
 implementation

compiler/symtable.pas

@@ -4224,25 +4224,32 @@ implementation
 
     function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
       var
+        searchst   : tsymtable;
+        searchsym  : tsym;
         hashedid   : THashedIDString;
         stackitem  : psymtablestackitem;
         i          : longint;
+        founddefowner,
         defowner   : tobjectdef;
       begin
         hashedid.id:=class_helper_prefix+s;
         stackitem:=symtablestack.stack;
+        result:=false;
+        srsym:=nil;
+        srsymtable:=nil;
+        founddefowner:=nil;
         while assigned(stackitem) do
           begin
-            srsymtable:=stackitem^.symtable;
-            srsym:=tsym(srsymtable.FindWithHash(hashedid));
-            if assigned(srsym) then
+            searchst:=stackitem^.symtable;
+            searchsym:=tsym(searchst.FindWithHash(hashedid));
+            if assigned(searchsym) then
               begin
-                if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
-                   not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
-                   (srsym.typ<>procsym) then
+                if not(searchst.symtabletype in [globalsymtable,staticsymtable]) or
+                   not(searchsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
+                   (searchsym.typ<>procsym) then
                   internalerror(2009111505);
                 { check whether this procsym includes a helper for this particular class }
-                for i:=0 to tprocsym(srsym).procdeflist.count-1 do
+                for i:=0 to tprocsym(searchsym).procdeflist.count-1 do
                   begin
                     { does pd inherit from (or is the same as) the class
                       that this method's category extended?
@@ -4250,7 +4257,7 @@ implementation
                       Warning: this list contains both category and objcclass methods
                        (for id.randommethod), so only check category methods here
                     }
-                    defowner:=tobjectdef(tprocdef(tprocsym(srsym).procdeflist[i]).owner.defowner);
+                    defowner:=tobjectdef(tprocdef(tprocsym(searchsym).procdeflist[i]).owner.defowner);
                     if is_objccategory(defowner) and
                        def_is_related(pd,defowner.childof) then
                       begin
@@ -4258,28 +4265,37 @@ implementation
                           in the static symtable, because then it can't be
                           inlined from outside this unit }
                         if assigned(current_procinfo) and
-                           (srsym.owner.symtabletype=staticsymtable) then
+                           (searchsym.owner.symtabletype=staticsymtable) then
                           include(current_procinfo.flags,pi_uses_static_symtable);
-                        { no need to keep looking. There might be other
-                          categories that extend this, a parent or child
-                          class with a method with the same name (either
-                          overriding this one, or overridden by this one),
-                          but that doesn't matter as far as the basic
-                          procsym is concerned.
+                        { Stop looking if this is a category that extends the specified
+                          class itself. There might be other categories that extend this,
+                          but that doesn't matter. If it extens a parent, keep looking
+                          in case we find the symbol in a category that extends this class
+                          (or a closer parent).
                         }
-                        srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
-                        srsymtable:=srsym.owner;
-                        addsymref(srsym);
-                        result:=true;
-                        exit;
+                        if not result or
+                           def_is_related(defowner.childof,founddefowner) then
+                          begin
+                            founddefowner:=defowner.childof;
+                            srsym:=tprocdef(tprocsym(searchsym).procdeflist[i]).procsym;
+                            srsymtable:=srsym.owner;
+                            result:=true;
+                            if pd=founddefowner then
+                              begin
+                                addsymref(srsym);
+                                exit;
+                              end;
+                          end;
                       end;
                   end;
               end;
             stackitem:=stackitem^.next;
           end;
-        srsym:=nil;
-        srsymtable:=nil;
-        result:=false;
+        if result then
+          begin
+            addsymref(srsym);
+            exit;
+          end;
       end;
 
 

compiler/utils/ppuutils/ppudump.pp

@@ -2011,7 +2011,8 @@ const
      (mask:po_is_function_ref; str: 'Function reference'),
      (mask:po_is_block;        str: 'C "Block"'),
      (mask:po_is_auto_getter;  str: 'Automatically generated getter'),
-     (mask:po_is_auto_setter;  str: 'Automatically generated setter')
+     (mask:po_is_auto_setter;  str: 'Automatically generated setter'),
+     (mask:po_objc_related_result_type; str: 'Objective-C related result type')
   );
 var
   proctypeoption  : tproctypeoption;

tests/test/tobjc34.pp

@@ -15,7 +15,7 @@ type
     class procedure testClassOverride; override;
   end;
 
-  tmyoverrideclass = class of NSObject;
+  tmyoverrideclass = class of MyOverride;
 
 var
   selfshouldbe: tmyoverrideclass;

tests/test/tobjc36.pp

@@ -57,7 +57,7 @@ begin
   b:=MyObject.alloc.init;
   b.extraproc(2);
   b.release;
-  c:=MyObject.alloc.init;
-  c.extraproc(2);
+  c:=MyObject2.alloc.init;
+  c.extraproc(3);
   c.release;
 end.

tests/test/tobjcl2.pp

@@ -43,7 +43,7 @@ function MyDerivedClass.callprotectedfun: byte;
 var
   a: MyLibObjCClass;
 begin
-  a:=NSObject(MyDerivedClass.alloc).init;
+  a:=MyDerivedClass.alloc.init;
   a.fa:=55;
   a.fb:=66;
   if a.publicfun<>55 then

tests/test/units/cocoaall/tw35994.pp

@@ -0,0 +1,31 @@
+
+{$MODE OBJFPC}
+{$MODESWITCH OBJECTIVEC1}
+
+program test;
+
+uses
+  CocoaAll;
+
+var
+  obj: NSObject;
+  path: NSString;
+  dict: NSDictionary;
+  mDict: NSMutableDictionary;
+  pool: NSAutoReleasePool;
+begin
+  pool := NSAutoReleasePool.alloc.init;
+  obj := NSObject.alloc.init;
+
+  path := NSSTR('');
+  dict := NSDictionary.dictionaryWithContentsOfFile(path);
+  dict := NSDictionary.alloc.initWithContentsOfFile(path); // ERROR: got "NSArray" expected "NSDictionary"
+  dict := NSDictionary(NSDictionary.alloc).initWithContentsOfFile(path);
+
+  dict := NSMutableDictionary.dictionaryWithContentsOfFile(path);
+  mDict := NSMutableDictionary.dictionaryWithContentsOfFile(path); // ERROR: got "NSDictionary" expected "NSMutableDictionary"
+  dict := NSMutableDictionary.alloc.initWithContentsOfFile(path); // ERROR: got "NSArray" expected "NSDictionary"
+  mDict := NSMutableDictionary.alloc.initWithContentsOfFile(path); // ERROR: got "NSArray" expected "NSDictionary"
+
+  pool.release;
+end.