ncgrtti.pas 105 KB

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