paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 03:29:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

--WARNING: start build process with FPC 2.2.4; won't work when

Browse Source 
starting with a previous 2.3.1 or compiler built from the objc branch
  + added basic objcprotocol support (only for external protocols
    currently)
     o use in type declaration: "type xp = objcprotocol ... end;"
     o when defining a root class that implements it:
       "type yc = objcclass(xp) ... end" (note: no support yet
       for something like "objcclass(id,xp)" or so)
     o when defining a non-root class that implements a protocol:
       "type zc = objcclass(nsobject,xp) ... end"
     o includes support for "required" and "optional" sections
     o no support yet for the objcprotocol(<protocol>) expression
       that enables getting a class instance representing the
       protocol (e.g., for use with "conformsToProtocol:")
     o message names have to specified in protocol declarations,
       but if an objcclass implements a protocol, the message names do
       not have to be repeated (but if they are, they have to match;
       the same goes when overriding inherited methods)
  + allow specifying the external name of Objective-C classes and
    protocols, since classes and protocols can have the same name
    (and you cannot use the same Pascal identifier in such caseq)
  + added NSObject protocol, and make the NSObject class use it
  + added missing NSObject class methods that have the same name
    as instance methods (added "class" name prefix to avoid clashes)
  * fixed several cases where the compiler did not treat Objective-C
    classes/protocols the same as Object Pascal classes/interfaces
    (a.o., forward declarations, alignment, regvars, several type
     conversions, ...)
  * allow "override" directive in objcclass declarations, and print
    a hint if it's forgotten in an external declaration (because it
    doesn't really matter there, and may make automated header
    conversion harder than necessary) and an error if will be used in
    a non-external declaration (because it is not possible to start
    a new vmt entry-tree in Objective-C, you can only override parent
    methods)
  * reject objcclasses/protocols as parameters to typeof()
  * don't try to test VMT validity of objcclasses/protocols

git-svn-id: branches/objc@13375 -
This commit is contained in:
Jonas Maebe 2009-07-09 20:48:28 +00:00
parent 2bcef8e018
commit 5a2ccfff52
44 changed files with 1090 additions and 417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitattributes vendored
View File

@ -8206,6 +8206,18 @@ tests/test/tobjc2.pp svneol=native#text/plain
tests/test/tobjc3.pp svneol=native#text/plain tests/test/tobjc3.pp svneol=native#text/plain
tests/test/tobjc4.pp svneol=native#text/plain tests/test/tobjc4.pp svneol=native#text/plain
tests/test/tobjc4a.pp svneol=native#text/plain tests/test/tobjc4a.pp svneol=native#text/plain
tests/test/tobjc5.pp svneol=native#text/plain
tests/test/tobjc5a.pp svneol=native#text/plain
tests/test/tobjc6.pp svneol=native#text/plain
tests/test/tobjc7.pp svneol=native#text/plain
tests/test/tobjc7a.pp svneol=native#text/plain
tests/test/tobjc7b.pp svneol=native#text/plain
tests/test/tobjc7c.pp svneol=native#text/plain
tests/test/tobjc8.pp svneol=native#text/plain
tests/test/tobjc8a.pp svneol=native#text/plain
tests/test/tobjc9.pp svneol=native#text/plain
tests/test/tobjc9a.pp svneol=native#text/plain
tests/test/tobjc9b.pp svneol=native#text/plain
tests/test/tobject1.pp svneol=native#text/plain tests/test/tobject1.pp svneol=native#text/plain
tests/test/tobject2.pp svneol=native#text/plain tests/test/tobject2.pp svneol=native#text/plain
tests/test/tobject3.pp svneol=native#text/plain tests/test/tobject3.pp svneol=native#text/plain

3
compiler/dbgdwarf.pas
View File

@ -3023,7 +3023,8 @@ implementation
current_asmdata.asmlists[al_dwarf_info].concat(tai_symbol.create(def_dwarf_class_struct_lab(def),0)); current_asmdata.asmlists[al_dwarf_info].concat(tai_symbol.create(def_dwarf_class_struct_lab(def),0));
doappend; doappend;
end; end;
odt_objcclass: odt_objcclass,
odt_objcprotocol:
begin begin
// Objective-C class: plain pointer for now // Objective-C class: plain pointer for now
append_entry(DW_TAG_pointer_type,false,[]); append_entry(DW_TAG_pointer_type,false,[]);

45
compiler/defcmp.pas
View File

@ -277,7 +277,7 @@ implementation
objectdef: objectdef:
begin begin
if (m_delphi in current_settings.modeswitches) and if (m_delphi in current_settings.modeswitches) and
is_class_or_interface_or_dispinterface(def_from) and is_class_or_interface_or_dispinterface_or_objc(def_from) and
(cdo_explicit in cdoptions) then (cdo_explicit in cdoptions) then
begin begin
eq:=te_convert_l1; eq:=te_convert_l1;
@ -1113,7 +1113,7 @@ implementation
can be assigned to void pointers, but it is less can be assigned to void pointers, but it is less
preferred than assigning to a related objectdef } preferred than assigning to a related objectdef }
if ( if (
is_class_or_interface_or_dispinterface(def_from) or is_class_or_interface_or_dispinterface_or_objc(def_from) or
(def_from.typ=classrefdef) (def_from.typ=classrefdef)
) and ) and
(tpointerdef(def_to).pointeddef.typ=orddef) and (tpointerdef(def_to).pointeddef.typ=orddef) and
@ -1122,11 +1122,11 @@ implementation
doconv:=tc_equal; doconv:=tc_equal;
eq:=te_convert_l2; eq:=te_convert_l2;
end end
else if is_objcclass(def_from) and else if is_objc_class_or_protocol(def_from) and
(def_to=objc_idtype) then (def_to=objc_idtype) then
begin begin
doconv:=tc_equal; doconv:=tc_equal;
eq:=te_convert_l1; eq:=te_convert_l2;
end; end;
end; end;
end; end;
@ -1230,7 +1230,7 @@ implementation
end end
else else
{ Class/interface specific } { Class/interface specific }
if is_class_or_interface_or_dispinterface(def_to) then if is_class_or_interface_or_dispinterface_or_objc(def_to) then
begin begin
{ void pointer also for delphi mode } { void pointer also for delphi mode }
if (m_delphi in current_settings.modeswitches) and if (m_delphi in current_settings.modeswitches) and
@ -1247,9 +1247,19 @@ implementation
doconv:=tc_equal; doconv:=tc_equal;
eq:=te_convert_l1; eq:=te_convert_l1;
end end
{ classes can be assigned to interfaces } { All Objective-C classes are compatible with ID }
else if is_interface(def_to) and else if is_objcclass(def_to) and
is_class(def_from) and (def_from=objc_idtype) then
begin
doconv:=tc_equal;
eq:=te_convert_l2;
end
{ classes can be assigned to interfaces
(same with objcclass and objcprotocol) }
else if ((is_interface(def_to) and
is_class(def_from)) or
(is_objcprotocol(def_to) and
is_objcclass(def_from))) and
assigned(tobjectdef(def_from).ImplementedInterfaces) then assigned(tobjectdef(def_from).ImplementedInterfaces) then
begin begin
{ we've to search in parent classes as well } { we've to search in parent classes as well }
@ -1258,7 +1268,11 @@ implementation
begin begin
if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then
begin begin
doconv:=tc_class_2_intf; if is_interface(def_to) then
doconv:=tc_class_2_intf
else
{ for Objective-C, we don't have to do anything special }
doconv:=tc_equal;
{ don't prefer this over objectdef->objectdef } { don't prefer this over objectdef->objectdef }
eq:=te_convert_l2; eq:=te_convert_l2;
break; break;
@ -1288,14 +1302,7 @@ implementation
doconv:=tc_int_2_int; doconv:=tc_int_2_int;
eq:=te_convert_l1; eq:=te_convert_l1;
end; end;
end end;
else if is_objcclass(def_to) and
(def_from=objc_idtype) then
begin
{ All Objective-C classes are compatible with ID }
doconv:=tc_equal;
eq:=te_convert_l1;
end;
end; end;
classrefdef : classrefdef :
@ -1693,8 +1700,8 @@ implementation
(equal_defs(parentretdef,childretdef)) or (equal_defs(parentretdef,childretdef)) or
((parentretdef.typ=objectdef) and ((parentretdef.typ=objectdef) and
(childretdef.typ=objectdef) and (childretdef.typ=objectdef) and
is_class_or_interface(parentretdef) and is_class_or_interface_or_objc(parentretdef) and
is_class_or_interface(childretdef) and is_class_or_interface_or_objc(childretdef) and
(tobjectdef(childretdef).is_related(tobjectdef(parentretdef)))) (tobjectdef(childretdef).is_related(tobjectdef(parentretdef))))
end; end;

2
compiler/defutil.pas
View File

@ -970,7 +970,7 @@ implementation
end; end;
objectdef : objectdef :
begin begin
if is_class_or_interface(def) then if is_class_or_interface_or_objc(def) then
result := OS_ADDR result := OS_ADDR
else else
result:=int_cgsize(def.size); result:=int_cgsize(def.size);

14
compiler/htypechk.pas
View File

@ -218,7 +218,7 @@ implementation
pointerdef : pointerdef :
begin begin
if ((rd.typ in [orddef,enumdef,pointerdef,classrefdef,procvardef]) or if ((rd.typ in [orddef,enumdef,pointerdef,classrefdef,procvardef]) or
is_class_or_interface(rd)) then is_class_or_interface_or_objc(rd)) then
begin begin
allowed:=false; allowed:=false;
exit; exit;
@ -280,7 +280,7 @@ implementation
begin begin
{ <> and = are defined for classes } { <> and = are defined for classes }
if (treetyp in [equaln,unequaln]) and if (treetyp in [equaln,unequaln]) and
is_class_or_interface(ld) then is_class_or_interface_or_objc(ld) then
begin begin
allowed:=false; allowed:=false;
exit; exit;
@ -842,7 +842,7 @@ implementation
end; end;
subscriptn : subscriptn :
begin begin
if is_class_or_interface(tunarynode(p).left.resultdef) then if is_class_or_interface_or_objc(tunarynode(p).left.resultdef) then
newstate := vs_read; newstate := vs_read;
p:=tunarynode(p).left; p:=tunarynode(p).left;
end; end;
@ -996,7 +996,7 @@ implementation
pointerdef : pointerdef :
gotpointer:=true; gotpointer:=true;
objectdef : objectdef :
gotclass:=is_class_or_interface(hp.resultdef); gotclass:=is_class_or_interface_or_objc(hp.resultdef);
recorddef : recorddef :
gotrecord:=true; gotrecord:=true;
classrefdef : classrefdef :
@ -1113,7 +1113,7 @@ implementation
pointerdef : pointerdef :
gotpointer:=true; gotpointer:=true;
objectdef : objectdef :
gotclass:=is_class_or_interface(hp.resultdef); gotclass:=is_class_or_interface_or_objc(hp.resultdef);
classrefdef : classrefdef :
gotclass:=true; gotclass:=true;
arraydef : arraydef :
@ -1210,7 +1210,7 @@ implementation
{ a class/interface access is an implicit } { a class/interface access is an implicit }
{ dereferencing } { dereferencing }
hp:=tsubscriptnode(hp).left; hp:=tsubscriptnode(hp).left;
if is_class_or_interface(hp.resultdef) then if is_class_or_interface_or_objc(hp.resultdef) then
gotderef:=true; gotderef:=true;
end; end;
muln, muln,
@ -1299,7 +1299,7 @@ implementation
pointerdef : pointerdef :
gotpointer:=true; gotpointer:=true;
objectdef : objectdef :
gotclass:=is_class_or_interface(hp.resultdef); gotclass:=is_class_or_interface_or_objc(hp.resultdef);
recorddef, { handle record like class it needs a subscription } recorddef, { handle record like class it needs a subscription }
classrefdef : classrefdef :
gotclass:=true; gotclass:=true;

34
compiler/msg/errore.msg
View File

@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
# #
# Parser # Parser
# #
# 03256 is the last used one # 03261 is the last used one
# #
% \section{Parser messages} % \section{Parser messages}
% This section lists all parser messages. The parser takes care of the % This section lists all parser messages. The parser takes care of the
@ -911,12 +911,12 @@ parser_e_no_con_des_in_interfaces=03171_E_Con- and destructors aren't allowed in
% Constructor and destructor declarations aren't allowed in interfaces. % Constructor and destructor declarations aren't allowed in interfaces.
% In the most cases method \var{QueryInterface} of \var{IUnknown} can % In the most cases method \var{QueryInterface} of \var{IUnknown} can
% be used to create a new interface. % be used to create a new interface.
parser_e_no_access_specifier_in_interfaces=03172_E_Access specifiers can't be used in INTERFACES 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 % The access specifiers \var{public}, \var{private}, \var{protected} and
% \var{published} can't be used in interfaces because all methods % \var{published} can't be used in interfaces and Objective-C protocols because all methods
% of an interface must be public. % of an interface/protocol must be public.
parser_e_no_vars_in_interfaces=03173_E_An interface can't contain fields parser_e_no_vars_in_interfaces=03173_E_An interface or Objective-C protocol cannot contain fields
% Declarations of fields aren't allowed in interfaces. An interface % 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. % 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 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 % Declaring local procedures as external is not possible. Local procedures
@ -1203,12 +1203,30 @@ parser_h_no_objc_parent=03256_H_Defining a new Objective-C root class. To derive
% root classes in Objective-C. For example, in the Cocoa framework both NSObject and NSProxy are root classes. % root classes in Objective-C. For example, in the Cocoa framework both NSObject and NSProxy are root classes.
% Therefore, you have to explicitly define a parent class (such as NSObject) if you want to derive your % Therefore, you have to explicitly define a parent class (such as NSObject) if you want to derive your
% Objective-C class from it. % Objective-C class from it.
parser_e_no_objc_published=03257_E_Objective-C classes cannot have published sections.
% In Object Pascal, ``published'' determines whether or not RTTI is generated. Since the Objective-C runtime always needs
% RTTI for everything, this specified does not make sense for Objective-C classes.
parser_f_need_objc=03258_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=03259_E_Inherited methods can only be overridden in Objective-C, add ``override''.
parser_h_should_use_override_objc=03260_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
% 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
% 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),
% which makes it hard for automated header conversion tools to include it everywhere.
parser_e_objc_message_name_changed=03261_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
% is that these message names uniquely define the message to the Objective-C runtime, which means that
% giving them a different message name breaks the ``override'' semantics.
% \end{description} % \end{description}
# #
# Type Checking # Type Checking
# #
# 04087 is the last used one # 04088 is the last used one
# #
% \section{Type checking errors} % \section{Type checking errors}
% This section lists all errors that can occur when type checking is % This section lists all errors that can occur when type checking is
@ -1506,6 +1524,8 @@ type_e_no_type_info=04087_E_No type info available for this type
% Type information is not generated for some types, such as enumerations with gaps % Type information is not generated for some types, such as enumerations with gaps
% in their value range (this includes enumerations whose lower bound is different % in their value range (this includes enumerations whose lower bound is different
% from zero). % from zero).
type_e_protocol_type_expected=04088_E_Objective-C protocol type expected, but got "$1"
% The compiler expected a protocol type name, but found something else.
% \end{description} % \end{description}
# #
# Symtable # Symtable

