objcutil.pas 32 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858
  1. {
  2. Copyright (c) 2009 by Jonas Maebe
  3. This unit implements some Objective-C helper routines at the node tree
  4. level.
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. {$i fpcdefs.inc}
  19. unit objcutil;
  20. interface
  21. uses
  22. node,
  23. symtype,symdef;
  24. { Check whether a string contains a syntactically valid selector name. }
  25. function objcvalidselectorname(value_str: pchar; len: longint): boolean;
  26. { Generate a node loading the superclass structure necessary to call
  27. an inherited Objective-C method. }
  28. function objcsuperclassnode(def: tdef): tnode;
  29. { The internals of Objective-C's @encode() functionality: encode a
  30. type into the internal format used by the run time. Returns false
  31. if a type is not representable by the Objective-C run time, and in
  32. that case also the failing definition. }
  33. function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
  34. { Encode a method's parameters and result type into the format used by the
  35. run time (for generating protocol and class rtti). }
  36. function objcencodemethod(pd: tprocdef): ansistring;
  37. { Check whether a type can be used in an Objective-C method
  38. signature or field declaration. }
  39. function objcchecktype(def: tdef; out founderror: tdef): boolean;
  40. { Exports all assembler symbols related to the obj-c class }
  41. procedure exportobjcclass(def: tobjectdef);
  42. implementation
  43. uses
  44. globtype,
  45. cutils,cclasses,
  46. pass_1,
  47. verbose,systems,
  48. symtable,symconst,symsym,
  49. defutil,paramgr,
  50. nbas,nmem,ncal,nld,ncon,ncnv,
  51. export;
  52. {******************************************************************
  53. validselectorname
  54. *******************************************************************}
  55. function objcvalidselectorname(value_str: pchar; len: longint): boolean;
  56. var
  57. i : longint;
  58. gotcolon : boolean;
  59. begin
  60. result:=false;
  61. { empty name is not allowed }
  62. if (len=0) then
  63. exit;
  64. gotcolon:=false;
  65. { if the first character is a colon, all of them must be colons }
  66. if (value_str[0] = ':') then
  67. begin
  68. for i:=1 to len-1 do
  69. if (value_str[i]<>':') then
  70. exit;
  71. end
  72. else
  73. begin
  74. { no special characters other than ':'
  75. }
  76. for i:=0 to len-1 do
  77. if (value_str[i] = ':') then
  78. gotcolon:=true
  79. else if not(value_str[i] in ['_','A'..'Z','a'..'z','0'..'9',':']) then
  80. exit;
  81. { if there is at least one colon, the final character must
  82. also be a colon (in case it's only one character that is
  83. a colon, this was already checked before the above loop)
  84. }
  85. if gotcolon and
  86. (value_str[len-1] <> ':') then
  87. exit;
  88. end;
  89. result:=true;
  90. end;
  91. {******************************************************************
  92. objcsuperclassnode
  93. *******************************************************************}
  94. function objcsuperclassnode(def: tdef): tnode;
  95. var
  96. para : tcallparanode;
  97. class_type : tdef;
  98. vs : tsym;
  99. begin
  100. { only valid for Objective-C classes and classrefs }
  101. if not is_objcclass(def) and
  102. not is_objcclassref(def) then
  103. internalerror(2009090901);
  104. { Can be done a lot more efficiently with direct symbol accesses, but
  105. requires extra node types. Maybe later. }
  106. if is_objcclassref(def) then
  107. begin
  108. para:=ccallparanode.create(cstringconstnode.createstr(tobjectdef(tclassrefdef(def).pointeddef).objextname^),nil);
  109. result:=ccallnode.createinternfromunit('OBJC','OBJC_GETMETACLASS',para);
  110. end
  111. else
  112. result:=cloadvmtaddrnode.create(ctypenode.create(def));
  113. {$if defined(onlymacosx10_6) or defined(arm) }
  114. { For the non-fragile ABI, the superclass send2 method itself loads the
  115. superclass. For the fragile ABI, we have to do this ourselves.
  116. NOTE: those send2 methods are only available on Mac OS X 10.6 and later!
  117. (but also on all iPhone SDK revisions we support) }
  118. if not(target_info.system in system_objc_nfabi) then
  119. {$endif onlymacosx10_6 or arm}
  120. begin
  121. class_type:=search_named_unit_globaltype('OBJC','OBJC_OBJECT').typedef;
  122. result:=ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(result,voidpointertype)),class_type);
  123. vs:=tsym(tabstractrecorddef(class_type).symtable.Find('SUPERCLASS'));
  124. if not assigned(vs) or
  125. (vs.typ<>fieldvarsym) then
  126. internalerror(200909301);
  127. result:=csubscriptnode.create(vs,result);
  128. end;
  129. typecheckpass(result);
  130. end;
  131. {******************************************************************
  132. Type encoding
  133. *******************************************************************}
  134. type
  135. trecordinfostate = (ris_initial, ris_afterpointer, ris_dontprint);
  136. function objcparasize(vs: tparavarsym): ptrint;
  137. begin
  138. result:=vs.paraloc[callerside].intsize;
  139. { In Objective-C, all ordinal types are widened to at least the
  140. size of the C "int" type. Assume __LP64__/4 byte ints for now. }
  141. if is_ordinal(vs.vardef) and
  142. (result<4) then
  143. result:=4;
  144. end;
  145. function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean; forward;
  146. function encoderecst(const recname: ansistring; recst: tabstractrecordsymtable; var encodedstr: ansistring; out founderror: tdef): boolean;
  147. var
  148. variantstarts: tfplist;
  149. i, varindex: longint;
  150. field,
  151. firstfield: tfieldvarsym;
  152. firstfieldvariant,
  153. bpacked: boolean;
  154. begin
  155. result:=false;
  156. bpacked:=recst.fieldalignment=bit_alignment;
  157. { Is the first field already the start of a variant? }
  158. firstfield:=nil;
  159. firstfieldvariant:=false;
  160. for i:=0 to recst.symlist.count-1 do
  161. begin
  162. if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
  163. continue;
  164. field:=tfieldvarsym(recst.symlist[i]);
  165. if not assigned(firstfield) then
  166. firstfield:=field
  167. else if (vo_is_first_field in field.varoptions) then
  168. begin
  169. if (field.fieldoffset=firstfield.fieldoffset) then
  170. firstfieldvariant:=true;
  171. end;
  172. end;
  173. variantstarts:=tfplist.create;
  174. encodedstr:=encodedstr+'{'+recname+'=';
  175. for i:=0 to recst.symlist.count-1 do
  176. begin
  177. if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
  178. continue;
  179. field:=tfieldvarsym(recst.symlist[i]);
  180. { start of a variant part? }
  181. if ((field=firstfield) and
  182. firstfieldvariant) or
  183. ((field<>firstfield) and
  184. (vo_is_first_field in field.varoptions)) then
  185. begin
  186. varindex:=variantstarts.count-1;
  187. if (varindex=-1) or
  188. (tfieldvarsym(variantstarts[varindex]).fieldoffset<field.fieldoffset) then
  189. begin
  190. { new, more deeply nested variant }
  191. encodedstr:=encodedstr+'(?={?=';
  192. variantstarts.add(field);
  193. end
  194. else
  195. begin
  196. { close existing nested variants if any }
  197. while (varindex>=0) and
  198. (tfieldvarsym(variantstarts[varindex]).fieldoffset>field.fieldoffset) do
  199. begin
  200. { close more deeply nested variants }
  201. encodedstr:=encodedstr+'})';
  202. dec(varindex);
  203. end;
  204. if (varindex<0) then
  205. internalerror(2009081805);
  206. if (tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset) then
  207. internalerror(2009081804);
  208. { variant at the same level as a previous one }
  209. variantstarts.count:=varindex+1;
  210. { No need to add this field, it has the same offset as the
  211. previous one at this position. }
  212. if tfieldvarsym(variantstarts[varindex]).fieldoffset<>field.fieldoffset then
  213. internalerror(2009081601);
  214. { close previous variant sub-part and start new one }
  215. encodedstr:=encodedstr+'}{?=';
  216. end
  217. end;
  218. if not addencodedtype(field.vardef,ris_afterpointer,bpacked,encodedstr,founderror) then
  219. exit;
  220. end;
  221. for i:=0 to variantstarts.count-1 do
  222. encodedstr:=encodedstr+'})';
  223. variantstarts.free;
  224. encodedstr:=encodedstr+'}';
  225. result:=true
  226. end;
  227. function addencodedtype(def: tdef; recordinfostate: trecordinfostate; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
  228. var
  229. recname: ansistring;
  230. recdef: trecorddef;
  231. objdef: tobjectdef;
  232. len: aint;
  233. c: char;
  234. newstate: trecordinfostate;
  235. addrpara: boolean;
  236. begin
  237. result:=true;
  238. case def.typ of
  239. stringdef :
  240. begin
  241. case tstringdef(def).stringtype of
  242. st_shortstring:
  243. { include length byte }
  244. encodedstr:=encodedstr+'['+tostr(tstringdef(def).len+1)+'C]';
  245. else
  246. { While we could handle refcounted Pascal strings correctly
  247. when such methods are called from Pascal code, things would
  248. completely break down if they were called from Objective-C
  249. code/reflection since the necessary refcount helper calls
  250. would be missing on the caller side (unless we'd
  251. automatically generate wrappers). }
  252. result:=false;
  253. end;
  254. end;
  255. enumdef,
  256. orddef :
  257. begin
  258. if bpacked and
  259. not is_void(def) then
  260. encodedstr:=encodedstr+'b'+tostr(def.packedbitsize)
  261. else
  262. begin
  263. if is_void(def) then
  264. c:='v'
  265. { in gcc, sizeof(_Bool) = sizeof(char) }
  266. else if is_boolean(def) and
  267. (def.size=1) then
  268. c:='B'
  269. else
  270. begin
  271. case def.size of
  272. 1:
  273. c:='c';
  274. 2:
  275. c:='s';
  276. 4:
  277. c:='i';
  278. 8:
  279. c:='q';
  280. else
  281. internalerror(2009081502);
  282. end;
  283. if not is_signed(def) then
  284. c:=upcase(c);
  285. end;
  286. encodedstr:=encodedstr+c;
  287. end;
  288. end;
  289. pointerdef :
  290. begin
  291. if is_pchar(def) then
  292. encodedstr:=encodedstr+'*'
  293. else if (def=objc_idtype) then
  294. encodedstr:=encodedstr+'@'
  295. else if (def=objc_seltype) then
  296. encodedstr:=encodedstr+':'
  297. else if (def=objc_metaclasstype) then
  298. encodedstr:=encodedstr+'#'
  299. else
  300. begin
  301. encodedstr:=encodedstr+'^';
  302. newstate:=recordinfostate;
  303. if (recordinfostate<ris_dontprint) then
  304. newstate:=succ(newstate);
  305. if not addencodedtype(tpointerdef(def).pointeddef,newstate,false,encodedstr,founderror) then
  306. begin
  307. result:=false;
  308. { report the exact (nested) error defintion }
  309. exit;
  310. end;
  311. end;
  312. end;
  313. floatdef :
  314. begin
  315. case tfloatdef(def).floattype of
  316. s32real:
  317. c:='f';
  318. s64real:
  319. c:='d';
  320. else
  321. begin
  322. c:='!';
  323. result:=false;
  324. end;
  325. end;
  326. encodedstr:=encodedstr+c;
  327. end;
  328. filedef :
  329. result:=false;
  330. recorddef :
  331. begin
  332. if assigned(def.typesym) then
  333. recname:=def.typename
  334. else
  335. recname:='?';
  336. if (recordinfostate<>ris_dontprint) then
  337. begin
  338. if not encoderecst(recname,tabstractrecordsymtable(trecorddef(def).symtable),encodedstr,founderror) then
  339. begin
  340. result:=false;
  341. { report the exact (nested) error defintion }
  342. exit;
  343. end
  344. end
  345. else
  346. encodedstr:=encodedstr+'{'+recname+'}'
  347. end;
  348. variantdef :
  349. begin
  350. recdef:=trecorddef(search_system_type('TVARDATA').typedef);
  351. if (recordinfostate<>ris_dontprint) then
  352. begin
  353. if not encoderecst(recdef.typename,tabstractrecordsymtable(recdef.symtable),encodedstr,founderror) then
  354. begin
  355. result:=false;
  356. { report the exact (nested) error defintion }
  357. exit;
  358. end
  359. end
  360. else
  361. encodedstr:=encodedstr+'{'+recdef.typename+'}';
  362. end;
  363. classrefdef :
  364. begin
  365. encodedstr:=encodedstr+'^';
  366. newstate:=recordinfostate;
  367. if (recordinfostate<>ris_dontprint) then
  368. newstate:=succ(newstate);
  369. if is_objcclassref(def) then
  370. begin
  371. objdef:=tobjectdef(tclassrefdef(def).pointeddef);
  372. if (newstate<>ris_dontprint) then
  373. { anonymous (objc)class definitions do not exist }
  374. begin
  375. if not encoderecst(objdef.objextname^,tabstractrecordsymtable(objdef.symtable),encodedstr,founderror) then
  376. { The fields of an Objective-C class should always be
  377. encodeable. }
  378. internalerror(2009081702);
  379. end
  380. else
  381. encodedstr:=encodedstr+'{'+objdef.objextname^+'}'
  382. end
  383. { Object Pascal classrefdefs point to a vmt, not really useful
  384. to completely write those here. I'm not even sure what the
  385. Objective-C run time uses this information for, since in C you
  386. can have forward struct definitions so not all structs passed
  387. to functions can be written out here either -> treat
  388. classrefdefs the same as such forward-defined structs. }
  389. else
  390. begin
  391. if assigned(def.typesym) then
  392. recname:=def.typename
  393. else
  394. recname:='?';
  395. encodedstr:=encodedstr+'{'+recname;
  396. if (newstate<>ris_dontprint) then
  397. encodedstr:=encodedstr+'=';
  398. encodedstr:=encodedstr+'}'
  399. end;
  400. end;
  401. setdef :
  402. begin
  403. addrpara:=paramanager.push_addr_param(vs_value,def,pocall_cdecl);
  404. if not addrpara then
  405. { encode as an record, they are always passed by value in C. }
  406. encodedstr:=encodedstr+'{?=';
  407. { Encode the set itself as an array. Without an encompassing
  408. record, these are always passed by reference in C. }
  409. encodedstr:=encodedstr+'['+tostr(def.size)+'C]';
  410. if not addrpara then
  411. encodedstr:=encodedstr+'}';
  412. end;
  413. formaldef :
  414. begin
  415. encodedstr:=encodedstr+'^v';
  416. end;
  417. arraydef :
  418. begin
  419. if is_array_of_const(def) then
  420. { do nothing, varargs are ignored in signatures }
  421. else if is_special_array(def) then
  422. result:=false
  423. else
  424. begin
  425. len:=tarraydef(def).highrange-tarraydef(def).lowrange+1;
  426. if is_packed_array(def) then
  427. begin
  428. { convert from bits to bytes for bitpacked arrays }
  429. len:=(len+7) div 8;
  430. { and encode as plain array of bytes }
  431. encodedstr:=encodedstr+'['+tostr(len)+'C]';
  432. end
  433. else
  434. begin
  435. encodedstr:=encodedstr+'['+tostr(len);
  436. { Embedded structured types in the array are printed
  437. in full regardless of the current recordinfostate. }
  438. if not addencodedtype(tarraydef(def).elementdef,ris_initial,false,encodedstr,founderror) then
  439. begin
  440. result:=false;
  441. { report the exact (nested) error defintion }
  442. exit;
  443. end;
  444. encodedstr:=encodedstr+']';
  445. end;
  446. end;
  447. end;
  448. procvardef :
  449. encodedstr:=encodedstr+'^?';
  450. objectdef :
  451. case tobjectdef(def).objecttype of
  452. odt_class,
  453. odt_object,
  454. odt_cppclass:
  455. begin
  456. newstate:=recordinfostate;
  457. { implicit pointer for classes }
  458. if (tobjectdef(def).objecttype=odt_class) then
  459. begin
  460. encodedstr:=encodedstr+'^';
  461. if (recordinfostate<ris_dontprint) then
  462. newstate:=succ(newstate);
  463. end;
  464. if newstate<>ris_dontprint then
  465. begin
  466. if not encoderecst(def.typename,tabstractrecordsymtable(tobjectdef(def).symtable),encodedstr,founderror) then
  467. begin
  468. result:=false;
  469. { report the exact (nested) error defintion }
  470. exit;
  471. end
  472. end
  473. else
  474. encodedstr:=encodedstr+'{'+def.typename+'}'
  475. end;
  476. odt_interfacecom,
  477. odt_interfacecom_property,
  478. odt_interfacecom_function,
  479. odt_dispinterface:
  480. result:=false;
  481. odt_interfacecorba:
  482. encodedstr:=encodedstr+'^{'+def.typename+'=}';
  483. { In Objective-C, the actual types of class instances are
  484. NSObject* etc, and those are encoded as "@". In FPC, to keep
  485. the similarity with Delphi-style Object Pascal, the type is
  486. NSObject and the pointer is implicit. Objective-C's "NSObject"
  487. has "class of NSObject" as equivalent here. }
  488. odt_objcclass,
  489. odt_objcprotocol:
  490. encodedstr:=encodedstr+'@';
  491. else
  492. internalerror(2009081509);
  493. end;
  494. undefineddef,
  495. errordef :
  496. result:=false;
  497. procdef :
  498. { must be done via objcencodemethod() }
  499. internalerror(2009081511);
  500. else
  501. internalerror(2009150812);
  502. end;
  503. if not result then
  504. founderror:=def;
  505. end;
  506. function objctryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
  507. begin
  508. result:=addencodedtype(def,ris_initial,false,encodedtype,founderror);
  509. end;
  510. function objcencodemethod(pd: tprocdef): ansistring;
  511. var
  512. parasize,
  513. totalsize: aint;
  514. vs: tparavarsym;
  515. i: longint;
  516. temp: ansistring;
  517. founderror: tdef;
  518. begin
  519. result:='';
  520. totalsize:=0;
  521. if not pd.has_paraloc_info then
  522. begin
  523. pd.requiredargarea:=paramanager.create_paraloc_info(pd,callerside);
  524. pd.has_paraloc_info:=true;
  525. end;
  526. {$if defined(powerpc) and defined(dummy)}
  527. { Disabled, because neither Clang nor gcc does this, and the ObjC
  528. runtime contains an explicit fix to detect this error. }
  529. { On ppc, the callee is responsible for removing the hidden function
  530. result parameter from the stack, so it has to know. On i386, it's
  531. the caller that does this. }
  532. if (pd.returndef<>voidtype) and
  533. paramgr.ret_in_param(pd.returndef,pocall_cdecl) then
  534. inc(totalsize,sizeof(pint));
  535. {$endif}
  536. for i:=0 to pd.paras.count-1 do
  537. begin
  538. vs:=tparavarsym(pd.paras[i]);
  539. if (vo_is_funcret in vs.varoptions) then
  540. continue;
  541. { addencodedtype always assumes a value parameter, so add
  542. a pointer indirection for var/out parameters. }
  543. if not paramanager.push_addr_param(vs_value,vs.vardef,pocall_cdecl) and
  544. (vs.varspez in [vs_var,vs_out]) then
  545. result:=result+'^';
  546. { Add the parameter type. }
  547. if not addencodedtype(vs.vardef,ris_initial,false,result,founderror) then
  548. { should be checked earlier on }
  549. internalerror(2009081701);
  550. { And the total size of the parameters coming before this one
  551. (i.e., the "offset" of this parameter). }
  552. result:=result+tostr(totalsize);
  553. { Update the total parameter size }
  554. parasize:=objcparasize(vs);
  555. inc(totalsize,parasize);
  556. end;
  557. { Prepend the total parameter size. }
  558. result:=tostr(totalsize)+result;
  559. { And the type of the function result (void in case of a procedure). }
  560. temp:='';
  561. if not addencodedtype(pd.returndef,ris_initial,false,temp,founderror) then
  562. internalerror(2009081801);
  563. result:=temp+result;
  564. end;
  565. {******************************************************************
  566. ObjC type validity checking
  567. *******************************************************************}
  568. function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean; forward;
  569. function checkrecsttype(recst: tabstractrecordsymtable; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
  570. var
  571. i: longint;
  572. field: tfieldvarsym;
  573. newstate: trecordinfostate;
  574. begin
  575. result:=false;
  576. newstate:=recordinfostate;
  577. { Although we never have to print the type info for nested
  578. records, check them anyway in case we're not after a pointer
  579. since if such records contain refcounted types then they
  580. can cause just as much trouble as if they were a simple
  581. refcounted field. }
  582. if (newstate=ris_afterpointer) then
  583. newstate:=ris_dontprint;
  584. for i:=0 to recst.symlist.count-1 do
  585. begin
  586. if (tsym(recst.symlist[i]).typ<>fieldvarsym) then
  587. continue;
  588. field:=tfieldvarsym(recst.symlist[i]);
  589. if not objcdochecktype(field.vardef,newstate,founderror) then
  590. exit;
  591. end;
  592. result:=true
  593. end;
  594. function objcdochecktype(def: tdef; recordinfostate: trecordinfostate; out founderror: tdef): boolean;
  595. var
  596. recdef: trecorddef;
  597. objdef: tobjectdef;
  598. newstate: trecordinfostate;
  599. begin
  600. result:=true;
  601. case def.typ of
  602. stringdef :
  603. begin
  604. case tstringdef(def).stringtype of
  605. st_shortstring:
  606. ;
  607. else
  608. { While we could handle refcounted Pascal strings correctly
  609. when such methods are called from Pascal code, things would
  610. completely break down if they were called from Objective-C
  611. code/reflection since the necessary refcount helper calls
  612. would be missing on the caller side (unless we'd
  613. automatically generate wrappers). }
  614. result:=false;
  615. end;
  616. end;
  617. enumdef,
  618. orddef :
  619. ;
  620. pointerdef :
  621. begin
  622. newstate:=recordinfostate;
  623. if (recordinfostate<ris_dontprint) then
  624. newstate:=succ(newstate);
  625. if not objcdochecktype(tpointerdef(def).pointeddef,newstate,founderror) then
  626. begin
  627. result:=false;
  628. { report the exact (nested) error defintion }
  629. exit;
  630. end;
  631. end;
  632. floatdef :
  633. begin
  634. case tfloatdef(def).floattype of
  635. s32real,
  636. s64real:
  637. ;
  638. else
  639. result:=false;
  640. end;
  641. end;
  642. filedef :
  643. result:=false;
  644. recorddef :
  645. begin
  646. if (recordinfostate<>ris_dontprint) then
  647. begin
  648. if not checkrecsttype(tabstractrecordsymtable(trecorddef(def).symtable),recordinfostate,founderror) then
  649. begin
  650. result:=false;
  651. { report the exact (nested) error defintion }
  652. exit;
  653. end
  654. end
  655. end;
  656. variantdef :
  657. begin
  658. recdef:=trecorddef(search_system_type('TVARDATA').typedef);
  659. if (recordinfostate<>ris_dontprint) then
  660. begin
  661. if not checkrecsttype(tabstractrecordsymtable(recdef.symtable),recordinfostate,founderror) then
  662. begin
  663. result:=false;
  664. { report the exact (nested) error defintion }
  665. exit;
  666. end
  667. end;
  668. end;
  669. classrefdef:
  670. begin
  671. if is_objcclassref(def) then
  672. begin
  673. objdef:=tobjectdef(tclassrefdef(def).pointeddef);
  674. newstate:=recordinfostate;
  675. if (recordinfostate<ris_dontprint) then
  676. newstate:=succ(newstate);
  677. if (newstate<>ris_dontprint) then
  678. begin
  679. if not checkrecsttype(tabstractrecordsymtable(objdef.symtable),recordinfostate,founderror) then
  680. begin
  681. result:=false;
  682. { report the exact (nested) error defintion }
  683. exit;
  684. end
  685. end
  686. end
  687. end;
  688. setdef,
  689. formaldef :
  690. ;
  691. arraydef :
  692. begin
  693. if is_array_of_const(def) then
  694. { ok, varargs are ignored in signatures }
  695. else if is_special_array(def) then
  696. result:=false
  697. else
  698. begin
  699. if not is_packed_array(def) then
  700. begin
  701. if not objcdochecktype(tarraydef(def).elementdef,ris_initial,founderror) then
  702. begin
  703. result:=false;
  704. { report the exact (nested) error defintion }
  705. exit;
  706. end;
  707. end;
  708. end;
  709. end;
  710. procvardef :
  711. ;
  712. objectdef :
  713. case tobjectdef(def).objecttype of
  714. odt_class,
  715. odt_object,
  716. odt_cppclass:
  717. begin
  718. newstate:=recordinfostate;
  719. { implicit pointer for classes }
  720. if (tobjectdef(def).objecttype=odt_class) then
  721. begin
  722. if (recordinfostate<ris_dontprint) then
  723. newstate:=succ(newstate);
  724. end;
  725. if newstate<>ris_dontprint then
  726. begin
  727. if not checkrecsttype(tabstractrecordsymtable(tobjectdef(def).symtable),newstate,founderror) then
  728. begin
  729. result:=false;
  730. { report the exact (nested) error defintion }
  731. exit;
  732. end
  733. end
  734. end;
  735. odt_interfacecom,
  736. odt_interfacecom_property,
  737. odt_interfacecom_function,
  738. odt_dispinterface:
  739. result:=false;
  740. odt_interfacecorba,
  741. odt_objcclass,
  742. odt_objcprotocol:
  743. ;
  744. else
  745. internalerror(2009081709);
  746. end;
  747. undefineddef,
  748. errordef :
  749. result:=false;
  750. procdef :
  751. result:=false;
  752. else
  753. internalerror(2009170812);
  754. end;
  755. if not result then
  756. founderror:=def;
  757. end;
  758. function objcchecktype(def: tdef; out founderror: tdef): boolean;
  759. begin
  760. result:=objcdochecktype(def,ris_initial,founderror);
  761. end;
  762. {******************************************************************
  763. ObjC class exporting
  764. *******************************************************************}
  765. procedure exportobjcclassfields(objccls: tobjectdef);
  766. var
  767. i: longint;
  768. vf: tfieldvarsym;
  769. prefix: string;
  770. begin
  771. prefix:=target_info.cprefix+'OBJC_IVAR_$_'+objccls.objextname^+'.';
  772. for i:=0 to objccls.symtable.SymList.Count-1 do
  773. if tsym(objccls.symtable.SymList[i]).typ=fieldvarsym then
  774. begin
  775. vf:=tfieldvarsym(objccls.symtable.SymList[i]);
  776. { TODO: package visibility (private_extern) -- must not be exported
  777. either}
  778. if not(vf.visibility in [vis_private,vis_strictprivate]) then
  779. exportname(prefix+vf.RealName,0);
  780. end;
  781. end;
  782. procedure exportobjcclass(def: tobjectdef);
  783. begin
  784. if (target_info.system in system_objc_nfabi) then
  785. begin
  786. { export class and metaclass symbols }
  787. exportname(def.rtti_mangledname(objcclassrtti),0);
  788. exportname(def.rtti_mangledname(objcmetartti),0);
  789. { export public/protected instance variable offset symbols }
  790. exportobjcclassfields(def);
  791. end
  792. else
  793. begin
  794. { export the class symbol }
  795. exportname('.objc_class_name_'+def.objextname^,0);
  796. end;
  797. end;
  798. end.