paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-24 19:31:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* allow any kind of fields in Object Pascal classes that are passed to

Browse Source 
Objective-C methods or which are fields of Objective-C classes (since they
    are basically opaque to the Objective-C runtime) + fixed tobjc11 so it
    expects classes to be encoded as opaque types
  * give a proper error message when using illegal field/parameter types in
    Objective-C classes/methods instead of an internal error (only checked
    during rtti generation rather than during parsing, because during parsing
    some types may still be forwarddefs)
  * split objcutil in objcdef and objcutil, with objcdef depending only on
    the symtable so it can be used in symdef

git-svn-id: trunk@14838 -
This commit is contained in:
Jonas Maebe 2010-01-31 21:13:41 +00:00
parent 4469501835
commit caca6cea37
10 changed files with 776 additions and 601 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -326,6 +326,7 @@ compiler/nopt.pas svneol=native#text/plain
compiler/nset.pas svneol=native#text/plain
compiler/nstate.pas svneol=native#text/plain
compiler/nutils.pas svneol=native#text/plain
compiler/objcdef.pas svneol=native#text/plain
compiler/objcgutl.pas svneol=native#text/plain
compiler/objcutil.pas svneol=native#text/plain
compiler/ogbase.pas svneol=native#text/plain
@ -9108,6 +9109,9 @@ tests/test/tobjc30a.pp svneol=native#text/plain
tests/test/tobjc30b.pp svneol=native#text/plain
tests/test/tobjc30c.pp svneol=native#text/plain
tests/test/tobjc31.pp svneol=native#text/plain
tests/test/tobjc32.pp svneol=native#text/plain
tests/test/tobjc32a.pp svneol=native#text/plain
tests/test/tobjc32b.pp svneol=native#text/plain
tests/test/tobjc4.pp svneol=native#text/plain
tests/test/tobjc4a.pp svneol=native#text/plain
tests/test/tobjc5.pp svneol=native#text/plain

2
compiler/ninl.pas
View File

@ -87,7 +87,7 @@ implementation
symconst,symdef,symsym,symtable,paramgr,defutil,
pass_1,
ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils,
nobjc,objcutil,
nobjc,objcdef,
cgbase,procinfo
;

651
compiler/objcdef.pas Normal file
View File