10
compiler/msgidx.inc
View File

@ -344,6 +344,11 @@ const
parser_e_message_string_too_long=03254; parser_e_message_string_too_long=03254;
parser_e_objc_message_name_too_long=03255; parser_e_objc_message_name_too_long=03255;
parser_h_no_objc_parent=03256; parser_h_no_objc_parent=03256;
parser_e_no_objc_published=03257;
parser_f_need_objc=03258;
parser_e_must_use_override_objc=03259;
parser_h_should_use_override_objc=03260;
parser_e_objc_message_name_changed=03261;
type_e_mismatch=04000; type_e_mismatch=04000;
type_e_incompatible_types=04001; type_e_incompatible_types=04001;
type_e_not_equal_types=04002; type_e_not_equal_types=04002;
@ -422,6 +427,7 @@ const
type_e_expected_objc_method_but_got=04085; type_e_expected_objc_method_but_got=04085;
type_e_expected_objc_method=04086; type_e_expected_objc_method=04086;
type_e_no_type_info=04087; type_e_no_type_info=04087;
type_e_protocol_type_expected=04088;
sym_e_id_not_found=05000; sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001; sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002; sym_e_duplicate_id=05002;
@ -794,9 +800,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 51955; MsgTxtSize = 52451;
MsgIdxMax : array[1..20] of longint=( MsgIdxMax : array[1..20] of longint=(
24,87,257,88,65,51,108,22,202,62, 24,87,262,89,65,51,108,22,202,62,
47,20,1,1,1,1,1,1,1,1 47,20,1,1,1,1,1,1,1,1
); );

522
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

12
compiler/nadd.pas
View File

@ -1560,18 +1560,18 @@ implementation
end end
{ class or interface equation } { class or interface equation }
else if is_class_or_interface(rd) or is_class_or_interface(ld) then else if is_class_or_interface_or_objc(rd) or is_class_or_interface_or_objc(ld) then
begin begin
if (nodetype in [equaln,unequaln]) then if (nodetype in [equaln,unequaln]) then
begin begin
if is_class_or_interface(rd) and is_class_or_interface(ld) then if is_class_or_interface_or_objc(rd) and is_class_or_interface_or_objc(ld) then
begin begin
if tobjectdef(rd).is_related(tobjectdef(ld)) then if tobjectdef(rd).is_related(tobjectdef(ld)) then
inserttypeconv(right,left.resultdef) inserttypeconv(right,left.resultdef)
else else
inserttypeconv(left,right.resultdef); inserttypeconv(left,right.resultdef);
end end
else if is_class_or_interface(rd) then else if is_class_or_interface_or_objc(rd) then
inserttypeconv(left,right.resultdef) inserttypeconv(left,right.resultdef)
else else
inserttypeconv(right,left.resultdef); inserttypeconv(right,left.resultdef);
@ -1595,7 +1595,7 @@ implementation
end end
{ allows comperasion with nil pointer } { allows comperasion with nil pointer }
else if is_class_or_interface(rd) or (rd.typ=classrefdef) then else if is_class_or_interface_or_objc(rd) or (rd.typ=classrefdef) then
begin begin
if (nodetype in [equaln,unequaln]) then if (nodetype in [equaln,unequaln]) then
inserttypeconv(left,right.resultdef) inserttypeconv(left,right.resultdef)
@ -1603,7 +1603,7 @@ implementation
CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename); CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
end end
else if is_class_or_interface(ld) or (ld.typ=classrefdef) then else if is_class_or_interface_or_objc(ld) or (ld.typ=classrefdef) then
begin begin
if (nodetype in [equaln,unequaln]) then if (nodetype in [equaln,unequaln]) then
inserttypeconv(right,left.resultdef) inserttypeconv(right,left.resultdef)
@ -2671,7 +2671,7 @@ implementation
expectloc:=LOC_FLAGS; expectloc:=LOC_FLAGS;
end end
else if is_class_or_interface(ld) then else if is_class_or_interface_or_objc(ld) then
begin begin
expectloc:=LOC_FLAGS; expectloc:=LOC_FLAGS;
end end

5
compiler/ncgmem.pas
View File

@ -273,9 +273,8 @@ implementation
if codegenerror then if codegenerror then
exit; exit;
paraloc1.init; paraloc1.init;
{ classes and interfaces must be dereferenced implicit } { classes and interfaces must be dereferenced implicitly }
if is_class_or_interface(left.resultdef) or if is_class_or_interface_or_objc(left.resultdef) then
is_objcclass(left.resultdef) then
begin begin
{ the contents of a class are aligned to a sizeof(pointer) } { the contents of a class are aligned to a sizeof(pointer) }
location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),sizeof(pint)); location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),sizeof(pint));

3
compiler/ncgutil.pas
View File

@ -2867,7 +2867,8 @@ implementation
{ test validity of VMT } { test validity of VMT }
if not(is_interface(objdef)) and if not(is_interface(objdef)) and
not(is_cppclass(objdef)) then not(is_cppclass(objdef)) and
not(is_objc_class_or_protocol(objdef)) then
cg.g_maybe_testvmt(list,vmtreg,objdef); cg.g_maybe_testvmt(list,vmtreg,objdef);
end; end;

10
compiler/ncnv.pas
View File

@ -1793,8 +1793,8 @@ implementation
make_not_regable(left,[ra_addr_regable]); make_not_regable(left,[ra_addr_regable]);
{ class/interface to class/interface, with checkobject support } { class/interface to class/interface, with checkobject support }
if is_class_or_interface(resultdef) and if is_class_or_interface_or_objc(resultdef) and
is_class_or_interface(left.resultdef) then is_class_or_interface_or_objc(left.resultdef) then
begin begin
{ check if the types are related } { check if the types are related }
if not(nf_internal in flags) and if not(nf_internal in flags) and
@ -1815,7 +1815,9 @@ implementation
end; end;
{ Add runtime check? } { Add runtime check? }
if (cs_check_object in current_settings.localswitches) and if not is_objc_class_or_protocol(resultdef) and
not is_objc_class_or_protocol(left.resultdef) and
(cs_check_object in current_settings.localswitches) and
not(nf_internal in flags) then not(nf_internal in flags) then
begin begin
{ we can translate the typeconvnode to 'as' when { we can translate the typeconvnode to 'as' when
@ -1866,7 +1868,7 @@ implementation
{ however, there are some exceptions } { however, there are some exceptions }
(not(resultdef.typ in [arraydef,recorddef,setdef,stringdef, (not(resultdef.typ in [arraydef,recorddef,setdef,stringdef,
filedef,variantdef,objectdef]) or filedef,variantdef,objectdef]) or
is_class_or_interface(resultdef) or is_class_or_interface_or_objc(resultdef) or
{ the softfloat code generates casts <const. float> to record } { the softfloat code generates casts <const. float> to record }
(nf_internal in flags) (nf_internal in flags)
)) ))

