ncgrtti.pas 105 KB

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