diff --git a/.gitattributes b/.gitattributes index 67380a7f83..fa7a85eec3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/compiler/ninl.pas b/compiler/ninl.pas index f6bffac830..0576f479ad 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -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 ; diff --git a/compiler/objcdef.pas b/compiler/objcdef.pas new file mode 100644 index 0000000000..ad02a075a8 --- /dev/null +++ b/compiler/objcdef.pas @@ -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=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 (recordinfostateris_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 (recordinfostateris_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 (recordinfostateris_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. diff --git a/compiler/objcgutl.pas b/compiler/objcgutl.pas index 4f4f7147e6..5b2b44d93e 100644 --- a/compiler/objcgutl.pas +++ b/compiler/objcgutl.pas @@ -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 diff --git a/compiler/objcutil.pas b/compiler/objcutil.pas index 6ff9b1b811..2c84599aae 100644 --- a/compiler/objcutil.pas +++ b/compiler/objcutil.pas @@ -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=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 (recordinfostateris_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 (recordinfostateris_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 (recordinfostateris_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 (recordinfostateris_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 (recordinfostateris_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 *******************************************************************} diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 704110ab93..522150dbec 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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; diff --git a/tests/test/tobjc11.pp b/tests/test/tobjc11.pp index d3675d8712..ff2ce2af26 100644 --- a/tests/test/tobjc11.pp +++ b/tests/test/tobjc11.pp @@ -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; diff --git a/tests/test/tobjc32.pp b/tests/test/tobjc32.pp new file mode 100644 index 0000000000..2ee36c7445 --- /dev/null +++ b/tests/test/tobjc32.pp @@ -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. diff --git a/tests/test/tobjc32a.pp b/tests/test/tobjc32a.pp new file mode 100644 index 0000000000..f0baa3033b --- /dev/null +++ b/tests/test/tobjc32a.pp @@ -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. diff --git a/tests/test/tobjc32b.pp b/tests/test/tobjc32b.pp new file mode 100644 index 0000000000..8fd66f65aa --- /dev/null +++ b/tests/test/tobjc32b.pp @@ -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.