4
compiler/nmem.pas
View File

@ -629,8 +629,8 @@ implementation
if codegenerror then if codegenerror then
exit; exit;
{ classes must be dereferenced implicit } { classes must be dereferenced implicitly }
if is_class_or_interface(left.resultdef) then if is_class_or_interface_or_objc(left.resultdef) then
expectloc:=LOC_REFERENCE expectloc:=LOC_REFERENCE
else else
begin begin

139
compiler/nobj.pas
View File

@ -39,6 +39,7 @@ interface
_Class : tobjectdef; _Class : tobjectdef;
function is_new_vmt_entry(pd:tprocdef):boolean; function is_new_vmt_entry(pd:tprocdef):boolean;
procedure add_new_vmt_entry(pd:tprocdef); procedure add_new_vmt_entry(pd:tprocdef);
function check_msg_str(vmtpd, pd: tprocdef):boolean;
function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef; function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef);
@ -47,7 +48,8 @@ interface
public public
constructor create(c:tobjectdef); constructor create(c:tobjectdef);
destructor destroy;override; destructor destroy;override;
procedure generate_vmt; procedure generate_vmt;
procedure build_interface_mappings;
end; end;
type type
@ -179,9 +181,49 @@ implementation
end; end;
function TVMTBuilder.check_msg_str(vmtpd, pd: tprocdef): boolean;
begin
result:=true;
if not(is_objc_class_or_protocol(_class)) then
begin
{ the only requirement for normal methods is that both either
have a message string or not (the value is irrelevant) }
if ((pd.procoptions * [po_msgstr]) <> (vmtpd.procoptions * [po_msgstr])) then
begin
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
tprocsym(vmtpd.procsym).write_parameter_lists(pd);
result:=false;
end
end
else
begin
{ the compiler should have ensured that the protocol or parent
class method has a message name specified }
if not(po_msgstr in vmtpd.procoptions) then
internalerror(2009070601);
if not(po_msgstr in pd.procoptions) then
begin
{ copy the protocol's/parent class' message name to the one in
the class if none has been specified there }
include(pd.procoptions,po_msgstr);
pd.messageinf.str:=stringdup(vmtpd.messageinf.str^);
end
else
begin
{ if both have a message name, make sure they are equal }
if (vmtpd.messageinf.str^<>pd.messageinf.str^) then
begin
MessagePos2(pd.fileinfo,parser_e_objc_message_name_changed,vmtpd.messageinf.str^,pd.messageinf.str^);
result:=false;
end;
end;
end;
end;
function TVMTBuilder.is_new_vmt_entry(pd:tprocdef):boolean; function TVMTBuilder.is_new_vmt_entry(pd:tprocdef):boolean;
const const
po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint, po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var var
i : longint; i : longint;
@ -233,7 +275,7 @@ implementation
( (
not(po_virtualmethod in pd.procoptions) or not(po_virtualmethod in pd.procoptions) or
{ new one has not override } { new one has not override }
(is_class_or_interface(_class) and not(po_overridingmethod in pd.procoptions)) (is_class_or_interface_or_objc(_class) and not(po_overridingmethod in pd.procoptions))
) then ) then
begin begin
if ( if (
@ -242,7 +284,31 @@ implementation
) then ) then
begin begin
if not(po_reintroduce in pd.procoptions) then if not(po_reintroduce in pd.procoptions) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false)); if not(is_objc_class_or_protocol(_class)) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else
begin
{ In Objective-C, you cannot create a new VMT entry to
start a new inheritance tree. We therefore give an
error when the class is implemented in Pascal, to
avoid confusion due to things working differently
with Object Pascal classes.
In case of external classes, we only give a hint,
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))
{ 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));
{ no new entry, but copy the message name if any from
the procdef in the parent class }
check_msg_str(vmtpd,pd);
exit;
end;
{ disable/hide old VMT entry } { disable/hide old VMT entry }
vmtentry^.visibility:=vis_hidden; vmtentry^.visibility:=vis_hidden;
end; end;
@ -275,6 +341,8 @@ implementation
tprocsym(vmtpd.procsym).write_parameter_lists(pd); tprocsym(vmtpd.procsym).write_parameter_lists(pd);
end; end;
check_msg_str(vmtpd,pd);
{ Give a note if the new visibility is lower. For a higher { Give a note if the new visibility is lower. For a higher
visibility update the vmt info } visibility update the vmt info }
if vmtentry^.visibility>pd.visibility then if vmtentry^.visibility>pd.visibility then
@ -301,10 +369,12 @@ implementation
begin begin
if not(po_reintroduce in pd.procoptions) then if not(po_reintroduce in pd.procoptions) then
begin begin
if not is_object(_class) then if not is_object(_class) and
not is_objc_class_or_protocol(_class) then
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false)) MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false))
else else
{ objects don't allow starting a new virtual tree } { objects don't allow starting a new virtual tree
and neither does Objective-C }
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,vmtpd.fullprocname(false)); MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,vmtpd.fullprocname(false));
end; end;
{ disable/hide old VMT entry } { disable/hide old VMT entry }
@ -320,7 +390,7 @@ implementation
function TVMTBuilder.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef; function TVMTBuilder.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef;
const const
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint, po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var var
implprocdef : Tprocdef; implprocdef : Tprocdef;
@ -346,7 +416,8 @@ implementation
(compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
(proc.proccalloption=implprocdef.proccalloption) and (proc.proccalloption=implprocdef.proccalloption) and
(proc.proctypeoption=implprocdef.proctypeoption) and (proc.proctypeoption=implprocdef.proctypeoption) and
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) and
check_msg_str(proc,implprocdef) then
begin begin
result:=implprocdef; result:=implprocdef;
exit; exit;
@ -386,9 +457,32 @@ implementation
implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name); implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
{ Add procdef to the implemented interface } { Add procdef to the implemented interface }
if assigned(implprocdef) then if assigned(implprocdef) then
ImplIntf.AddImplProc(implprocdef) begin
if (implprocdef._class.objecttype<>odt_objcclass) then
ImplIntf.AddImplProc(implprocdef)
else
begin
{ If no message name has been specified for the method
in the objcclass, copy it from the protocol
definition. }
if not(po_msgstr in tprocdef(def).procoptions) then
begin
include(tprocdef(def).procoptions,po_msgstr);
implprocdef.messageinf.str:=stringdup(tprocdef(def).messageinf.str^);
end
else
begin
{ If a message name has been specified in the
objcclass, it has to match the message name in the
protocol definition. }
if (implprocdef.messageinf.str^<>tprocdef(def).messageinf.str^) then
MessagePos2(implprocdef.fileinfo,parser_e_objc_message_name_changed,tprocdef(def).messageinf.str^,implprocdef.messageinf.str^);
end;
end;
end
else else
if ImplIntf.IType=etStandard then if (ImplIntf.IType=etStandard) and
not(tprocdef(def).optional) then
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false)); Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
end; end;
end; end;
@ -545,7 +639,6 @@ implementation
var var
i : longint; i : longint;
def : tdef; def : tdef;
ImplIntf : TImplementedInterface;
old_current_objectdef : tobjectdef; old_current_objectdef : tobjectdef;
begin begin
old_current_objectdef:=current_objectdef; old_current_objectdef:=current_objectdef;
@ -574,7 +667,25 @@ implementation
add_new_vmt_entry(tprocdef(def)); add_new_vmt_entry(tprocdef(def));
end; end;
end; end;
build_interface_mappings;
if assigned(_class.ImplementedInterfaces) and
not(is_objc_class_or_protocol(_class)) then
begin
{ Optimize interface tables to reuse wrappers }
intf_optimize_vtbls;
{ Allocate interface tables }
intf_allocate_vtbls;
end;
current_objectdef:=old_current_objectdef;
end;
procedure TVMTBuilder.build_interface_mappings;
var
ImplIntf : TImplementedInterface;
i: longint;
begin
{ Find Procdefs implementing the interfaces } { Find Procdefs implementing the interfaces }
if assigned(_class.ImplementedInterfaces) then if assigned(_class.ImplementedInterfaces) then
begin begin
@ -584,13 +695,7 @@ implementation
ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef); intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef);
end; end;
{ Optimize interface tables to reuse wrappers }
intf_optimize_vtbls;
{ Allocate interface tables }
intf_allocate_vtbls;
end; end;
current_objectdef:=old_current_objectdef;
end; end;

2
compiler/nutils.pas
View File

@ -658,7 +658,7 @@ implementation
end; end;
subscriptn: subscriptn:
begin begin
if is_class_or_interface(tunarynode(p).left.resultdef) then if is_class_or_interface_or_objc(tunarynode(p).left.resultdef) then
inc(result); inc(result);
if (result = NODE_COMPLEXITY_INF) then if (result = NODE_COMPLEXITY_INF) then
exit; exit;

49
compiler/pdecl.pas
View File

