+ support for id.anyobjcmethodinscope() calls for Objective-Pascal code,

using standard FPC overload selection logic
  * fixed detection of references to static symbol tables for class
    helpers

git-svn-id: trunk@14234 -

.gitattributes

@@ -8992,6 +8992,10 @@ tests/test/tobjc29.pp svneol=native#text/plain
 tests/test/tobjc29a.pp svneol=native#text/plain
 tests/test/tobjc29b.pp svneol=native#text/plain
 tests/test/tobjc3.pp svneol=native#text/plain
+tests/test/tobjc30.pp svneol=native#text/plain
+tests/test/tobjc30a.pp svneol=native#text/plain
+tests/test/tobjc30b.pp svneol=native#text/plain
+tests/test/tobjc30c.pp svneol=native#text/plain
 tests/test/tobjc4.pp svneol=native#text/plain
 tests/test/tobjc4a.pp svneol=native#text/plain
 tests/test/tobjc5.pp svneol=native#text/plain
@@ -9332,6 +9336,7 @@ tests/test/uobjc24.pp svneol=native#text/plain
 tests/test/uobjc26.pp svneol=native#text/plain
 tests/test/uobjc27a.pp svneol=native#text/plain
 tests/test/uobjc27b.pp svneol=native#text/plain
+tests/test/uobjc30c.pp svneol=native#text/plain
 tests/test/uobjc7.pp svneol=native#text/plain
 tests/test/uobjcl1.pp svneol=native#text/plain
 tests/test/uprec6.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -67,11 +67,11 @@ interface
         FParaLength : smallint;
         FAllowVariant : boolean;
         procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
-        procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
+        procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
-        procedure create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
+        procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
-        function  proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
+        function  proc_add(ps:tprocsym;pd:tprocdef;objcidcall: boolean):pcandidate;
       public
-        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
+        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
         constructor create_operator(op:ttoken;ppn:tnode);
         destructor destroy;override;
         procedure list(all:boolean);
@@ -1610,7 +1610,7 @@ implementation
                            TCallCandidates
 ****************************************************************************}
 
-    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
+    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
       begin
         if not assigned(sym) then
           internalerror(200411015);
@@ -1618,7 +1618,7 @@ implementation
         FProcsym:=sym;
         FProcsymtable:=st;
         FParanode:=ppn;
-        create_candidate_list(ignorevisibility,allowdefaultparas);
+        create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall);
       end;
 
 
@@ -1628,7 +1628,7 @@ implementation
         FProcsym:=nil;
         FProcsymtable:=nil;
         FParanode:=ppn;
-        create_candidate_list(false,false);
+        create_candidate_list(false,false,false);
       end;
 
 
@@ -1685,7 +1685,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
+    procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
       var
         j          : integer;
         pd         : tprocdef;
@@ -1698,10 +1698,15 @@ implementation
         { we search all overloaded operator definitions in the symtablestack. The found
           entries are only added to the procs list and not the procsym, because
           the list can change in every situation }
-        if FOperator<>NOTOKEN then
+        if FOperator=NOTOKEN then
-          hashedid.id:=overloaded_names[FOperator]
+          begin
+            if not objcidcall then
+              hashedid.id:=FProcsym.name
+            else
+              hashedid.id:=class_helper_prefix+FProcsym.name;
+          end
         else
-          hashedid.id:=FProcsym.name;
+          hashedid.id:=overloaded_names[FOperator];
 
         checkstack:=symtablestack.stack;
         if assigned(FProcsymtable) then
@@ -1731,8 +1736,10 @@ implementation
                           hasoverload:=true;
                         ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
                       end;
-                    { when there is no explicit overload we stop searching }
+                    { when there is no explicit overload we stop searching,
-                    if not hasoverload then
+                      except for Objective-C methods called via id }
+                    if not hasoverload and
+                       not objcidcall then
                       break;
                   end;
               end;
@@ -1741,7 +1748,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
+    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
       var
         j     : integer;
         pd    : tprocdef;
@@ -1755,11 +1762,12 @@ implementation
 
         { Find all available overloads for this procsym }
         ProcdefOverloadList:=TFPObjectList.Create(false);
-        if (FOperator=NOTOKEN) and
+        if not objcidcall and
+           (FOperator=NOTOKEN) and
            (FProcsym.owner.symtabletype=objectsymtable) then
           collect_overloads_in_class(ProcdefOverloadList)
         else
-          collect_overloads_in_units(ProcdefOverloadList);
+          collect_overloads_in_units(ProcdefOverloadList,objcidcall);
 
         { determine length of parameter list.
           for operators also enable the variant-operators if
@@ -1823,7 +1831,9 @@ implementation
                 hp:=FCandidateProcs;
                 while assigned(hp) do
                   begin
-                    if compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal then
+                    if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal) and
+                       (not(po_objc in pd.procoptions) or
+                        (pd.messageinf.str^=hp^.data.messageinf.str^)) then
                       begin
                         found:=true;
                         break;
@@ -1831,7 +1841,7 @@ implementation
                     hp:=hp^.next;
                   end;
                 if not found then
