paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 13:28:05 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

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

git-svn-id: trunk@14234 -
This commit is contained in:
Jonas Maebe 2009-11-21 00:14:21 +00:00
parent 9d5b597105
commit af85e45b67
11 changed files with 282 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

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

59
compiler/htypechk.pas
View File

@ -67,11 +67,11 @@ interface
FParaLength : smallint;
FAllowVariant : boolean;
procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
procedure create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
function proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
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
hashedid.id:=overloaded_names[FOperator]
if FOperator=NOTOKEN then
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 }
if not hasoverload then
{ when there is no explicit overload we stop searching,
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;

5
compiler/ncal.pas
View File

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

29
compiler/pexpr.pas
View File

@ -2086,9 +2086,32 @@ implementation
end;
pointerdef:
begin
Message(parser_e_invalid_qualifier);
if tpointerdef(p1.resultdef).pointeddef.typ in [recorddef,objectdef,classrefdef] then
Message(parser_h_maybe_deref_caret_missing);
if (p1.resultdef=objc_idtype) then
begin
{ 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

3
compiler/symdef.pas
View File

@ -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;

68
compiler/symtable.pas
View File

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

17
tests/test/tobjc30.pp Normal file
View File

@ -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.

36
tests/test/tobjc30a.pp Normal file
View File

@ -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.

37
tests/test/tobjc30b.pp Normal file
View File

@ -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.

31
tests/test/tobjc30c.pp Normal file
View File

@ -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.

24
tests/test/uobjc30c.pp Normal file
View File

@ -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.