@ -278,19 +278,30 @@ implementation
procedure types_dec; procedure types_dec;
procedure finish_objc_class(od: tobjectdef); procedure get_objc_class_or_protocol_external_status(od: tobjectdef);
begin begin
{ Objective-C classes can be external -> all messages inside are { Objective-C classes can be external -> all messages inside are
external (defined at the class level instead of per method, so external (defined at the class level instead of per method, so
that you cannot define some methods as external and some not) that you cannot define some methods as external and some not)
} }
if (token = _ID) and if (token=_ID) and
(idtoken = _EXTERNAL) then (idtoken=_EXTERNAL) then
begin begin
consume(_EXTERNAL); consume(_EXTERNAL);
if (token=_ID) and
(idtoken=_NAME) then
begin
consume(_NAME);
od.objextname:=stringdup(get_stringconst);
end
else
od.objextname:=stringdup(od.objrealname^);
consume(_SEMICOLON); consume(_SEMICOLON);
od.make_all_methods_external; od.make_all_methods_external;
end; include(od.objectoptions,oo_is_external);
end
else { or also allow "public name 'x'"? }
od.objextname:=stringdup(od.objrealname^);
end; end;
@ -380,7 +391,7 @@ implementation
(token=_DISPINTERFACE) or (token=_DISPINTERFACE) or
(token=_OBJCCLASS)) and (token=_OBJCCLASS)) and
(assigned(ttypesym(sym).typedef)) and (assigned(ttypesym(sym).typedef)) and
is_class_or_interface_or_dispinterface(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 (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
begin begin
case token of case token of
@ -395,6 +406,8 @@ implementation
objecttype:=odt_dispinterface; objecttype:=odt_dispinterface;
_OBJCCLASS : _OBJCCLASS :
objecttype:=odt_objcclass; objecttype:=odt_objcclass;
_OBJCPROTOCOL :
objecttype:=odt_objcprotocol;
else else
internalerror(200811072); internalerror(200811072);
end; end;
@ -432,7 +445,7 @@ implementation
hdef:=tstoreddef(hdef).getcopy; hdef:=tstoreddef(hdef).getcopy;
{ fix name, it is used e.g. for tables } { fix name, it is used e.g. for tables }
if is_class_or_interface_or_dispinterface(hdef) then if is_class_or_interface_or_dispinterface_or_objc(hdef) then
with tobjectdef(hdef) do with tobjectdef(hdef) do
begin begin
stringdispose(objname); stringdispose(objname);
@ -489,21 +502,33 @@ implementation
end; end;
objectdef : objectdef :
begin begin
try_consume_hintdirective(newtype.symoptions);
consume(_SEMICOLON);
{ we have to know whether the class or protocol is
external before the vmt is built, because some errors/
hints depend on this }
if is_objc_class_or_protocol(hdef) then
get_objc_class_or_protocol_external_status(tobjectdef(hdef));
{ Build VMT indexes, skip for type renaming and forward classes } { Build VMT indexes, skip for type renaming and forward classes }
if (hdef.typesym=newtype) and if (hdef.typesym=newtype) and
not(oo_is_forward in tobjectdef(hdef).objectoptions) and not(oo_is_forward in tobjectdef(hdef).objectoptions) and
not(df_generic in hdef.defoptions) and not(df_generic in hdef.defoptions) then
not is_objcclass(hdef) then
begin begin
vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef)); vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef));
vmtbuilder.generate_vmt; vmtbuilder.generate_vmt;
vmtbuilder.free; vmtbuilder.free;
end; end;
try_consume_hintdirective(newtype.symoptions);
consume(_SEMICOLON);
if is_objcclass(hdef) then { In case of an objcclass, verify that all methods have a message
finish_objc_class(tobjectdef(hdef)); name set. We only check this now, because message names can be set
during the protocol (interface) mapping. At the same time, set the
mangled names.
}
if is_objc_class_or_protocol(hdef) then
tobjectdef(hdef).check_and_finish_messages;
end; end;
recorddef : recorddef :
begin begin

122
compiler/pdecobj.pas
View File

@ -160,6 +160,23 @@ implementation
end; end;
procedure setobjcclassmethodoptions;
var
i : longint;
def : tdef;
begin
for i:=0 to current_objectdef.symtable.DefList.count-1 do
begin
def:=tdef(current_objectdef.symtable.DefList[i]);
if assigned(def) and
(def.typ=procdef) then
begin
include(tprocdef(def).procoptions,po_virtualmethod);
end;
end;
end;
procedure handleImplementedInterface(intfdef : tobjectdef); procedure handleImplementedInterface(intfdef : tobjectdef);
begin begin
if not is_interface(intfdef) then if not is_interface(intfdef) then
@ -180,7 +197,23 @@ implementation
end; end;
procedure readImplementedInterfaces; procedure handleImplementedProtocol(intfdef : tobjectdef);
begin
if not is_objcprotocol(intfdef) then
begin
Message1(type_e_protocol_type_expected,intfdef.typename);
exit;
end;
if current_objectdef.find_implemented_interface(intfdef)<>nil then
Message1(sym_e_duplicate_id,intfdef.objname^)
else
begin
current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
end;
end;
procedure readImplementedInterfacesAndProtocols(intf: boolean);
var var
hdef : tdef; hdef : tdef;
begin begin
@ -189,10 +222,16 @@ implementation
id_type(hdef,false); id_type(hdef,false);
if (hdef.typ<>objectdef) then if (hdef.typ<>objectdef) then
begin begin
Message1(type_e_interface_type_expected,hdef.typename); if intf then
Message1(type_e_interface_type_expected,hdef.typename)
else
Message1(type_e_protocol_type_expected,hdef.typename);
continue; continue;
end; end;
handleImplementedInterface(tobjectdef(hdef)); if intf then
handleImplementedInterface(tobjectdef(hdef))
else
handleImplementedProtocol(tobjectdef(hdef));
end; end;
end; end;
@ -274,6 +313,18 @@ implementation
Message(parser_e_mix_of_classes_and_objects); Message(parser_e_mix_of_classes_and_objects);
odt_objcclass: odt_objcclass:
if not(is_objcclass(childof)) then if not(is_objcclass(childof)) then
begin
if is_objcprotocol(childof) then
begin
intfchildof:=childof;
childof:=nil;
CGMessage(parser_h_no_objc_parent);
end
else
Message(parser_e_mix_of_classes_and_objects);
end;
odt_objcprotocol:
if not(is_objcprotocol(childof)) then
Message(parser_e_mix_of_classes_and_objects); Message(parser_e_mix_of_classes_and_objects);
odt_object: odt_object:
if not(is_object(childof)) then if not(is_object(childof)) then
@ -325,11 +376,14 @@ implementation
if hasparentdefined then if hasparentdefined then
begin begin
if current_objectdef.objecttype=odt_class then if current_objectdef.objecttype in [odt_class,odt_objcclass] then
begin begin
if assigned(intfchildof) then if assigned(intfchildof) then
handleImplementedInterface(intfchildof); if current_objectdef.objecttype=odt_class then
readImplementedInterfaces; handleImplementedInterface(intfchildof)
else
handleImplementedProtocol(intfchildof);
readImplementedInterfacesAndProtocols(current_objectdef.objecttype=odt_class);
end; end;
consume(_RKLAMMER); consume(_RKLAMMER);
end; end;
@ -374,14 +428,12 @@ implementation
procedure chkobjc(pd: tprocdef); procedure chkobjc(pd: tprocdef);
begin begin
if is_objcclass(pd._class) then if is_objc_class_or_protocol(pd._class) then
begin begin
{ none of the explicit calling conventions should be allowed } { none of the explicit calling conventions should be allowed }
if (po_hascallingconvention in pd.procoptions) then if (po_hascallingconvention in pd.procoptions) then
internalerror(2009032501); internalerror(2009032501);
pd.proccalloption:=pocall_cdecl; pd.proccalloption:=pocall_cdecl;
if not(po_msgstr in pd.procoptions) then
Message(parser_e_objc_requires_msgstr);
include(pd.procoptions,po_objc); include(pd.procoptions,po_objc);
end; end;
end; end;
@ -450,11 +502,19 @@ implementation
end; end;
_ID : _ID :
begin begin
case idtoken of if is_objcprotocol(current_objectdef) and
((idtoken=_REQUIRED) or
(idtoken=_OPTIONAL)) then
begin
current_objectdef.symtable.currentlyoptional:=(idtoken=_OPTIONAL);
consume(idtoken)
end
else case idtoken of
_PRIVATE : _PRIVATE :
begin begin
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
Message(parser_e_no_access_specifier_in_interfaces); is_objcprotocol(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PRIVATE); consume(_PRIVATE);
current_objectdef.symtable.currentvisibility:=vis_private; current_objectdef.symtable.currentvisibility:=vis_private;
include(current_objectdef.objectoptions,oo_has_private); include(current_objectdef.objectoptions,oo_has_private);
@ -462,7 +522,8 @@ implementation
end; end;
_PROTECTED : _PROTECTED :
begin begin
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PROTECTED); consume(_PROTECTED);
current_objectdef.symtable.currentvisibility:=vis_protected; current_objectdef.symtable.currentvisibility:=vis_protected;
@ -471,7 +532,8 @@ implementation
end; end;
_PUBLIC : _PUBLIC :
begin begin
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLIC); consume(_PUBLIC);
current_objectdef.symtable.currentvisibility:=vis_public; current_objectdef.symtable.currentvisibility:=vis_public;
@ -482,15 +544,21 @@ implementation
{ we've to check for a pushlished section in non- } { we've to check for a pushlished section in non- }
{ publishable classes later, if a real declaration } { publishable classes later, if a real declaration }
{ this is the way, delphi does it } { this is the way, delphi does it }
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
{ Objective-C classes do not support "published",
as basically everything is published. }
if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_no_objc_published);
consume(_PUBLISHED); consume(_PUBLISHED);
current_objectdef.symtable.currentvisibility:=vis_published; current_objectdef.symtable.currentvisibility:=vis_published;
fields_allowed:=true; fields_allowed:=true;
end; end;
_STRICT : _STRICT :
begin begin
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_STRICT); consume(_STRICT);
if token=_ID then if token=_ID then
@ -520,7 +588,8 @@ implementation
begin begin
if object_member_blocktype=bt_general then if object_member_blocktype=bt_general then
begin begin
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
is_objcprotocol(current_objectdef) then
Message(parser_e_no_vars_in_interfaces); Message(parser_e_no_vars_in_interfaces);
if (current_objectdef.symtable.currentvisibility=vis_published) and if (current_objectdef.symtable.currentvisibility=vis_published) and
@ -601,7 +670,7 @@ implementation
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
{ Objective-C does not know the concept of a constructor } { Objective-C does not know the concept of a constructor }
if is_objcclass(current_objectdef) then if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor); Message(parser_e_objc_no_constructor_destructor);
oldparse_only:=parse_only; oldparse_only:=parse_only;
@ -639,7 +708,7 @@ implementation
Message(parser_w_destructor_should_be_public); Message(parser_w_destructor_should_be_public);
{ Objective-C does not know the concept of a destructor } { Objective-C does not know the concept of a destructor }
if is_objcclass(current_objectdef) then if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor); Message(parser_e_objc_no_constructor_destructor);
oldparse_only:=parse_only; oldparse_only:=parse_only;
@ -727,6 +796,14 @@ implementation
class_tobject:=current_objectdef; class_tobject:=current_objectdef;
end; end;
end; end;
if (current_module.modulename^='OBJCBASE') then
begin
case current_objectdef.objecttype of
odt_objcclass:
if (current_objectdef.objname^='Protocol') then
objc_protocoltype:=current_objectdef;
end;
end;
end; end;
{ set published flag in $M+ mode, it can also be inherited and will { set published flag in $M+ mode, it can also be inherited and will
@ -772,8 +849,11 @@ implementation
not(oo_has_constructor in current_objectdef.objectoptions) then not(oo_has_constructor in current_objectdef.objectoptions) then
Message1(parser_w_virtual_without_constructor,current_objectdef.objrealname^); Message1(parser_w_virtual_without_constructor,current_objectdef.objrealname^);
if is_interface(current_objectdef) then if is_interface(current_objectdef) or
setinterfacemethodoptions; is_objcprotocol(current_objectdef) then
setinterfacemethodoptions
else if is_objcclass(current_objectdef) then
setobjcclassmethodoptions;
{ return defined objectdef } { return defined objectdef }
result:=current_objectdef; result:=current_objectdef;

32
compiler/pdecsub.pas
View File

@ -40,7 +40,8 @@ interface
pd_notprocvar, { directive can not be used procvar declaration } pd_notprocvar, { directive can not be used procvar declaration }
pd_dispinterface,{ directive can be used with dispinterface methods } pd_dispinterface,{ directive can be used with dispinterface methods }
pd_cppobject, { directive can be used with cppclass } pd_cppobject, { directive can be used with cppclass }
pd_objcclass { directive can be used with objcclass } pd_objcclass, { directive can be used with objcclass }
pd_objcprot { directive can be used with objcprotocol }
); );
tpdflags=set of tpdflag; tpdflags=set of tpdflag;
@ -160,7 +161,7 @@ implementation
vsp : tvarspez; vsp : tvarspez;
begin begin
if (pd.typ=procdef) and if (pd.typ=procdef) and
is_objcclass(tprocdef(pd)._class) then is_objc_class_or_protocol(tprocdef(pd)._class) then
begin begin
{ insert Objective-C self and selector parameters } { insert Objective-C self and selector parameters }
vs:=tparavarsym.create('$msgsel',paranr_vmt,vs_value,objc_seltype,[vo_is_msgsel,vo_is_hidden_para]); vs:=tparavarsym.create('$msgsel',paranr_vmt,vs_value,objc_seltype,[vo_is_msgsel,vo_is_hidden_para]);
@ -883,6 +884,7 @@ implementation
{ symbol options that need to be kept per procdef } { symbol options that need to be kept per procdef }
pd.fileinfo:=procstartfilepos; pd.fileinfo:=procstartfilepos;
pd.visibility:=symtablestack.top.currentvisibility; pd.visibility:=symtablestack.top.currentvisibility;
pd.optional:=symtablestack.top.currentlyoptional;
{ parse parameters } { parse parameters }
if token=_LKLAMMER then if token=_LKLAMMER then
@ -932,6 +934,7 @@ implementation
if is_interface(aclass) then if is_interface(aclass) then
Message(parser_e_no_static_method_in_interfaces) Message(parser_e_no_static_method_in_interfaces)
else else
{ class methods are also allowed for Objective-C protocols }
isclassmethod:=true; isclassmethod:=true;
end; end;
case token of case token of
@ -1329,7 +1332,7 @@ procedure pd_override(pd:tabstractprocdef);
begin begin
if pd.typ<>procdef then if pd.typ<>procdef then
internalerror(2003042611); internalerror(2003042611);
if not(is_class_or_interface(tprocdef(pd)._class)) then if not(is_class_or_interface_or_objc(tprocdef(pd)._class)) then
Message(parser_e_no_object_override); Message(parser_e_no_object_override);
end; end;
@ -1348,10 +1351,10 @@ begin
if pd.typ<>procdef then if pd.typ<>procdef then
internalerror(2003042613); internalerror(2003042613);
if not is_class(tprocdef(pd)._class) and if not is_class(tprocdef(pd)._class) and
not is_objcclass(tprocdef(pd)._class) then not is_objc_class_or_protocol(tprocdef(pd)._class) then
Message(parser_e_msg_only_for_classes); Message(parser_e_msg_only_for_classes);
{ check parameter type } { check parameter type }
if not is_objcclass(tprocdef(pd)._class) then if not is_objc_class_or_protocol(tprocdef(pd)._class) then
begin begin
paracnt:=0; paracnt:=0;
pd.parast.SymList.ForEachCall(@check_msg_para,@paracnt); pd.parast.SymList.ForEachCall(@check_msg_para,@paracnt);
@ -1365,11 +1368,6 @@ begin
if (tstringconstnode(pt).len>255) then if (tstringconstnode(pt).len>255) then
Message(parser_e_message_string_too_long); Message(parser_e_message_string_too_long);
tprocdef(pd).messageinf.str:=stringdup(tstringconstnode(pt).value_str); tprocdef(pd).messageinf.str:=stringdup(tstringconstnode(pt).value_str);
{ the message string is the last part we need to set the mangled name
for an Objective-C message
}
if is_objcclass(tprocdef(pd)._class) then
tprocdef(pd).setmangledname(tprocdef(pd).objcmangledname);
end end
else else
if is_constintnode(pt) and if is_constintnode(pt) and
@ -1855,7 +1853,7 @@ const
mutexclpo : [po_external,po_exports] mutexclpo : [po_external,po_exports]
),( ),(
idtok:_MESSAGE; idtok:_MESSAGE;
pd_flags : [pd_interface,pd_object,pd_notobjintf,pd_objcclass]; pd_flags : [pd_interface,pd_object,pd_notobjintf,pd_objcclass, pd_objcprot];
handler : @pd_message; handler : @pd_message;
pocall : pocall_none; pocall : pocall_none;
pooption : []; { can be po_msgstr or po_msgint } pooption : []; { can be po_msgstr or po_msgint }
@ -1900,7 +1898,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_OVERRIDE; idtok:_OVERRIDE;
pd_flags : [pd_interface,pd_object,pd_notobjintf]; pd_flags : [pd_interface,pd_object,pd_notobjintf,pd_objcclass];
handler : @pd_override; handler : @pd_override;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_overridingmethod,po_virtualmethod]; pooption : [po_overridingmethod,po_virtualmethod];
@ -2013,7 +2011,7 @@ const
mutexclpo : [po_assembler,po_external,po_virtualmethod] mutexclpo : [po_assembler,po_external,po_virtualmethod]
),( ),(
idtok:_VARARGS; idtok:_VARARGS;
pd_flags : [pd_interface,pd_implemen,pd_procvar,pd_objcclass]; pd_flags : [pd_interface,pd_implemen,pd_procvar,pd_objcclass, pd_objcprot];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_varargs]; pooption : [po_varargs];
@ -2110,7 +2108,7 @@ const
begin begin
{ parsing a procvar type the name can be any { parsing a procvar type the name can be any
next variable !! } next variable !! }
if ((pdflags * [pd_procvar,pd_object,pd_objcclass])=[]) and if ((pdflags * [pd_procvar,pd_object,pd_objcclass,pd_objcprot])=[]) and
not(idtoken=_PROPERTY) then not(idtoken=_PROPERTY) then
Message1(parser_w_unknown_proc_directive_ignored,name); Message1(parser_w_unknown_proc_directive_ignored,name);
exit; exit;
@ -2178,6 +2176,12 @@ const
if is_objcclass(tprocdef(pd)._class) and if is_objcclass(tprocdef(pd)._class) and
not(pd_objcclass in proc_direcdata[p].pd_flags) then not(pd_objcclass in proc_direcdata[p].pd_flags) then
exit; exit;
{ check if method and directive not for objcprotocol }
if is_objcprotocol(tprocdef(pd)._class) and
not(pd_objcprot in proc_direcdata[p].pd_flags) then
exit;
end; end;
{ consume directive, and turn flag on } { consume directive, and turn flag on }