-                  proc_add(fprocsym,pd);
+                  proc_add(fprocsym,pd,objcidcall);
               end;
           end;
 
@@ -1839,9 +1849,10 @@ implementation
       end;
 
 
-    function tcallcandidates.proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
+    function tcallcandidates.proc_add(ps:tprocsym;pd:tprocdef;objcidcall: boolean):pcandidate;
       var
         defaultparacnt : integer;
+        parentst        : tsymtable;
       begin
         { generate new candidate entry }
         new(result);
@@ -1868,7 +1879,15 @@ implementation
          end;
         { Give a small penalty for overloaded methods not in
           defined the current class/unit }
-        if ps.owner<>pd.owner then
+        parentst:=ps.owner;
+        {  when calling Objective-C methods via id.method, then the found
+           procsym will be inside an arbitrary ObjectSymtable, and we don't
+           want togive the methods of that particular objcclass precedence over
+           other methods, so instead check against the symtable in which this
+           objcclass is defined }
+        if objcidcall then
+          parentst:=parentst.defowner.owner;
+        if (parentst<>pd.owner) then
           result^.ordinal_distance:=result^.ordinal_distance+1.0;
       end;
 

compiler/ncal.pas

@@ -47,7 +47,8 @@ interface
          cnf_member_call,        { called with implicit methodpointer tree }
          cnf_uses_varargs,       { varargs are used in the declaration }
          cnf_create_failed,      { exception thrown in constructor -> don't call beforedestruction }
-         cnf_objc_processed      { the procedure name has been set to the appropriate objc_msgSend* variant -> don't process again }
+         cnf_objc_processed,     { the procedure name has been set to the appropriate objc_msgSend* variant -> don't process again }
+         cnf_objc_id_call        { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -2538,7 +2539,7 @@ implementation
                   { ignore possible private for properties or in delphi mode for anon. inherited (FK) }
                   ignorevisibility:=(nf_isproperty in flags) or
                                     ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
-                  candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,not(nf_isproperty in flags));
+                  candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags);
 
                    { no procedures found? then there is something wrong
                      with the parameter size or the procedures are

compiler/pexpr.pas

@@ -2086,9 +2086,32 @@ implementation
                          end;
                        pointerdef:
                          begin
-                           Message(parser_e_invalid_qualifier);
+                           if (p1.resultdef=objc_idtype) then
-                           if tpointerdef(p1.resultdef).pointeddef.typ in [recorddef,objectdef,classrefdef] then
+                             begin
-                             Message(parser_h_maybe_deref_caret_missing);
+                               { objc's id type can be used to call any
+                                 Objective-C method of any Objective-C class
+                                 type that's currently in scope }
+                               if search_objc_method(pattern,srsym,srsymtable) then
+                                 begin
+                                   consume(_ID);
+                                   do_proc_call(srsym,srsymtable,nil,
+                                     (getaddr and not(token in [_CARET,_POINT])),
+                                     again,p1,[cnf_objc_id_call]);
+                                   { we need to know which procedure is called }
+                                   do_typecheckpass(p1);
+                                 end
+                               else
+                                 begin
+                                   consume(_ID);
+                                   Message(parser_e_methode_id_expected);
+                                 end;
+                             end
+                           else
+                             begin
+                               Message(parser_e_invalid_qualifier);
+                               if tpointerdef(p1.resultdef).pointeddef.typ in [recorddef,objectdef,classrefdef] then
+                                 Message(parser_h_maybe_deref_caret_missing);
+                             end
                          end;
                        else
                          begin

compiler/symdef.pas

@@ -4140,7 +4140,8 @@ implementation
            tstoredsymtable(symtable).derefimpl;
          { the procdefs are not owned by the class helper procsyms, so they
            are not stored/restored either -> re-add them here }
-         if (oo_is_classhelper in objectoptions) then
+         if (objecttype=odt_objcclass) or
+            (oo_is_classhelper in objectoptions) then
            symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
       end;
 

compiler/symtable.pas

@@ -205,6 +205,7 @@ interface
     function  search_assignment_operator(from_def,to_def:Tdef):Tprocdef;
     function  search_enumerator_operator(type_def:Tdef):Tprocdef;
     function  search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
+    function  search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
     {Looks for macro s (must be given in upper case) in the macrosymbolstack, }
     {and returns it if found. Returns nil otherwise.}
     function  search_macro(const s : string):tsym;
@@ -2060,6 +2061,12 @@ implementation
                     if (oo_is_classhelper in defowner.objectoptions) and
                        pd.is_related(defowner.childof) then
                       begin
+                        { we need to know if a procedure references symbols
+                          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
+                          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
@@ -2069,12 +2076,6 @@ implementation
                         }
                         srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
                         srsymtable:=srsym.owner;
-                        { we need to know if a procedure references symbols
-                          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
-                          include(current_procinfo.flags,pi_uses_static_symtable);
                         addsymref(srsym);
                         result:=true;
                         exit;
@@ -2089,6 +2090,61 @@ implementation
       end;
 
 
+    function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
+      var
+        hashedid   : THashedIDString;
+        stackitem  : psymtablestackitem;
+        i          : longint;
+      begin
+        hashedid.id:=class_helper_prefix+s;
+        stackitem:=symtablestack.stack;
+        while assigned(stackitem) do
+          begin
+            srsymtable:=stackitem^.symtable;
+            srsym:=tsym(srsymtable.FindWithHash(hashedid));
+            if assigned(srsym) then
+              begin
+                if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
+                   not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
+                   (srsym.typ<>procsym) then
+                  internalerror(2009112005);
+                { check whether this procsym includes a helper for this particular class }
+                for i:=0 to tprocsym(srsym).procdeflist.count-1 do
+                  begin
+                    { we need to know if a procedure references symbols
+                      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
+                      include(current_procinfo.flags,pi_uses_static_symtable);
+                    { no need to keep looking. There might be other
+                      methods with the same name, but that doesn't matter
+                      as far as the basic procsym is concerned.
+                    }
+                    srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
+                    { We need the symtable in which the classhelper-like sym
+                      is located, not the objectdef. The reason is that the
+                      callnode will climb the symtablestack until it encounters
+                      this symtable to start looking for overloads (and it won't
+                      find the objectsymtable in which this method sym is
+                      located
+
+                    srsymtable:=srsym.owner;
+                    }
+                    addsymref(srsym);
+                    result:=true;
+                    exit;
+                  end;
+              end;
+            stackitem:=stackitem^.next;
+          end;
+        srsym:=nil;
+        srsymtable:=nil;
+        result:=false;
+      end;
+
+
+
     function search_class_member(pd : tobjectdef;const s : string):tsym;
     { searches n in symtable of pd and all anchestors }
       var

tests/test/tobjc30.pp

@@ -0,0 +1,17 @@
+{ %target=darwin }
+{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
+
+{ Written by Jonas Maebe in 2009, released into the Public Domain }
+
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+var
+  a: id;
+begin
+  a:=NSObject.alloc.init;
+  if a.conformsToProtocol_(objcprotocol(NSObjectProtocol)) then
+    writeln('ok conformsToProtocol')
+  else
+    halt(1);
+end.

tests/test/tobjc30a.pp

@@ -0,0 +1,36 @@
+{ %target=darwin }
+{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
+
+{ Written by Jonas Maebe in 2009, released into the Public Domain }
+
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+type
+  { should succeed because both methods have the same selector }
+  ta = objcclass(NSObject)
+    function proc1(para: longint): longint; message 'proc1:';
+  end;
+
+  tb = objcclass(NSObject)
+    function proc1(para: longint): longint; message 'proc1:';
+  end;
+
+function ta.proc1(para: longint): longint;
+begin
+  writeln(para);
+  proc1:=para;
+end;
+
+function tb.proc1(para: longint): longint;
+begin
+  writeln(para);
+  proc1:=para;
+end;
+
+var
+  a: id;
+begin
+  a:=ta.alloc.init;
+  a.proc1(5);
+end.

tests/test/tobjc30b.pp

@@ -0,0 +1,37 @@
+{ %target=darwin }
+{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
+{ %fail }
+
+{ Written by Jonas Maebe in 2009, released into the Public Domain }
+
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+type
+  { should succeed because both methods have the same selector }
+  ta = objcclass(NSObject)
+    function proc1(para: longint): longint; message 'proc1:';
+  end;
+
+  tb = objcclass(NSObject)
+    function proc1(para: longint): longint; message 'anotherselector:';
+  end;
+
+function ta.proc1(para: longint): longint;
+begin
+  writeln(para);
+  proc1:=para;
+end;
+
+function tb.proc1(para: longint): longint;
+begin
+  writeln(para);
+  proc1:=para;
+end;
+
+var
+  a: id;
+begin
+  a:=ta.alloc.init;
+  a.proc1(5);
+end.

tests/test/tobjc30c.pp

@@ -0,0 +1,31 @@
+{ %target=darwin }
+{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
+
+{ Written by Jonas Maebe in 2009, released into the Public Domain }
+
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+uses
+  uobjc30c;
+
+type
+  tla = objcclass(NSObject)
+    function mytest(const c: shortstring): longint; message 'mystest:';
+  end;
+
+function tla.mytest(const c: shortstring): longint;
+begin
+  halt(1);
+  result:=-1;
+end;
+
+var
+  a: id;
+begin
+  a:=ta.alloc.init;
+  ta(a).field:=123;
+  if (a.mytest('c')<>123) then
+    halt(2);
+  a.release
+end.

tests/test/uobjc30c.pp

@@ -0,0 +1,24 @@
+{$mode objfpc}
+{$modeswitch objectivec1}
+
+{ Written by Jonas Maebe in 2009, released into the public domain }
+
+unit uobjc30c;
+
+interface
+
+type
+  ta = objcclass(NSObject)
+    field: longint;
+    function mytest(c: char): longint; message 'mystest:';
+  end;
+
+implementation
+
+function ta.mytest(c: char): longint;
+begin
+  writeln(c);
+  result:=field;
+end;
+
+end.