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

+ Objective-C category support (old and new ABI, both external and

Browse Source 
implemented in Pascal). See
    http://wiki.freepascal.org/FPC_PasCocoa#Category_declaration for syntax
    details

git-svn-id: trunk@14196 -
This commit is contained in:
Jonas Maebe 2009-11-16 00:12:08 +00:00
parent 9e87f42b16
commit f8754d8fab
27 changed files with 1330 additions and 525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.gitattributes vendored
View File

@ -8963,6 +8963,13 @@ tests/test/tobjc20.pp svneol=native#text/plain
tests/test/tobjc21.pp svneol=native#text/plain
tests/test/tobjc22.pp svneol=native#text/plain
tests/test/tobjc23.pp svneol=native#text/plain
tests/test/tobjc24.pp svneol=native#text/plain
tests/test/tobjc25.pp svneol=native#text/plain
tests/test/tobjc26.pp svneol=native#text/plain
tests/test/tobjc26a.pp svneol=native#text/plain
tests/test/tobjc27a.pp svneol=native#text/plain
tests/test/tobjc27b.pp svneol=native#text/plain
tests/test/tobjc28.pp svneol=native#text/plain
tests/test/tobjc3.pp svneol=native#text/plain
tests/test/tobjc4.pp svneol=native#text/plain
tests/test/tobjc4a.pp svneol=native#text/plain
@ -9300,6 +9307,10 @@ tests/test/units/sysutils/tfloattostr.pp svneol=native#text/plain
tests/test/units/sysutils/tlocale.pp svneol=native#text/plain
tests/test/units/sysutils/tsscanf.pp svneol=native#text/plain
tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
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/uobjc7.pp svneol=native#text/plain
tests/test/uobjcl1.pp svneol=native#text/plain
tests/test/uprec6.pp svneol=native#text/plain

43
compiler/msg/errore.msg
View File