13
compiler/pexpr.pas
View File

@ -370,11 +370,12 @@ implementation
ttypenode(p1).allowed:=true; ttypenode(p1).allowed:=true;
{ Allow classrefdef, which is required for { Allow classrefdef, which is required for
Typeof(self) in static class methods } Typeof(self) in static class methods }
if (p1.resultdef.typ = objectdef) or if not(is_objc_class_or_protocol(p1.resultdef)) and
(assigned(current_procinfo) and ((p1.resultdef.typ = objectdef) or
((po_classmethod in current_procinfo.procdef.procoptions) or (assigned(current_procinfo) and
(po_staticmethod in current_procinfo.procdef.procoptions)) and ((po_classmethod in current_procinfo.procdef.procoptions) or
(p1.resultdef.typ=classrefdef)) then (po_staticmethod in current_procinfo.procdef.procoptions)) and
(p1.resultdef.typ=classrefdef))) then
statement_syssym:=geninlinenode(in_typeof_x,false,p1) statement_syssym:=geninlinenode(in_typeof_x,false,p1)
else else
begin begin
@ -488,7 +489,7 @@ implementation
procvardef, procvardef,
classrefdef : ; classrefdef : ;
objectdef : objectdef :
if not is_class_or_interface(p1.resultdef) then if not is_class_or_interface_or_objc(p1.resultdef) then
begin begin
Message(parser_e_illegal_parameter_list); Message(parser_e_illegal_parameter_list);
err:=true; err:=true;

2
compiler/pstatmnt.pas
View File

@ -536,7 +536,7 @@ implementation
typecheckpass(p); typecheckpass(p);
end; end;
{ classes and interfaces have implicit dereferencing } { classes and interfaces have implicit dereferencing }
hasimplicitderef:=is_class_or_interface(p.resultdef) or hasimplicitderef:=is_class_or_interface_or_objc(p.resultdef) or
(p.resultdef.typ = classrefdef); (p.resultdef.typ = classrefdef);
if hasimplicitderef then if hasimplicitderef then
hdef:=p.resultdef hdef:=p.resultdef

2
compiler/ptconst.pas
View File

@ -1223,7 +1223,7 @@ implementation
end; end;
{ only allow nil for class and interface } { only allow nil for class and interface }
if is_class_or_interface(def) then if is_class_or_interface_or_objc(def) then
begin begin
n:=comp_expr(true); n:=comp_expr(true);
if n.nodetype<>niln then if n.nodetype<>niln then

21
compiler/ptype.pas
View File

@ -302,7 +302,7 @@ implementation
{ Reparse the original type definition } { Reparse the original type definition }
if not err then if not err then
begin begin
{ Firsta new typesym so we can reuse this specialization and { First a new typesym so we can reuse this specialization and
references to this specialization can be handled } references to this specialization can be handled }
srsym:=ttypesym.create(specializename,generrordef); srsym:=ttypesym.create(specializename,generrordef);
specializest.insert(srsym); specializest.insert(srsym);
@ -357,7 +357,7 @@ implementation
(current_objectdef.objname^=pattern) and (current_objectdef.objname^=pattern) and
( (
(testcurobject=2) or (testcurobject=2) or
is_class_or_interface(current_objectdef) is_class_or_interface_or_objc(current_objectdef)
)then )then
begin begin
consume(_ID); consume(_ID);
@ -542,7 +542,7 @@ implementation
(current_objectdef.objname^=pattern) and (current_objectdef.objname^=pattern) and
( (
(testcurobject=2) or (testcurobject=2) or
is_class_or_interface(current_objectdef) is_class_or_interface_or_objc(current_objectdef)
)then )then
begin begin
consume(_ID); consume(_ID);
@ -989,6 +989,9 @@ implementation
end; end;
_OBJCCLASS : _OBJCCLASS :
begin begin
if not(m_objectivec1 in current_settings.modeswitches) then
Message(parser_f_need_objc);
consume(token); consume(token);
def:=object_dec(odt_objcclass,name,genericdef,genericlist,nil); def:=object_dec(odt_objcclass,name,genericdef,genericlist,nil);
end; end;
@ -1004,6 +1007,14 @@ implementation
else {it_interfacecorba} else {it_interfacecorba}
def:=object_dec(odt_interfacecorba,name,genericdef,genericlist,nil); def:=object_dec(odt_interfacecorba,name,genericdef,genericlist,nil);
end; end;
_OBJCPROTOCOL :
begin
if not(m_objectivec1 in current_settings.modeswitches) then
Message(parser_f_need_objc);
consume(token);
def:=object_dec(odt_objcprotocol,name,genericdef,genericlist,nil);
end;
_OBJECT : _OBJECT :
begin begin
consume(token); consume(token);
@ -1105,7 +1116,7 @@ implementation
if ( if (
assigned(def.typesym) and assigned(def.typesym) and
(st.symtabletype=globalsymtable) and (st.symtabletype=globalsymtable) and
not is_objcclass(def) not is_objc_class_or_protocol(def)
) or ) or
def.needs_inittable or def.needs_inittable or
(ds_init_table_used in def.defstates) then (ds_init_table_used in def.defstates) then
@ -1114,7 +1125,7 @@ implementation
if ( if (
assigned(def.typesym) and assigned(def.typesym) and
(st.symtabletype=globalsymtable) and (st.symtabletype=globalsymtable) and
not is_objcclass(def) not is_objc_class_or_protocol(def)
) or ) or
(ds_rtti_table_used in def.defstates) then (ds_rtti_table_used in def.defstates) then
RTTIWriter.write_rtti(def,fullrtti); RTTIWriter.write_rtti(def,fullrtti);

