* implement support for the Objective-C "related result type" convention

as described on
    http://releases.llvm.org/8.0.0/tools/clang/docs/LanguageExtensions.html#objective-c-features
    (rest of mantis #35994)

git-svn-id: trunk@42816 -

.gitattributes

@@ -15415,6 +15415,7 @@ tests/test/units/classes/tstringlistexchange.pp svneol=native#text/pascal
 tests/test/units/classes/ttbits.pp svneol=native#text/pascal
 tests/test/units/classes/ttlist.pp svneol=native#text/plain
 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

@@ -2505,6 +2505,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

@@ -3864,6 +3864,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

@@ -539,6 +539,52 @@ implementation
         consume(_RECKKLAMMER);
       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;var rtti_attrs_def: trtti_attribute_list);
 
       function determine_generic_def(name:tidstring):tstoreddef;
@@ -1057,7 +1103,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

@@ -420,7 +420,9 @@ type
     po_noinline,
     { same as po_varargs, but with an array-of-const parameter instead of with the
       "varargs" modifier or Mac-Pascal ".." parameter }
-    po_variadic
+    po_variadic,
+    { implicitly return same type as the class instance to which the message is sent }
+    po_objc_related_result_type
   );
   tprocoptions=set of tprocoption;
 
@@ -1064,7 +1066,8 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
       'po_is_auto_getter',{po_is_auto_getter}
       'po_is_auto_setter',{po_is_auto_setter}
       'po_noinline',{po_noinline}
-      'C-style array-of-const' {po_variadic}
+      'C-style array-of-const', {po_variadic}
+      'objc-related-result-type' {po_objc_related_result_type}
     );
 
 implementation

compiler/utils/ppuutils/ppudump.pp

@@ -2951,7 +2951,8 @@ const
      (mask:po_is_auto_getter;  str: 'Automatically generated getter'),
      (mask:po_is_auto_setter;  str: 'Automatically generated setter'),
      (mask:po_noinline;        str: 'Never inline'),
-     (mask:po_variadic;        str: 'C VarArgs with array-of-const para')
+     (mask:po_variadic;        str: 'C VarArgs with array-of-const para'),
+     (mask:po_objc_related_result_type; str: 'Objective-C related result type')
   );
 var
   proctypeoption  : tproctypeoption;

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.