@ -0,0 +1,651 @@
{
Copyright (c) 2010 by Jonas Maebe
This unit implements some Objective-C type helper routines (minimal
unit dependencies, usable in symdef).
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{$i fpcdefs.inc}
unit objcdef;
interface
uses
node,
symtype;
{ The internals of Objective-C's @encode() functionality: encode a
type into the internal format used by the run time. Returns false
if a type is not representable by the Objective-C run time, and in
that case also the failing definition. }
function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
{ Check whether a type can be used in an Objective-C method
signature or field declaration. }
function objcchecktype(def: tdef; out founderror: tdef): boolean;
{ add type info for def at the end of encodedstr. recordinfostate influences
whether a record-style type will be fully encoded, or just using its
type name. bpacked indicates whether a record/array is bitpacked.
On error, founderror contains the type that triggered the error. }
type
trecordinfostate = (ris_initial, ris_afterpointer, ris_dontprint);
function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
implementation
uses
globtype,
cutils,cclasses,
verbose,systems,
symtable,symconst,symsym,symdef,
defutil,paramgr;
{******************************************************************
Type encoding
*******************************************************************}
function encoderecst(const recname: ansistring; recst: tabstractrecordsymtable; var encodedstr: ansistring; out founderror: tdef): boolean;
var
variantstarts: tfplist;
i, varindex: longint;
field,
firstfield: tfieldvarsym;
firstfieldvariant,
bpacked: boolean;
begin
result:=false;
bpacked:=recst.fieldalignment=bit_alignment;
{ Is the first field already the start of a variant? }
firstfield:=nil;
firstfieldvariant:=false;
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
if not assigned(firstfield) then
firstfield:=field
else if (vo_is_first_field in field.varoptions) then
begin
if (field.fieldoffset=firstfield.fieldoffset) then
firstfieldvariant:=true;
end;
end;
variantstarts:=tfplist.create;
encodedstr:=encodedstr+'{'+recname+'=';
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
{ start of a variant part? }
if ((field=firstfield) and
firstfieldvariant) or
((field<>firstfield) and
(vo_is_first_field in field.varoptions)) then
begin
varindex:=variantstarts.count-1;
if (varindex=-1) or
(tfieldvarsym(variantstarts[varindex]).fieldoffset<field.fieldoffset) then
begin
{ new, more deeply nested variant }
encodedstr:=encodedstr+'(?={?=';
variantstarts.add(field);
end
else
begin
{ close existing nested variants if any }
while (varindex>=0) and
(tfieldvarsym(variantstarts[varindex]).fieldoffset>field.fieldoffset) do
begin
{ close more deeply nested variants }
encodedstr:=encodedstr+'})';
dec(varindex);
end;
if (varindex<0) then
internalerror(2009081805);
if (tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset) then
internalerror(2009081804);
{ variant at the same level as a previous one }
variantstarts.count:=varindex+1;
{ No need to add this field, it has the same offset as the
previous one at this position. }
if tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset then
internalerror(2009081601);
{ close previous variant sub-part and start new one }
encodedstr:=encodedstr+'}{?=';
end
end;
if not addencodedtype(field.vardef,ris_afterpointer,bpacked,encodedstr,founderror) then
exit;
end;
for i:=0 to variantstarts.count-1 do
encodedstr:=encodedstr+'})';
variantstarts.free;
encodedstr:=encodedstr+'}';
result:=true
end;
function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
var
recname: ansistring;
recdef: trecorddef;
objdef: tobjectdef;
len: aint;
c: char;
newstate: trecordinfostate;
addrpara: boolean;
begin
result:=true;
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
st_shortstring:
{ include length byte }
encodedstr:=encodedstr+'['+tostr(tstringdef(def).len+1)+'C]';
else
{ While we could handle refcounted Pascal strings correctly
when such methods are called from Pascal code, things would
completely break down if they were called from Objective-C
code/reflection since the necessary refcount helper calls
would be missing on the caller side (unless we'd
automatically generate wrappers). }
result:=false;
end;
end;
enumdef,
orddef :
begin
if bpacked and
not is_void(def) then
encodedstr:=encodedstr+'b'+tostr(def.packedbitsize)
else
begin
if is_void(def) then
c:='v'
{ in gcc, sizeof(_Bool) = sizeof(char) }
else if is_boolean(def) and
(def.size=1) then
c:='B'
else
begin
case def.size of
1:
c:='c';
2:
c:='s';
4:
c:='i';
8:
c:='q';
else
internalerror(2009081502);
end;
if not is_signed(def) then
c:=upcase(c);
end;
encodedstr:=encodedstr+c;
end;
end;
pointerdef :
begin
if is_pchar(def) then
encodedstr:=encodedstr+'*'
else if (def=objc_idtype) then
encodedstr:=encodedstr+'@'
else if (def=objc_seltype) then
encodedstr:=encodedstr+':'
else if (def=objc_metaclasstype) then
encodedstr:=encodedstr+'#'
else
begin
encodedstr:=encodedstr+'^';
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if not addencodedtype(tpointerdef(def).pointeddef,newstate,false,encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
end;
floatdef :
begin
case tfloatdef(def).floattype of
s32real:
c:='f';
s64real:
c:='d';
else
begin
c:='!';
result:=false;
end;
end;
encodedstr:=encodedstr+c;
end;
filedef :
result:=false;
recorddef :
begin
if assigned(def.typesym) then
recname:=def.typename
else
recname:='?';
if (recordinfostate<>ris_dontprint) then
begin
if not encoderecst(recname,tabstractrecordsymtable(trecorddef(def).symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+recname+'}'
end;
variantdef :
begin
recdef:=trecorddef(search_system_type('TVARDATA').typedef);
if (recordinfostate<>ris_dontprint) then
begin
if not encoderecst(recdef.typename,tabstractrecordsymtable(recdef.symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+recdef.typename+'}';
end;
classrefdef :
begin
encodedstr:=encodedstr+'^';
newstate:=recordinfostate;
if (recordinfostate<>ris_dontprint) then
newstate:=succ(newstate);
if is_objcclassref(def) then
begin
objdef:=tobjectdef(tclassrefdef(def).pointeddef);
if (newstate<>ris_dontprint) then
{ anonymous (objc)class definitions do not exist }
begin
if not encoderecst(objdef.objextname^,tabstractrecordsymtable(objdef.symtable),encodedstr,founderror) then
{ The fields of an Objective-C class should always be
encodeable. }
internalerror(2009081702);
end
else
encodedstr:=encodedstr+'{'+objdef.objextname^+'}'
end
{ Object Pascal classrefdefs point to a vmt, not really useful
to completely write those here. I'm not even sure what the
Objective-C run time uses this information for, since in C you
can have forward struct definitions so not all structs passed
to functions can be written out here either -> treat
classrefdefs the same as such forward-defined structs. }
else
begin
if assigned(def.typesym) then
recname:=def.typename
else
recname:='?';
encodedstr:=encodedstr+'{'+recname;
if (newstate<>ris_dontprint) then
encodedstr:=encodedstr+'=';
encodedstr:=encodedstr+'}'
end;
end;
setdef :
begin
addrpara:=paramanager.push_addr_param(vs_value,def,pocall_cdecl);
if not addrpara then
{ encode as an record, they are always passed by value in C. }
encodedstr:=encodedstr+'{?=';
{ Encode the set itself as an array. Without an encompassing
record, these are always passed by reference in C. }
encodedstr:=encodedstr+'['+tostr(def.size)+'C]';
if not addrpara then
encodedstr:=encodedstr+'}';
end;
formaldef :
begin
encodedstr:=encodedstr+'^v';
end;
arraydef :
begin
if is_array_of_const(def) then
{ do nothing, varargs are ignored in signatures }
else if is_special_array(def) then
result:=false
else
begin
len:=tarraydef(def).highrange-tarraydef(def).lowrange+1;
if is_packed_array(def) then
begin
{ convert from bits to bytes for bitpacked arrays }
len:=(len+7) div 8;
{ and encode as plain array of bytes }
encodedstr:=encodedstr+'['+tostr(len)+'C]';
end
else
begin
encodedstr:=encodedstr+'['+tostr(len);
{ Embedded structured types in the array are printed
in full regardless of the current recordinfostate. }
if not addencodedtype(tarraydef(def).elementdef,ris_initial,false,encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
encodedstr:=encodedstr+']';
end;
end;
end;
procvardef :
encodedstr:=encodedstr+'^?';
objectdef :
case tobjectdef(def).objecttype of
odt_class,
odt_object,
odt_cppclass:
begin
newstate:=recordinfostate;
{ implicit pointer for classes }
if (tobjectdef(def).objecttype=odt_class) then
begin
encodedstr:=encodedstr+'^';
{ make all classes opaque, so even if they contain a
reference-counted field there is no problem. Since a
"dereferenced class" object does not exist, this should
not cause problems }
newstate:=ris_dontprint;
end;
if newstate<>ris_dontprint then
begin
if not encoderecst(def.typename,tabstractrecordsymtable(tobjectdef(def).symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+def.typename+'}'
end;
odt_interfacecom,
odt_interfacecom_property,
odt_interfacecom_function,
odt_dispinterface:
result:=false;
odt_interfacecorba:
encodedstr:=encodedstr+'^{'+def.typename+'=}';
{ In Objective-C, the actual types of class instances are
NSObject* etc, and those are encoded as "@". In FPC, to keep
the similarity with Delphi-style Object Pascal, the type is
NSObject and the pointer is implicit. Objective-C's "NSObject"
has "class of NSObject" as equivalent here. }
odt_objcclass,
odt_objcprotocol:
encodedstr:=encodedstr+'@';
else
internalerror(2009081509);
end;
undefineddef,
errordef :
result:=false;
procdef :
{ must be done via objcencodemethod() }
internalerror(2009081511);
else
internalerror(2009150812);
end;
if not result then
founderror:=def;
end;
function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
begin
result:=addencodedtype(def,ris_initial,false,encodedtype,founderror);
end;
{******************************************************************
ObjC type validity checking
*******************************************************************}
function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean; forward;
function checkrecsttype(recst: tabstractrecordsymtable; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
var
i: longint;
field: tfieldvarsym;
newstate: trecordinfostate;
begin
result:=false;
newstate:=recordinfostate;
{ Although we never have to print the type info for nested
records, check them anyway in case we're not after a pointer
since if such records contain refcounted types then they
can cause just as much trouble as if they were a simple
refcounted field. }
if (newstate=ris_afterpointer) then
newstate:=ris_dontprint;
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
if not objcdochecktype(field.vardef,newstate,founderror) then
exit;
end;
result:=true
end;
function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
var
recdef: trecorddef;
objdef: tobjectdef;
newstate: trecordinfostate;
begin
result:=true;
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
st_shortstring:
;
else
{ While we could handle refcounted Pascal strings correctly
when such methods are called from Pascal code, things would
completely break down if they were called from Objective-C
code/reflection since the necessary refcount helper calls
would be missing on the caller side (unless we'd
automatically generate wrappers). }
result:=false;
end;
end;
enumdef,
orddef :
;
pointerdef :
begin
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if not objcdochecktype(tpointerdef(def).pointeddef,newstate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
floatdef :
begin
case tfloatdef(def).floattype of
s32real,
s64real:
;
else
result:=false;
end;
end;
filedef :
result:=false;
recorddef :
begin
if (recordinfostate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(trecorddef(def).symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end;
variantdef :
begin
recdef:=trecorddef(search_system_type('TVARDATA').typedef);
if (recordinfostate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(recdef.symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end;
end;
classrefdef:
begin
if is_objcclassref(def) then
begin
objdef:=tobjectdef(tclassrefdef(def).pointeddef);
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if (newstate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(objdef.symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end
end;
setdef,
formaldef :
;
arraydef :
begin
if is_array_of_const(def) then
{ ok, varargs are ignored in signatures }
else if is_special_array(def) then
result:=false
else
begin
if not is_packed_array(def) then
begin
if not objcdochecktype(tarraydef(def).elementdef,ris_initial,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
end;
end;
procvardef :
;
objectdef :
case tobjectdef(def).objecttype of
odt_class,
odt_object,
odt_cppclass:
begin
newstate:=recordinfostate;
{ implicit pointer for classes }
if (tobjectdef(def).objecttype=odt_class) then
begin
{ make all classes opaque, so even if they contain a
reference-counted field there is no problem. Since a
"dereferenced class" object does not exist, this should
not cause problems }
newstate:=ris_dontprint;
end;
if newstate<>ris_dontprint then
begin
if not checkrecsttype(tabstractrecordsymtable(tobjectdef(def).symtable),newstate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end;
odt_interfacecom,
odt_interfacecom_property,
odt_interfacecom_function,
odt_dispinterface:
result:=false;
odt_interfacecorba,
odt_objcclass,
odt_objcprotocol:
;
else
internalerror(2009081709);
end;
undefineddef,
errordef :
result:=false;
procdef :
result:=false;
else
internalerror(2009170812);
end;
if not result then
founderror:=def;
end;
function objcchecktype(def: tdef; out founderror: tdef): boolean;
begin
result:=objcdochecktype(def,ris_initial,founderror);
end;
end.

11
compiler/objcgutl.pas
View File

@ -45,7 +45,7 @@ implementation
systems,
aasmtai,
cgbase,
objcutil,
objcdef,objcutil,
symconst,symtype,symsym,symtable,
verbose;
@ -443,6 +443,13 @@ procedure tobjcrttiwriter.gen_objc_rtti_sections(list:TAsmList; st:TSymtable);
for i:=0 to st.DefList.Count-1 do
begin
def:=tdef(st.DefList[i]);
{ check whether all types used in Objective-C class/protocol/category
declarations can be used with the Objective-C run time (can only be
done now, because at parse-time some of these types can still be
forwarddefs) }
if is_objc_class_or_protocol(def) then
if not tobjectdef(def).check_objc_types then
continue;
if is_objcclass(def) and
not(oo_is_external in tobjectdef(def).objectoptions) then
begin
@ -519,7 +526,7 @@ procedure tobjcrttiwriter_fragile.gen_objc_ivars(list: TAsmList; objccls: tobjec
inc(vcnt);
end
else
{ must be caught during parsing }
{ Should be caught during parsing }
internalerror(2009090601);
end;
if vcnt=0 then

597
compiler/objcutil.pas
View File

@ -1,5 +1,5 @@
{
Copyright (c) 2009 by Jonas Maebe
Copyright (c) 2009-2010 by Jonas Maebe
This unit implements some Objective-C helper routines at the node tree
level.
@ -38,20 +38,10 @@ interface
an inherited Objective-C method. }
function objcsuperclassnode(def: tdef): tnode;
{ The internals of Objective-C's @encode() functionality: encode a
type into the internal format used by the run time. Returns false
if a type is not representable by the Objective-C run time, and in
that case also the failing definition. }
function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
{ Encode a method's parameters and result type into the format used by the
run time (for generating protocol and class rtti). }
function objcencodemethod(pd: tprocdef): ansistring;
{ Check whether a type can be used in an Objective-C method
signature or field declaration. }
function objcchecktype(def: tdef; out founderror: tdef): boolean;
{ Exports all assembler symbols related to the obj-c class }
procedure exportobjcclass(def: tobjectdef);
@ -63,6 +53,7 @@ implementation
pass_1,
verbose,systems,
symtable,symconst,symsym,
objcdef,
defutil,paramgr,
nbas,nmem,ncal,nld,ncon,ncnv,
export;
@ -192,9 +183,6 @@ end;
Type encoding
*******************************************************************}
type
trecordinfostate = (ris_initial, ris_afterpointer, ris_dontprint);
function objcparasize(vs: tparavarsym): ptrint;
begin
result:=vs.paraloc[callerside].intsize;
@ -206,381 +194,6 @@ end;
end;
function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean; forward;
function encoderecst(const recname: ansistring; recst: tabstractrecordsymtable; var encodedstr: ansistring; out founderror: tdef): boolean;
var
variantstarts: tfplist;
i, varindex: longint;
field,
firstfield: tfieldvarsym;
firstfieldvariant,
bpacked: boolean;
begin
result:=false;
bpacked:=recst.fieldalignment=bit_alignment;
{ Is the first field already the start of a variant? }
firstfield:=nil;
firstfieldvariant:=false;
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
if not assigned(firstfield) then
firstfield:=field
else if (vo_is_first_field in field.varoptions) then
begin
if (field.fieldoffset=firstfield.fieldoffset) then
firstfieldvariant:=true;
end;
end;
variantstarts:=tfplist.create;
encodedstr:=encodedstr+'{'+recname+'=';
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
{ start of a variant part? }
if ((field=firstfield) and
firstfieldvariant) or
((field<>firstfield) and
(vo_is_first_field in field.varoptions)) then
begin
varindex:=variantstarts.count-1;
if (varindex=-1) or
(tfieldvarsym(variantstarts[varindex]).fieldoffset<field.fieldoffset) then
begin
{ new, more deeply nested variant }
encodedstr:=encodedstr+'(?={?=';
variantstarts.add(field);
end
else
begin
{ close existing nested variants if any }
while (varindex>=0) and
(tfieldvarsym(variantstarts[varindex]).fieldoffset>field.fieldoffset) do
begin
{ close more deeply nested variants }
encodedstr:=encodedstr+'})';
dec(varindex);
end;
if (varindex<0) then
internalerror(2009081805);
if (tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset) then
internalerror(2009081804);
{ variant at the same level as a previous one }
variantstarts.count:=varindex+1;
{ No need to add this field, it has the same offset as the
previous one at this position. }
if tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset then
internalerror(2009081601);
{ close previous variant sub-part and start new one }
encodedstr:=encodedstr+'}{?=';
end
end;
if not addencodedtype(field.vardef,ris_afterpointer,bpacked,encodedstr,founderror) then
exit;
end;
for i:=0 to variantstarts.count-1 do
encodedstr:=encodedstr+'})';
variantstarts.free;
encodedstr:=encodedstr+'}';
result:=true
end;
function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
var
recname: ansistring;
recdef: trecorddef;
objdef: tobjectdef;
len: aint;
c: char;
newstate: trecordinfostate;
addrpara: boolean;
begin
result:=true;
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
st_shortstring:
{ include length byte }
encodedstr:=encodedstr+'['+tostr(tstringdef(def).len+1)+'C]';
else
{ While we could handle refcounted Pascal strings correctly
when such methods are called from Pascal code, things would
completely break down if they were called from Objective-C
code/reflection since the necessary refcount helper calls
would be missing on the caller side (unless we'd
automatically generate wrappers). }
result:=false;
end;
end;
enumdef,
orddef :
begin
if bpacked and
not is_void(def) then
encodedstr:=encodedstr+'b'+tostr(def.packedbitsize)
else
begin
if is_void(def) then
c:='v'
{ in gcc, sizeof(_Bool) = sizeof(char) }
else if is_boolean(def) and
(def.size=1) then
c:='B'
else
begin
case def.size of
1:
c:='c';
2:
c:='s';
4:
c:='i';
8:
c:='q';
else
internalerror(2009081502);
end;
if not is_signed(def) then
c:=upcase(c);
end;
encodedstr:=encodedstr+c;
end;
end;
pointerdef :
begin
if is_pchar(def) then
encodedstr:=encodedstr+'*'
else if (def=objc_idtype) then
encodedstr:=encodedstr+'@'
else if (def=objc_seltype) then
encodedstr:=encodedstr+':'
else if (def=objc_metaclasstype) then
encodedstr:=encodedstr+'#'
else
begin
encodedstr:=encodedstr+'^';
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if not addencodedtype(tpointerdef(def).pointeddef,newstate,false,encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
end;
floatdef :
begin
case tfloatdef(def).floattype of
s32real:
c:='f';
s64real:
c:='d';
else
begin
c:='!';
result:=false;
end;
end;
encodedstr:=encodedstr+c;
end;
filedef :
result:=false;
recorddef :
begin
if assigned(def.typesym) then
recname:=def.typename
else
recname:='?';
if (recordinfostate<>ris_dontprint) then
begin
if not encoderecst(recname,tabstractrecordsymtable(trecorddef(def).symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+recname+'}'
end;
variantdef :
begin
recdef:=trecorddef(search_system_type('TVARDATA').typedef);
if (recordinfostate<>ris_dontprint) then
begin
if not encoderecst(recdef.typename,tabstractrecordsymtable(recdef.symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+recdef.typename+'}';
end;
classrefdef :
begin
encodedstr:=encodedstr+'^';
newstate:=recordinfostate;
if (recordinfostate<>ris_dontprint) then
newstate:=succ(newstate);
if is_objcclassref(def) then
begin
objdef:=tobjectdef(tclassrefdef(def).pointeddef);
if (newstate<>ris_dontprint) then
{ anonymous (objc)class definitions do not exist }
begin
if not encoderecst(objdef.objextname^,tabstractrecordsymtable(objdef.symtable),encodedstr,founderror) then
{ The fields of an Objective-C class should always be
encodeable. }
internalerror(2009081702);
end
else
encodedstr:=encodedstr+'{'+objdef.objextname^+'}'
end
{ Object Pascal classrefdefs point to a vmt, not really useful
to completely write those here. I'm not even sure what the
Objective-C run time uses this information for, since in C you
can have forward struct definitions so not all structs passed
to functions can be written out here either -> treat
classrefdefs the same as such forward-defined structs. }
else
begin
if assigned(def.typesym) then
recname:=def.typename
else
recname:='?';
encodedstr:=encodedstr+'{'+recname;
if (newstate<>ris_dontprint) then
encodedstr:=encodedstr+'=';
encodedstr:=encodedstr+'}'
end;
end;
setdef :
begin
addrpara:=paramanager.push_addr_param(vs_value,def,pocall_cdecl);
if not addrpara then
{ encode as an record, they are always passed by value in C. }
encodedstr:=encodedstr+'{?=';
{ Encode the set itself as an array. Without an encompassing
record, these are always passed by reference in C. }
encodedstr:=encodedstr+'['+tostr(def.size)+'C]';
if not addrpara then
encodedstr:=encodedstr+'}';
end;
formaldef :
begin
encodedstr:=encodedstr+'^v';
end;
arraydef :
begin
if is_array_of_const(def) then
{ do nothing, varargs are ignored in signatures }
else if is_special_array(def) then
result:=false
else
begin
len:=tarraydef(def).highrange-tarraydef(def).lowrange+1;
if is_packed_array(def) then
begin
{ convert from bits to bytes for bitpacked arrays }
len:=(len+7) div 8;
{ and encode as plain array of bytes }
encodedstr:=encodedstr+'['+tostr(len)+'C]';
end
else
begin
encodedstr:=encodedstr+'['+tostr(len);
{ Embedded structured types in the array are printed
in full regardless of the current recordinfostate. }
if not addencodedtype(tarraydef(def).elementdef,ris_initial,false,encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
encodedstr:=encodedstr+']';
end;
end;
end;
procvardef :
encodedstr:=encodedstr+'^?';
objectdef :
case tobjectdef(def).objecttype of
odt_class,
odt_object,
odt_cppclass:
begin
newstate:=recordinfostate;
{ implicit pointer for classes }
if (tobjectdef(def).objecttype=odt_class) then
begin
encodedstr:=encodedstr+'^';
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
end;
if newstate<>ris_dontprint then
begin
if not encoderecst(def.typename,tabstractrecordsymtable(tobjectdef(def).symtable),encodedstr,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
else
encodedstr:=encodedstr+'{'+def.typename+'}'
end;
odt_interfacecom,
odt_interfacecom_property,
odt_interfacecom_function,
odt_dispinterface:
result:=false;
odt_interfacecorba:
encodedstr:=encodedstr+'^{'+def.typename+'=}';
{ In Objective-C, the actual types of class instances are
NSObject* etc, and those are encoded as "@". In FPC, to keep
the similarity with Delphi-style Object Pascal, the type is
NSObject and the pointer is implicit. Objective-C's "NSObject"
has "class of NSObject" as equivalent here. }
odt_objcclass,
odt_objcprotocol:
encodedstr:=encodedstr+'@';
else
internalerror(2009081509);
end;
undefineddef,
errordef :
result:=false;
procdef :
{ must be done via objcencodemethod() }
internalerror(2009081511);
else
internalerror(2009150812);
end;
if not result then
founderror:=def;
end;
function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
begin
result:=addencodedtype(def,ris_initial,false,encodedtype,founderror);
end;
function objcencodemethod(pd: tprocdef): ansistring;
var
parasize,
@ -639,212 +252,6 @@ end;
end;
{******************************************************************
ObjC type validity checking
*******************************************************************}
function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean; forward;
function checkrecsttype(recst: tabstractrecordsymtable; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
var
i: longint;
field: tfieldvarsym;
newstate: trecordinfostate;
begin
result:=false;
newstate:=recordinfostate;
{ Although we never have to print the type info for nested
records, check them anyway in case we're not after a pointer
since if such records contain refcounted types then they
can cause just as much trouble as if they were a simple
refcounted field. }
if (newstate=ris_afterpointer) then
newstate:=ris_dontprint;
for i:=0 to recst.symlist.count-1 do
begin
if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
continue;
field:=tfieldvarsym(recst.symlist[i]);
if not objcdochecktype(field.vardef,newstate,founderror) then
exit;
end;
result:=true
end;
function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
var
recdef: trecorddef;
objdef: tobjectdef;
newstate: trecordinfostate;
begin
result:=true;
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
st_shortstring:
;
else
{ While we could handle refcounted Pascal strings correctly
when such methods are called from Pascal code, things would
completely break down if they were called from Objective-C
code/reflection since the necessary refcount helper calls
would be missing on the caller side (unless we'd
automatically generate wrappers). }
result:=false;
end;
end;
enumdef,
orddef :
;
pointerdef :
begin
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if not objcdochecktype(tpointerdef(def).pointeddef,newstate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
floatdef :
begin
case tfloatdef(def).floattype of
s32real,
s64real:
;
else
result:=false;
end;
end;
filedef :
result:=false;
recorddef :
begin
if (recordinfostate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(trecorddef(def).symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end;
variantdef :
begin
recdef:=trecorddef(search_system_type('TVARDATA').typedef);
if (recordinfostate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(recdef.symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end;
end;
classrefdef:
begin
if is_objcclassref(def) then
begin
objdef:=tobjectdef(tclassrefdef(def).pointeddef);
newstate:=recordinfostate;
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
if (newstate<>ris_dontprint) then
begin
if not checkrecsttype(tabstractrecordsymtable(objdef.symtable),recordinfostate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end
end;
setdef,
formaldef :
;
arraydef :
begin
if is_array_of_const(def) then
{ ok, varargs are ignored in signatures }
else if is_special_array(def) then
result:=false
else
begin
if not is_packed_array(def) then
begin
if not objcdochecktype(tarraydef(def).elementdef,ris_initial,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
end;
end;
procvardef :
;
objectdef :
case tobjectdef(def).objecttype of
odt_class,
odt_object,
odt_cppclass:
begin
newstate:=recordinfostate;
{ implicit pointer for classes }
if (tobjectdef(def).objecttype=odt_class) then
begin
if (recordinfostate<ris_dontprint) then
newstate:=succ(newstate);
end;
if newstate<>ris_dontprint then
begin
if not checkrecsttype(tabstractrecordsymtable(tobjectdef(def).symtable),newstate,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end
end
end;
odt_interfacecom,
odt_interfacecom_property,
odt_interfacecom_function,
odt_dispinterface:
result:=false;
odt_interfacecorba,
odt_objcclass,
odt_objcprotocol:
;
else
internalerror(2009081709);
end;
undefineddef,
errordef :
result:=false;
procdef :
result:=false;
else
internalerror(2009170812);
end;
if not result then
founderror:=def;
end;
function objcchecktype(def: tdef; out founderror: tdef): boolean;
begin
result:=objcdochecktype(def,ris_initial,founderror);
end;
{******************************************************************
ObjC class exporting
*******************************************************************}

57
compiler/symdef.pas
View File

@ -318,6 +318,7 @@ interface
procedure make_all_methods_external;
{ ObjC }
procedure finish_objc_data;
function check_objc_types: boolean;
{ C++ }
procedure finish_cpp_data;
function RttiName: string;
@ -768,7 +769,7 @@ implementation
{ target }
systems,aasmcpu,paramgr,
{ symtable }
symsym,symtable,symutil,defutil,
symsym,symtable,symutil,defutil,objcdef,
{ module }
fmodule,
{ other }
@ -4742,6 +4743,7 @@ implementation
var
def: tdef absolute data;
pd: tprocdef absolute data;
founderrordef: tdef;
i,
paracount: longint;
begin
@ -4767,7 +4769,8 @@ implementation
another type. }
if not(po_has_mangledname in pd.procoptions) then
begin
{ check whether the number of formal parameters is correct }
{ check whether the number of formal parameters is correct,
and whether they have valid Objective-C types }
paracount:=0;
for i:=1 to length(pd.messageinf.str^) do
if pd.messageinf.str^[i]=':' then
@ -4821,6 +4824,56 @@ implementation
end;
procedure verify_objc_vardef(data: tobject; arg: pointer);
var
sym: tabstractvarsym absolute data;
res: pboolean absolute arg;
founderrordef: tdef;
begin
if not(tsym(data).typ in [paravarsym,fieldvarsym]) then
exit;
if (sym.typ=paravarsym) and
((vo_is_hidden_para in tparavarsym(sym).varoptions) or
is_array_of_const(tparavarsym(sym).vardef)) then
exit;
if not objcchecktype(sym.vardef,founderrordef) then
begin
MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
res^:=false;
end;
end;
procedure verify_objc_procdef_paras(data: tobject; arg: pointer);
var
def: tdef absolute data;
res: pboolean absolute arg;
founderrordef: tdef;
begin
if (def.typ<>procdef) then
exit;
{ check parameter types for validity }
tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg);
{ check the result type for validity }
if not objcchecktype(tprocdef(def).returndef,founderrordef) then
begin
MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename);
res^:=false;
end;
end;
function tobjectdef.check_objc_types: boolean;
begin
{ done in separate step from finish_objc_data, because when
finish_objc_data is called, not all forwarddefs have been resolved
yet and we need to know all types here }
result:=true;
self.symtable.symlist.foreachcall(@verify_objc_vardef,@result);
self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result);
end;
procedure do_cpp_import_info(data: tobject; arg: pointer);
var
def: tdef absolute data;

2
tests/test/tobjc11.pp
View File

@ -109,7 +109,7 @@ type
begin
check('tra',objcencode(tra),'{tra=ii}');
check('TStrippedVarRec',objcencode(TStrippedVarRec),'{TStrippedVarRec=c(?={?=i}{?=B}{?=C}{?=S}{?=^[256C]}{?=^v}{?=*}{?=^{TObject}}{?=^{TClass}}{?=^S}{?=^v}{?=^v}{?=^v}{?=^q}{?=^Q})}');
check('TObject',objcencode(TObject),'^{TObject=^v}');
check('TObject',objcencode(TObject),'^{TObject}');
check('tnestedvarrec',objcencode(tnestedvarrec),'{tnestedvarrec=i^{tra}(?={?={tnestedvarrechelper1=(?={?=f}{?=d})}}{?={tnestedvarrechelper2=ic}}{?=i})}');
end;

15
tests/test/tobjc32.pp Normal file
View File

@ -0,0 +1,15 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$mode objfpc}
{$modeswitch objectivec1}
type
tc = objcclass(NSObject)
s: ansistring;
end;
begin
end.

19
tests/test/tobjc32a.pp Normal file
View File

@ -0,0 +1,19 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$mode objfpc}
{$modeswitch objectivec1}
type
tc = objcclass(NSObject)
function test: ansistring; message 'test';
end;
procedure tc.test: ansistring;
begin
end;
begin
end.

19
tests/test/tobjc32b.pp Normal file
View File

@ -0,0 +1,19 @@
{ %fail }
{ %target=darwin }
{ %cpu=powerpc,powerpc64,i386,x86_64,arm }
{$mode objfpc}
{$modeswitch objectivec1}
type
tc = objcclass(NSObject)
procedure test(s: ansistring); message 'test:';
end;
procedure tc.test(s: ansistring);
begin
end;
begin
end.