2
compiler/symbase.pas
View File

@ -96,6 +96,7 @@ interface
moduleid : longint; moduleid : longint;
refcount : smallint; refcount : smallint;
currentvisibility : tvisibility; currentvisibility : tvisibility;
currentlyoptional : boolean;
{ level of symtable, used for nested procedures } { level of symtable, used for nested procedures }
symtablelevel : byte; symtablelevel : byte;
symtabletype : TSymtabletype; symtabletype : TSymtabletype;
@ -222,6 +223,7 @@ implementation
SymList:=TFPHashObjectList.Create(true); SymList:=TFPHashObjectList.Create(true);
refcount:=1; refcount:=1;
currentvisibility:=vis_public; currentvisibility:=vis_public;
currentlyoptional:=false;
end; end;

7
compiler/symconst.pas
View File

@ -290,7 +290,8 @@ type
odt_interfacecorba, odt_interfacecorba,
odt_cppclass, odt_cppclass,
odt_dispinterface, odt_dispinterface,
odt_objcclass odt_objcclass,
odt_objcprotocol
); );
{ Variations in interfaces implementation } { Variations in interfaces implementation }
@ -317,7 +318,9 @@ type
oo_has_msgint, oo_has_msgint,
oo_can_have_published,{ the class has rtti, i.e. you can publish properties } oo_can_have_published,{ the class has rtti, i.e. you can publish properties }
oo_has_default_property, oo_has_default_property,
oo_has_valid_guid oo_has_valid_guid,
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;) }
); );
tobjectoptions=set of tobjectoption; tobjectoptions=set of tobjectoption;

113
compiler/symdef.pas
View File

@ -241,7 +241,9 @@ interface
childofderef : tderef; childofderef : tderef;
objname, objname,
objrealname : pshortstring; objrealname,
{ for Objective-C: protocols and classes can have the same name there }
objextname : pshortstring;
objectoptions : tobjectoptions; objectoptions : tobjectoptions;
{ to be able to have a variable vmt position } { to be able to have a variable vmt position }
{ and no vmt field for objects without virtuals } { and no vmt field for objects without virtuals }
@ -301,7 +303,9 @@ interface
procedure register_maybe_created_object_type; procedure register_maybe_created_object_type;
procedure register_created_classref_type; procedure register_created_classref_type;
procedure register_vmt_call(index:longint); procedure register_vmt_call(index:longint);
{ ObjC }
procedure make_all_methods_external; procedure make_all_methods_external;
procedure check_and_finish_messages;
end; end;
tclassrefdef = class(tabstractpointerdef) tclassrefdef = class(tabstractpointerdef)
@ -488,7 +492,9 @@ interface
{ true if the procedure is declared in the interface } { true if the procedure is declared in the interface }
interfacedef : boolean; interfacedef : boolean;
{ true if the procedure has a forward declaration } { true if the procedure has a forward declaration }
hasforward : boolean; hasforward,
{ true if the procedure is an optional method in an Objective-C protocol }
optional : boolean;
{ import info } { import info }
import_dll, import_dll,
import_name : pshortstring; import_name : pshortstring;
@ -669,6 +675,8 @@ interface
objc_superclasstype, objc_superclasstype,
objc_idtype, objc_idtype,
objc_seltype : tpointerdef; objc_seltype : tpointerdef;
{ base type of @protocol(protocolname) Objective-C statements }
objc_protocoltype : tobjectdef;
const const
{$ifdef i386} {$ifdef i386}
@ -720,9 +728,13 @@ interface
function is_cppclass(def: tdef): boolean; function is_cppclass(def: tdef): boolean;
function is_objcclass(def: tdef): boolean; function is_objcclass(def: tdef): boolean;
function is_objcclassref(def: tdef): boolean; function is_objcclassref(def: tdef): boolean;
function is_objcprotocol(def: tdef): boolean;
function is_objc_class_or_protocol(def: tdef): boolean;
function is_class_or_interface(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; function is_class_or_interface_or_object(def: tdef): boolean;
function is_class_or_interface_or_dispinterface(def: tdef): boolean; function is_class_or_interface_or_dispinterface(def: tdef): boolean;
function is_class_or_interface_or_dispinterface_or_objc(def: tdef): boolean;
procedure loadobjctypes; procedure loadobjctypes;
@ -1118,7 +1130,7 @@ implementation
procvardef : procvardef :
is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions); is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
objectdef: objectdef:
is_intregable:=(is_class(self) or is_interface(self)) and not needs_inittable; is_intregable:=(is_class_or_interface_or_objc(self)) and not needs_inittable;
setdef: setdef:
is_intregable:=is_smallset(self); is_intregable:=is_smallset(self);
recorddef: recorddef:
@ -2937,6 +2949,7 @@ implementation
forwarddef:=true; forwarddef:=true;
interfacedef:=false; interfacedef:=false;
hasforward:=false; hasforward:=false;
optional:=false;
_class := nil; _class := nil;
import_dll:=nil; import_dll:=nil;
import_name:=nil; import_name:=nil;
@ -2965,6 +2978,7 @@ implementation
ppufile.getposinfo(fileinfo); ppufile.getposinfo(fileinfo);
visibility:=tvisibility(ppufile.getbyte); visibility:=tvisibility(ppufile.getbyte);
ppufile.getsmallset(symoptions); ppufile.getsmallset(symoptions);
optional:=boolean(ppufile.getbyte);
{$ifdef powerpc} {$ifdef powerpc}
{ library symbol for AmigaOS/MorphOS } { library symbol for AmigaOS/MorphOS }
ppufile.getderef(libsymderef); ppufile.getderef(libsymderef);
@ -3102,6 +3116,7 @@ implementation
ppufile.putposinfo(fileinfo); ppufile.putposinfo(fileinfo);
ppufile.putbyte(byte(visibility)); ppufile.putbyte(byte(visibility));
ppufile.putsmallset(symoptions); ppufile.putsmallset(symoptions);
ppufile.putbyte(byte(optional));
{$ifdef powerpc} {$ifdef powerpc}
{ library symbol for AmigaOS/MorphOS } { library symbol for AmigaOS/MorphOS }
ppufile.putderef(libsymderef); ppufile.putderef(libsymderef);
@ -3516,7 +3531,7 @@ implementation
if not (po_msgstr in procoptions) then if not (po_msgstr in procoptions) then
internalerror(2009030901); internalerror(2009030901);
{ we may very well need longer strings to handle these... } { we may very well need longer strings to handle these... }
if ((255-length(tobjectdef(procsym.owner.defowner).objrealname^) if ((255-length(tobjectdef(procsym.owner.defowner).objextname^)
-length('+[ ]')-length(messageinf.str^)) < 0) then -length('+[ ]')-length(messageinf.str^)) < 0) then
Message1(parser_e_objc_message_name_too_long,messageinf.str^); Message1(parser_e_objc_message_name_too_long,messageinf.str^);
if not(po_classmethod in procoptions) then if not(po_classmethod in procoptions) then
@ -3711,7 +3726,7 @@ implementation
if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
prepareguid; prepareguid;
{ setup implemented interfaces } { setup implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba] then if objecttype in [odt_class,odt_interfacecorba,odt_objcclass] then
ImplementedInterfaces:=TFPObjectList.Create(true) ImplementedInterfaces:=TFPObjectList.Create(true)
else else
ImplementedInterfaces:=nil; ImplementedInterfaces:=nil;
@ -3731,6 +3746,10 @@ implementation
objecttype:=tobjecttyp(ppufile.getbyte); objecttype:=tobjecttyp(ppufile.getbyte);
objrealname:=stringdup(ppufile.getstring); objrealname:=stringdup(ppufile.getstring);
objname:=stringdup(upper(objrealname^)); objname:=stringdup(upper(objrealname^));
objextname:=stringdup(ppufile.getstring);
{ only used for external Objective-C classes/protocols }
if (objextname^='') then
stringdispose(objextname);
symtable:=tObjectSymtable.create(self,objrealname^,0); symtable:=tObjectSymtable.create(self,objrealname^,0);
tObjectSymtable(symtable).datasize:=ppufile.getaint; tObjectSymtable(symtable).datasize:=ppufile.getaint;
tObjectSymtable(symtable).fieldalignment:=ppufile.getbyte; tObjectSymtable(symtable).fieldalignment:=ppufile.getbyte;
@ -3761,7 +3780,7 @@ implementation
end; end;
{ load implemented interfaces } { load implemented interfaces }
if objecttype in [odt_class,odt_interfacecorba] then if objecttype in [odt_class,odt_interfacecorba,odt_objcclass] then
begin begin
ImplementedInterfaces:=TFPObjectList.Create(true); ImplementedInterfaces:=TFPObjectList.Create(true);
implintfcount:=ppufile.getlongint; implintfcount:=ppufile.getlongint;
@ -3792,6 +3811,10 @@ implementation
(objecttype=odt_interfacecom) and (objecttype=odt_interfacecom) and
(objname^='IUNKNOWN') then (objname^='IUNKNOWN') then
interface_iunknown:=self; interface_iunknown:=self;
if (childof=nil) and
(objecttype=odt_objcclass) and
(objname^='PROTOCOL') then
objc_protocoltype:=self;
writing_class_record_dbginfo:=false; writing_class_record_dbginfo:=false;
end; end;
@ -3805,6 +3828,7 @@ implementation
end; end;
stringdispose(objname); stringdispose(objname);
stringdispose(objrealname); stringdispose(objrealname);
stringdispose(objextname);
stringdispose(iidstr); stringdispose(iidstr);
if assigned(ImplementedInterfaces) then if assigned(ImplementedInterfaces) then
begin begin
@ -3843,6 +3867,8 @@ implementation
tobjectdef(result).objname:=stringdup(objname^); tobjectdef(result).objname:=stringdup(objname^);
if assigned(objrealname) then if assigned(objrealname) then
tobjectdef(result).objrealname:=stringdup(objrealname^); tobjectdef(result).objrealname:=stringdup(objrealname^);
if assigned(objextname) then
tobjectdef(result).objextname:=stringdup(objextname^);
tobjectdef(result).objectoptions:=objectoptions; tobjectdef(result).objectoptions:=objectoptions;
include(tobjectdef(result).defoptions,df_copied_def); include(tobjectdef(result).defoptions,df_copied_def);
tobjectdef(result).vmt_offset:=vmt_offset; tobjectdef(result).vmt_offset:=vmt_offset;
@ -3875,6 +3901,10 @@ implementation
inherited ppuwrite(ppufile); inherited ppuwrite(ppufile);
ppufile.putbyte(byte(objecttype)); ppufile.putbyte(byte(objecttype));
ppufile.putstring(objrealname^); ppufile.putstring(objrealname^);
if assigned(objextname) then
ppufile.putstring(objextname^)
else
ppufile.putstring('');
ppufile.putaint(tObjectSymtable(symtable).datasize); ppufile.putaint(tObjectSymtable(symtable).datasize);
ppufile.putbyte(tObjectSymtable(symtable).fieldalignment); ppufile.putbyte(tObjectSymtable(symtable).fieldalignment);
ppufile.putbyte(tObjectSymtable(symtable).recordalignment); ppufile.putbyte(tObjectSymtable(symtable).recordalignment);
@ -4113,7 +4143,7 @@ implementation
procedure tobjectdef.check_forwards; procedure tobjectdef.check_forwards;
begin begin
if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol]) then
tstoredsymtable(symtable).check_forwards; tstoredsymtable(symtable).check_forwards;
if (oo_is_forward in objectoptions) then if (oo_is_forward in objectoptions) then
begin begin
@ -4179,7 +4209,7 @@ implementation
function tobjectdef.size : aint; function tobjectdef.size : aint;
begin begin
if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass] then if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol] then
result:=sizeof(pint) result:=sizeof(pint)
else else
result:=tObjectSymtable(symtable).datasize; result:=tObjectSymtable(symtable).datasize;
@ -4188,7 +4218,7 @@ implementation
function tobjectdef.alignment:shortint; function tobjectdef.alignment:shortint;
begin begin
if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass] then if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol] then
alignment:=sizeof(pint) alignment:=sizeof(pint)
else else
alignment:=tObjectSymtable(symtable).recordalignment; alignment:=tObjectSymtable(symtable).recordalignment;
@ -4202,7 +4232,8 @@ implementation
odt_class: odt_class:
{ the +2*sizeof(pint) is size and -size } { the +2*sizeof(pint) is size and -size }
vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint); vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint);
odt_objcclass: odt_objcclass,
odt_objcprotocol:
vmtmethodoffset:=0; vmtmethodoffset:=0;
odt_interfacecom,odt_interfacecorba: odt_interfacecom,odt_interfacecorba:
vmtmethodoffset:=index*sizeof(pint); vmtmethodoffset:=index*sizeof(pint);
@ -4237,7 +4268,8 @@ implementation
odt_object: odt_object:
needs_inittable:=tObjectSymtable(symtable).needs_init_final; needs_inittable:=tObjectSymtable(symtable).needs_init_final;
odt_cppclass, odt_cppclass,
odt_objcclass: odt_objcclass,
odt_objcprotocol:
needs_inittable:=false; needs_inittable:=false;
else else
internalerror(200108267); internalerror(200108267);
@ -4346,6 +4378,29 @@ implementation
end; end;
procedure check_and_finish_msg(data: tobject; arg: pointer);
var
def: tdef absolute data;
begin
if (def.typ = procdef) then
begin
{ 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 tprocdef(def).procoptions) then
tprocdef(def).setmangledname(tprocdef(def).objcmangledname)
else
MessagePos(tprocdef(def).fileinfo,parser_e_objc_requires_msgstr)
end;
end;
procedure tobjectdef.check_and_finish_messages;
begin
self.symtable.DefList.foreachcall(@check_and_finish_msg,nil);
end;
{**************************************************************************** {****************************************************************************
TImplementedInterface TImplementedInterface
****************************************************************************} ****************************************************************************}
@ -4644,6 +4699,24 @@ implementation
end; end;
function is_objcprotocol(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
(tobjectdef(def).objecttype=odt_objcprotocol);
end;
function is_objc_class_or_protocol(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
(tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]);
end;
function is_class_or_interface(def: tdef): boolean; function is_class_or_interface(def: tdef): boolean;
begin begin
result:= result:=
@ -4653,6 +4726,15 @@ implementation
end; end;
function is_class_or_interface_or_objc(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
(tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]);
end;
function is_class_or_interface_or_object(def: tdef): boolean; function is_class_or_interface_or_object(def: tdef): boolean;
begin begin
result:= result:=
@ -4671,6 +4753,15 @@ implementation
end; end;
function is_class_or_interface_or_dispinterface_or_objc(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
(tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol]);
end;
procedure loadobjctypes; procedure loadobjctypes;
begin begin
objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC1','POBJC_CLASS').typedef); objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC1','POBJC_CLASS').typedef);