@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
#
# Parser
#
# 03275 is the last used one
# 03280 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -913,11 +913,11 @@ parser_e_no_con_des_in_interfaces=03171_E_Con- and destructors aren't allowed in
% be used to create a new interface.
parser_e_no_access_specifier_in_interfaces=03172_E_Access specifiers can't be used in INTERFACEs and OBJCPROTOCOLs
% The access specifiers \var{public}, \var{private}, \var{protected} and
% \var{published} can't be used in interfaces and Objective-C protocols because all methods
% of an interface/protocol must be public.
parser_e_no_vars_in_interfaces=03173_E_An interface or Objective-C protocol cannot contain fields
% Declarations of fields are not allowed in interfaces and Objective-C protocols. An interface/protocol
% can contain only methods and properties with method read/write specifiers.
% \var{published} can't be used in interfaces, Objective-C protocols and categories because all methods
% of an interface/protocol/category must be public.
parser_e_no_vars_in_interfaces=03173_E_An interface or Objective-C protocol or category cannot contain fields
% Declarations of fields are not allowed in interfaces and Objective-C protocols and categories.
% An interface/protocol/category can contain only methods and properties with method read/write specifiers.
parser_e_no_local_proc_external=03174_E_Can't declare local procedure as EXTERNAL
% Declaring local procedures as external is not possible. Local procedures
% get hidden parameters that will make the chance of errors very high.
@ -992,7 +992,7 @@ parser_e_illegal_calling_convention=03195_W_Calling convention directive ignored
% Some calling conventions are supported only by certain CPUs. I.e. most non-i386 ports support
% only the standard ABI calling convention of the CPU.
parser_e_no_object_reintroduce=03196_E_REINTRODUCE can't be used in objects
% \var{reintroduce} is not supported for objects.
% \var{reintroduce} is not supported for objects, Objective-C classes and Objective-C protocols.
parser_e_paraloc_only_one_para=03197_E_Each argument must have its own location
% If locations for arguments are specified explicitly as it is required by
% some syscall conventions, each argument must have its own location. Things
@ -1245,13 +1245,13 @@ parser_e_no_objc_published=03271_E_Objective-C classes cannot have published sec
parser_f_need_objc=03272_F_This module requires an Objective-C mode switch to be compiled
% This error indicates the use of Objective-C language features without an Objective-C mode switch
% active. Enable one via the -M command line switch, or the {\$modeswitch x} directive.
parser_e_must_use_override_objc=03273_E_Inherited methods can only be overridden in Objective-C, add ``override''.
parser_h_should_use_override_objc=03274_H_Inherited methods can only be overridden in Objective-C, add ``override''.
% It is not possible to ``reintroduce'' methods in Objective-C like in Object Pascal. Methods with the same
parser_e_must_use_override_objc=03273_E_Inherited methods can only be overridden in Objective-C, add "override".
parser_h_should_use_override_objc=03274_H_Inherited methods can only be overridden in Objective-C, add "override".
% It is not possible to \var{reintroduce} methods in Objective-C like in Object Pascal. Methods with the same
% name always map to the same virtual method entry. In order to make this clear in the source code,
% the compiler always requires the ``override'' directive to be specified when implementing overriding
% the compiler always requires the \var{override} directive to be specified when implementing overriding
% Objective-C methods in Pascal. If the implementation is external, this rule is relaxed because Objective-C
% does not have any ``override''-style keyword (since it's the default and only behaviour in that language),
% does not have any \var{override}-style keyword (since it's the default and only behaviour in that language),
% which makes it hard for automated header conversion tools to include it everywhere.
parser_e_objc_message_name_changed=03275_E_Message name "$1" in inherited class is different from message name "$2" in current class.
% An overriding Objective-C method cannot have a different message name than an inherited method. The reason
@ -1260,11 +1260,24 @@ parser_e_objc_message_name_changed=03275_E_Message name "$1" in inherited class
parser_e_no_objc_unique=03276_E_It is not yet possible to make unique copies of Objective-C types
% Duplicating an Objective-C type using \var{type x = type y;} is not yet supported. You may be able to
% obtain the desired effect using \var{type x = objcclass(y) end;} instead.
parser_e_no_category_as_types=03277_E_Objective-C categories cannot be used as types
% It is not possible to declare a variable as an instance of an Objective-C category. A
% category adds methods to the scope of an existing class, but does not define a type by itself.
parser_e_no_category_override=03278_E_Categories do not override, but replace methods. Use "reintroduce" instead.
parser_e_must_use_reintroduce_objc=03279_E_Replaced methods can only be reintroduced in Objective-C, add "reintroduce".
parser_h_should_use_reintroduce_objc=03280_H_Replaced methods can only be reintroduced in Objective-C, add "reintroduce".
% A category replaces an existing method in an Objective-C class, rather than that it overrides it.
% Calling an inherited method from an category method will call that method in
% the extended class' parent, not in the extended class itself. The
% replaced method in the original class is basically lost, and can no longer be
% called or referred to. This behaviour corresponds somewhat more closely to
% \var{reintroduce} than to \var{override} (although in case of \var{reintroduce}
% in Object Pascal, hidden methods are still reachable via inherited).
% \end{description}
#
# Type Checking
#
# 04093 is the last used one
# 04094 is the last used one
#
% \section{Type checking errors}
% This section lists all errors that can occur when type checking is
@ -1578,7 +1591,9 @@ type_e_objc_type_unsupported=04092_E_The type "$1" is not supported for interact
% interfaces) cannot be used as fields of Objective-C classes, cannot be
% directly passed to Objective-C methods, and cannot be encoded using \var{objc_encode}.
type_e_class_or_objcclass_type_expected=04093_E_Class or objcclass type expected, but got "$1"
% It is only possible to create class reference types of \var{class} and
% It is only possible to create class reference types of \var{class} and \var{objcclass}
type_e_objcclass_type_expected=04094_E_Objcclass type expected
% The compiler expected an Objc
% \var{objcclass} types
%
% \end{description}

9
compiler/msgidx.inc
View File

@ -364,6 +364,10 @@ const
parser_h_should_use_override_objc=03274;
parser_e_objc_message_name_changed=03275;
parser_e_no_objc_unique=03276;
parser_e_no_category_as_types=03277;
parser_e_no_category_override=03278;
parser_e_must_use_reintroduce_objc=03279;
parser_h_should_use_reintroduce_objc=03280;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -448,6 +452,7 @@ const
type_e_protocol_type_expected=04091;
type_e_objc_type_unsupported=04092;
type_e_class_or_objcclass_type_expected=04093;
type_e_objcclass_type_expected=04094;
sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002;
@ -827,9 +832,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 54197;
MsgTxtSize = 54546;
MsgIdxMax : array[1..20] of longint=(
24,87,277,94,71,51,108,22,202,62,
24,87,281,95,71,51,108,22,202,62,
48,20,1,1,1,1,1,1,1,1
);

786
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

18
compiler/nobj.pas
View File

@ -281,8 +281,12 @@ implementation
if (po_virtualmethod in vmtpd.procoptions) and
(
not(po_virtualmethod in pd.procoptions) or
{ new one has not override }
(is_class_or_interface_or_objc(_class) and not(po_overridingmethod in pd.procoptions))
(
{ new one does not have reintroduce in case of an objccategory }
(is_objccategory(_class) and not(po_reintroduce in pd.procoptions)) or
{ new one does not have override in case of objpas/objc class/intf/proto }
(is_class_or_interface_or_objc(_class) and not is_objccategory(_class) and not(po_overridingmethod in pd.procoptions))
)
) then
begin
if (
@ -305,12 +309,18 @@ implementation
because requiring override everywhere may make
automated header translation tools too complex. }
if not(oo_is_external in _class.objectoptions) then
MessagePos1(pd.fileinfo,parser_e_must_use_override_objc,pd.fullprocname(false))
if not is_objccategory(_class) then
MessagePos1(pd.fileinfo,parser_e_must_use_override_objc,pd.fullprocname(false))
else
MessagePos1(pd.fileinfo,parser_e_must_use_reintroduce_objc,pd.fullprocname(false))
{ there may be a lot of these in auto-translated
heaeders, so only calculate the fullprocname if
the hint will be shown }
else if CheckVerbosity(V_Hint) then
MessagePos1(pd.fileinfo,parser_h_should_use_override_objc,pd.fullprocname(false));
if not is_objccategory(_class) then
MessagePos1(pd.fileinfo,parser_h_should_use_override_objc,pd.fullprocname(false))
else
MessagePos1(pd.fileinfo,parser_h_should_use_reintroduce_objc,pd.fullprocname(false));
{ no new entry, but copy the message name if any from
the procdef in the parent class }
check_msg_str(vmtpd,pd);

241
compiler/objcgutl.pas
View File

@ -56,13 +56,16 @@ implementation
tobjcrttiwriter = class
protected
fabi: tobjcabi;
classdefs: tfpobjectlist;
classsyms: tfpobjectlist;
classdefs,
catdefs: tfpobjectlist;
classsyms,
catsyms: tfpobjectlist;
procedure gen_objc_methods(list: tasmlist; objccls: tobjectdef; out methodslabel: tasmlabel; classmethods, iscategory: Boolean);
procedure gen_objc_protocol_list(list:TAsmList; protolist: TFPObjectList; out protolistsym: TAsmLabel);
procedure gen_objc_cat_methods(list:TAsmList; items: TFPObjectList; section: tasmsectiontype;const sectname: string; out listsym: TAsmLabel);
procedure gen_objc_protocol(list:TAsmList; protocol: tobjectdef; out protocollabel: TAsmSymbol);virtual;abstract;
procedure gen_objc_category_sections(list:TAsmList; objccat: tobjectdef; out catlabel: TAsmSymbol);virtual;abstract;
procedure gen_objc_classes_sections(list:TAsmList; objclss: tobjectdef; out classlabel: TAsmSymbol);virtual;abstract;
procedure gen_objc_info_sections(list: tasmlist);virtual;abstract;
public
@ -78,6 +81,7 @@ implementation
protected
procedure gen_objc_ivars(list: TAsmList; objccls: tobjectdef; out ivarslabel: TAsmLabel);
procedure gen_objc_protocol(list:TAsmList; protocol: tobjectdef; out protocollabel: TAsmSymbol);override;
procedure gen_objc_category_sections(list:TAsmList; objccat: tobjectdef; out catlabel: TAsmSymbol);override;
procedure gen_objc_classes_sections(list:TAsmList; objclss: tobjectdef; out classlabel: TAsmSymbol);override;
procedure gen_objc_info_sections(list: tasmlist);override;
public
@ -96,6 +100,7 @@ implementation
procedure gen_objc_ivars(list: TAsmList; objccls: tobjectdef; out ivarslabel: TAsmLabel);
procedure gen_objc_protocol(list:TAsmList; protocol: tobjectdef; out protocollabel: TAsmSymbol);override;
procedure gen_objc_category_sections(list:TAsmList; objccat: tobjectdef; out catlabel: TAsmSymbol);override;
procedure gen_objc_classes_sections(list:TAsmList; objclss: tobjectdef; out classlabel: TAsmSymbol);override;
procedure gen_objc_info_sections(list: tasmlist);override;
public
@ -277,7 +282,7 @@ procedure tobjcrttiwriter.gen_objc_methods(list: tasmlist; objccls: tobjectdef;
for i:=0 to objccls.vmtentries.count-1 do
begin
def:=pvmtentry(objccls.vmtentries[i])^.procdef;
if Assigned(def.procstarttai) and
if (def.owner.defowner=objccls) and
(classmethods = (po_classmethod in def.procoptions)) then
begin
defs[mcnt].def:=def;
@ -290,9 +295,9 @@ procedure tobjcrttiwriter.gen_objc_methods(list: tasmlist; objccls: tobjectdef;
exit;
if iscategory then
new_section(list,clsSectType[classmethods],clsSectName[classmethods],sizeof(ptrint))
new_section(list,catSectType[classmethods],catSectName[classmethods],sizeof(ptrint))
else
new_section(list,catSectType[classmethods],catSectName[classmethods],sizeof(ptrint));
new_section(list,clsSectType[classmethods],clsSectName[classmethods],sizeof(ptrint));
current_asmdata.getlabel(methodslabel,alt_data);
list.Concat(tai_label.Create(methodslabel));
@ -441,9 +446,18 @@ procedure tobjcrttiwriter.gen_objc_rtti_sections(list:TAsmList; st:TSymtable);
if is_objcclass(def) and
not(oo_is_external in tobjectdef(def).objectoptions) then
begin
gen_objc_classes_sections(list,tobjectdef(def),sym);
classsyms.add(sym);
classdefs.add(def);
if not(oo_is_classhelper in tobjectdef(def).objectoptions) then
begin
gen_objc_classes_sections(list,tobjectdef(def),sym);
classsyms.add(sym);
classdefs.add(def);
end
else
begin
gen_objc_category_sections(list,tobjectdef(def),sym);
catsyms.add(sym);
catdefs.add(def);
end
end;
end;
end;
@ -454,6 +468,8 @@ constructor tobjcrttiwriter.create(_abi: tobjcabi);
fabi:=_abi;
classdefs:=tfpobjectlist.create(false);
classsyms:=tfpobjectlist.create(false);
catdefs:=tfpobjectlist.create(false);
catsyms:=tfpobjectlist.create(false);
end;
@ -461,6 +477,8 @@ destructor tobjcrttiwriter.destroy;
begin
classdefs.free;
classsyms.free;
catdefs.free;
catsyms.free;
inherited destroy;
end;
@ -584,6 +602,61 @@ procedure tobjcrttiwriter_fragile.gen_objc_protocol(list:TAsmList; protocol: tob
end;
(*
From Clang:
struct _objc_category {
char *category_name;
char *class_name;
struct _objc_method_list *instance_methods;
struct _objc_method_list *class_methods;
struct _objc_protocol_list *protocols;
uint32_t size; // <rdar://4585769>
struct _objc_property_list *instance_properties;
};
*)
{ Generate rtti for an Objective-C class and its meta-class. }
procedure tobjcrttiwriter_fragile.gen_objc_category_sections(list:TAsmList; objccat: tobjectdef; out catlabel: TAsmSymbol);
var
instmthdlist,
clsmthdlist,
protolistsym : TAsmLabel;
catstrsym,
clsstrsym,
catsym : TAsmSymbol;
begin
{ the category name }
catstrsym:=objcreatestringpoolentry(objccat.objextname^,sp_objcclassnames,sec_objc_class_names);
{ the name of the class it extends }
clsstrsym:=objcreatestringpoolentry(objccat.childof.objextname^,sp_objcclassnames,sec_objc_class_names);
{ generate the methods lists }
gen_objc_methods(list,objccat,instmthdlist,false,true);
gen_objc_methods(list,objccat,clsmthdlist,true,true);
{ generate implemented protocols list }
gen_objc_protocol_list(list,objccat.ImplementedInterfaces,protolistsym);
{ category declaration section }
new_section(list,sec_objc_category,'_OBJC_CATEGORY',sizeof(pint));
catsym:=current_asmdata.DefineAsmSymbol(objccat.rtti_mangledname(objcclassrtti),AB_LOCAL,AT_DATA);
list.Concat(tai_symbol.Create(catsym,0));
list.Concat(Tai_const.Create_sym(catstrsym));
list.Concat(Tai_const.Create_sym(clsstrsym));
ConcatSymOrNil(list,instmthdlist);
ConcatSymOrNil(list,clsmthdlist);
ConcatSymOrNil(list,protolistsym);
{ size of this structure }
list.Concat(Tai_const.Create_32bit(28));
{ properties, not yet supported }
list.Concat(Tai_const.Create_32bit(0));
catlabel:=catsym;
end;
(*
From Clang:
@ -604,6 +677,8 @@ From Clang:
};
*)
{ Generate rtti for an Objective-C class and its meta-class. }
procedure tobjcrttiwriter_fragile.gen_objc_classes_sections(list:TAsmList; objclss: tobjectdef; out classlabel: TAsmSymbol);
const
@ -705,7 +780,7 @@ procedure tobjcrttiwriter_fragile.gen_objc_classes_sections(list:TAsmList; objcl
clssym:=current_asmdata.DefineAsmSymbol(objclss.rtti_mangledname(objcclassrtti),AB_LOCAL,AT_DATA);
list.Concat(tai_symbol.Create(clssym,0));
{ for class declaration: the is points to the meta-class declaration }
{ for class declaration: the isa points to the meta-class declaration }
list.Concat(Tai_const.Create_sym(metasym));
{ pointer to the super_class name if any, nil otherwise }
if assigned(superStrSym) then
@ -752,7 +827,8 @@ procedure tobjcrttiwriter_fragile.gen_objc_info_sections(list: tasmlist);
parent: tobjectdef;
superclasses: tfpobjectlist;
begin
if (classsyms.count<>0) then
if (classsyms.count<>0) or
(catsyms.count<>0) then
begin
new_section(list,sec_objc_symbols,'_OBJC_SYMBOLS',sizeof(pint));
sym := current_asmdata.DefineAsmSymbol(target_asm.labelprefix+'_OBJC_SYMBOLS_$',AB_LOCAL,AT_DATA);
@ -766,11 +842,13 @@ procedure tobjcrttiwriter_fragile.gen_objc_info_sections(list: tasmlist);
{ From Clang: number of defined classes }
list.Concat(Tai_const.Create_16bit(classsyms.count));
{ From Clang: number of defined categories }
list.Concat(Tai_const.Create_16bit(0));
list.Concat(Tai_const.Create_16bit(catsyms.count));
{ first all classes }
for i:=0 to classsyms.count-1 do
list.Concat(Tai_const.Create_sym(tasmsymbol(classsyms[i])));
{ then all categories }
for i:=0 to catsyms.count-1 do
list.Concat(Tai_const.Create_sym(tasmsymbol(catsyms[i])));
end
else
sym:=nil;
@ -801,10 +879,25 @@ procedure tobjcrttiwriter_fragile.gen_objc_info_sections(list: tasmlist);
superclasses.add(parent);
end;
end;
for i:=0 to catdefs.count-1 do
begin
parent:=tobjectdef(catdefs[i]).childof;
{ warning: linear search, performance hazard if large number of subclasses }
if assigned(parent) and
(superclasses.indexof(parent)=-1) then
begin
list.concat(tai_directive.create(asd_lazy_reference,'.objc_class_name_'+parent.objextname^));
superclasses.add(parent);
end;
end;
superclasses.free;
{ reference symbols for all classes defined in this unit }
{ reference symbols for all classes and categories defined in this unit }
for i:=0 to classdefs.count-1 do
list.concat(tai_symbol.Createname_global_value('.objc_class_name_'+tobjectdef(classdefs[i]).objextname^,AT_DATA,0,0));
for i:=0 to catdefs.count-1 do
list.concat(tai_symbol.Createname_global_value('.objc_category_name_'+
tobjectdef(catdefs[i]).childof.objextname^+'_'+
tobjectdef(catdefs[i]).objextname^,AT_DATA,0,0));
end;
@ -1043,6 +1136,55 @@ procedure tobjcrttiwriter_nonfragile.gen_objc_protocol(list: tasmlist; protocol:
list.Concat(tai_directive.Create(asd_weak_definition,listsym.name));
end;
(*
From Clang:
/// struct _category_t {
/// const char * const name;
/// struct _class_t *const cls;
/// const struct _method_list_t * const instance_methods;
/// const struct _method_list_t * const class_methods;
/// const struct _protocol_list_t * const protocols;
/// const struct _prop_list_t * const properties;
/// }
*)
procedure tobjcrttiwriter_nonfragile.gen_objc_category_sections(list:TAsmList; objccat: tobjectdef; out catlabel: TAsmSymbol);
var
instmthdlist,
clsmthdlist,
protolistsym : TAsmLabel;
catstrsym,
clssym,
catsym : TAsmSymbol;
begin
{ the category name }
catstrsym:=objcreatestringpoolentry(objccat.objextname^,sp_objcclassnames,sec_objc_class_names);
{ the class it extends }
clssym:=current_asmdata.RefAsmSymbol(objccat.childof.rtti_mangledname(objcclassrtti));
{ generate the methods lists }
gen_objc_methods(list,objccat,instmthdlist,false,true);
gen_objc_methods(list,objccat,clsmthdlist,true,true);
{ generate implemented protocols list }
gen_objc_protocol_list(list,objccat.ImplementedInterfaces,protolistsym);
{ category declaration section }
new_section(list,sec_objc_const,'_OBJC_CATEGORY',sizeof(pint));
catsym:=current_asmdata.DefineAsmSymbol(objccat.rtti_mangledname(objcclassrtti),AB_LOCAL,AT_DATA);
list.Concat(tai_symbol.Create(catsym,0));
list.Concat(Tai_const.Create_sym(catstrsym));
list.Concat(Tai_const.Create_sym(clssym));
ConcatSymOrNil(list,instmthdlist);
ConcatSymOrNil(list,clsmthdlist);
ConcatSymOrNil(list,protolistsym);
{ properties, not yet supported }
list.Concat(Tai_const.Create_pint(0));
catlabel:=catsym;
end;
(*
From Clang:
@ -1363,45 +1505,58 @@ procedure tobjcrttiwriter_nonfragile.addclasslist(list: tasmlist; section: tasms
procedure tobjcrttiwriter_nonfragile.gen_objc_info_sections(list: tasmlist);
function collectnonlazyclasses(classes: tfpobjectlist): tfpobjectlist;
var
symentry : tsym;
procdef : tprocdef;
i,j : longint;
begin
{ non-lazy classes are all classes that define a class method with the
selector called "load" (simply inheriting this class method is not enough,
they have to implement it themselves)
-- TODO: this currently only works if the Pascal identifier is also 'load'! }
result:=tfpobjectlist.create(false);
for i:=0 to classes.count-1 do
begin
symentry:=tsym(tobjectsymtable(tobjectdef(classes[i]).symtable).find('LOAD'));
if assigned(symentry) and
(symentry.typ=procsym) then
begin
for j:=0 to tprocsym(symentry).ProcdefList.count do
begin
procdef:=tprocdef(tprocsym(symentry).ProcdefList[0]);
if ((po_classmethod in procdef.procoptions) and
(procdef.messageinf.str^='load')) then
begin
result.add(classes[i]);
break;
end;
end;
end;
end;
end;
var
i,j : longint;
symentry : tsym;
procdef : tprocdef;
nonlazyclasses : tfpobjectlist;
nonlazyclasses,
nonlazycategories : tfpobjectlist;
begin
if (classsyms.count=0) then
if (classdefs.count=0) and
(catdefs.count=0) then
exit;
{ non-lazy classes are all classes that define a class method with the
selector called "load" (simply inheriting this class method is not enough,
they have to implement it themselves)
-- TODO: this currently only works if the Pascal identifier is also 'load'! }
nonlazyclasses:=tfpobjectlist.create(false);
for i:=0 to classdefs.count-1 do
begin
symentry:=tsym(tobjectsymtable(tobjectdef(classdefs[i]).symtable).find('LOAD'));
if assigned(symentry) and
(symentry.typ=procsym) then
begin
for j:=0 to tprocsym(symentry).ProcdefList.count do
begin
procdef:=tprocdef(tprocsym(symentry).ProcdefList[0]);
if ((po_classmethod in procdef.procoptions) and
(procdef.messageinf.str^='load')) then
begin
nonlazyclasses.add(classdefs[i]);
break;
end;
end;
end;
end;
nonlazyclasses:=collectnonlazyclasses(classdefs);
nonlazycategories:=collectnonlazyclasses(catdefs);
{ this list has to include all classes, also the non-lazy ones }
addclasslist(list,sec_objc_classlist,target_asm.labelprefix+'_OBJC_LABEL_CLASS_$',classdefs);
addclasslist(list,sec_objc_nlclasslist,target_asm.labelprefix+'_OBJC_LABEL_NONLAZY_CLASS_$',nonlazyclasses);
{ TODO: category and non-lazy category lists }
{ category and non-lazy category lists }
addclasslist(list,sec_objc_catlist,target_asm.labelprefix+'_OBJC_LABEL_CATEGORY_$',catdefs);
addclasslist(list,sec_objc_nlcatlist,target_asm.labelprefix+'_OBJC_LABEL_NONLAZY_CATEGORY_$',nonlazycategories);
nonlazyclasses.free;
nonlazycategories.free;
{ the non-fragile abi doesn't have any module info, nor lazy references
to used classes or to parent classes }
end;
@ -1431,7 +1586,7 @@ procedure MaybeGenerateObjectiveCImageInfo(globalst, localst: tsymtable);
current_asmdata.asmlists[al_objc_data].concat(Tai_symbol.Createname(target_asm.labelprefix+'_OBJC_IMAGE_INFO',AT_LABEL,sizeof(pint)));
current_asmdata.asmlists[al_objc_data].concat(Tai_const.Create_64bit(0));
{ generate rtti for all obj-c classes, protocols and categories (todo)
{ generate rtti for all obj-c classes, protocols and categories
defined in this module. }
if not(target_info.system in system_objc_nfabi) then
objcrttiwriter:=tobjcrttiwriter_fragile.create

50
compiler/objcutil.pas
View File

@ -117,11 +117,22 @@ end;
objcsuperclassnode
*******************************************************************}
function objcloadbasefield(n: tnode; const fieldname: string): tnode;
var
vs : tsym;
begin
result:=ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(n,voidpointertype)),objc_objecttype);
vs:=tsym(tabstractrecorddef(objc_objecttype).symtable.Find(fieldname));
if not assigned(vs) or
(vs.typ<>fieldvarsym) then
internalerror(200911301);
result:=csubscriptnode.create(vs,result);
end;
function objcsuperclassnode(def: tdef): tnode;
var
para : tcallparanode;
class_type : tdef;
vs : tsym;
begin
{ only valid for Objective-C classes and classrefs }
if not is_objcclass(def) and
@ -131,11 +142,30 @@ end;
requires extra node types. Maybe later. }
if is_objcclassref(def) then
begin
para:=ccallparanode.create(cstringconstnode.createstr(tobjectdef(tclassrefdef(def).pointeddef).objextname^),nil);
result:=ccallnode.createinternfromunit('OBJC','OBJC_GETMETACLASS',para);
if (oo_is_classhelper in tobjectdef(tclassrefdef(def).pointeddef).objectoptions) then
begin
{ in case we are in a category method, we need the metaclass of the
superclass class extended by this category (= metaclass of superclass of superclass) }
result:=cloadvmtaddrnode.create(ctypenode.create(tobjectdef(tclassrefdef(def).pointeddef).childof.childof));
result:=objcloadbasefield(result,'ISA');
typecheckpass(result);
{ we're done }
exit;
end
else
begin
{ otherwise we need the superclass of the metaclass }
para:=ccallparanode.create(cstringconstnode.createstr(tobjectdef(tclassrefdef(def).pointeddef).objextname^),nil);
result:=ccallnode.createinternfromunit('OBJC','OBJC_GETMETACLASS',para);
end
end
else
result:=cloadvmtaddrnode.create(ctypenode.create(def));
begin
if not(oo_is_classhelper in tobjectdef(def).objectoptions) then
result:=cloadvmtaddrnode.create(ctypenode.create(def))
else
result:=cloadvmtaddrnode.create(ctypenode.create(tobjectdef(def).childof))
end;
{$if defined(onlymacosx10_6) or defined(arm) }
{ For the non-fragile ABI, the superclass send2 method itself loads the
@ -145,15 +175,7 @@ end;
(but also on all iPhone SDK revisions we support) }
if not(target_info.system in system_objc_nfabi) then
{$endif onlymacosx10_6 or arm}
begin
class_type:=search_named_unit_globaltype('OBJC','OBJC_OBJECT').typedef;
result:=ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(result,voidpointertype)),class_type);
vs:=tsym(tabstractrecorddef(class_type).symtable.Find('SUPERCLASS'));
if not assigned(vs) or
(vs.typ<>fieldvarsym) then
internalerror(200909301);
result:=csubscriptnode.create(vs,result);
end;
result:=objcloadbasefield(result,'SUPERCLASS');
typecheckpass(result);
end;

6
compiler/pdecl.pas
View File

@ -440,7 +440,8 @@ implementation
(token=_INTERFACE) or
(token=_DISPINTERFACE) or
(token=_OBJCCLASS) or
(token=_OBJCPROTOCOL)) and
(token=_OBJCPROTOCOL) or
(token=_OBJCCATEGORY)) and
(assigned(ttypesym(sym).typedef)) and
is_class_or_interface_or_dispinterface_or_objc(ttypesym(sym).typedef) and
(oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
@ -455,7 +456,8 @@ implementation
objecttype:=odt_interfacecorba;
_DISPINTERFACE :
objecttype:=odt_dispinterface;
_OBJCCLASS :
_OBJCCLASS,
_OBJCCATEGORY :
objecttype:=odt_objcclass;
_OBJCPROTOCOL :
objecttype:=odt_objcprotocol;

44
compiler/pdecobj.pas
View File

@ -313,15 +313,20 @@ implementation
hasparentdefined:=false;
{ reads the parent class }
if try_to_consume(_LKLAMMER) then
if (token=_LKLAMMER) or
is_objccategory(current_objectdef) then
begin
consume(_LKLAMMER);
{ use single_type instead of id_type for specialize support }
single_type(hdef,false,false);
if (not assigned(hdef)) or
(hdef.typ<>objectdef) then
begin
if assigned(hdef) then
Message1(type_e_class_type_expected,hdef.typename);
Message1(type_e_class_type_expected,hdef.typename)
else if is_objccategory(current_objectdef) then
{ a category must specify the class to extend }
Message(type_e_objcclass_type_expected);
end
else
begin
@ -358,13 +363,20 @@ implementation
if not(is_cppclass(childof)) then
Message(parser_e_mix_of_classes_and_objects);
odt_objcclass:
if not(is_objcclass(childof)) then
if not(is_objcclass(childof) or
is_objccategory(childof)) then
begin
if is_objcprotocol(childof) then
begin
intfchildof:=childof;
childof:=nil;
CGMessage(parser_h_no_objc_parent);
if not(oo_is_classhelper in current_objectdef.objectoptions) then
begin
intfchildof:=childof;
childof:=nil;
CGMessage(parser_h_no_objc_parent);
end
else
{ a category must specify the class to extend }
CGMessage(type_e_objcclass_type_expected);
end
else
Message(parser_e_mix_of_classes_and_objects);
@ -562,7 +574,7 @@ implementation
_PRIVATE :
begin
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
is_objc_protocol_or_category(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PRIVATE);
current_objectdef.symtable.currentvisibility:=vis_private;
@ -572,7 +584,7 @@ implementation
_PROTECTED :
begin
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
is_objc_protocol_or_category(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PROTECTED);
current_objectdef.symtable.currentvisibility:=vis_protected;
@ -582,7 +594,7 @@ implementation
_PUBLIC :
begin
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
is_objc_protocol_or_category(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLIC);
current_objectdef.symtable.currentvisibility:=vis_public;
@ -593,8 +605,7 @@ implementation
{ we've to check for a pushlished section in non- }
{ publishable classes later, if a real declaration }
{ this is the way, delphi does it }
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
if is_interface(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
{ Objective-C classes do not support "published",
as basically everything is published. }
@ -607,7 +618,7 @@ implementation
_STRICT :
begin
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
is_objc_protocol_or_category(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_STRICT);
if token=_ID then
@ -638,7 +649,7 @@ implementation
if object_member_blocktype=bt_general then
begin
if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
is_objc_protocol_or_category(current_objectdef) then
Message(parser_e_no_vars_in_interfaces);
if (current_objectdef.symtable.currentvisibility=vis_published) and
@ -871,6 +882,13 @@ implementation
end
else
begin
{ change objccategories into objcclass helpers }
if (objecttype=odt_objccategory) then
begin
current_objectdef.objecttype:=odt_objcclass;
include(current_objectdef.objectoptions,oo_is_classhelper);
end;
{ parse list of options (abstract / sealed) }
parse_object_options;

9
compiler/pdecsub.pas
View File

@ -1413,7 +1413,9 @@ begin
if pd.typ<>procdef then
internalerror(2003042611);
if not(is_class_or_interface_or_objc(tprocdef(pd)._class)) then
Message(parser_e_no_object_override);
Message(parser_e_no_object_override)
else if is_objccategory(tprocdef(pd)._class) then
Message(parser_e_no_category_override);
end;
procedure pd_overload(pd:tabstractprocdef);
@ -1483,7 +1485,8 @@ procedure pd_reintroduce(pd:tabstractprocdef);
begin
if pd.typ<>procdef then
internalerror(200401211);
if not(is_class_or_interface_or_object(tprocdef(pd)._class)) then
if not(is_class_or_interface_or_object(tprocdef(pd)._class)) and
not(is_objccategory(tprocdef(pd)._class)) then
Message(parser_e_no_object_reintroduce);
end;
@ -2036,7 +2039,7 @@ const
mutexclpo : [po_external]
),(
idtok:_REINTRODUCE;
pd_flags : [pd_interface,pd_object,pd_notobjintf];
pd_flags : [pd_interface,pd_object,pd_notobjintf,pd_objcclass];
handler : @pd_reintroduce;
pocall : pocall_none;
pooption : [po_reintroduce];

22
compiler/ptype.pas
View File

@ -493,7 +493,12 @@ implementation
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
end;
end
else if is_objccategory(def) then
begin
Message(parser_e_no_category_as_types);
def:=generrordef
end
end;
end;
@ -622,7 +627,12 @@ implementation
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
end;
end
else if is_objccategory(def) then
begin
Message(parser_e_no_category_as_types);
def:=generrordef
end
end;
end
else
@ -1023,6 +1033,14 @@ implementation
consume(token);
def:=object_dec(odt_objcprotocol,name,genericdef,genericlist,nil);
end;
_OBJCCATEGORY :
begin
if not(m_objectivec1 in current_settings.modeswitches) then
Message(parser_f_need_objc);
consume(token);
def:=object_dec(odt_objccategory,name,genericdef,genericlist,nil);
end;
_OBJECT :
begin
consume(token);

9
compiler/symconst.pas
View File

@ -117,6 +117,9 @@ const
paranr_syscall_legacy = high(word)-2;
paranr_result_leftright = high(word)-1;
{ prefix for names of class helper procsyms added to regular symtables }
class_helper_prefix = 'CH$';
type
{ keep this in sync with TIntfFlag in rtl/objpas/typinfo.pp }
@ -302,7 +305,8 @@ type
odt_cppclass,
odt_dispinterface,
odt_objcclass,
odt_objcprotocol
odt_objcprotocol,
odt_objccategory { note that these are changed into odt_class afterwards }
);
{ Variations in interfaces implementation }
@ -335,7 +339,8 @@ type
oo_has_enumerator_movenext,
oo_has_enumerator_current,
oo_is_external, { the class is externally implemented (objcclass, cppclass) }
oo_is_anonymous { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_classhelper { objcclasses that represent categories, and Delpi-style class helpers, are marked like this }
);
tobjectoptions=set of tobjectoption;

151
compiler/symdef.pas
View File

@ -685,6 +685,7 @@ interface
objc_superclasstype,
objc_idtype,
objc_seltype : tpointerdef;
objc_objecttype : trecorddef;
{ base type of @protocol(protocolname) Objective-C statements }
objc_protocoltype : tobjectdef;
@ -739,7 +740,9 @@ interface
function is_objcclass(def: tdef): boolean;
function is_objcclassref(def: tdef): boolean;
function is_objcprotocol(def: tdef): boolean;
function is_objccategory(def: tdef): boolean;
function is_objc_class_or_protocol(def: tdef): boolean;
function is_objc_protocol_or_category(def: tdef): boolean;
function is_class_or_interface(def: tdef): boolean;
function is_class_or_interface_or_objc(def: tdef): boolean;
function is_class_or_interface_or_object(def: tdef): boolean;
@ -3582,12 +3585,19 @@ implementation
function tprocdef.objcmangledname : string;
var
manglednamelen: longint;
iscatmethod : boolean;
begin
if not (po_msgstr in procoptions) then
internalerror(2009030901);
{ we may very well need longer strings to handle these... }
if ((255-length(tobjectdef(procsym.owner.defowner).objextname^)
-length('+"[ ]"')-length(messageinf.str^)) < 0) then
manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+
length('+"[ ]"')+length(messageinf.str^);
iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions;
if (iscatmethod) then
inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()'));
if manglednamelen>255 then
Message1(parser_e_objc_message_name_too_long,messageinf.str^);
if not(po_classmethod in procoptions) then
result:='"-['
@ -3596,9 +3606,12 @@ implementation
{ quotes are necessary because the +/- otherwise confuse the assembler
into expecting a number
}
result:=
result+tobjectdef(procsym.owner.defowner).objextname^+' '+
messageinf.str^+']"';
if iscatmethod then
result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'(';
result:=result+tobjectdef(procsym.owner.defowner).objextname^;
if iscatmethod then
result:=result+')';
result:=result+' '+messageinf.str^+']"';
end;
@ -4082,6 +4095,36 @@ implementation
end;
procedure create_class_helper_for_procdef(def: tobject; arg: pointer);
var
pd: tprocdef absolute def;
st: tsymtable;
psym: tsym;
nname: TIDString;
begin
if (tdef(def).typ<>procdef) then
exit;
{ pd.owner = objcclass symtable -> defowner = objcclassdef ->
owner = symtable in which objcclassdef is defined
}
st:=pd.owner.defowner.owner;
nname:=class_helper_prefix+tprocsym(pd.procsym).name;
{ check for an existing procsym with our special name }
psym:=tsym(st.find(nname));
if not assigned(psym) then
begin
psym:=tprocsym.create(nname);
{ avoid warning about this symbol being unused }
psym.IncRefCount;
st.insert(psym,true);
end
else if (psym.typ<>procsym) then
internalerror(2009111501);
{ add ourselves to this special procsym }
tprocsym(psym).procdeflist.add(def);
end;
procedure tobjectdef.buildderefimpl;
begin
inherited buildderefimpl;
@ -4095,6 +4138,10 @@ implementation
inherited derefimpl;
if not (df_copied_def in defoptions) then
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
symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
end;
@ -4385,9 +4432,15 @@ implementation
begin
case rt of
objcclassrtti:
result:=result+'_OBJC_CLASS_';
if not(oo_is_classhelper in objectoptions) then
result:=result+'_OBJC_CLASS_'
else
result:=result+'_OBJC_CATEGORY_';
objcmetartti:
result:=result+'_OBJC_METACLASS_';
if not(oo_is_classhelper in objectoptions) then
result:=result+'_OBJC_METACLASS_'
else
internalerror(2009111511);
else
internalerror(2009092302);
end;
@ -4401,9 +4454,15 @@ implementation
case objecttype of
odt_objcclass:
begin
if (oo_is_classhelper in objectoptions) and
(rt<>objcclassrtti) then
internalerror(2009111512);
case rt of
objcclassrtti:
result:='_OBJC_CLASS_$_';
if not(oo_is_classhelper in objectoptions) then
result:='_OBJC_CLASS_$_'
else
result:='_OBJC_$_CATEGORY_';
objcmetartti:
result:='_OBJC_METACLASS_$_';
objcclassrortti:
@ -4656,35 +4715,43 @@ implementation
begin
if (def.typ=procdef) then
begin
{ add all messages also under a dummy name to the symtable in
which the objcclass/protocol/category is declared, so they can
be called via id.<name>
}
create_class_helper_for_procdef(pd,nil);
{ we have to wait until now to set the mangled name because it
depends on the (possibly external) class name, which is defined
at the very end. }
if (po_msgstr in pd.procoptions) then
if not(po_msgstr in pd.procoptions) then
begin
{ Mangled name is already set in case this is a copy of
another type. }
if not(po_has_mangledname in pd.procoptions) then
begin
{ check whether the number of formal parameters is correct }
paracount:=0;
for i:=1 to length(pd.messageinf.str^) do
if pd.messageinf.str^[i]=':' then
inc(paracount);
for i:=0 to pd.paras.count-1 do
if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
dec(paracount);
if (paracount<>0) then
MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
{ recover to avoid internalerror later on }
include(pd.procoptions,po_msgstr);
pd.messageinf.str:=stringdup('MissingDeclaration');
end;
{ Mangled name is already set in case this is a copy of
another type. }
if not(po_has_mangledname in pd.procoptions) then
begin
{ check whether the number of formal parameters is correct }
paracount:=0;
for i:=1 to length(pd.messageinf.str^) do
if pd.messageinf.str^[i]=':' then
inc(paracount);
for i:=0 to pd.paras.count-1 do
if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and
not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then
dec(paracount);
if (paracount<>0) then
MessagePos(pd.fileinfo,sym_e_objc_para_mismatch);
pd.setmangledname(pd.objcmangledname);
end
else
{ all checks already done }
exit;
pd.setmangledname(pd.objcmangledname);
end
else
MessagePos(pd.fileinfo,parser_e_objc_requires_msgstr);
{ all checks already done }
exit;
if not(oo_is_external in pd._class.objectoptions) then
begin
if (po_varargs in pd.procoptions) then
@ -5065,6 +5132,18 @@ implementation
end;
function is_objccategory(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
{ if used as a forward type }
((tobjectdef(def).objecttype=odt_objccategory) or
{ if used as after it has been resolved }
((tobjectdef(def).objecttype=odt_objcclass) and
(oo_is_classhelper in tobjectdef(def).objectoptions)));
end;
function is_objc_class_or_protocol(def: tdef): boolean;
begin
result:=
@ -5074,6 +5153,17 @@ implementation
end;
function is_objc_protocol_or_category(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
((tobjectdef(def).objecttype = odt_objcprotocol) or
((tobjectdef(def).objecttype = odt_objcclass) and
(oo_is_classhelper in tobjectdef(def).objectoptions)));
end;
function is_class_or_interface(def: tdef): boolean;
begin
result:=
@ -5125,6 +5215,7 @@ implementation
objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER').typedef);
objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID').typedef);
objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL').typedef);
objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT').typedef);
end;

91
compiler/symtable.pas
View File

@ -204,6 +204,7 @@ interface
function search_class_member(pd : tobjectdef;const s : string):tsym;
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;
{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;
@ -1674,6 +1675,16 @@ implementation
exit;
end;
end;
{ also search for class helpers }
if (srsymtable.symtabletype=objectsymtable) and
is_objcclass(tdef(srsymtable.defowner)) then
begin
if search_class_helper(tobjectdef(srsymtable.defowner),s,srsym,srsymtable) then
begin
result:=true;
exit;
end;
end;
stackitem:=stackitem^.next;
end;
srsym:=nil;
@ -1810,7 +1821,9 @@ implementation
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
var
hashedid : THashedIDString;
orgclass : tobjectdef;
begin
orgclass:=classh;
{ The contextclassh is used for visibility. The classh must be equal to
or be a parent of contextclassh. E.g. for inherited searches the classh is the
parent. }
@ -1832,8 +1845,13 @@ implementation
end;
classh:=classh.childof;
end;
srsym:=nil;
srsymtable:=nil;
if is_objcclass(orgclass) then
result:=search_class_helper(orgclass,s,srsym,srsymtable)
else
begin
srsym:=nil;
srsymtable:=nil;
end;
end;
@ -1993,8 +2011,6 @@ implementation
function search_named_unit_globaltype(const unitname, typename: TIDString): ttypesym;
var
contextobjdef : tobjectdef;
stackitem : psymtablestackitem;
srsymtable: tsymtable;
sym: tsym;
begin
@ -2012,14 +2028,71 @@ implementation
end;
function search_class_helper(pd : tobjectdef;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(2009111505);
{ check whether this procsym includes a helper for this particular class }
for i:=0 to tprocsym(srsym).procdeflist.count-1 do
begin
{ does pd inherit from (or is the same as) the class
that this method's category extended?
}
if pd.is_related(tobjectdef(tprocdef(tprocsym(srsym).procdeflist[i]).owner.defowner).childof) then
begin
{ 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.
}
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;
end;
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
hashedid : THashedIDString;
hashedid : THashedIDString;
srsym : tsym;
orgpd : tobjectdef;
srsymtable : tsymtable;
begin
hashedid.id:=s;
orgpd:=pd;
while assigned(pd) do
begin
srsym:=tsym(pd.symtable.FindWithHash(hashedid));
@ -2030,9 +2103,15 @@ implementation
end;
pd:=pd.childof;
end;
search_class_member:=nil;
{ not found, now look for class helpers }
if is_objcclass(pd) then
search_class_helper(orgpd,s,result,srsymtable)
else
result:=nil;
end;
function search_macro(const s : string):tsym;
var
stackitem : psymtablestackitem;

2
compiler/tokens.pas
View File

@ -250,6 +250,7 @@ type
_EXPERIMENTAL,
_FINALIZATION,
_NOSTACKFRAME,
_OBJCCATEGORY,
_OBJCPROTOCOL,
_WEAKEXTERNAL,
_DISPINTERFACE,
@ -510,6 +511,7 @@ const
(str:'EXPERIMENTAL' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'FINALIZATION' ;special:false;keyword:m_initfinal;op:NOTOKEN),
(str:'NOSTACKFRAME' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OBJCCATEGORY' ;special:false;keyword:m_objectivec1;op:NOTOKEN), { Objective-C category }
(str:'OBJCPROTOCOL' ;special:false;keyword:m_objectivec1;op:NOTOKEN), { Objective-C protocol }
(str:'WEAKEXTERNAL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'DISPINTERFACE' ;special:false;keyword:m_class;op:NOTOKEN),

6
compiler/utils/ppudump.pp
View File

@ -1390,7 +1390,8 @@ type
oo_has_enumerator_movenext,
oo_has_enumerator_current,
oo_is_external, { the class is externally implemented (objcclass, cppclass) }
oo_is_anonymous { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_classhelper { objcclasses that represent categories, and Delpi-style class helpers, are marked like this }
);
tobjectoptions=set of tobjectoption;
tsymopt=record
@ -1418,7 +1419,8 @@ const
(mask:oo_has_enumerator_movenext; str:'HasEnumeratorMoveNext'),
(mask:oo_has_enumerator_current; str:'HasEnumeratorCurrent'),
(mask:oo_is_external; str:'External'),
(mask:oo_is_anonymous; str:'Anonymous'));
(mask:oo_is_anonymous; str:'Anonymous'),
(mask:oo_is_classhelper; str:'Class Helper/Category'));
var
symoptions : tobjectoptions;
i : longint;

16
tests/test/tobjc24.pp Normal file
View File

@ -0,0 +1,16 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$modeswitch objectivec1}
uses
uobjc24;
var
a: ta;
begin
{ category is in implementation -> should not be visible here }
ta.implementationcategorymethod;
end.

122
tests/test/tobjc25.pp Normal file
View File

@ -0,0 +1,122 @@
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$mode objfpc}
{$modeswitch objectivec1}
type
tbaseclass = objccategory(NSObject)
function tabaseproc(cp: longint): double; message 'tabaseproc:';
class function taclassproc: longint; message 'taclassproc';
end;
ta = objcclass(NSObject)
a: longint;
procedure taproc; message 'taproc';
function tabaseproc(cp: longint): double; message 'tabaseproc:'; //override; -- override doesn't work, the compiler doesn't treat the category as part of NSObject
class function taclassproc: longint; message 'taclassproc'; //override; -- idem
end;
ca = objccategory(ta)
procedure categorymethod; message 'categorymethod';
function tabaseproc(cp: longint): double; reintroduce;
end;
da = objccategory(ta)
procedure anothercategorymethod; message 'anothercategorymethod';
class function taclassproc: longint; reintroduce;
end;
class function tbaseclass.taclassproc: longint;
begin
writeln('tbaseclass.taclassproc');
result:=654321;
end;
function tbaseclass.tabaseproc(cp: longint): double;
begin
writeln('tbaseclass.tabaseproc');
if (cp<>98765) then
halt(12);
result:=1234.875;
end;
procedure ta.taproc;
begin
a:=0;
categorymethod;
if (a<>1) then
halt(1);
anothercategorymethod;
if (a<>2) then
halt(2);
if taclassproc<>123456 then
halt(5);
end;
function ta.tabaseproc(cp: longint): double;
begin
{ should be replaced/hidden by ca.tabaseproc }
halt(9);
result:=-1.0;
end;
class function ta.taclassproc: longint;
begin
{ should be replaced/hidden by da.taclassproc }
halt(3);
result:=0;
end;
procedure ca.categorymethod;
begin
a:=1;
if tabaseproc(555) <> 1.0 then
halt(16);
end;
function ca.tabaseproc(cp: longint): double;
begin
writeln('start ca.tabaseproc');
if (cp<>555) then
halt(13);
if inherited tabaseproc(98765)<>1234.875 then
halt(11);
writeln('end ca.tabaseproc');
result:=1.0;
end;
procedure da.anothercategorymethod;
begin
a:=2;
if tabaseproc(555)<>1.0 then
halt(15);
end;
class function da.taclassproc: longint;
begin
writeln('start da.taclassproc, calling inherited');
if inherited taclassproc<>654321 then
halt(4);
writeln('end da.taclassproc');
result:=123456;
end;
var
a: ta;
begin
a:=ta(ta.alloc).init;
a.taproc;
a.a:=0;
a.categorymethod;
if (a.a<>1) then
halt(6);
a.anothercategorymethod;
if (a.a<>2) then
halt(7);
if a.taclassproc<>123456 then
halt(8);
if (a.tabaseproc(555)<>1.0) then
halt(14);
a.release;
end.

18
tests/test/tobjc26.pp Normal file
View File

@ -0,0 +1,18 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$modeswitch objectivec1}
uses
uobjc26;
var
a: ta;
begin
a:=ta(ta.alloc).init;
// should not be visible
a.implementationcategorymethod;
a.release
end.

16
tests/test/tobjc26a.pp Normal file
View File

@ -0,0 +1,16 @@
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$modeswitch objectivec1}
uses
uobjc26;
var
a: ta;
begin
a:=ta(ta.alloc).init;
a.taproc;
a.release
end.

26
tests/test/tobjc27a.pp Normal file
View File

@ -0,0 +1,26 @@
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{ %recompile }
{$modeswitch objectivec1}
uses
uobjc27a,uobjc27b;
var
a: ta;
c: tachild;
begin
a:=ta(ta.alloc).init;
if a.da_categorymethod<>2 then
halt(1);
a.release;
c:=tachild(tachild.alloc).init;
if c.da_categorymethod<>2 then
halt(2);
if c.eachild_categorymethod<>3 then
halt(3);
c.release;
end.

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

@ -0,0 +1,17 @@
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{ %fail }
{$modeswitch objectivec1}
uses
uobjc27a;
var
a: ta;
begin
{ da_category method is declared in uobjc27a, which is used in the
implementation of uobjc27b -> should not be visible here }
a.da_categorymethod;
end.

25
tests/test/tobjc28.pp Normal file
View File

@ -0,0 +1,25 @@
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{ %fail }
{$modeswitch objectivec1}
type
ta = objcclass(NSObject)
end;
ca = objccategory(ta)
procedure categorymethod; message 'categorymethod';
end;
procedure ca.categorymethod;
begin
end;
var
a: NSObject;
begin
a:=ta(ta.alloc).init;
{ should fail because the category is for ta, not for nsobject }
a.categorymethod;
end.

22
tests/test/uobjc24.pp Normal file
View File

@ -0,0 +1,22 @@
{$modeswitch objectivec1}
unit uobjc24;
interface
type
ta = objcclass(NSObject)
end;
implementation
type
ca = objccategory(ta)
procedure implementationcategorymethod;
end;
procedure ca.implementationcategorymethod;
begin
end;
end.

33
tests/test/uobjc26.pp Normal file
View File

@ -0,0 +1,33 @@
{$modeswitch objectivec1}
unit uobjc26;
interface
type
ta = objcclass(NSObject)
l: longint;
procedure taproc; message 'taproc';
end;
implementation
type
ca = objccategory(ta)
procedure implementationcategorymethod; message 'implementationcategorymethod';
end;
procedure ca.implementationcategorymethod;
begin
l:=1;
end;
procedure ta.taproc;
begin
l:=0;
implementationcategorymethod;
if l<>1 then
halt(1);
end;
end.

27
tests/test/uobjc27a.pp Normal file
View File

@ -0,0 +1,27 @@
{$mode objfpc}
{$modeswitch objectivec1}
unit uobjc27a;
interface
type
ta = objcclass(NSObject)
end;
type
ca = objccategory(ta)
function ca_categorymethod: longint; message 'ca_categorymethod';
end;
implementation
uses
uobjc27b;
function ca.ca_categorymethod: longint;
begin
result:=da_categorymethod-1;
end;
end.

35
tests/test/uobjc27b.pp Normal file
View File

@ -0,0 +1,35 @@
{$mode objfpc}
{$modeswitch objectivec1}
unit uobjc27b;
interface
uses uobjc27a;
type
tachild = objcclass(ta)
end;
type
eachild = objccategory(tachild)
function eachild_categorymethod: longint; message 'eachild_categorymethod';
end;
da = objccategory(ta)
function da_categorymethod: longint; message 'da_categorymethod';
end;
implementation
function eachild.eachild_categorymethod: longint;
begin
result:=ca_categorymethod+2;
end;
function da.da_categorymethod: longint;
begin
result:=2;
end;
end.