ncgrtti.pas 106 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Routines for the code generation of RTTI data structures
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ncgrtti;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,constexp,globtype,
  22. aasmbase,aasmcnst,
  23. symbase,symconst,symtype,symdef,symsym,
  24. parabase;
  25. type
  26. { TRTTIWriter }
  27. TRTTIWriter=class
  28. private
  29. { required internal alignment of the rtti data }
  30. reqalign: shortint;
  31. { required packing of all structures except for ttypeinfo and tpropinfo,
  32. which always use packrecords 1 }
  33. defaultpacking: shortint;
  34. { write comments ? }
  35. addcomments : boolean;
  36. procedure fields_write_rtti(st:tsymtable;rt:trttitype);
  37. procedure params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  38. procedure fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  39. procedure methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  40. procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  41. procedure published_write_rtti(def : tobjectdef;rt:trttitype);
  42. procedure properties_write_rtti_data(tcb:ttai_typedconstbuilder;propnamelist:TFPHashObjectList;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  43. procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  44. procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  45. procedure collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
  46. { only use a direct reference if the referenced type can *only* reside
  47. in the same unit as the current one }
  48. function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  49. procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  50. procedure write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype);
  51. procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
  52. procedure write_attribute_data(tcb: ttai_typedconstbuilder;attr_list:trtti_attribute_list);
  53. procedure write_child_rtti_data(def:tdef;rt:trttitype);
  54. procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  55. procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  56. procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  57. function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  58. procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  59. procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  60. procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  61. procedure write_param(tcb:ttai_typedconstbuilder;para:tparavarsym);
  62. procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  63. procedure maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string); inline;
  64. public
  65. constructor create;
  66. procedure write_rtti(def:tdef;rt:trttitype);
  67. procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
  68. procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline;
  69. function get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  70. function get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  71. function get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  72. end;
  73. { generate RTTI and init tables }
  74. procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
  75. var
  76. RTTIWriter : TRTTIWriter;
  77. implementation
  78. uses
  79. cutils,
  80. globals,verbose,systems,
  81. node,ncal,ncon,
  82. fmodule, procinfo,
  83. symtable,symutil,
  84. aasmtai,aasmdata,
  85. defutil,
  86. paramgr
  87. ;
  88. const
  89. rttidefstate : array[trttitype] of tdefstate =
  90. (ds_rtti_table_written,ds_init_table_written,
  91. { Objective-C related, does not pass here }
  92. symconst.ds_none,symconst.ds_none,
  93. symconst.ds_none,symconst.ds_none);
  94. rttitypenames : array[trttitype] of string =
  95. ('full','init',
  96. 'objcmeta','objcmetaro',
  97. 'objcclass','objcclassro');
  98. type
  99. TPropNameListItem = class(TFPHashObject)
  100. propindex : longint;
  101. propowner : TSymtable;
  102. end;
  103. function visibility_to_rtti_flags(vis: tvisibility): byte;
  104. begin
  105. case vis of
  106. vis_private:
  107. result:=byte(rv_private);
  108. vis_strictprivate:
  109. begin
  110. result:=byte(rv_private);
  111. // add bit to indicate "strict"
  112. result:=result or (1 shl 2);
  113. end;
  114. vis_protected:
  115. result:=byte(rv_protected);
  116. vis_strictprotected:
  117. begin
  118. result:=byte(rv_protected);
  119. // add bit to indicate "strict"
  120. result:=result or (1 shl 2);
  121. end;
  122. vis_public:
  123. result:=byte(rv_public);
  124. vis_published:
  125. result:=byte(rv_published);
  126. otherwise
  127. internalerror(2021061301);
  128. end;
  129. end;
  130. procedure write_persistent_type_info(st: tsymtable; is_global: boolean);
  131. var
  132. i : longint;
  133. def : tdef;
  134. begin
  135. { no Delphi-style RTTI for managed platforms }
  136. if target_info.system in systems_managed_vm then
  137. exit;
  138. for i:=0 to st.DefList.Count-1 do
  139. begin
  140. def:=tdef(st.DefList[i]);
  141. { skip generics }
  142. if [df_generic,df_genconstraint]*def.defoptions<>[] then
  143. continue;
  144. case def.typ of
  145. recorddef:
  146. write_persistent_type_info(trecorddef(def).symtable,is_global);
  147. objectdef :
  148. begin
  149. { Skip forward defs }
  150. if (oo_is_forward in tobjectdef(def).objectoptions) then
  151. continue;
  152. { skip unique type aliases, they use the RTTI from the parent class }
  153. if tobjectdef(def).is_unique_objpasdef then
  154. continue;
  155. write_persistent_type_info(tobjectdef(def).symtable,is_global);
  156. end;
  157. procdef :
  158. begin
  159. if assigned(tprocdef(def).localst) and
  160. (tprocdef(def).localst.symtabletype=localsymtable) then
  161. write_persistent_type_info(tprocdef(def).localst,false);
  162. if assigned(tprocdef(def).parast) then
  163. write_persistent_type_info(tprocdef(def).parast,false);
  164. end;
  165. errordef:
  166. { we shouldn't have come this far if we have an errordef somewhere }
  167. internalerror(2017010701);
  168. undefineddef:
  169. { don't write any RTTI for these }
  170. continue;
  171. else
  172. ;
  173. end;
  174. { always generate persistent tables for types in the interface so
  175. they can be reused in other units and give always the same pointer
  176. location. }
  177. { Init }
  178. if (
  179. assigned(def.typesym) and
  180. is_global and
  181. not is_objc_class_or_protocol(def)
  182. ) or
  183. is_managed_type(def) or
  184. (ds_init_table_used in def.defstates) then
  185. RTTIWriter.write_rtti(def,initrtti);
  186. { RTTI }
  187. if not(df_internal in def.defoptions) and
  188. (
  189. (
  190. assigned(def.typesym) and
  191. is_global and
  192. not is_objc_class_or_protocol(def)
  193. ) or
  194. (ds_rtti_table_used in def.defstates)
  195. ) then
  196. RTTIWriter.write_rtti(def,fullrtti);
  197. end;
  198. end;
  199. {***************************************************************************
  200. TRTTIWriter
  201. ***************************************************************************}
  202. function TRTTIWriter.get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  203. begin
  204. result:=ref_rtti(def,rt,indirect,'');
  205. end;
  206. function TRTTIWriter.get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  207. begin
  208. result:=ref_rtti(def,rt,indirect,'_o2s');
  209. end;
  210. function TRTTIWriter.get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  211. begin
  212. result:=ref_rtti(def,rt,indirect,'_s2o');
  213. end;
  214. procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities);
  215. var
  216. rtticount,
  217. totalcount,
  218. i,j,k : longint;
  219. sym : tprocsym;
  220. def : tprocdef;
  221. para : tparavarsym;
  222. begin
  223. maybe_add_comment(tcb,'RTTI: begin methods');
  224. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  225. targetinfos[target_info.system]^.alignment.recordalignmin);
  226. totalcount:=0;
  227. rtticount:=0;
  228. for i:=0 to st.symlist.count-1 do
  229. if tsym(st.symlist[i]).typ=procsym then
  230. begin
  231. sym:=tprocsym(st.symlist[i]);
  232. inc(totalcount,sym.procdeflist.count);
  233. for j:=0 to sym.procdeflist.count-1 do
  234. begin
  235. def:=tprocdef(sym.procdeflist[j]);
  236. if (def.visibility in visibilities) and not (def.is_generic) then
  237. inc(rtticount);
  238. end;
  239. end;
  240. { write the count section for non-extended methods }
  241. if not extended_rtti then
  242. begin
  243. maybe_add_comment(tcb,#9'count');
  244. tcb.emit_ord_const(totalcount,u16inttype);
  245. maybe_add_comment(tcb,#9'RTTI count');
  246. if rtticount=0 then
  247. tcb.emit_ord_const($FFFF,u16inttype)
  248. else
  249. tcb.emit_ord_const(rtticount,u16inttype);
  250. end;
  251. if rtticount>0 then
  252. for i:=0 to st.symlist.count-1 do
  253. if tsym(st.symlist[i]).typ=procsym then
  254. begin
  255. sym:=tprocsym(st.symlist[i]);
  256. for j:=0 to sym.procdeflist.count-1 do
  257. begin
  258. def:=tprocdef(sym.procdeflist[j]);
  259. if (def.is_generic) or not (def.visibility in visibilities) then
  260. continue;
  261. def.init_paraloc_info(callerside);
  262. maybe_add_comment(tcb,'RTTI: begin method '+def.fullprocname(false));
  263. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  264. targetinfos[target_info.system]^.alignment.recordalignmin);
  265. maybe_add_comment(tcb,#9'return type');
  266. write_rtti_reference(tcb,def.returndef,fullrtti);
  267. maybe_add_comment(tcb,#9'calling convention');
  268. write_callconv(tcb,def);
  269. maybe_add_comment(tcb,#9'method kind');
  270. write_methodkind(tcb,def);
  271. maybe_add_comment(tcb,#9'param count');
  272. tcb.emit_ord_const(def.paras.count,u16inttype);
  273. maybe_add_comment(tcb,#9'caller args size');
  274. tcb.emit_ord_const(def.callerargareasize,sizesinttype);
  275. maybe_add_comment(tcb,#9'invoke helper');
  276. if def.invoke_helper=nil then
  277. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidcodepointertype)
  278. else
  279. tcb.emit_procdef_const(def.invoke_helper);
  280. maybe_add_comment(tcb,#9'name');
  281. tcb.emit_pooled_shortstring_const_ref(sym.realname);
  282. if extended_rtti then
  283. begin
  284. { write visibility section for extended RTTI }
  285. maybe_add_comment(tcb,#9'visibility');
  286. tcb.emit_ord_const(visibility_to_rtti_flags(def.visibility),u8inttype);
  287. { for objects and classes write a VMT index }
  288. if st.defowner.typ=objectdef then
  289. begin
  290. maybe_add_comment(tcb,#9'VMT index');
  291. tcb.emit_ord_const(def.extnumber,u16inttype);
  292. end;
  293. maybe_add_comment(tcb,#9'Code Address');
  294. tcb.emit_procdef_const(def);
  295. maybe_add_comment(tcb,#9'Attribute table');
  296. write_attribute_data(tcb,def.rtti_attribute_list);
  297. end;
  298. for k:=0 to def.paras.count-1 do
  299. write_param(tcb,tparavarsym(def.paras[k]));
  300. if not is_void(def.returndef) then
  301. begin
  302. maybe_add_comment(tcb,#9'return loc');
  303. write_paralocs(tcb,@def.funcretloc[callerside]);
  304. end;
  305. tcb.end_anonymous_record;
  306. maybe_add_comment(tcb,'RTTI: end method '+def.fullprocname(false));
  307. end;
  308. end;
  309. tcb.end_anonymous_record;
  310. maybe_add_comment(tcb,'RTTI: end methods');
  311. end;
  312. procedure TRTTIWriter.write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  313. var
  314. name: shortstring;
  315. begin
  316. if assigned(def.typesym) then
  317. name:=ttypesym(def.typesym).realname
  318. else
  319. name:='';
  320. { TTypeInfo, always packed and doesn't need alignment }
  321. tcb.begin_anonymous_record(
  322. internaltypeprefixName[itp_rtti_header]+tostr(length(name)),1,1,
  323. targetinfos[target_info.system]^.alignment.recordalignmin);
  324. if def.typ=arraydef then
  325. InternalError(201012211);
  326. tcb.emit_tai(Tai_const.Create_8bit(typekind),u8inttype);
  327. tcb.emit_shortstring_const(name);
  328. tcb.end_anonymous_record;
  329. end;
  330. function TRTTIWriter.write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  331. begin
  332. case def.proctypeoption of
  333. potype_constructor: result:=mkConstructor;
  334. potype_destructor: result:=mkDestructor;
  335. potype_class_constructor: result:=mkClassConstructor;
  336. potype_class_destructor: result:=mkClassDestructor;
  337. potype_operator: result:=mkOperatorOverload;
  338. potype_procedure:
  339. if po_classmethod in def.procoptions then
  340. result:=mkClassProcedure
  341. else
  342. result:=mkProcedure;
  343. potype_function:
  344. if po_classmethod in def.procoptions then
  345. result:=mkClassFunction
  346. else
  347. result:=mkFunction;
  348. else
  349. begin
  350. if def.returndef = voidtype then
  351. result:=mkProcedure
  352. else
  353. result:=mkFunction;
  354. end;
  355. end;
  356. tcb.emit_ord_const(result,u8inttype);
  357. end;
  358. procedure TRTTIWriter.write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  359. const
  360. ProcCallOptionToCallConv: array[tproccalloption] of byte = (
  361. { pocall_none } 0,
  362. { pocall_cdecl } 1,
  363. { pocall_cppdecl } 5,
  364. { pocall_far16 } 6,
  365. { pocall_oldfpccall } 7,
  366. { pocall_internproc } 8,
  367. { pocall_syscall } 9,
  368. { pocall_pascal } 2,
  369. { pocall_register } 0,
  370. { pocall_safecall } 4,
  371. { pocall_stdcall } 3,
  372. { pocall_softfloat } 10,
  373. { pocall_mwpascal } 11,
  374. { pocall_interrupt } 12,
  375. { pocall_hardfloat } 13,
  376. { pocall_sysv_abi_default } 14,
  377. { pocall_sysv_abi_cdecl } 15,
  378. { pocall_ms_abi_default } 16,
  379. { pocall_ms_abi_cdecl } 17,
  380. { pocall_vectorcall } 18
  381. );
  382. begin
  383. tcb.emit_ord_const(ProcCallOptionToCallConv[def.proccalloption],u8inttype);
  384. end;
  385. procedure TRTTIWriter.write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  386. var
  387. locs : trttiparalocs;
  388. i : longint;
  389. pool : THashSet;
  390. entry : PHashSetItem;
  391. loclab : TAsmLabel;
  392. loctcb : ttai_typedconstbuilder;
  393. datadef : tdef;
  394. begin
  395. locs:=paramanager.cgparalocs_to_rttiparalocs(para^.location);
  396. if length(locs)>high(byte) then
  397. internalerror(2017010601);
  398. if length(locs)=0 then
  399. begin
  400. { *shrugs* }
  401. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidpointertype);
  402. exit;
  403. end;
  404. { do we have such a paraloc already in the pool? }
  405. pool:=current_asmdata.ConstPools[sp_paraloc];
  406. entry:=pool.FindOrAdd(@locs[0],length(locs)*sizeof(trttiparaloc));
  407. if not assigned(entry^.Data) then
  408. begin
  409. current_asmdata.getglobaldatalabel(loclab);
  410. loctcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  411. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  412. targetinfos[target_info.system]^.alignment.recordalignmin);
  413. loctcb.emit_ord_const(length(locs),u8inttype);
  414. for i:=low(locs) to high(locs) do
  415. begin
  416. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  417. targetinfos[target_info.system]^.alignment.recordalignmin);
  418. loctcb.emit_ord_const(locs[i].loctype,u8inttype);
  419. loctcb.emit_ord_const(locs[i].regsub,u8inttype);
  420. loctcb.emit_ord_const(locs[i].regindex,u16inttype);
  421. { the corresponding type for aint is alusinttype }
  422. loctcb.emit_ord_const(locs[i].offset,alusinttype);
  423. loctcb.end_anonymous_record;
  424. end;
  425. datadef:=loctcb.end_anonymous_record;
  426. current_asmdata.asmlists[al_typedconsts].concatList(
  427. loctcb.get_final_asmlist(loclab,datadef,sec_rodata_norel,loclab.name,const_align(sizeof(pint)))
  428. );
  429. loctcb.free;
  430. loctcb := nil;
  431. entry^.data:=loclab;
  432. end
  433. else
  434. loclab:=TAsmLabel(entry^.Data);
  435. tcb.emit_tai(Tai_const.Create_sym(loclab),voidpointertype);
  436. end;
  437. procedure TRTTIWriter.write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  438. var
  439. paraspec : word;
  440. begin
  441. case parasym.varspez of
  442. vs_value : paraspec := 0;
  443. vs_const : paraspec := pfConst;
  444. vs_var : paraspec := pfVar;
  445. vs_out : paraspec := pfOut;
  446. vs_constref: paraspec := pfConstRef;
  447. else
  448. internalerror(2013112904);
  449. end;
  450. { Kylix also seems to always add both pfArray and pfReference
  451. in this case
  452. }
  453. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  454. paraspec:=paraspec or pfArray or pfReference;
  455. { and these for classes and interfaces (maybe because they
  456. are themselves addresses?)
  457. }
  458. if is_class_or_interface(parasym.vardef) then
  459. paraspec:=paraspec or pfAddress;
  460. { flags for the hidden parameters }
  461. if vo_is_hidden_para in parasym.varoptions then
  462. paraspec:=paraspec or pfHidden;
  463. if vo_is_high_para in parasym.varoptions then
  464. paraspec:=paraspec or pfHigh;
  465. if vo_is_self in parasym.varoptions then
  466. paraspec:=paraspec or pfSelf;
  467. if vo_is_vmt in parasym.varoptions then
  468. paraspec:=paraspec or pfVmt;
  469. if vo_is_funcret in parasym.varoptions then
  470. paraspec:=paraspec or pfResult;
  471. { set bits run from the highest to the lowest bit on
  472. big endian systems
  473. }
  474. if (target_info.endian = endian_big) then
  475. paraspec:=reverse_word(paraspec);
  476. { write flags for current parameter }
  477. tcb.emit_ord_const(paraspec,u16inttype);
  478. end;
  479. procedure TRTTIWriter.write_param(tcb: ttai_typedconstbuilder;
  480. para: tparavarsym);
  481. begin
  482. maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname);
  483. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  484. targetinfos[target_info.system]^.alignment.recordalignmin);
  485. maybe_add_comment(tcb,#9'type');
  486. if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
  487. write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
  488. else if para.vardef=cformaltype then
  489. write_rtti_reference(tcb,nil,fullrtti)
  490. else
  491. write_rtti_reference(tcb,para.vardef,fullrtti);
  492. maybe_add_comment(tcb,#9'flags');
  493. write_param_flag(tcb,para);
  494. maybe_add_comment(tcb,#9'name');
  495. tcb.emit_pooled_shortstring_const_ref(para.realname);
  496. maybe_add_comment(tcb,#9'locs');
  497. write_paralocs(tcb,@para.paraloc[callerside]);
  498. tcb.end_anonymous_record;
  499. maybe_add_comment(tcb,'RTTI: end param '+para.prettyname);
  500. end;
  501. function compare_mop_offset_entry(item1,item2:pointer):longint;
  502. var
  503. entry1: pmanagementoperator_offset_entry absolute item1;
  504. entry2: pmanagementoperator_offset_entry absolute item2;
  505. begin
  506. if entry1^.offset<entry2^.offset then
  507. result:=-1
  508. else if entry1^.offset>entry2^.offset then
  509. result:=1
  510. else
  511. result:=0;
  512. end;
  513. procedure TRTTIWriter.write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  514. var
  515. list : tfplist;
  516. datatcb : ttai_typedconstbuilder;
  517. tbllbl : TAsmLabel;
  518. entry : pmanagementoperator_offset_entry;
  519. datadef,entrydef : tdef;
  520. i : longint;
  521. pdef : tobjectdef;
  522. begin
  523. list:=tfplist.create;
  524. tabstractrecordsymtable(def.symtable).get_managementoperator_offset_list(mop,list);
  525. if (def.typ=objectdef) then
  526. begin
  527. pdef:=tobjectdef(def).childof;
  528. while assigned(pdef) do
  529. begin
  530. tabstractrecordsymtable(pdef.symtable).get_managementoperator_offset_list(mop,list);
  531. pdef:=pdef.childof;
  532. end;
  533. list.sort(@compare_mop_offset_entry);
  534. end;
  535. if list.count=0 then
  536. tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype)
  537. else
  538. begin
  539. tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',datatcb,tbllbl);
  540. datatcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  541. targetinfos[target_info.system]^.alignment.recordalignmin);
  542. datatcb.emit_ord_const(list.count,u32inttype);
  543. entrydef:=get_recorddef(itp_init_mop_offset_entry,[voidcodepointertype,sizeuinttype],defaultpacking);
  544. for i:=0 to list.count-1 do
  545. begin
  546. entry:=pmanagementoperator_offset_entry(list[i]);
  547. datatcb.maybe_begin_aggregate(entrydef);
  548. datatcb.queue_init(voidcodepointertype);
  549. datatcb.queue_emit_proc(entry^.pd);
  550. datatcb.queue_init(sizeuinttype);
  551. datatcb.queue_emit_ordconst(entry^.offset,sizeuinttype);
  552. datatcb.maybe_end_aggregate(entrydef);
  553. dispose(entry);
  554. end;
  555. datadef:=datatcb.end_anonymous_record;
  556. tcb.finish_internal_data_builder(datatcb,tbllbl,datadef,sizeof(pint));
  557. tcb.emit_tai(tai_const.Create_sym(tbllbl),voidpointertype);
  558. end;
  559. list.free;
  560. list := nil;
  561. end;
  562. procedure TRTTIWriter.write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  563. begin
  564. if is_open_array(def) then
  565. { open arrays never have a typesym with a name, since you cannot
  566. define an "open array type". Kylix prints the type of the
  567. elements in the array in this case (so together with the pfArray
  568. flag, you can reconstruct the full typename, I assume (JM))
  569. }
  570. def:=tarraydef(def).elementdef;
  571. { name }
  572. if assigned(def.typesym) then
  573. tcb.emit_shortstring_const(ttypesym(def.typesym).prettyname)
  574. else
  575. tcb.emit_shortstring_const('');
  576. end;
  577. procedure TRTTIWriter.write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype);
  578. begin
  579. if rt<>fullrtti then
  580. write_attribute_data(tcb,nil)
  581. else
  582. write_attribute_data(tcb,tstoreddef(def).rtti_attribute_list);
  583. end;
  584. { writes a 32-bit count followed by array of field infos for given symtable }
  585. procedure TRTTIWriter.fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  586. var
  587. i : longint;
  588. sym : tsym;
  589. fieldcnt: longint;
  590. st: tsymtable;
  591. fields: tfplist;
  592. parentrtti: boolean;
  593. begin
  594. fieldcnt:=0;
  595. parentrtti:=false;
  596. st:=def.symtable;
  597. fields:=tfplist.create;
  598. fields.capacity:=st.symlist.count+1;
  599. { For objects, treat parent (if any) as a field with offset 0. This
  600. provides correct handling of entire instance with RTL rtti routines. }
  601. if (def.typ=objectdef) and (tobjectdef(def).objecttype=odt_object) and
  602. Assigned(tobjectdef(def).childof) and
  603. ((rt=fullrtti) or (tobjectdef(def).childof.needs_inittable)) then
  604. begin
  605. parentrtti:=true;
  606. inc(fieldcnt);
  607. end;
  608. for i:=0 to st.SymList.Count-1 do
  609. begin
  610. sym:=tsym(st.SymList[i]);
  611. if is_normal_fieldvarsym(sym) and
  612. (
  613. (rt=fullrtti) or
  614. tfieldvarsym(sym).vardef.needs_inittable
  615. ) and
  616. not is_objc_class_or_protocol(tfieldvarsym(sym).vardef) then
  617. begin
  618. fields.add(tfieldvarsym(sym));
  619. inc(fieldcnt);
  620. end;
  621. end;
  622. { insert field count before data }
  623. maybe_add_comment(tcb,'Field count');
  624. tcb.emit_ord_const(fieldcnt,u32inttype);
  625. { parent object? }
  626. if parentrtti then
  627. begin
  628. write_rtti_reference(tcb,tobjectdef(def).childof,rt);
  629. tcb.emit_ord_const(0,ptruinttype);
  630. end;
  631. { fields }
  632. for i:=0 to fields.count-1 do
  633. begin
  634. sym:=tsym(fields[i]);
  635. maybe_add_comment(tcb,'RTTI begin field '+tostr(i)+': '+sym.prettyname);
  636. write_rtti_reference(tcb,tfieldvarsym(sym).vardef,rt);
  637. tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,sizeuinttype);
  638. maybe_add_comment(tcb,'RTTI end field '+tostr(i)+': '+sym.prettyname);
  639. end;
  640. fields.free;
  641. fields := nil;
  642. end;
  643. procedure TRTTIWriter.fields_write_rtti(st:tsymtable;rt:trttitype);
  644. var
  645. i : longint;
  646. sym : tsym;
  647. begin
  648. for i:=0 to st.SymList.Count-1 do
  649. begin
  650. sym:=tsym(st.SymList[i]);
  651. if is_normal_fieldvarsym(sym) and
  652. (
  653. (rt=fullrtti) or
  654. tfieldvarsym(sym).vardef.needs_inittable
  655. ) then
  656. write_rtti(tfieldvarsym(sym).vardef,rt);
  657. end;
  658. end;
  659. procedure TRTTIWriter.params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  660. var
  661. i : longint;
  662. sym : tparavarsym;
  663. begin
  664. for i:=0 to def.paras.count-1 do
  665. begin
  666. sym:=tparavarsym(def.paras[i]);
  667. if not (vo_is_hidden_para in sym.varoptions) or allow_hidden then
  668. begin
  669. if is_open_array(sym.vardef) or is_array_of_const(sym.vardef) then
  670. write_rtti(tarraydef(sym.vardef).elementdef,rt)
  671. else
  672. write_rtti(sym.vardef,rt);
  673. end;
  674. end;
  675. end;
  676. procedure TRTTIWriter.methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  677. var
  678. i,j : longint;
  679. sym : tprocsym;
  680. def : tabstractprocdef;
  681. begin
  682. for i:=0 to st.symlist.count-1 do
  683. if tsym(st.symlist[i]).typ=procsym then
  684. begin
  685. sym:=tprocsym(st.symlist[i]);
  686. for j:=0 to sym.procdeflist.count-1 do
  687. begin
  688. def:=tabstractprocdef(sym.procdeflist[j]);
  689. write_rtti(def.returndef,rt);
  690. params_write_rtti(def,rt,allow_hidden);
  691. end;
  692. end;
  693. end;
  694. procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  695. var
  696. methodcount,
  697. i, j: longint;
  698. sym: tprocsym;
  699. pdef : tprocdef;
  700. begin
  701. { count methods }
  702. methodcount:=0;
  703. for i:=0 to def.symtable.symlist.count-1 do
  704. if tsym(def.symtable.symlist[i]).typ=procsym then
  705. begin
  706. sym:=tprocsym(def.symtable.symlist[i]);
  707. for j:=0 to sym.procdeflist.count-1 do
  708. begin
  709. pdef:=tprocdef(sym.procdeflist[j]);
  710. if (not pdef.is_generic) and def.is_visible_for_rtti(ro_methods,pdef.visibility) then
  711. inc(methodcount);
  712. end;
  713. end;
  714. tcb.begin_anonymous_record('',packrecords,min(reqalign,SizeOf(PInt)),
  715. targetinfos[target_info.system]^.alignment.recordalignmin);
  716. { emit method count }
  717. maybe_add_comment(tcb,'RTTI Method table: method count');
  718. tcb.emit_ord_const(methodcount,u16inttype);
  719. { emit method entries (array) }
  720. if methodcount>0 then
  721. write_methods(tcb,def.symtable,true,def.rtti_visibilities_for_option(ro_methods));
  722. tcb.end_anonymous_record;
  723. end;
  724. procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
  725. begin
  726. write_extended_method_table(tcb,def,defaultpacking);
  727. end;
  728. procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint);
  729. var
  730. i,cnt: integer;
  731. asym: tsym;
  732. fldsym : tfieldvarsym;
  733. list: TFPList;
  734. begin
  735. list:=TFPList.Create;
  736. { build list of visible fields }
  737. for i:=0 to def.symtable.symlist.Count-1 do
  738. begin
  739. asym:=tsym(def.symtable.symlist[i]);
  740. if (asym.typ=fieldvarsym) and
  741. not(sp_static in asym.symoptions) and
  742. def.is_visible_for_rtti(ro_fields, asym.visibility) then
  743. list.add(asym);
  744. end;
  745. {
  746. TExtendedFieldTable = record
  747. FieldCount: Word;
  748. Fields: array[0..0] of TExtendedFieldInfo;
  749. end;
  750. }
  751. tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_table]+tostr(list.count),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
  752. maybe_add_comment(tcb,'RTTI: Extended Field count');
  753. tcb.emit_ord_const(list.count,u16inttype);
  754. for i := 0 to list.count-1 do
  755. begin
  756. fldsym:=tfieldvarsym(list[i]);
  757. {
  758. TExtendedFieldInfo = record
  759. FieldOffset: SizeUInt;
  760. FieldType: Pointer;
  761. FieldVisibility: Byte;
  762. Name: PShortString;
  763. Attributes :
  764. end;
  765. }
  766. tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_field]+tostr(fldsym.fieldoffset),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin);
  767. { FieldOffset }
  768. tcb.emit_tai(Tai_const.Create_sizeint(fldsym.fieldoffset),sizeuinttype);
  769. { FieldType: PPTypeInfo }
  770. if is_objc_class_or_protocol(fldsym.vardef) then
  771. tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(voidpointertype,fullrtti,true)),voidpointertype)
  772. else
  773. tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(fldsym.vardef,fullrtti,true)),voidpointertype);
  774. { FieldVisibility }
  775. tcb.emit_ord_const(visibility_to_rtti_flags(fldsym.visibility),u8inttype);
  776. { Name }
  777. tcb.emit_pooled_shortstring_const_ref(fldsym.realname);
  778. { Attribute table }
  779. if assigned(fldsym.rtti_attribute_list) and assigned(fldsym.rtti_attribute_list.rtti_attributes) then
  780. cnt:=fldsym.rtti_attribute_list.rtti_attributes.count
  781. else
  782. cnt:=0;
  783. write_attribute_data(tcb,fldsym.rtti_attribute_list);
  784. tcb.end_anonymous_record;
  785. end;
  786. tcb.end_anonymous_record;
  787. list.free;
  788. list := nil;
  789. end;
  790. procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef);
  791. begin
  792. write_extended_field_table(tcb,def,defaultpacking);
  793. end;
  794. procedure TRTTIWriter.published_write_rtti(def : tobjectdef;rt:trttitype);
  795. var
  796. i : longint;
  797. st : tsymtable;
  798. sym : tsym;
  799. begin
  800. st:=def.symtable;
  801. for i:=0 to st.SymList.Count-1 do
  802. begin
  803. sym:=tsym(st.SymList[i]);
  804. if (sym.visibility=vis_published) or def.is_visible_for_rtti(ro_properties, sym.visibility) then
  805. begin
  806. case tsym(sym).typ of
  807. propertysym:
  808. write_rtti(tpropertysym(sym).propdef,rt);
  809. fieldvarsym:
  810. write_rtti(tfieldvarsym(sym).vardef,rt);
  811. else
  812. ;
  813. end;
  814. end;
  815. end;
  816. end;
  817. procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities);
  818. var
  819. i : longint;
  820. sym : tsym;
  821. pn : tpropnamelistitem;
  822. begin
  823. { search into parent for objects }
  824. if def.typ=objectdef then
  825. begin
  826. if assigned(tobjectdef(def).childof) then
  827. collect_propnamelist(propnamelist,tobjectdef(def).childof,visibilities);
  828. end;
  829. for i:=0 to def.symtable.SymList.Count-1 do
  830. begin
  831. sym:=tsym(def.symtable.SymList[i]);
  832. if (tsym(sym).typ=propertysym) and
  833. (sym.visibility in visibilities) then
  834. begin
  835. pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name));
  836. if not assigned(pn) then
  837. begin
  838. pn:=tpropnamelistitem.create(propnamelist,tsym(sym).name);
  839. pn.propindex:=propnamelist.count-1;
  840. pn.propowner:=tsym(sym).owner;
  841. end;
  842. end;
  843. end;
  844. end;
  845. procedure TRTTIWriter.properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList; st:tsymtable; extended_rtti:boolean; visibilities:tvisibilities);
  846. var
  847. i : longint;
  848. sym : tsym;
  849. proctypesinfo : byte;
  850. propnameitem : tpropnamelistitem;
  851. propdefname : string;
  852. tbltcb : ttai_typedconstbuilder;
  853. tbllab : tasmlabel;
  854. tbldef : tdef;
  855. visbyte : byte;
  856. procedure writeaccessproc(tcb: ttai_typedconstbuilder; pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
  857. var
  858. typvalue : byte;
  859. hp : ppropaccesslistitem;
  860. extnumber: longint;
  861. address,space : longint;
  862. def : tdef;
  863. hpropsym : tpropertysym;
  864. propaccesslist : tpropaccesslist;
  865. begin
  866. hpropsym:=tpropertysym(sym);
  867. repeat
  868. propaccesslist:=hpropsym.propaccesslist[pap];
  869. if not propaccesslist.empty then
  870. break;
  871. hpropsym:=hpropsym.overriddenpropsym;
  872. until not assigned(hpropsym);
  873. if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then
  874. begin
  875. tcb.emit_tai(Tai_const.Create_int_codeptr(unsetvalue),codeptruinttype);
  876. typvalue:=3;
  877. end
  878. { also for accessing class fields }
  879. else if propaccesslist.firstsym^.sym.typ=fieldvarsym then
  880. begin
  881. address:=0;
  882. hp:=propaccesslist.firstsym;
  883. def:=nil;
  884. while assigned(hp) do
  885. begin
  886. case hp^.sltype of
  887. sl_load :
  888. begin
  889. def:=tfieldvarsym(hp^.sym).vardef;
  890. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  891. end;
  892. sl_subscript :
  893. begin
  894. if not(assigned(def) and
  895. ((def.typ=recorddef) or
  896. is_object(def))) then
  897. internalerror(200402171);
  898. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  899. def:=tfieldvarsym(hp^.sym).vardef;
  900. end;
  901. sl_vec :
  902. begin
  903. if not(assigned(def) and (def.typ=arraydef)) then
  904. internalerror(200402172);
  905. def:=tarraydef(def).elementdef;
  906. {Hp.value is a Tconstexprint, which can be rather large,
  907. sanity check for longint overflow.}
  908. space:=(high(address)-address) div def.size;
  909. if int64(space)<hp^.value then
  910. internalerror(200706101);
  911. inc(address,int64(def.size*hp^.value));
  912. end;
  913. else
  914. internalerror(2019050523);
  915. end;
  916. hp:=hp^.next;
  917. end;
  918. tcb.emit_tai(Tai_const.Create_int_codeptr(address),codeptruinttype);
  919. typvalue:=0;
  920. end
  921. else
  922. begin
  923. { When there was an error then procdef is not assigned }
  924. if not assigned(propaccesslist.procdef) then
  925. exit;
  926. if not(po_virtualmethod in tprocdef(propaccesslist.procdef).procoptions) or
  927. is_objectpascal_helper(tprocdef(propaccesslist.procdef).struct) then
  928. begin
  929. tcb.queue_init(codeptruinttype);
  930. tcb.queue_emit_proc(tprocdef(propaccesslist.procdef));
  931. typvalue:=1;
  932. end
  933. else
  934. begin
  935. { virtual method, write vmt offset }
  936. extnumber:=tprocdef(propaccesslist.procdef).extnumber;
  937. tcb.emit_tai(Tai_const.Create_int_codeptr(
  938. tobjectdef(tprocdef(propaccesslist.procdef).struct).vmtmethodoffset(extnumber)),
  939. codeptruinttype);
  940. { register for wpo }
  941. tobjectdef(tprocdef(propaccesslist.procdef).struct).register_vmt_call(extnumber);
  942. {$ifdef vtentry}
  943. { not sure if we can insert those vtentry symbols safely here }
  944. {$error register methods used for published properties}
  945. {$endif vtentry}
  946. typvalue:=2;
  947. end;
  948. end;
  949. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  950. end;
  951. function properties_count(st:tsymtable):longint;
  952. var
  953. i : longint;
  954. sym : tsym;
  955. begin
  956. result:=0;
  957. for i:=0 to st.SymList.Count-1 do
  958. begin
  959. sym:=tsym(st.SymList[i]);
  960. if (tsym(sym).typ=propertysym) and
  961. (sym.visibility in visibilities) and
  962. (extended_rtti or (
  963. (tpropertysym(sym).parast=Nil) and
  964. not (sp_static in sym.symoptions)
  965. )) then
  966. inc(result);
  967. end;
  968. end;
  969. procedure write_prop_params(tcb:ttai_typedconstbuilder;paramst:tsymtable);
  970. var
  971. paramtcb : ttai_typedconstbuilder;
  972. paramlbl : tasmlabel;
  973. paramdef : tdef;
  974. i : longint;
  975. begin
  976. tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',paramtcb,paramlbl);
  977. paramtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  978. targetinfos[target_info.system]^.alignment.recordalignmin);
  979. { paramcount }
  980. paramtcb.emit_ord_const(paramst.symlist.count,u32inttype);
  981. for i:=0 to paramst.symlist.count-1 do
  982. begin
  983. if tsym(paramst.symlist[i]).typ<>paravarsym then
  984. Internalerror(2024103101);
  985. write_param(paramtcb,tparavarsym(paramst.symlist[i]));
  986. end;
  987. paramdef:=paramtcb.end_anonymous_record;
  988. tcb.finish_internal_data_builder(paramtcb,paramlbl,paramdef,sizeof(pint));
  989. tcb.emit_tai(tai_const.Create_sym(paramlbl),voidpointertype);
  990. end;
  991. function write_propinfo_data(tcb: ttai_typedconstbuilder; sym: tpropertysym): tdef;
  992. begin
  993. { we can only easily reuse defs if the property is not stored,
  994. because otherwise the rtti layout depends on how the "stored"
  995. is defined (field, indexed expression, virtual method, ...) }
  996. if not(ppo_stored in sym.propoptions) then
  997. propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(sym.realname))
  998. else
  999. propdefname:='';
  1000. { TPropInfo is a packed record (even on targets that require
  1001. alignment), but it starts aligned }
  1002. if addcomments then
  1003. if assigned(st.name) then
  1004. tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+' (class/rec: '+st.name^+')')
  1005. else
  1006. tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+'(anon)');
  1007. tcb.begin_anonymous_record(
  1008. propdefname,
  1009. 1,min(reqalign,SizeOf(PInt)),
  1010. targetinfos[target_info.system]^.alignment.recordalignmin);
  1011. if ppo_indexed in sym.propoptions then
  1012. proctypesinfo:=$40
  1013. else
  1014. proctypesinfo:=0;
  1015. if addcomments then
  1016. tcb.emit_comment(#9'type info '+sym.Name+' (Type: '+sym.propdef.GetTypeName+')');
  1017. write_rtti_reference(tcb,sym.propdef,fullrtti);
  1018. if addcomments then
  1019. tcb.emit_comment(#9'read access');
  1020. writeaccessproc(tcb,palt_read,0,0);
  1021. if addcomments then
  1022. tcb.emit_comment(#9'write access');
  1023. writeaccessproc(tcb,palt_write,2,0);
  1024. { is it stored ? }
  1025. if addcomments then
  1026. tcb.emit_comment(#9'stored ?');
  1027. if not(ppo_stored in sym.propoptions) then
  1028. begin
  1029. { no, so put a constant zero }
  1030. tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype);
  1031. proctypesinfo:=proctypesinfo or (3 shl 4);
  1032. end
  1033. else
  1034. writeaccessproc(tcb,palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
  1035. if addcomments then
  1036. tcb.emit_comment(#9'Index');
  1037. tcb.emit_ord_const(sym.index,u32inttype);
  1038. if addcomments then
  1039. tcb.emit_comment(#9'default');
  1040. tcb.emit_ord_const(sym.default,u32inttype);
  1041. propnameitem:=TPropNameListItem(propnamelist.Find(sym.name));
  1042. if not assigned(propnameitem) then
  1043. internalerror(200512201);
  1044. if addcomments then
  1045. tcb.emit_comment(#9'property index');
  1046. tcb.emit_ord_const(propnameitem.propindex,u16inttype);
  1047. if addcomments then
  1048. tcb.emit_comment(#9'proc types');
  1049. tcb.emit_ord_const(proctypesinfo,u8inttype);
  1050. if addcomments then
  1051. tcb.emit_comment(#9'is static prop');
  1052. tcb.emit_ord_const(ord(sp_static in sym.symoptions),pasbool1type);
  1053. { index parameters }
  1054. if addcomments then
  1055. tcb.emit_comment(#9'indexed params');
  1056. if extended_rtti and assigned(tpropertysym(sym).parast) then
  1057. write_prop_params(tcb,sym.parast)
  1058. else
  1059. tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype);
  1060. { write reference to attribute table }
  1061. if addcomments then
  1062. tcb.emit_comment(#9'attributes');
  1063. write_attribute_data(tcb,sym.rtti_attribute_list);
  1064. { write property name }
  1065. if addcomments then
  1066. tcb.emit_comment(#9'name');
  1067. tcb.emit_shortstring_const(sym.realname);
  1068. result:=tcb.end_anonymous_record;
  1069. if addcomments then
  1070. tcb.emit_comment('RTTI: End propinfo record '+sym.realname);
  1071. end;
  1072. begin
  1073. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1074. targetinfos[target_info.system]^.alignment.recordalignmin);
  1075. if extended_rtti then
  1076. maybe_add_comment(tcb,'RTTI: Extended property data: Property count')
  1077. else
  1078. maybe_add_comment(tcb,'RTTI: Legacy property data: Property count');
  1079. tcb.emit_ord_const(properties_count(st),u16inttype);
  1080. for i:=0 to st.SymList.Count-1 do
  1081. begin
  1082. sym:=tsym(st.SymList[i]);
  1083. if (sym.typ=propertysym) and
  1084. (sym.visibility in visibilities) and
  1085. (extended_rtti or (tpropertysym(sym).parast=Nil)) then
  1086. begin
  1087. if extended_rtti then
  1088. begin
  1089. {
  1090. TPropInfoEx = record
  1091. Flags: Byte;
  1092. Info: PPropInfo;
  1093. // AttrData: TAttrData
  1094. end;
  1095. }
  1096. maybe_add_comment(tcb,'RTTI: begin property '+sym.prettyname);
  1097. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1098. targetinfos[target_info.system]^.alignment.recordalignmin);
  1099. { write visiblity flags for extended RTTI }
  1100. maybe_add_comment(tcb,#9'visibility flags');
  1101. visbyte:=byte(visibility_to_rtti_flags(sym.visibility));
  1102. tcb.emit_ord_const(visByte,u8inttype);
  1103. { create separate constant builder }
  1104. current_asmdata.getglobaldatalabel(tbllab);
  1105. tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  1106. { write TPropInfo record }
  1107. tbldef:=write_propinfo_data(tbltcb,tpropertysym(sym));
  1108. current_asmdata.asmlists[al_rtti].concatlist(
  1109. tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
  1110. );
  1111. tbltcb.free;
  1112. tbltcb := nil;
  1113. { write the pointer to the prop info }
  1114. maybe_add_comment(tcb,#9'property info reference');
  1115. tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
  1116. { end record }
  1117. tcb.end_anonymous_record;
  1118. maybe_add_comment(tcb,'RTTI: end property '+sym.prettyname);
  1119. end
  1120. else if not (sp_static in sym.symoptions) then
  1121. write_propinfo_data(tcb,tpropertysym(sym));
  1122. end;
  1123. end;
  1124. tcb.end_anonymous_record;
  1125. end;
  1126. procedure TRTTIWriter.write_rtti_data(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  1127. procedure unknown_rtti(def:tstoreddef);
  1128. begin
  1129. tcb.emit_ord_const(tkUnknown,u8inttype);
  1130. write_rtti_name(tcb,def);
  1131. write_common_rtti_data(tcb,def,rt);
  1132. end;
  1133. procedure variantdef_rtti(def:tvariantdef);
  1134. begin
  1135. write_header(tcb,def,tkVariant);
  1136. write_common_rtti_data(tcb,def,rt);
  1137. end;
  1138. procedure stringdef_rtti(def:tstringdef);
  1139. const
  1140. string_typekinds: array[tstringtype] of byte = (
  1141. tkSString,tkLString,tkAString,tkWString,tkUString
  1142. );
  1143. begin
  1144. write_header(tcb,def,string_typekinds[def.stringtype]);
  1145. tcb.begin_anonymous_record(
  1146. internaltypeprefixName[itp_rtti_outer]+tostr(string_typekinds[def.stringtype]),
  1147. defaultpacking,reqalign,
  1148. targetinfos[target_info.system]^.alignment.recordalignmin);
  1149. write_common_rtti_data(tcb,def,rt);
  1150. case def.stringtype of
  1151. st_ansistring:
  1152. begin
  1153. tcb.begin_anonymous_record(
  1154. internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]),
  1155. defaultpacking,reqalign,
  1156. targetinfos[target_info.system]^.alignment.recordalignmin);
  1157. tcb.emit_ord_const(def.encoding,u16inttype);
  1158. tcb.end_anonymous_record;
  1159. end;
  1160. st_shortstring:
  1161. begin
  1162. tcb.begin_anonymous_record(
  1163. internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]),
  1164. defaultpacking,reqalign,
  1165. targetinfos[target_info.system]^.alignment.recordalignmin);
  1166. tcb.emit_ord_const(def.len,u8inttype);
  1167. tcb.end_anonymous_record;
  1168. end;
  1169. st_widestring,
  1170. st_unicodestring,
  1171. st_longstring:
  1172. { nothing }
  1173. ;
  1174. end;
  1175. tcb.end_anonymous_record;
  1176. end;
  1177. procedure enumdef_rtti(def: tenumdef);
  1178. var
  1179. i : integer;
  1180. hp : tenumsym;
  1181. begin
  1182. write_header(tcb,def,tkEnumeration);
  1183. { align; the named fields are so that we can let the compiler
  1184. calculate the string offsets later on }
  1185. tcb.next_field_name:='size_start_rec';
  1186. { add a typename so that it can be reused when writing the the s2o
  1187. and o2s arrays for llvm (otherwise we have to write out the entire
  1188. type definition every time we access an element from this record) }
  1189. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec]+def.unique_id_str,defaultpacking,reqalign,
  1190. targetinfos[target_info.system]^.alignment.recordalignmin);
  1191. write_common_rtti_data(tcb,def,rt);
  1192. tcb.next_field_name:='typ_union_rec';
  1193. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec2]+def.unique_id_str,defaultpacking,reqalign,
  1194. targetinfos[target_info.system]^.alignment.recordalignmin);
  1195. case longint(def.size) of
  1196. 1 :
  1197. tcb.emit_ord_const(otUByte,u8inttype);
  1198. 2 :
  1199. tcb.emit_ord_const(otUWord,u8inttype);
  1200. 4 :
  1201. tcb.emit_ord_const(otULong,u8inttype);
  1202. end;
  1203. { we need to align by Tconstptruint here to satisfy the alignment
  1204. rules set by records: in the typinfo unit we overlay a TTypeData
  1205. record on this data, which at the innermost variant record needs an
  1206. alignment of TConstPtrUint due to e.g. the "CompType" member for
  1207. tkSet (also the "BaseType" member for tkEnumeration).
  1208. We need to adhere to this, otherwise things will break. }
  1209. tcb.next_field_name:='min_max_rec';
  1210. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_min_max_rec]+def.unique_id_str,defaultpacking,reqalign,
  1211. targetinfos[target_info.system]^.alignment.recordalignmin);
  1212. tcb.emit_ord_const(def.min,s32inttype);
  1213. tcb.emit_ord_const(def.max,s32inttype);
  1214. tcb.next_field_name:='basetype_array_rec';
  1215. { all strings must appear right after each other -> from now on
  1216. packrecords 1 (but the start must still be aligned) }
  1217. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_basetype_array_rec]+def.unique_id_str,1,reqalign,
  1218. targetinfos[target_info.system]^.alignment.recordalignmin);
  1219. { write base type }
  1220. write_rtti_reference(tcb,def.basedef,rt);
  1221. for i:=0 to def.symtable.SymList.Count-1 do
  1222. begin
  1223. hp:=tenumsym(def.symtable.SymList[i]);
  1224. if hp.value<def.minval then
  1225. continue
  1226. else
  1227. if hp.value>def.maxval then
  1228. break;
  1229. tcb.next_field_name:=hp.name;
  1230. tcb.emit_shortstring_const(hp.realname);
  1231. end;
  1232. { write unit name }
  1233. tcb.emit_shortstring_const(current_module.realmodulename^);
  1234. { write zero which is required by RTL }
  1235. tcb.emit_ord_const(0,u8inttype);
  1236. { terminate all records }
  1237. tcb.end_anonymous_record;
  1238. tcb.end_anonymous_record;
  1239. tcb.end_anonymous_record;
  1240. tcb.end_anonymous_record;
  1241. end;
  1242. procedure orddef_rtti(def:torddef);
  1243. procedure doint32_64(typekind: byte;min,max:int64);
  1244. const
  1245. trans : array[tordtype] of byte =
  1246. (otUByte{otNone},
  1247. otUByte,otUWord,otULong,otUQWord,otUByte{otNone},
  1248. otSByte,otSWord,otSLong,otSQWord,otUByte{otNone},
  1249. otUByte,otUByte,otUWord,otULong,otUQWord,
  1250. otSByte,otSWord,otSLong,otSQWord,
  1251. otUByte,otUWord,otUByte,255);
  1252. var
  1253. elesize: string[1];
  1254. deftrans: byte;
  1255. begin
  1256. write_header(tcb,def,typekind);
  1257. deftrans:=trans[def.ordtype];
  1258. case deftrans of
  1259. otUQWord,
  1260. otSQWord:
  1261. elesize:='8';
  1262. 255:
  1263. begin
  1264. if def.packedbitsize<=32 then
  1265. begin
  1266. elesize:='4';
  1267. if def.low<0 then
  1268. deftrans:=otSLong
  1269. else
  1270. deftrans:=otULong;
  1271. end
  1272. else
  1273. begin
  1274. elesize:='8';
  1275. if def.low<0 then
  1276. deftrans:=otSQWord
  1277. else
  1278. deftrans:=otUQWord;
  1279. end;
  1280. end
  1281. else
  1282. elesize:='4'
  1283. end;
  1284. tcb.begin_anonymous_record(
  1285. internaltypeprefixName[itp_rtti_ord_outer]+elesize,
  1286. defaultpacking,reqalign,
  1287. targetinfos[target_info.system]^.alignment.recordalignmin);
  1288. write_common_rtti_data(tcb,def,rt);
  1289. tcb.begin_anonymous_record(
  1290. internaltypeprefixName[itp_rtti_ord_middle]+elesize,
  1291. defaultpacking,reqalign,
  1292. targetinfos[target_info.system]^.alignment.recordalignmin);
  1293. tcb.emit_ord_const(byte(trans[def.ordtype]),u8inttype);
  1294. tcb.begin_anonymous_record(
  1295. internaltypeprefixName[itp_rtti_ord_inner]+elesize,
  1296. defaultpacking,reqalign,
  1297. targetinfos[target_info.system]^.alignment.recordalignmin);
  1298. {Convert to longint to smuggle values in high(longint)+1..high(cardinal) into asmlist.}
  1299. case deftrans of
  1300. otUQWord:
  1301. begin
  1302. tcb.emit_ord_const(min,u64inttype);
  1303. tcb.emit_ord_const(max,u64inttype);
  1304. end;
  1305. otSQWord:
  1306. begin
  1307. tcb.emit_ord_const(min,s64inttype);
  1308. tcb.emit_ord_const(max,s64inttype);
  1309. end;
  1310. else
  1311. begin
  1312. tcb.emit_ord_const(longint(min),s32inttype);
  1313. tcb.emit_ord_const(longint(max),s32inttype);
  1314. end;
  1315. end;
  1316. tcb.end_anonymous_record;
  1317. tcb.end_anonymous_record;
  1318. tcb.end_anonymous_record;
  1319. end;
  1320. procedure dointeger(typekind:byte);inline;
  1321. begin
  1322. doint32_64(typekind,int64(def.low.svalue),int64(def.high.svalue));
  1323. end;
  1324. begin
  1325. case def.ordtype of
  1326. s64bit :
  1327. dointeger(tkInt64);
  1328. u64bit :
  1329. dointeger(tkQWord);
  1330. pasbool1,
  1331. pasbool8,
  1332. pasbool16,
  1333. pasbool32,
  1334. pasbool64:
  1335. dointeger(tkBool);
  1336. { use different low/high values to be Delphi compatible }
  1337. bool8bit,
  1338. bool16bit,
  1339. bool32bit:
  1340. doint32_64(tkBool,longint(low(longint)),longint(high(longint)));
  1341. bool64bit:
  1342. doint32_64(tkBool,low(int64),high(int64));
  1343. uchar:
  1344. dointeger(tkChar);
  1345. uwidechar:
  1346. dointeger(tkWChar);
  1347. scurrency:
  1348. begin
  1349. write_header(tcb,def,tkFloat);
  1350. tcb.begin_anonymous_record(
  1351. internaltypeprefixName[itp_1byte],
  1352. defaultpacking,reqalign,
  1353. targetinfos[target_info.system]^.alignment.recordalignmin);
  1354. write_common_rtti_data(tcb,def,rt);
  1355. tcb.emit_ord_const(ftCurr,u8inttype);
  1356. tcb.end_anonymous_record;
  1357. end;
  1358. else
  1359. dointeger(tkInteger);
  1360. end;
  1361. end;
  1362. procedure floatdef_rtti(def:tfloatdef);
  1363. const
  1364. {tfloattype = (s32real,s64real,s80real,sc80real,s64bit,s128bit);}
  1365. translate : array[tfloattype] of byte =
  1366. (ftSingle,ftDouble,ftExtended,ftExtended,ftComp,ftCurr,ftFloat128);
  1367. begin
  1368. write_header(tcb,def,tkFloat);
  1369. tcb.begin_anonymous_record(
  1370. internaltypeprefixName[itp_1byte],
  1371. defaultpacking,reqalign,
  1372. targetinfos[target_info.system]^.alignment.recordalignmin);
  1373. write_common_rtti_data(tcb,def,rt);
  1374. tcb.begin_anonymous_record(
  1375. internaltypeprefixName[itp_rtti_float],
  1376. defaultpacking,reqalign,
  1377. targetinfos[target_info.system]^.alignment.recordalignmin);
  1378. tcb.emit_ord_const(translate[def.floattype],u8inttype);
  1379. tcb.end_anonymous_record;
  1380. tcb.end_anonymous_record;
  1381. end;
  1382. procedure setdef_rtti(def:tsetdef);
  1383. begin
  1384. write_header(tcb,def,tkSet);
  1385. tcb.begin_anonymous_record(
  1386. internaltypeprefixName[itp_rtti_set_outer],
  1387. defaultpacking,reqalign,
  1388. targetinfos[target_info.system]^.alignment.recordalignmin);
  1389. write_common_rtti_data(tcb,def,rt);
  1390. tcb.begin_anonymous_record(
  1391. internaltypeprefixName[itp_rtti_set_middle],
  1392. defaultpacking,reqalign,
  1393. targetinfos[target_info.system]^.alignment.recordalignmin);
  1394. case def.size of
  1395. 1:
  1396. tcb.emit_ord_const(otUByte,u8inttype);
  1397. 2:
  1398. tcb.emit_ord_const(otUWord,u8inttype);
  1399. 4:
  1400. tcb.emit_ord_const(otULong,u8inttype);
  1401. else
  1402. tcb.emit_ord_const(otUByte,u8inttype);
  1403. end;
  1404. tcb.begin_anonymous_record(
  1405. internaltypeprefixName[itp_rtti_set_inner],
  1406. defaultpacking,reqalign,
  1407. targetinfos[target_info.system]^.alignment.recordalignmin);
  1408. tcb.emit_ord_const(def.size,sizesinttype);
  1409. write_rtti_reference(tcb,def.elementdef,rt);
  1410. tcb.end_anonymous_record;
  1411. tcb.end_anonymous_record;
  1412. tcb.end_anonymous_record;
  1413. end;
  1414. procedure arraydef_rtti(def:tarraydef);
  1415. var
  1416. i,dimcount: byte;
  1417. totalcount: asizeuint;
  1418. finaldef: tdef;
  1419. curdef:tarraydef;
  1420. begin
  1421. if ado_IsDynamicArray in def.arrayoptions then
  1422. tcb.emit_ord_const(tkDynArray,u8inttype)
  1423. else
  1424. tcb.emit_ord_const(tkArray,u8inttype);
  1425. write_rtti_name(tcb,def);
  1426. if not(ado_IsDynamicArray in def.arrayoptions) then
  1427. begin
  1428. { remember tha last instruction. we will need to insert some
  1429. calculated values after it }
  1430. finaldef:=def;
  1431. totalcount:=1;
  1432. dimcount:=0;
  1433. repeat
  1434. curdef:=tarraydef(finaldef);
  1435. finaldef:=curdef.elementdef;
  1436. { Dims[i] PTypeInfo }
  1437. inc(dimcount);
  1438. totalcount:=totalcount*curdef.elecount;
  1439. until (finaldef.typ<>arraydef) or
  1440. (ado_IsDynamicArray in tarraydef(finaldef).arrayoptions);
  1441. tcb.begin_anonymous_record(
  1442. internaltypeprefixName[itp_rtti_normal_array]+tostr(dimcount),
  1443. defaultpacking,reqalign,
  1444. targetinfos[target_info.system]^.alignment.recordalignmin);
  1445. write_common_rtti_data(tcb,def,rt);
  1446. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_normal_array_inner]+tostr(dimcount),
  1447. defaultpacking,reqalign,
  1448. targetinfos[target_info.system]^.alignment.recordalignmin);
  1449. { total size = elecount * elesize of the first arraydef }
  1450. tcb.emit_tai(Tai_const.Create_sizeint(def.elecount*def.elesize),sizeuinttype);
  1451. { total element count }
  1452. tcb.emit_tai(Tai_const.Create_sizeint(asizeint(totalcount)),sizeuinttype);
  1453. { last dimension element type }
  1454. if is_objc_class_or_protocol(curdef.elementdef) then
  1455. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(voidpointertype,rt,true)),voidpointertype)
  1456. else
  1457. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(curdef.elementdef,rt,true)),voidpointertype);
  1458. { dimension count }
  1459. tcb.emit_ord_const(dimcount,u8inttype);
  1460. finaldef:=def;
  1461. { ranges of the dimensions }
  1462. for i:=1 to dimcount do
  1463. begin
  1464. curdef:=tarraydef(finaldef);
  1465. finaldef:=curdef.elementdef;
  1466. { Dims[i] PPTypeInfo }
  1467. write_rtti_reference(tcb,curdef.rangedef,rt);
  1468. end;
  1469. end
  1470. else
  1471. { write a delphi almost compatible dyn. array entry:
  1472. there are two types, eltype and eltype2, the latter is nil if the element type needs
  1473. no finalization, the former is always valid, delphi has this swapped, but for
  1474. compatibility with older fpc versions we do it different, to be delphi compatible,
  1475. the names are swapped in typinfo.pp
  1476. }
  1477. begin
  1478. tcb.begin_anonymous_record(
  1479. internaltypeprefixName[itp_rtti_dyn_array],
  1480. defaultpacking,reqalign,
  1481. targetinfos[target_info.system]^.alignment.recordalignmin);
  1482. write_common_rtti_data(tcb,def,rt);
  1483. { record in TypInfo is aligned differently from init rtti }
  1484. tcb.begin_anonymous_record(
  1485. internaltypeprefixName[itp_rtti_dyn_array_inner],
  1486. defaultpacking,reqalign,
  1487. targetinfos[target_info.system]^.alignment.recordalignmin);
  1488. { size of elements }
  1489. tcb.emit_tai(Tai_const.Create_sizeint(def.elesize),sizeuinttype);
  1490. { element type }
  1491. write_rtti_reference(tcb,def.elementdef,rt);
  1492. { variant type }
  1493. tcb.emit_ord_const(tstoreddef(def.elementdef).getvardef,s32inttype);
  1494. { element type }
  1495. if def.elementdef.needs_inittable then
  1496. write_rtti_reference(tcb,def.elementdef,rt)
  1497. else
  1498. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1499. { write unit name }
  1500. tcb.emit_shortstring_const(current_module.realmodulename^);
  1501. end;
  1502. tcb.end_anonymous_record;
  1503. tcb.end_anonymous_record;
  1504. end;
  1505. procedure classrefdef_rtti(def:tclassrefdef);
  1506. begin
  1507. write_header(tcb,def,tkClassRef);
  1508. tcb.begin_anonymous_record(
  1509. internaltypeprefixName[itp_rtti_ref],
  1510. defaultpacking,reqalign,
  1511. targetinfos[target_info.system]^.alignment.recordalignmin);
  1512. write_common_rtti_data(tcb,def,rt);
  1513. tcb.begin_anonymous_record(
  1514. internaltypeprefixName[itp_rtti_classref],
  1515. defaultpacking,reqalign,
  1516. targetinfos[target_info.system]^.alignment.recordalignmin);
  1517. write_rtti_reference(tcb,def.pointeddef,rt);
  1518. tcb.end_anonymous_record;
  1519. tcb.end_anonymous_record;
  1520. end;
  1521. procedure pointerdef_rtti(def:tpointerdef);
  1522. begin
  1523. write_header(tcb,def,tkPointer);
  1524. tcb.begin_anonymous_record(
  1525. internaltypeprefixName[itp_rtti_ref],
  1526. defaultpacking,reqalign,
  1527. targetinfos[target_info.system]^.alignment.recordalignmin);
  1528. write_common_rtti_data(tcb,def,rt);
  1529. tcb.begin_anonymous_record(
  1530. internaltypeprefixName[itp_rtti_pointer],
  1531. defaultpacking,reqalign,
  1532. targetinfos[target_info.system]^.alignment.recordalignmin);
  1533. write_rtti_reference(tcb,def.pointeddef,rt);
  1534. tcb.end_anonymous_record;
  1535. tcb.end_anonymous_record;
  1536. end;
  1537. procedure recorddef_rtti(def:trecorddef);
  1538. procedure write_record_operators(rttilab:tasmlabel);
  1539. var
  1540. rttidef: tdef;
  1541. tcb: ttai_typedconstbuilder;
  1542. mop: tmanagementoperator;
  1543. procdef: tprocdef;
  1544. begin
  1545. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
  1546. tcb.begin_anonymous_record(
  1547. '',
  1548. defaultpacking,min(reqalign,SizeOf(PInt)),
  1549. targetinfos[target_info.system]^.alignment.recordalignmin
  1550. );
  1551. { use "succ" to omit first enum item "mop_none" }
  1552. for mop := succ(low(tmanagementoperator)) to high(tmanagementoperator) do
  1553. begin
  1554. if not (mop in trecordsymtable(def.symtable).managementoperators) then
  1555. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype)
  1556. else
  1557. begin
  1558. procdef := search_management_operator(mop, def);
  1559. if procdef = nil then
  1560. internalerror(201603021)
  1561. else
  1562. tcb.emit_tai(Tai_const.Createname(procdef.mangledname,AT_FUNCTION,0),
  1563. cprocvardef.getreusableprocaddr(procdef,pc_address_only));
  1564. end;
  1565. end;
  1566. rttidef := tcb.end_anonymous_record;
  1567. current_asmdata.AsmLists[al_rtti].concatList(
  1568. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,
  1569. sizeof(PInt)));
  1570. tcb.free;
  1571. tcb := nil;
  1572. end;
  1573. procedure write_extended_property_table;
  1574. var
  1575. propnamelist: TFPHashObjectList;
  1576. visibilities: tvisibilities;
  1577. begin
  1578. propnamelist:=TFPHashObjectList.Create;
  1579. visibilities:=def.rtti_visibilities_for_option(ro_properties);
  1580. collect_propnamelist(propnamelist,def,visibilities);
  1581. properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
  1582. propnamelist.free;
  1583. propnamelist := nil;
  1584. end;
  1585. var
  1586. oplab : tasmlabel;
  1587. begin
  1588. write_header(tcb,def,tkRecord);
  1589. { need extra reqalign record, because otherwise the u32 int will
  1590. only be aligned to 4 even on 64 bit target (while the rtti code
  1591. in typinfo expects alignments to sizeof(pointer)) }
  1592. tcb.begin_anonymous_record('',
  1593. defaultpacking,reqalign,
  1594. targetinfos[target_info.system]^.alignment.recordalignmin);
  1595. write_common_rtti_data(tcb,def,rt);
  1596. tcb.begin_anonymous_record('',
  1597. defaultpacking,reqalign,
  1598. targetinfos[target_info.system]^.alignment.recordalignmin);
  1599. { store special terminator for init table for more optimal rtl operations
  1600. strictly related to RecordRTTI procedure in rtti.inc (directly
  1601. related to RTTIRecordRttiInfoToInitInfo function) }
  1602. if rt=initrtti then
  1603. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1604. else
  1605. { we use a direct reference as the init RTTI is always in the same
  1606. unit as the full RTTI }
  1607. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype);
  1608. tcb.emit_ord_const(def.size,u32inttype);
  1609. oplab:=nil;
  1610. { store rtti management operators only for init table }
  1611. if rt=initrtti then
  1612. begin
  1613. { for now records don't have the initializer table }
  1614. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1615. if (trecordsymtable(def.symtable).managementoperators=[]) then
  1616. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1617. else
  1618. begin
  1619. current_asmdata.getlocaldatalabel(oplab);
  1620. tcb.emit_tai(Tai_const.Createname(
  1621. oplab.name,
  1622. AT_DATA_FORCEINDIRECT,0),voidpointertype);
  1623. end;
  1624. end;
  1625. fields_write_rtti_data(tcb,def,rt);
  1626. { write extended rtti }
  1627. if rt=fullrtti then
  1628. begin
  1629. write_extended_field_table(tcb,def,defaultpacking);
  1630. write_extended_method_table(tcb,def,defaultpacking);
  1631. write_extended_property_table;
  1632. end;
  1633. tcb.end_anonymous_record;
  1634. tcb.end_anonymous_record;
  1635. { write pointers to operators if needed }
  1636. if (rt=initrtti) and (trecordsymtable(def.symtable).managementoperators<>[]) then
  1637. write_record_operators(oplab);
  1638. end;
  1639. procedure procvardef_rtti(def:tprocvardef);
  1640. procedure write_para(parasym:tparavarsym);
  1641. begin
  1642. { write flags for current parameter }
  1643. write_param_flag(tcb,parasym);
  1644. { write name of current parameter }
  1645. tcb.emit_shortstring_const(parasym.realname);
  1646. { write name of type of current parameter }
  1647. write_rtti_name(tcb,parasym.vardef);
  1648. end;
  1649. procedure write_procedure_param(parasym:tparavarsym);
  1650. begin
  1651. { every parameter is expected to start aligned }
  1652. tcb.begin_anonymous_record(
  1653. internaltypeprefixName[itp_rtti_proc_param]+tostr(length(parasym.realname)),
  1654. defaultpacking,min(reqalign,SizeOf(PInt)),
  1655. targetinfos[target_info.system]^.alignment.recordalignmin);
  1656. { write flags for current parameter }
  1657. write_param_flag(tcb,parasym);
  1658. { write param type }
  1659. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  1660. write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti)
  1661. else if parasym.vardef=cformaltype then
  1662. write_rtti_reference(tcb,nil,fullrtti)
  1663. else
  1664. write_rtti_reference(tcb,parasym.vardef,fullrtti);
  1665. { write name of current parameter }
  1666. tcb.emit_shortstring_const(parasym.realname);
  1667. tcb.end_anonymous_record;
  1668. end;
  1669. var
  1670. methodkind : byte;
  1671. i : integer;
  1672. begin
  1673. if po_methodpointer in def.procoptions then
  1674. begin
  1675. { write method id and name }
  1676. write_header(tcb,def,tkMethod);
  1677. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1678. targetinfos[target_info.system]^.alignment.recordalignmin);
  1679. write_common_rtti_data(tcb,def,rt);
  1680. tcb.begin_anonymous_record('',
  1681. defaultpacking,reqalign,
  1682. targetinfos[target_info.system]^.alignment.recordalignmin);
  1683. { write kind of method }
  1684. methodkind:=write_methodkind(tcb,def);
  1685. { write parameter info. The parameters must be written in reverse order
  1686. if this method uses right to left parameter pushing! }
  1687. tcb.emit_ord_const(def.paras.count,u8inttype);
  1688. for i:=0 to def.paras.count-1 do
  1689. write_para(tparavarsym(def.paras[i]));
  1690. if (methodkind=mkFunction) or (methodkind=mkClassFunction) then
  1691. begin
  1692. { write name of result type }
  1693. write_rtti_name(tcb,def.returndef);
  1694. { enclosing record takes care of alignment }
  1695. { write result typeinfo }
  1696. write_rtti_reference(tcb,def.returndef,fullrtti);
  1697. end;
  1698. { write calling convention }
  1699. write_callconv(tcb,def);
  1700. { enclosing record takes care of alignment }
  1701. { write params typeinfo }
  1702. for i:=0 to def.paras.count-1 do
  1703. begin
  1704. if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then
  1705. write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti)
  1706. else if tparavarsym(def.paras[i]).vardef=cformaltype then
  1707. write_rtti_reference(tcb,nil,fullrtti)
  1708. else
  1709. write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti);
  1710. end;
  1711. tcb.end_anonymous_record;
  1712. tcb.end_anonymous_record;
  1713. end
  1714. else
  1715. begin
  1716. write_header(tcb,def,tkProcvar);
  1717. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1718. targetinfos[target_info.system]^.alignment.recordalignmin);
  1719. write_common_rtti_data(tcb,def,rt);
  1720. tcb.begin_anonymous_record('',
  1721. defaultpacking,reqalign,
  1722. targetinfos[target_info.system]^.alignment.recordalignmin);
  1723. { flags }
  1724. tcb.emit_ord_const(0,u8inttype);
  1725. { write calling convention }
  1726. write_callconv(tcb,def);
  1727. { enclosing record takes care of alignment }
  1728. { write result typeinfo }
  1729. write_rtti_reference(tcb,def.returndef,fullrtti);
  1730. { write parameter count }
  1731. tcb.emit_ord_const(def.paras.count,u8inttype);
  1732. for i:=0 to def.paras.count-1 do
  1733. write_procedure_param(tparavarsym(def.paras[i]));
  1734. tcb.end_anonymous_record;
  1735. tcb.end_anonymous_record;
  1736. end;
  1737. end;
  1738. procedure objectdef_rtti(def: tobjectdef);
  1739. procedure objectdef_rtti_fields(def:tobjectdef);
  1740. begin
  1741. maybe_add_comment(tcb,'RTTI begin fields '+def.objname^);
  1742. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1743. targetinfos[target_info.system]^.alignment.recordalignmin);
  1744. { - for compatiblity with record RTTI we need to write a terminator-
  1745. Nil pointer for initrtti as well for objects
  1746. - for RTTI consistency for objects we need point from fullrtti
  1747. to initrtti
  1748. - classes are assumed to have the same INIT RTTI as records
  1749. (see TObject.CleanupInstance)
  1750. - neither helper nor class type have fullrtti for fields
  1751. }
  1752. if (rt=initrtti) then
  1753. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1754. else
  1755. if (def.objecttype=odt_object) then
  1756. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype)
  1757. else
  1758. internalerror(2017011801);
  1759. tcb.emit_ord_const(def.size, u32inttype);
  1760. { pointer to management operators available only for initrtti }
  1761. if (rt=initrtti) then
  1762. begin
  1763. { initializer table only available for classes currently }
  1764. if def.objecttype=odt_class then
  1765. write_mop_offset_table(tcb,def,mop_initialize)
  1766. else
  1767. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1768. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1769. end;
  1770. { enclosing record takes care of alignment }
  1771. fields_write_rtti_data(tcb,def,rt);
  1772. tcb.end_anonymous_record;
  1773. maybe_add_comment(tcb,'RTTI end fields '+def.objname^);
  1774. end;
  1775. procedure objectdef_rtti_interface_init(def:tobjectdef);
  1776. begin
  1777. tcb.emit_ord_const(def.size, u32inttype);
  1778. end;
  1779. procedure objectdef_extended_rtti_class(def:tobjectdef);
  1780. var
  1781. propnamelist : TFPHashObjectList;
  1782. visibilities : tvisibilities;
  1783. begin
  1784. propnamelist:=TFPHashObjectList.Create;
  1785. visibilities:=def.rtti_visibilities_for_option(ro_properties);
  1786. collect_propnamelist(propnamelist,def,visibilities);
  1787. properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities);
  1788. propnamelist.free;
  1789. propnamelist := nil;
  1790. end;
  1791. procedure objectdef_rtti_class_full(def:tobjectdef);
  1792. var
  1793. propnamelist : TFPHashObjectList;
  1794. begin
  1795. { Collect unique property names with nameindex }
  1796. propnamelist:=TFPHashObjectList.Create;
  1797. collect_propnamelist(propnamelist,def,[vis_published]);
  1798. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1799. targetinfos[target_info.system]^.alignment.recordalignmin);
  1800. if not is_objectpascal_helper(def) then
  1801. begin
  1802. maybe_add_comment(tcb,#9'Parent type info');
  1803. if (oo_has_vmt in def.objectoptions) then
  1804. tcb.emit_tai(
  1805. Tai_const.Createname(def.vmt_mangledname,AT_DATA_FORCEINDIRECT,0),
  1806. cpointerdef.getreusable(def.vmt_def))
  1807. else
  1808. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1809. end;
  1810. { write parent typeinfo }
  1811. maybe_add_comment(tcb,#9'Parent type info');
  1812. write_rtti_reference(tcb,def.childof,fullrtti);
  1813. { write typeinfo of extended type }
  1814. if is_objectpascal_helper(def) then
  1815. if assigned(def.extendeddef) then
  1816. begin
  1817. maybe_add_comment(tcb,#9'helper for type info');
  1818. write_rtti_reference(tcb,def.extendeddef,fullrtti)
  1819. end
  1820. else
  1821. InternalError(2011033001);
  1822. { total number of unique properties }
  1823. maybe_add_comment(tcb,#9'Number of properties');
  1824. tcb.emit_ord_const(propnamelist.count,u16inttype);
  1825. { write unit name }
  1826. maybe_add_comment(tcb, #9'Unit name');
  1827. tcb.emit_shortstring_const(current_module.realmodulename^);
  1828. { write published properties for this object }
  1829. properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
  1830. { write extended properties }
  1831. objectdef_extended_rtti_class(def);
  1832. tcb.end_anonymous_record;
  1833. propnamelist.free;
  1834. propnamelist := nil;
  1835. end;
  1836. procedure objectdef_rtti_interface_full(def:tobjectdef);
  1837. var
  1838. propnamelist : TFPHashObjectList;
  1839. { if changed to a set, make sure it's still a byte large, and
  1840. swap appropriately when cross-compiling
  1841. }
  1842. IntfFlags: byte;
  1843. begin
  1844. { Collect unique property names with nameindex }
  1845. propnamelist:=TFPHashObjectList.Create;
  1846. collect_propnamelist(propnamelist,def,[vis_published]);
  1847. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1848. targetinfos[target_info.system]^.alignment.recordalignmin);
  1849. { write parent typeinfo }
  1850. write_rtti_reference(tcb,def.childof,fullrtti);
  1851. { interface: write flags, iid and iidstr }
  1852. IntfFlags:=0;
  1853. if assigned(def.iidguid) then
  1854. IntfFlags:=IntfFlags or (1 shl ord(ifHasGuid));
  1855. if (def.objecttype=odt_interfacecorba) and (def.iidstr^<>'') then
  1856. IntfFlags:=IntfFlags or (1 shl ord(ifHasStrGUID));
  1857. if (def.objecttype=odt_dispinterface) then
  1858. IntfFlags:=IntfFlags or (1 shl ord(ifDispInterface));
  1859. if (target_info.endian=endian_big) then
  1860. IntfFlags:=reverse_byte(IntfFlags);
  1861. {
  1862. ifDispatch, }
  1863. tcb.emit_ord_const(IntfFlags,u8inttype);
  1864. { write GUID }
  1865. tcb.emit_guid_const(def.iidguid^);
  1866. { write hidden class reference - if it is nil, write_rtti_reference writes nil }
  1867. write_rtti_reference(tcb,def.hiddenclassdef,fullrtti);
  1868. { write unit name }
  1869. tcb.emit_shortstring_const(current_module.realmodulename^);
  1870. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1871. targetinfos[target_info.system]^.alignment.recordalignmin);
  1872. { write iidstr }
  1873. if def.objecttype=odt_interfacecorba then
  1874. begin
  1875. { prepareguid always allocates an empty string }
  1876. if not assigned(def.iidstr) then
  1877. internalerror(2016021901);
  1878. tcb.emit_shortstring_const(def.iidstr^)
  1879. end;
  1880. { write published properties for this object }
  1881. properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]);
  1882. { write published methods for this interface }
  1883. write_methods(tcb,def.symtable,false,[vis_published]);
  1884. tcb.end_anonymous_record;
  1885. tcb.end_anonymous_record;
  1886. propnamelist.free;
  1887. propnamelist := nil;
  1888. end;
  1889. begin
  1890. case def.objecttype of
  1891. odt_class:
  1892. tcb.emit_ord_const(tkclass,u8inttype);
  1893. odt_object:
  1894. tcb.emit_ord_const(tkobject,u8inttype);
  1895. odt_dispinterface,
  1896. odt_interfacecom:
  1897. tcb.emit_ord_const(tkInterface,u8inttype);
  1898. odt_interfacecorba:
  1899. tcb.emit_ord_const(tkinterfaceCorba,u8inttype);
  1900. odt_helper:
  1901. tcb.emit_ord_const(tkhelper,u8inttype);
  1902. else
  1903. internalerror(200611034);
  1904. end;
  1905. { generate the name }
  1906. tcb.emit_shortstring_const(def.objrealname^);
  1907. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1908. targetinfos[target_info.system]^.alignment.recordalignmin);
  1909. write_common_rtti_data(tcb,def,rt);
  1910. case rt of
  1911. initrtti :
  1912. begin
  1913. if def.objecttype in [odt_class,odt_object,odt_helper] then
  1914. objectdef_rtti_fields(def)
  1915. else
  1916. objectdef_rtti_interface_init(def);
  1917. end;
  1918. fullrtti :
  1919. begin
  1920. tcb.begin_anonymous_record('',
  1921. defaultpacking,reqalign,
  1922. targetinfos[target_info.system]^.alignment.recordalignmin);
  1923. case def.objecttype of
  1924. odt_helper,
  1925. odt_class:
  1926. objectdef_rtti_class_full(def);
  1927. odt_object:
  1928. objectdef_rtti_fields(def);
  1929. else
  1930. objectdef_rtti_interface_full(def);
  1931. end;
  1932. tcb.end_anonymous_record;
  1933. end;
  1934. else
  1935. ;
  1936. end;
  1937. tcb.end_anonymous_record;
  1938. end;
  1939. begin
  1940. case def.typ of
  1941. variantdef :
  1942. variantdef_rtti(tvariantdef(def));
  1943. stringdef :
  1944. stringdef_rtti(tstringdef(def));
  1945. enumdef :
  1946. enumdef_rtti(tenumdef(def));
  1947. orddef :
  1948. orddef_rtti(torddef(def));
  1949. floatdef :
  1950. floatdef_rtti(tfloatdef(def));
  1951. setdef :
  1952. setdef_rtti(tsetdef(def));
  1953. procvardef :
  1954. procvardef_rtti(tprocvardef(def));
  1955. arraydef :
  1956. begin
  1957. if ado_IsBitPacked in tarraydef(def).arrayoptions then
  1958. unknown_rtti(tstoreddef(def))
  1959. else
  1960. arraydef_rtti(tarraydef(def));
  1961. end;
  1962. recorddef :
  1963. begin
  1964. if trecorddef(def).is_packed then
  1965. unknown_rtti(tstoreddef(def))
  1966. else
  1967. recorddef_rtti(trecorddef(def));
  1968. end;
  1969. objectdef :
  1970. objectdef_rtti(tobjectdef(def));
  1971. classrefdef :
  1972. classrefdef_rtti(tclassrefdef(def));
  1973. pointerdef :
  1974. pointerdef_rtti(tpointerdef(def));
  1975. else
  1976. unknown_rtti(tstoreddef(def));
  1977. end;
  1978. end;
  1979. procedure TRTTIWriter.write_attribute_data(tcb:ttai_typedconstbuilder;attr_list:trtti_attribute_list);
  1980. procedure write_args(tbltcb:ttai_typedconstbuilder;attr:trtti_attribute);
  1981. var
  1982. argtcb : ttai_typedconstbuilder;
  1983. arglab : tasmlabel;
  1984. argdef : tdef;
  1985. i : sizeint;
  1986. begin
  1987. if length(attr.paras)=0 then
  1988. begin
  1989. tbltcb.emit_tai(tai_const.Create_16bit(0),u16inttype);
  1990. tbltcb.emit_tai(tai_const.Create_nil_dataptr,voidpointertype);
  1991. end
  1992. else
  1993. begin
  1994. current_asmdata.getglobaldatalabel(arglab);
  1995. argtcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  1996. argtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  1997. targetinfos[target_info.system]^.alignment.recordalignmin);
  1998. for i:=0 to High(attr.paras) do
  1999. begin
  2000. case attr.paras[i].nodetype of
  2001. niln,
  2002. ordconstn,
  2003. realconstn,
  2004. stringconstn,
  2005. pointerconstn,
  2006. guidconstn:
  2007. tconstnode(attr.paras[i]).emit_data(argtcb);
  2008. setconstn:
  2009. tsetconstnode(attr.paras[i]).emit_data(argtcb);
  2010. else
  2011. internalerror(2019070803);
  2012. end;
  2013. end;
  2014. argdef:=argtcb.end_anonymous_record;
  2015. current_asmdata.asmlists[al_rtti].concatlist(
  2016. argtcb.get_final_asmlist(arglab,argdef,sec_rodata,arglab.name,const_align(sizeof(pint)))
  2017. );
  2018. argtcb.free;
  2019. argtcb := nil;
  2020. { write argument size and the reference to the argument entry }
  2021. tbltcb.emit_ord_const(argdef.size,u16inttype);
  2022. tbltcb.emit_tai(Tai_const.Create_sym(arglab),voidpointertype);
  2023. end;
  2024. end;
  2025. var
  2026. count,i: word;
  2027. attr : trtti_attribute;
  2028. tbltcb : ttai_typedconstbuilder;
  2029. tbllab : tasmlabel;
  2030. tbldef : tdef;
  2031. begin
  2032. if assigned(attr_list) then
  2033. count:=attr_list.get_attribute_count
  2034. else
  2035. count:=0;
  2036. if count=0 then
  2037. begin
  2038. { write a Nil reference }
  2039. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  2040. exit;
  2041. end;
  2042. { first write the attribute list as a separate table }
  2043. current_asmdata.getglobaldatalabel(tbllab);
  2044. tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]);
  2045. tbltcb.begin_anonymous_record(
  2046. internaltypeprefixName[itp_rtti_attr_list]+tostr(count),
  2047. defaultpacking,min(reqalign,SizeOf(PInt)),
  2048. targetinfos[target_info.system]^.alignment.recordalignmin);
  2049. tbltcb.emit_ord_const(count,u16inttype);
  2050. for i:=0 to count-1 do
  2051. begin
  2052. tbltcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_attr_entry],defaultpacking,min(reqalign,SizeOf(PInt)),
  2053. targetinfos[target_info.system]^.alignment.recordalignmin);
  2054. attr:=trtti_attribute(attr_list.rtti_attributes[i]);
  2055. write_rtti_reference(tbltcb,ttypesym(attr.typesym).typedef,fullrtti);
  2056. tbltcb.emit_procdef_const(tprocdef(tcallnode(attr.constructorcall).procdefinition));
  2057. if not assigned(attr.constructorpd) then
  2058. internalerror(2019071004);
  2059. tbltcb.emit_procdef_const(tprocdef(attr.constructorpd));
  2060. write_args(tbltcb,attr);
  2061. tbltcb.end_anonymous_record;
  2062. end;
  2063. tbldef:=tbltcb.end_anonymous_record;
  2064. current_asmdata.asmlists[al_rtti].concatlist(
  2065. tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint)))
  2066. );
  2067. tbltcb.free;
  2068. tbltcb := nil;
  2069. { write the reference to the attribute table }
  2070. tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
  2071. end;
  2072. function enumsym_compare_name(item1, item2: pointer): Integer;
  2073. var
  2074. enum1: tenumsym absolute item1;
  2075. enum2: tenumsym absolute item2;
  2076. begin
  2077. if enum1=enum2 then
  2078. result:=0
  2079. else if enum1.name>enum2.name then
  2080. result:=1
  2081. else
  2082. { there can't be equal names, identifiers are unique }
  2083. result:=-1;
  2084. end;
  2085. function enumsym_compare_value(item1, item2: pointer): Integer;
  2086. var
  2087. enum1: tenumsym absolute item1;
  2088. enum2: tenumsym absolute item2;
  2089. begin
  2090. if enum1.value>enum2.value then
  2091. result:=1
  2092. else if enum1.value<enum2.value then
  2093. result:=-1
  2094. else
  2095. result:=0;
  2096. end;
  2097. procedure TRTTIWriter.write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  2098. type Penumsym = ^Tenumsym;
  2099. { Writes a helper table for accelerated conversion of ordinal enum values to strings.
  2100. If you change something in this method, make sure to adapt the corresponding code
  2101. in sstrings.inc. }
  2102. procedure enumdef_rtti_ord2stringindex(rttidef: trecorddef; const syms: tfplist);
  2103. var rttilab:Tasmsymbol;
  2104. h,i,o,prev_value:longint;
  2105. mode:(lookup,search); {Modify with care, ordinal value of enum is written.}
  2106. r:single; {Must be real type because of integer overflow risk.}
  2107. tcb: ttai_typedconstbuilder;
  2108. sym_count: integer;
  2109. tabledef: tdef;
  2110. begin
  2111. {Decide wether a lookup array is size efficient.}
  2112. mode:=lookup;
  2113. sym_count:=syms.count;
  2114. if sym_count>0 then
  2115. begin
  2116. i:=1;
  2117. r:=0;
  2118. h:=tenumsym(syms[0]).value; {Next expected enum value is min.}
  2119. { set prev_value for the first iteration to a value that is
  2120. different from the first one without risking overflow (it's used
  2121. to detect whether two enum values are the same) }
  2122. if h=0 then
  2123. prev_value:=1
  2124. else
  2125. prev_value:=0;
  2126. while i<sym_count do
  2127. begin
  2128. { if two enum values are the same, we have to create a table }
  2129. if (prev_value=h) then
  2130. begin
  2131. mode:=search;
  2132. break;
  2133. end;
  2134. {Calculate size of hole between values. Avoid integer overflows.}
  2135. r:=r+(single(tenumsym(syms[i]).value)-single(h))-1;
  2136. prev_value:=h;
  2137. h:=tenumsym(syms[i]).value;
  2138. inc(i);
  2139. end;
  2140. if r>sym_count then
  2141. mode:=search; {Don't waste more than 50% space.}
  2142. end;
  2143. { write rtti data; make sure that the alignment matches the corresponding data structure
  2144. in the code that uses it (if alignment is required). }
  2145. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2146. { use TConstPtrUInt packrecords to ensure good alignment }
  2147. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  2148. targetinfos[target_info.system]^.alignment.recordalignmin);
  2149. { now emit the data: first the mode }
  2150. tcb.emit_tai(Tai_const.create_32bit(longint(mode)),u32inttype);
  2151. { align }
  2152. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2153. targetinfos[target_info.system]^.alignment.recordalignmin);
  2154. if mode=lookup then
  2155. begin
  2156. o:=tenumsym(syms[0]).value; {Start with min value.}
  2157. for i:=0 to sym_count-1 do
  2158. begin
  2159. while o<tenumsym(syms[i]).value do
  2160. begin
  2161. tcb.emit_tai(Tai_const.create_nil_dataptr,ptruinttype);
  2162. inc(o);
  2163. end;
  2164. inc(o);
  2165. tcb.queue_init(voidpointertype);
  2166. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2167. ['size_start_rec',
  2168. 'typ_union_rec',
  2169. 'min_max_rec',
  2170. 'basetype_array_rec',
  2171. tsym(syms[i]).Name]
  2172. );
  2173. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2174. end;
  2175. end
  2176. else
  2177. begin
  2178. tcb.emit_ord_const(sym_count,u32inttype);
  2179. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2180. targetinfos[target_info.system]^.alignment.recordalignmin);
  2181. for i:=0 to sym_count-1 do
  2182. begin
  2183. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  2184. tcb.queue_init(voidpointertype);
  2185. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2186. ['size_start_rec',
  2187. 'typ_union_rec',
  2188. 'min_max_rec',
  2189. 'basetype_array_rec',
  2190. tsym(syms[i]).Name]
  2191. );
  2192. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2193. end;
  2194. tcb.end_anonymous_record;
  2195. end;
  2196. tcb.end_anonymous_record;
  2197. tabledef:=tcb.end_anonymous_record;
  2198. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_o2s',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  2199. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  2200. rttilab,tabledef,sec_rodata,
  2201. rttilab.name,sizeof(PInt)));
  2202. tcb.free;
  2203. tcb := nil;
  2204. current_module.add_public_asmsym(rttilab);
  2205. end;
  2206. { Writes a helper table for accelerated conversion of string to ordinal enum values.
  2207. If you change something in this method, make sure to adapt the corresponding code
  2208. in sstrings.inc. }
  2209. procedure enumdef_rtti_string2ordindex(rttidef: trecorddef; const syms: tfplist);
  2210. var
  2211. tcb: ttai_typedconstbuilder;
  2212. rttilab: Tasmsymbol;
  2213. i:longint;
  2214. tabledef: tdef;
  2215. begin
  2216. { write rtti data }
  2217. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2218. { begin of Tstring_to_ord }
  2219. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2220. targetinfos[target_info.system]^.alignment.recordalignmin);
  2221. tcb.emit_ord_const(syms.count,s32inttype);
  2222. { begin of "data" array in Tstring_to_ord }
  2223. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  2224. targetinfos[target_info.system]^.alignment.recordalignmin);
  2225. for i:=0 to syms.count-1 do
  2226. begin
  2227. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  2228. { alignment of pointer value handled by enclosing record already }
  2229. tcb.queue_init(voidpointertype);
  2230. tcb.queue_subscriptn_multiple_by_name(rttidef,
  2231. ['size_start_rec',
  2232. 'typ_union_rec',
  2233. 'min_max_rec',
  2234. 'basetype_array_rec',
  2235. tsym(syms[i]).Name]
  2236. );
  2237. tcb.queue_emit_asmsym(mainrtti,rttidef);
  2238. end;
  2239. tcb.end_anonymous_record;
  2240. tabledef:=tcb.end_anonymous_record;
  2241. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_s2o',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  2242. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  2243. rttilab,tabledef,sec_rodata,
  2244. rttilab.name,sizeof(PInt)));
  2245. tcb.free;
  2246. tcb := nil;
  2247. current_module.add_public_asmsym(rttilab);
  2248. end;
  2249. procedure enumdef_rtti_extrasyms(def:Tenumdef);
  2250. var
  2251. t:Tenumsym;
  2252. syms:tfplist;
  2253. i:longint;
  2254. rttitypesym: ttypesym;
  2255. rttidef: trecorddef;
  2256. s:TIDString;
  2257. begin
  2258. { collect enumsyms belonging to this enum type (could be a subsection
  2259. in case of a subrange type) }
  2260. syms:=tfplist.create;
  2261. for i := 0 to def.symtable.SymList.Count - 1 do
  2262. begin
  2263. t:=tenumsym(def.symtable.SymList[i]);
  2264. if t.value<def.minval then
  2265. continue
  2266. else
  2267. if t.value>def.maxval then
  2268. break;
  2269. syms.add(t);
  2270. end;
  2271. { sort the syms by enum name }
  2272. syms.sort(@enumsym_compare_name);
  2273. s:=internaltypeprefixName[itp_rttidef]+def.rtti_mangledname(fullrtti);
  2274. rttitypesym:=try_search_current_module_type(s);
  2275. if not assigned(rttitypesym) or
  2276. (ttypesym(rttitypesym).typedef.typ<>recorddef) then
  2277. internalerror(2015071402);
  2278. rttidef:=trecorddef(ttypesym(rttitypesym).typedef);
  2279. enumdef_rtti_string2ordindex(rttidef,syms);
  2280. { sort the syms by enum value }
  2281. syms.sort(@enumsym_compare_value);
  2282. enumdef_rtti_ord2stringindex(rttidef,syms);
  2283. syms.free;
  2284. syms := nil;
  2285. end;
  2286. begin
  2287. case def.typ of
  2288. enumdef:
  2289. if rt=fullrtti then
  2290. begin
  2291. enumdef_rtti_extrasyms(Tenumdef(def));
  2292. end;
  2293. else
  2294. ;
  2295. end;
  2296. end;
  2297. procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
  2298. begin
  2299. case def.typ of
  2300. enumdef :
  2301. if assigned(tenumdef(def).basedef) then
  2302. write_rtti(tenumdef(def).basedef,rt);
  2303. setdef :
  2304. write_rtti(tsetdef(def).elementdef,rt);
  2305. arraydef :
  2306. begin
  2307. write_rtti(tarraydef(def).rangedef,rt);
  2308. write_rtti(tarraydef(def).elementdef,rt);
  2309. end;
  2310. recorddef :
  2311. begin
  2312. { guarantee initrtti for any record for RTTI purposes
  2313. also for fpc_initialize, fpc_finalize }
  2314. if (rt=fullrtti) then
  2315. begin
  2316. include(def.defstates,ds_init_table_used);
  2317. write_rtti(def, initrtti);
  2318. end;
  2319. fields_write_rtti(trecorddef(def).symtable,rt);
  2320. end;
  2321. objectdef :
  2322. begin
  2323. if assigned(tobjectdef(def).childof) then
  2324. write_rtti(tobjectdef(def).childof,rt);
  2325. if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
  2326. fields_write_rtti(tobjectdef(def).symtable,rt)
  2327. else
  2328. published_write_rtti(tobjectdef(def),rt);
  2329. if (rt=fullrtti) then
  2330. begin
  2331. { guarantee initrtti for any object for RTTI purposes
  2332. also for fpc_initialize, fpc_finalize }
  2333. if (tobjectdef(def).objecttype=odt_object) then
  2334. begin
  2335. include(def.defstates,ds_init_table_used);
  2336. write_rtti(def,initrtti);
  2337. end;
  2338. if (is_interface(def) or is_dispinterface(def))
  2339. and (oo_can_have_published in tobjectdef(def).objectoptions) then
  2340. methods_write_rtti(tobjectdef(def).symtable,rt,[vis_published],true);
  2341. end;
  2342. end;
  2343. classrefdef,
  2344. pointerdef:
  2345. if not is_objc_class_or_protocol(tabstractpointerdef(def).pointeddef) then
  2346. write_rtti(tabstractpointerdef(def).pointeddef,rt);
  2347. procvardef:
  2348. params_write_rtti(tabstractprocdef(def),rt,false);
  2349. else
  2350. ;
  2351. end;
  2352. end;
  2353. procedure TRTTIWriter.write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  2354. begin
  2355. { we don't care about the real type here, because
  2356. a) we don't index into these elements
  2357. b) we may not have the rtti type available at the point that we
  2358. are emitting this data, because of forward definitions etc
  2359. c) if the rtti is emitted in another unit, we won't have the type
  2360. available at all
  2361. For the cases where the type is emitted in the current unit and hence
  2362. the underlying system will detect and complain about symbol def
  2363. mismatches, type conversions will have to be inserted afterwards (like
  2364. in llvm/llvmtype)
  2365. }
  2366. if not assigned(def) or is_void(def) or ((rt<>initrtti) and is_objc_class_or_protocol(def)) then
  2367. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  2368. else
  2369. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,rt,true)),voidpointertype);
  2370. end;
  2371. function TRTTIWriter.ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  2372. var
  2373. s : tsymstr;
  2374. begin
  2375. s:=def.rtti_mangledname(rt)+suffix;
  2376. result:=current_asmdata.RefAsmSymbol(s,AT_DATA,indirect);
  2377. if def.owner.moduleid<>current_module.moduleid then
  2378. current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA);
  2379. end;
  2380. procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype);
  2381. var
  2382. tcb: ttai_typedconstbuilder;
  2383. opts : ttcasmlistoptions;
  2384. rttilab: tasmsymbol;
  2385. rttidef: tdef;
  2386. s: TIDString;
  2387. begin
  2388. { Objective-C has its own RTTI system }
  2389. if is_objc_class_or_protocol(def) then
  2390. exit;
  2391. { only write rtti of definitions from the current module }
  2392. if not findunitsymtable(def.owner).iscurrentunit then
  2393. exit;
  2394. { check if separate initrtti is actually needed }
  2395. if (rt=initrtti) and (not def.needs_separate_initrtti) then
  2396. rt:=fullrtti;
  2397. { prevent recursion }
  2398. if rttidefstate[rt] in def.defstates then
  2399. exit;
  2400. include(def.defstates,rttidefstate[rt]);
  2401. { write first all dependencies }
  2402. write_child_rtti_data(def,rt);
  2403. { write rtti data }
  2404. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  2405. s:=internaltypeprefixName[itp_rttidef]+tstoreddef(def).rtti_mangledname(rt);
  2406. maybe_add_comment(tcb,'RTTI: begin Type '+def.GetTypeName+' ('+rttitypenames[rt]+')');
  2407. tcb.begin_anonymous_record(
  2408. s,
  2409. defaultpacking,reqalign,
  2410. targetinfos[target_info.system]^.alignment.recordalignmin
  2411. );
  2412. write_rtti_data(tcb,def,rt);
  2413. rttidef:=tcb.end_anonymous_record;
  2414. maybe_add_comment(tcb,'RTTI: end Type '+def.GetTypeName+' ('+rttitypenames[rt]+')');
  2415. rttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(rt),AB_GLOBAL,AT_DATA_NOINDIRECT,rttidef);
  2416. current_asmdata.AsmLists[al_rtti].concatList(
  2417. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,min(target_info.alignment.maxCrecordalign,SizeOf(QWord))));
  2418. tcb.free;
  2419. tcb := nil;
  2420. current_module.add_public_asmsym(rttilab);
  2421. { write additional data }
  2422. write_rtti_extrasyms(def,rt,rttilab);
  2423. end;
  2424. procedure TRTTIWriter.maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string);
  2425. begin
  2426. if addcomments then
  2427. tcb.emit_comment(comment);
  2428. end;
  2429. constructor TRTTIWriter.create;
  2430. begin
  2431. addcomments:=cs_asm_rtti_source in current_settings.globalswitches;
  2432. if tf_requires_proper_alignment in target_info.flags then
  2433. begin
  2434. reqalign:=min(sizeof(QWord),target_info.alignment.maxCrecordalign);
  2435. defaultpacking:=C_alignment;
  2436. end
  2437. else
  2438. begin
  2439. reqalign:=1;
  2440. defaultpacking:=1;
  2441. end;
  2442. end;
  2443. end.