2
compiler/symtable.pas
View File

@ -195,7 +195,7 @@ interface
function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean; function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;

6
compiler/tokens.pas
View File

@ -205,12 +205,14 @@ type
_LOCATION, _LOCATION,
_MWPASCAL, _MWPASCAL,
_OPERATOR, _OPERATOR,
_OPTIONAL,
_OVERLOAD, _OVERLOAD,
_OVERRIDE, _OVERRIDE,
_PLATFORM, _PLATFORM,
_PROPERTY, _PROPERTY,
_READONLY, _READONLY,
_REGISTER, _REGISTER,
_REQUIRED,
_REQUIRES, _REQUIRES,
_RESIDENT, _RESIDENT,
_SAFECALL, _SAFECALL,
@ -244,6 +246,7 @@ type
_EXPERIMENTAL, _EXPERIMENTAL,
_FINALIZATION, _FINALIZATION,
_NOSTACKFRAME, _NOSTACKFRAME,
_OBJCPROTOCOL,
_WEAKEXTERNAL, _WEAKEXTERNAL,
_DISPINTERFACE, _DISPINTERFACE,
_UNIMPLEMENTED, _UNIMPLEMENTED,
@ -458,12 +461,14 @@ const
(str:'LOCATION' ;special:false;keyword:m_none;op:NOTOKEN), (str:'LOCATION' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'MWPASCAL' ;special:false;keyword:m_none;op:NOTOKEN), (str:'MWPASCAL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OPERATOR' ;special:false;keyword:m_fpc;op:NOTOKEN), (str:'OPERATOR' ;special:false;keyword:m_fpc;op:NOTOKEN),
(str:'OPTIONAL' ;special:false;keyword:m_none;op:NOTOKEN), { optional methods in an Objective-C protocol }
(str:'OVERLOAD' ;special:false;keyword:m_none;op:NOTOKEN), (str:'OVERLOAD' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OVERRIDE' ;special:false;keyword:m_none;op:NOTOKEN), (str:'OVERRIDE' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'PLATFORM' ;special:false;keyword:m_none;op:NOTOKEN), (str:'PLATFORM' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'PROPERTY' ;special:false;keyword:m_property;op:NOTOKEN), (str:'PROPERTY' ;special:false;keyword:m_property;op:NOTOKEN),
(str:'READONLY' ;special:false;keyword:m_none;op:NOTOKEN), (str:'READONLY' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'REGISTER' ;special:false;keyword:m_none;op:NOTOKEN), (str:'REGISTER' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'REQUIRED' ;special:false;keyword:m_none;op:NOTOKEN), { required methods in an Objective-C protocol }
(str:'REQUIRES' ;special:false;keyword:m_none;op:NOTOKEN), (str:'REQUIRES' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'RESIDENT' ;special:false;keyword:m_none;op:NOTOKEN), (str:'RESIDENT' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'SAFECALL' ;special:false;keyword:m_none;op:NOTOKEN), (str:'SAFECALL' ;special:false;keyword:m_none;op:NOTOKEN),
@ -497,6 +502,7 @@ const
(str:'EXPERIMENTAL' ;special:false;keyword:m_all;op:NOTOKEN), (str:'EXPERIMENTAL' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'FINALIZATION' ;special:false;keyword:m_initfinal;op:NOTOKEN), (str:'FINALIZATION' ;special:false;keyword:m_initfinal;op:NOTOKEN),
(str:'NOSTACKFRAME' ;special:false;keyword:m_none;op:NOTOKEN), (str:'NOSTACKFRAME' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'OBJCPROTOCOL' ;special:false;keyword:m_objectivec1;op:NOTOKEN), { Objective-C protocol }
(str:'WEAKEXTERNAL' ;special:false;keyword:m_none;op:NOTOKEN), (str:'WEAKEXTERNAL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'DISPINTERFACE' ;special:false;keyword:m_class;op:NOTOKEN), (str:'DISPINTERFACE' ;special:false;keyword:m_class;op:NOTOKEN),
(str:'UNIMPLEMENTED' ;special:false;keyword:m_all;op:NOTOKEN), (str:'UNIMPLEMENTED' ;special:false;keyword:m_all;op:NOTOKEN),

1
rtl/inc/objc1.pp
View File

@ -44,6 +44,7 @@ type
_class: pobjc_class; _class: pobjc_class;
end; end;
id = ^objc_object; id = ^objc_object;
pobjc_object = id;
_fpc_objc_sel_type = record _fpc_objc_sel_type = record
end; end;

76
rtl/inc/objcbase.pp
View File

@ -33,15 +33,15 @@ type
NSCoder = objcclass; external; NSCoder = objcclass; external;
} }
NSObject = objcclass Protocol = objcclass
strict protected end; external;
isa: pobjc_class;
public NSObjectProtocol = objcprotocol
{ NSObject protocol }
function isEqual_(obj: id): boolean; message 'isEqual:'; function isEqual_(obj: id): boolean; message 'isEqual:';
function hash: cuint; message 'hash'; function hash: cuint; message 'hash';
// implemented as class method instead?
// function superclass: pobjc_class; function superclass: pobjc_class; message 'superclass';
function _class: pobjc_class; message 'class';
{ "self" is both a hidden parameter to each method, and a method of { "self" is both a hidden parameter to each method, and a method of
NSObject and thereby of each subclass as well NSObject and thereby of each subclass as well
} }
@ -56,8 +56,7 @@ type
function isKindOfClass_(aClass: pobjc_class): boolean; message 'isKindOfClass:'; function isKindOfClass_(aClass: pobjc_class): boolean; message 'isKindOfClass:';
function isMemberOfClass_(aClass: pobjc_class): boolean; message 'isMemberOfClass:'; function isMemberOfClass_(aClass: pobjc_class): boolean; message 'isMemberOfClass:';
// implemented as class method instead? function conformsToProtocol_(aProtocol: Protocol): boolean; message 'conformsToProtocol:';
// function conformsToProtocol(aProtocol: pobjc_protocal): boolean;
function respondsToSelector_(aSelector: SEL): boolean; message 'respondsToSelector:'; function respondsToSelector_(aSelector: SEL): boolean; message 'respondsToSelector:';
@ -66,8 +65,51 @@ type
function autorelease: id; message 'autorelease'; function autorelease: id; message 'autorelease';
function retainCount: cint; message 'retainCount'; function retainCount: cint; message 'retainCount';
// implemented as class method instead? function description: {NSString} id; message 'description';
// function description: NSString; end; external name 'NSObject';
NSObject = objcclass(NSObjectProtocol)
strict protected
isa: pobjc_class;
public
{ NSObjectProtocol -- the message names are copied from the protocol
definition by the compiler, but you can still repeat them if you want }
function isEqual_(obj: id): boolean;
function hash: cuint;
function superclass: pobjc_class;
function _class: pobjc_class;
{ "self" is both a hidden parameter to each method, and a method of
NSObject and thereby of each subclass as well
}
function self: id;
function zone: id; { NSZone }
function performSelector_(aSelector: SEL): id;
function performSelector_withObject_(aSelector: SEL; obj: id): id;
function performSelector_withObject_withObject(aSelector: SEL; obj1, obj2: id): id;
function isProxy: boolean;
function isKindOfClass_(aClass: pobjc_class): boolean;
function isMemberOfClass_(aClass: pobjc_class): boolean;
function conformsToProtocol_(aProtocol: Protocol): boolean;
function respondsToSelector_(aSelector: SEL): boolean;
function retain: id;
procedure release; { oneway }
function autorelease: id;
function retainCount: cint;
function description: {NSString} id;
{ NSObject class }
{ "class" prefix to method name to avoid name collision with NSObjectProtocol }
class function classIsEqual_(obj: id): boolean; message 'isEqual:';
{ "class" prefix to method name to avoid name collision with NSObjectProtocol }
class function classHash: cuint; message 'hash';
{ NSObject methods } { NSObject methods }
@ -80,6 +122,7 @@ type
class function allocWithZone_(_zone: id {NSZone}): id; message 'allocWithZone:'; class function allocWithZone_(_zone: id {NSZone}): id; message 'allocWithZone:';
class function alloc: id; message 'alloc'; class function alloc: id; message 'alloc';
procedure dealloc; message 'dealloc'; procedure dealloc; message 'dealloc';
{ if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4 } { if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4 }
procedure finalize; message 'finalize'; procedure finalize; message 'finalize';
{ endif } { endif }
@ -90,11 +133,14 @@ type
class function copyWithZone_(_zone: id {NSZone}): id; message 'copyWithZone:'; class function copyWithZone_(_zone: id {NSZone}): id; message 'copyWithZone:';
class function mutableCopyWithZone_(_zone: id {NSZone}): id; message 'mutableCopyWithZone:'; class function mutableCopyWithZone_(_zone: id {NSZone}): id; message 'mutableCopyWithZone:';
class function superclass: pobjc_class; message 'superclass'; { "class" prefix to method name to avoid name collision with NSObjectProtocol }
class function _class: pobjc_class; message 'class'; class function classSuperclass: pobjc_class; message 'superclass';
{ "class" prefix to method name to avoid name collision with NSObjectProtocol }
class function classClass: pobjc_class; message 'class';
class procedure poseAsClass_(aClass: pobjc_class); message 'poseAsClass:'; class procedure poseAsClass_(aClass: pobjc_class); message 'poseAsClass:';
class function instancesRespondToSelector_(aSelector: SEL): boolean; message 'instancesRespondToSelector:'; class function instancesRespondToSelector_(aSelector: SEL): boolean; message 'instancesRespondToSelector:';
class function conformsToProtocol_(aProtocol: pobjc_protocal): boolean; message 'conformsToProtocol:'; { "class" prefix to method name to avoid name collision with NSObjectProtocol }
class function classConformsToProtocol_(aProtocol: Protocol): boolean; message 'conformsToProtocol:';
function methodForSelector_(aSelector: SEL): IMP; message 'methodForSelector:'; function methodForSelector_(aSelector: SEL): IMP; message 'methodForSelector:';
class function instanceMethodForSelector_(aSelector: SEL): IMP; message 'instanceMethodForSelector:'; class function instanceMethodForSelector_(aSelector: SEL): IMP; message 'instanceMethodForSelector:';
class function version: cint; message 'version'; class function version: cint; message 'version';
@ -103,7 +149,7 @@ type
procedure forwardInvocation_(anInvocation: id {NSInvocation}); message 'forwardInvocation:'; procedure forwardInvocation_(anInvocation: id {NSInvocation}); message 'forwardInvocation:';
function methodSignatureForSelector_(aSelector: SEL): id {NSMethodSignature}; message 'methodSignatureForSelector:'; function methodSignatureForSelector_(aSelector: SEL): id {NSMethodSignature}; message 'methodSignatureForSelector:';
class function description: id {NSString}; message 'description'; class function classDescription: id {NSString}; message 'description';
function classForCoder: pobjc_class; message 'classForCoder'; function classForCoder: pobjc_class; message 'classForCoder';
function replacementObjectForCoder_(aCoder: id {NSCoder}): id; message 'replacementObjectForCoder:'; function replacementObjectForCoder_(aCoder: id {NSCoder}): id; message 'replacementObjectForCoder:';

11
tests/test/tobjc3.pp
View File

@ -11,5 +11,16 @@ type
ta = objcclass ta = objcclass
end; external; end; external;
var
a: ta;
b: nsobject;
c: id;
begin begin
{ avoid hints about unused types/variables/units }
a:=nil;
if (a<>nil) then
exit;
c:=nil;
b:=c;
b.isEqual_(b);
end. end.

2
tests/test/tobjc4.pp
View File

@ -7,7 +7,7 @@
type type
ta = objcclass ta = objcclass
{ no constructors in Objective-C } { no constructors in Objective-C }
constructor create; constructor create; message 'create';
end; external; end; external;
begin begin

2
tests/test/tobjc4a.pp
View File

@ -7,7 +7,7 @@
type type
ta = objcclass ta = objcclass
{ no destructors in Objective-C } { no destructors in Objective-C }
destructor done; destructor done; message 'done';
end; external; end; external;
begin begin

14
tests/test/tobjc5.pp Normal file
View File

@ -0,0 +1,14 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,i386 }
{$modeswitch objectivec1}
type
ta = objcclass
{ needs message name specification }
procedure test;
end; external;
begin
end.

14
tests/test/tobjc5a.pp Normal file
View File

@ -0,0 +1,14 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,i386 }
{$modeswitch objectivec1}
type
ta = objcprotocol
{ needs message name specification }
procedure test;
end; external;
begin
end.

14
tests/test/tobjc6.pp Normal file
View File

@ -0,0 +1,14 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{$mode objfpc}
{$modeswitch objectivec1}
type
ta = objcclass;
ta = objcclass
end;
begin
end.

23
tests/test/tobjc7.pp Normal file
View File

@ -0,0 +1,23 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %norun }
{ %recompile }
{$mode objfpc}
{$modeswitch objectivec1}
uses
uobjc7;
type
tobjcclass = objcclass(tobjcprot)
procedure isrequired;
procedure alsorequired;
{ fake external name to avoid linking errors once we
add external references in all cases to ensure that
all necessary libraries are linked, like gcc does }
end; external name 'NSObject';
begin
end.

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

@ -0,0 +1,22 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %fail }
{$mode objfpc}
{$modeswitch objectivec1}
uses
uobjc7;
type
tobjcclass = objcclass(tobjcprot)
procedure alsorequired;
{ fake external name to avoid linking errors once we
add external references in all cases to ensure that
all necessary libraries are linked, like gcc does }
end; external name 'NSObject';
begin
end.

21
tests/test/tobjc7b.pp Normal file
View File

@ -0,0 +1,21 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %fail }
{$mode objfpc}
{$modeswitch objectivec1}
uses
uobjc7;
type
tobjcclass = objcclass(tobjcprot)
procedure isrequired;
{ fake external name to avoid linking errors once we
add external references in all cases to ensure that
all necessary libraries are linked, like gcc does }
end; external name 'NSObject';
begin
end.

23
tests/test/tobjc7c.pp Normal file
View File

@ -0,0 +1,23 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %norun }
{$mode objfpc}
{$modeswitch objectivec1}
uses
uobjc7;
type
tobjcclass = objcclass(tobjcprot)
procedure isrequired;
procedure isoptional;
procedure alsorequired;
{ fake external name to avoid linking errors once we
add external references in all cases to ensure that
all necessary libraries are linked, like gcc does }
end; external name 'NSObject';
begin
end.

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

@ -0,0 +1,24 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %opt=-vh -Seh }
{ %fail }
{$mode objfpc}
{$modeswitch objectivec1}
uses
ctypes;
type
TMyTestClass = objcclass(NSObject)
{ should give a hint because of a missing 'override' }
function hash: cuint;
end; external name 'NSZone';
var
a: id;
begin
{ avoid warnings/hints about unused types/variables }
a:=TMyTestClass.alloc;
tmytestclass(a).Retain;
end.

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

@ -0,0 +1,24 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %opt=-vh -Seh }
{ %norun }
{$mode objfpc}
{$modeswitch objectivec1}
uses
ctypes;
type
TMyTestClass = objcclass(NSObject)
{ should not give a hint, since we have 'override' }
function hash: cuint; override;
end; external name 'NSZone';
var
a: id;
begin
{ avoid warnings/hints about unused types/variables }
a:=TMyTestClass.alloc;
tmytestclass(a).Retain;
end.

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

@ -0,0 +1,16 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %norun }
{$mode objfpc}
{$modeswitch objectivec1}
uses
ctypes;
var
a: NSObjectProtocol;
b: NSObject;
begin
a:=b;
end.

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

@ -0,0 +1,16 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %fail }
{$mode objfpc}
{$modeswitch objectivec1}
uses
ctypes;
var
a: NSObjectProtocol;
b: NSObject;
begin
b:=a;
end.

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

@ -0,0 +1,16 @@
{ %target=darwin }
{ %cpu=powerpc,i386 }
{ %norun }
{$mode objfpc}
{$modeswitch objectivec1}
uses
ctypes;
var
a: NSObjectProtocol;
b: NSObject;
begin
a:=b;
end.