ncgrtti.pas 82 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102
  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. procedure fields_write_rtti(st:tsymtable;rt:trttitype);
  35. procedure params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  36. procedure fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  37. procedure methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  38. procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  39. procedure published_write_rtti(st:tsymtable;rt:trttitype);
  40. function published_properties_count(st:tsymtable):longint;
  41. procedure published_properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist: TFPHashObjectList; st: tsymtable);
  42. procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
  43. { only use a direct reference if the referenced type can *only* reside
  44. in the same unit as the current one }
  45. function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  46. procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  47. procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
  48. procedure write_child_rtti_data(def:tdef;rt:trttitype);
  49. procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  50. procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
  51. procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  52. function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  53. procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  54. procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  55. procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  56. procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  57. public
  58. constructor create;
  59. procedure write_rtti(def:tdef;rt:trttitype);
  60. function get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  61. function get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  62. function get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
  63. end;
  64. { generate RTTI and init tables }
  65. procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
  66. var
  67. RTTIWriter : TRTTIWriter;
  68. implementation
  69. uses
  70. cutils,
  71. globals,verbose,systems,
  72. fmodule, procinfo,
  73. symtable,
  74. aasmtai,aasmdata,
  75. defutil,
  76. paramgr
  77. ;
  78. const
  79. rttidefstate : array[trttitype] of tdefstate =
  80. (ds_rtti_table_written,ds_init_table_written,
  81. { Objective-C related, does not pass here }
  82. symconst.ds_none,symconst.ds_none,
  83. symconst.ds_none,symconst.ds_none);
  84. type
  85. TPropNameListItem = class(TFPHashObject)
  86. propindex : longint;
  87. propowner : TSymtable;
  88. end;
  89. procedure write_persistent_type_info(st: tsymtable; is_global: boolean);
  90. var
  91. i : longint;
  92. def : tdef;
  93. begin
  94. { no Delphi-style RTTI for managed platforms }
  95. if target_info.system in systems_managed_vm then
  96. exit;
  97. for i:=0 to st.DefList.Count-1 do
  98. begin
  99. def:=tdef(st.DefList[i]);
  100. { skip generics }
  101. if [df_generic,df_genconstraint]*def.defoptions<>[] then
  102. continue;
  103. case def.typ of
  104. recorddef:
  105. write_persistent_type_info(trecorddef(def).symtable,is_global);
  106. objectdef :
  107. begin
  108. { Skip forward defs }
  109. if (oo_is_forward in tobjectdef(def).objectoptions) then
  110. continue;
  111. write_persistent_type_info(tobjectdef(def).symtable,is_global);
  112. end;
  113. procdef :
  114. begin
  115. if assigned(tprocdef(def).localst) and
  116. (tprocdef(def).localst.symtabletype=localsymtable) then
  117. write_persistent_type_info(tprocdef(def).localst,false);
  118. if assigned(tprocdef(def).parast) then
  119. write_persistent_type_info(tprocdef(def).parast,false);
  120. end;
  121. errordef:
  122. { we shouldn't have come this far if we have an errordef somewhere }
  123. internalerror(2017010701);
  124. undefineddef:
  125. { don't write any RTTI for these }
  126. continue;
  127. else
  128. ;
  129. end;
  130. { always generate persistent tables for types in the interface so
  131. they can be reused in other units and give always the same pointer
  132. location. }
  133. { Init }
  134. if (
  135. assigned(def.typesym) and
  136. is_global and
  137. not is_objc_class_or_protocol(def)
  138. ) or
  139. is_managed_type(def) or
  140. (ds_init_table_used in def.defstates) then
  141. RTTIWriter.write_rtti(def,initrtti);
  142. { RTTI }
  143. if (
  144. assigned(def.typesym) and
  145. is_global and
  146. not is_objc_class_or_protocol(def)
  147. ) or
  148. (ds_rtti_table_used in def.defstates) then
  149. RTTIWriter.write_rtti(def,fullrtti);
  150. end;
  151. end;
  152. {***************************************************************************
  153. TRTTIWriter
  154. ***************************************************************************}
  155. function TRTTIWriter.get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  156. begin
  157. result:=ref_rtti(def,rt,indirect,'');
  158. end;
  159. function TRTTIWriter.get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  160. begin
  161. result:=ref_rtti(def,rt,indirect,'_o2s');
  162. end;
  163. function TRTTIWriter.get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol;
  164. begin
  165. result:=ref_rtti(def,rt,indirect,'_s2o');
  166. end;
  167. procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
  168. var
  169. rtticount,
  170. totalcount,
  171. i,j,k : longint;
  172. sym : tprocsym;
  173. def : tprocdef;
  174. para : tparavarsym;
  175. begin
  176. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  177. targetinfos[target_info.system]^.alignment.recordalignmin,
  178. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  179. totalcount:=0;
  180. rtticount:=0;
  181. for i:=0 to st.symlist.count-1 do
  182. if tsym(st.symlist[i]).typ=procsym then
  183. begin
  184. sym:=tprocsym(st.symlist[i]);
  185. inc(totalcount,sym.procdeflist.count);
  186. for j:=0 to sym.procdeflist.count-1 do
  187. if tprocdef(sym.procdeflist[j]).visibility in visibilities then
  188. inc(rtticount);
  189. end;
  190. tcb.emit_ord_const(totalcount,u16inttype);
  191. if rtticount = 0 then
  192. tcb.emit_ord_const($FFFF,u16inttype)
  193. else
  194. begin
  195. tcb.emit_ord_const(rtticount,u16inttype);
  196. for i:=0 to st.symlist.count-1 do
  197. if tsym(st.symlist[i]).typ=procsym then
  198. begin
  199. sym:=tprocsym(st.symlist[i]);
  200. for j:=0 to sym.procdeflist.count-1 do
  201. begin
  202. def:=tprocdef(sym.procdeflist[j]);
  203. if not (def.visibility in visibilities) then
  204. continue;
  205. def.init_paraloc_info(callerside);
  206. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  207. targetinfos[target_info.system]^.alignment.recordalignmin,
  208. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  209. write_rtti_reference(tcb,def.returndef,fullrtti);
  210. write_callconv(tcb,def);
  211. write_methodkind(tcb,def);
  212. tcb.emit_ord_const(def.paras.count,u16inttype);
  213. tcb.emit_ord_const(def.callerargareasize,ptrsinttype);
  214. tcb.emit_pooled_shortstring_const_ref(sym.realname);
  215. for k:=0 to def.paras.count-1 do
  216. begin
  217. para:=tparavarsym(def.paras[k]);
  218. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  219. targetinfos[target_info.system]^.alignment.recordalignmin,
  220. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  221. if is_open_array(para.vardef) or is_array_of_const(para.vardef) then
  222. write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti)
  223. else if para.vardef=cformaltype then
  224. write_rtti_reference(tcb,nil,fullrtti)
  225. else
  226. write_rtti_reference(tcb,para.vardef,fullrtti);
  227. write_param_flag(tcb,para);
  228. tcb.emit_pooled_shortstring_const_ref(para.realname);
  229. write_paralocs(tcb,@para.paraloc[callerside]);
  230. tcb.end_anonymous_record;
  231. end;
  232. if not is_void(def.returndef) then
  233. write_paralocs(tcb,@def.funcretloc[callerside]);
  234. tcb.end_anonymous_record;
  235. end;
  236. end;
  237. end;
  238. tcb.end_anonymous_record;
  239. end;
  240. procedure TRTTIWriter.write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
  241. var
  242. name: shortstring;
  243. begin
  244. if assigned(def.typesym) then
  245. name:=ttypesym(def.typesym).realname
  246. else
  247. name:='';
  248. { TTypeInfo, always packed and doesn't need alignment }
  249. tcb.begin_anonymous_record(
  250. internaltypeprefixName[itp_rtti_header]+tostr(length(name)),1,1,
  251. targetinfos[target_info.system]^.alignment.recordalignmin,
  252. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  253. if def.typ=arraydef then
  254. InternalError(201012211);
  255. tcb.emit_tai(Tai_const.Create_8bit(typekind),u8inttype);
  256. tcb.emit_shortstring_const(name);
  257. tcb.end_anonymous_record;
  258. end;
  259. function TRTTIWriter.write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
  260. begin
  261. case def.proctypeoption of
  262. potype_constructor: result:=mkConstructor;
  263. potype_destructor: result:=mkDestructor;
  264. potype_class_constructor: result:=mkClassConstructor;
  265. potype_class_destructor: result:=mkClassDestructor;
  266. potype_operator: result:=mkOperatorOverload;
  267. potype_procedure:
  268. if po_classmethod in def.procoptions then
  269. result:=mkClassProcedure
  270. else
  271. result:=mkProcedure;
  272. potype_function:
  273. if po_classmethod in def.procoptions then
  274. result:=mkClassFunction
  275. else
  276. result:=mkFunction;
  277. else
  278. begin
  279. if def.returndef = voidtype then
  280. result:=mkProcedure
  281. else
  282. result:=mkFunction;
  283. end;
  284. end;
  285. tcb.emit_ord_const(result,u8inttype);
  286. end;
  287. procedure TRTTIWriter.write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
  288. const
  289. ProcCallOptionToCallConv: array[tproccalloption] of byte = (
  290. { pocall_none } 0,
  291. { pocall_cdecl } 1,
  292. { pocall_cppdecl } 5,
  293. { pocall_far16 } 6,
  294. { pocall_oldfpccall } 7,
  295. { pocall_internproc } 8,
  296. { pocall_syscall } 9,
  297. { pocall_pascal } 2,
  298. { pocall_register } 0,
  299. { pocall_safecall } 4,
  300. { pocall_stdcall } 3,
  301. { pocall_softfloat } 10,
  302. { pocall_mwpascal } 11,
  303. { pocall_interrupt } 12,
  304. { pocall_hardfloat } 13,
  305. { pocall_sysv_abi_default } 14,
  306. { pocall_sysv_abi_cdecl } 15,
  307. { pocall_ms_abi_default } 16,
  308. { pocall_ms_abi_cdecl } 17,
  309. { pocall_vectorcall } 18
  310. );
  311. begin
  312. tcb.emit_ord_const(ProcCallOptionToCallConv[def.proccalloption],u8inttype);
  313. end;
  314. procedure TRTTIWriter.write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara);
  315. var
  316. locs : trttiparalocs;
  317. i : longint;
  318. pool : THashSet;
  319. entry : PHashSetItem;
  320. loclab : TAsmLabel;
  321. loctcb : ttai_typedconstbuilder;
  322. datadef : tdef;
  323. begin
  324. locs:=paramanager.cgparalocs_to_rttiparalocs(para^.location);
  325. if length(locs)>high(byte) then
  326. internalerror(2017010601);
  327. if length(locs)=0 then
  328. begin
  329. { *shrugs* }
  330. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidpointertype);
  331. exit;
  332. end;
  333. { do we have such a paraloc already in the pool? }
  334. pool:=current_asmdata.ConstPools[sp_paraloc];
  335. entry:=pool.FindOrAdd(@locs[0],length(locs)*sizeof(trttiparaloc));
  336. if not assigned(entry^.Data) then
  337. begin
  338. current_asmdata.getglobaldatalabel(loclab);
  339. loctcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]);
  340. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  341. targetinfos[target_info.system]^.alignment.recordalignmin,
  342. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  343. loctcb.emit_ord_const(length(locs),u8inttype);
  344. for i:=low(locs) to high(locs) do
  345. begin
  346. loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  347. targetinfos[target_info.system]^.alignment.recordalignmin,
  348. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  349. loctcb.emit_ord_const(locs[i].loctype,u8inttype);
  350. loctcb.emit_ord_const(locs[i].regsub,u8inttype);
  351. loctcb.emit_ord_const(locs[i].regindex,u16inttype);
  352. { the corresponding type for aint is alusinttype }
  353. loctcb.emit_ord_const(locs[i].offset,alusinttype);
  354. loctcb.end_anonymous_record;
  355. end;
  356. datadef:=loctcb.end_anonymous_record;
  357. current_asmdata.asmlists[al_typedconsts].concatList(
  358. loctcb.get_final_asmlist(loclab,datadef,sec_rodata_norel,loclab.name,const_align(sizeof(pint)))
  359. );
  360. loctcb.free;
  361. entry^.data:=loclab;
  362. end
  363. else
  364. loclab:=TAsmLabel(entry^.Data);
  365. tcb.emit_tai(Tai_const.Create_sym(loclab),voidpointertype);
  366. end;
  367. procedure TRTTIWriter.write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
  368. var
  369. paraspec : word;
  370. begin
  371. case parasym.varspez of
  372. vs_value : paraspec := 0;
  373. vs_const : paraspec := pfConst;
  374. vs_var : paraspec := pfVar;
  375. vs_out : paraspec := pfOut;
  376. vs_constref: paraspec := pfConstRef;
  377. else
  378. internalerror(2013112904);
  379. end;
  380. { Kylix also seems to always add both pfArray and pfReference
  381. in this case
  382. }
  383. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  384. paraspec:=paraspec or pfArray or pfReference;
  385. { and these for classes and interfaces (maybe because they
  386. are themselves addresses?)
  387. }
  388. if is_class_or_interface(parasym.vardef) then
  389. paraspec:=paraspec or pfAddress;
  390. { flags for the hidden parameters }
  391. if vo_is_hidden_para in parasym.varoptions then
  392. paraspec:=paraspec or pfHidden;
  393. if vo_is_high_para in parasym.varoptions then
  394. paraspec:=paraspec or pfHigh;
  395. if vo_is_self in parasym.varoptions then
  396. paraspec:=paraspec or pfSelf;
  397. if vo_is_vmt in parasym.varoptions then
  398. paraspec:=paraspec or pfVmt;
  399. if vo_is_funcret in parasym.varoptions then
  400. paraspec:=paraspec or pfResult;
  401. { set bits run from the highest to the lowest bit on
  402. big endian systems
  403. }
  404. if (target_info.endian = endian_big) then
  405. paraspec:=reverse_word(paraspec);
  406. { write flags for current parameter }
  407. tcb.emit_ord_const(paraspec,u16inttype);
  408. end;
  409. function compare_mop_offset_entry(item1,item2:pointer):longint;
  410. var
  411. entry1: pmanagementoperator_offset_entry absolute item1;
  412. entry2: pmanagementoperator_offset_entry absolute item2;
  413. begin
  414. if entry1^.offset<entry2^.offset then
  415. result:=-1
  416. else if entry1^.offset>entry2^.offset then
  417. result:=1
  418. else
  419. result:=0;
  420. end;
  421. procedure TRTTIWriter.write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator);
  422. var
  423. list : tfplist;
  424. datatcb : ttai_typedconstbuilder;
  425. tbllbl : TAsmLabel;
  426. entry : pmanagementoperator_offset_entry;
  427. datadef,entrydef : tdef;
  428. i : longint;
  429. pdef : tobjectdef;
  430. begin
  431. list:=tfplist.create;
  432. tabstractrecordsymtable(def.symtable).get_managementoperator_offset_list(mop,list);
  433. if (def.typ=objectdef) then
  434. begin
  435. pdef:=tobjectdef(def).childof;
  436. while assigned(pdef) do
  437. begin
  438. tabstractrecordsymtable(pdef.symtable).get_managementoperator_offset_list(mop,list);
  439. pdef:=pdef.childof;
  440. end;
  441. list.sort(@compare_mop_offset_entry);
  442. end;
  443. if list.count=0 then
  444. tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype)
  445. else
  446. begin
  447. tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',datatcb,tbllbl);
  448. datatcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  449. targetinfos[target_info.system]^.alignment.recordalignmin,
  450. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  451. datatcb.emit_ord_const(list.count,u32inttype);
  452. entrydef:=get_recorddef(itp_init_mop_offset_entry,[voidcodepointertype,sizeuinttype],defaultpacking);
  453. for i:=0 to list.count-1 do
  454. begin
  455. entry:=pmanagementoperator_offset_entry(list[i]);
  456. datatcb.maybe_begin_aggregate(entrydef);
  457. datatcb.queue_init(voidcodepointertype);
  458. datatcb.queue_emit_proc(entry^.pd);
  459. datatcb.queue_init(sizeuinttype);
  460. datatcb.queue_emit_ordconst(entry^.offset,sizeuinttype);
  461. datatcb.maybe_end_aggregate(entrydef);
  462. dispose(entry);
  463. end;
  464. datadef:=datatcb.end_anonymous_record;
  465. tcb.finish_internal_data_builder(datatcb,tbllbl,datadef,sizeof(pint));
  466. tcb.emit_tai(tai_const.Create_sym(tbllbl),voidpointertype);
  467. end;
  468. list.free;
  469. end;
  470. procedure TRTTIWriter.write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
  471. begin
  472. if is_open_array(def) then
  473. { open arrays never have a typesym with a name, since you cannot
  474. define an "open array type". Kylix prints the type of the
  475. elements in the array in this case (so together with the pfArray
  476. flag, you can reconstruct the full typename, I assume (JM))
  477. }
  478. def:=tarraydef(def).elementdef;
  479. { name }
  480. if assigned(def.typesym) then
  481. tcb.emit_shortstring_const(ttypesym(def.typesym).realname)
  482. else
  483. tcb.emit_shortstring_const('');
  484. end;
  485. { writes a 32-bit count followed by array of field infos for given symtable }
  486. procedure TRTTIWriter.fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype);
  487. var
  488. i : longint;
  489. sym : tsym;
  490. fieldcnt: longint;
  491. st: tsymtable;
  492. fields: tfplist;
  493. parentrtti: boolean;
  494. begin
  495. fieldcnt:=0;
  496. parentrtti:=false;
  497. st:=def.symtable;
  498. fields:=tfplist.create;
  499. fields.capacity:=st.symlist.count+1;
  500. { For objects, treat parent (if any) as a field with offset 0. This
  501. provides correct handling of entire instance with RTL rtti routines. }
  502. if (def.typ=objectdef) and (tobjectdef(def).objecttype=odt_object) and
  503. Assigned(tobjectdef(def).childof) and
  504. ((rt=fullrtti) or (tobjectdef(def).childof.needs_inittable)) then
  505. begin
  506. parentrtti:=true;
  507. inc(fieldcnt);
  508. end;
  509. for i:=0 to st.SymList.Count-1 do
  510. begin
  511. sym:=tsym(st.SymList[i]);
  512. if (tsym(sym).typ=fieldvarsym) and
  513. not(sp_static in tsym(sym).symoptions) and
  514. (
  515. (rt=fullrtti) or
  516. tfieldvarsym(sym).vardef.needs_inittable
  517. ) and
  518. not is_objc_class_or_protocol(tfieldvarsym(sym).vardef) then
  519. begin
  520. fields.add(tfieldvarsym(sym));
  521. inc(fieldcnt);
  522. end;
  523. end;
  524. { insert field count before data }
  525. tcb.emit_ord_const(fieldcnt,u32inttype);
  526. { parent object? }
  527. if parentrtti then
  528. begin
  529. write_rtti_reference(tcb,tobjectdef(def).childof,rt);
  530. tcb.emit_ord_const(0,ptruinttype);
  531. end;
  532. { fields }
  533. for i:=0 to fields.count-1 do
  534. begin
  535. sym:=tsym(fields[i]);
  536. write_rtti_reference(tcb,tfieldvarsym(sym).vardef,rt);
  537. tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,ptruinttype);
  538. end;
  539. fields.free;
  540. end;
  541. procedure TRTTIWriter.fields_write_rtti(st:tsymtable;rt:trttitype);
  542. var
  543. i : longint;
  544. sym : tsym;
  545. begin
  546. for i:=0 to st.SymList.Count-1 do
  547. begin
  548. sym:=tsym(st.SymList[i]);
  549. if (tsym(sym).typ=fieldvarsym) and
  550. not(sp_static in tsym(sym).symoptions) and
  551. (
  552. (rt=fullrtti) or
  553. tfieldvarsym(sym).vardef.needs_inittable
  554. ) then
  555. write_rtti(tfieldvarsym(sym).vardef,rt);
  556. end;
  557. end;
  558. procedure TRTTIWriter.params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean);
  559. var
  560. i : longint;
  561. sym : tparavarsym;
  562. begin
  563. for i:=0 to def.paras.count-1 do
  564. begin
  565. sym:=tparavarsym(def.paras[i]);
  566. if not (vo_is_hidden_para in sym.varoptions) or allow_hidden then
  567. begin
  568. if is_open_array(sym.vardef) or is_array_of_const(sym.vardef) then
  569. write_rtti(tarraydef(sym.vardef).elementdef,rt)
  570. else
  571. write_rtti(sym.vardef,rt);
  572. end;
  573. end;
  574. end;
  575. procedure TRTTIWriter.methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean);
  576. var
  577. i,j : longint;
  578. sym : tprocsym;
  579. def : tabstractprocdef;
  580. begin
  581. for i:=0 to st.symlist.count-1 do
  582. if tsym(st.symlist[i]).typ=procsym then
  583. begin
  584. sym:=tprocsym(st.symlist[i]);
  585. for j:=0 to sym.procdeflist.count-1 do
  586. begin
  587. def:=tabstractprocdef(sym.procdeflist[j]);
  588. write_rtti(def.returndef,rt);
  589. params_write_rtti(def,rt,allow_hidden);
  590. end;
  591. end;
  592. end;
  593. procedure TRTTIWriter.published_write_rtti(st:tsymtable;rt:trttitype);
  594. var
  595. i : longint;
  596. sym : tsym;
  597. begin
  598. for i:=0 to st.SymList.Count-1 do
  599. begin
  600. sym:=tsym(st.SymList[i]);
  601. if (sym.visibility=vis_published) then
  602. begin
  603. case tsym(sym).typ of
  604. propertysym:
  605. write_rtti(tpropertysym(sym).propdef,rt);
  606. fieldvarsym:
  607. write_rtti(tfieldvarsym(sym).vardef,rt);
  608. else
  609. ;
  610. end;
  611. end;
  612. end;
  613. end;
  614. function TRTTIWriter.published_properties_count(st:tsymtable):longint;
  615. var
  616. i : longint;
  617. sym : tsym;
  618. begin
  619. result:=0;
  620. for i:=0 to st.SymList.Count-1 do
  621. begin
  622. sym:=tsym(st.SymList[i]);
  623. if (tsym(sym).typ=propertysym) and
  624. (sym.visibility=vis_published) then
  625. inc(result);
  626. end;
  627. end;
  628. procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
  629. var
  630. i : longint;
  631. sym : tsym;
  632. pn : tpropnamelistitem;
  633. begin
  634. if assigned(objdef.childof) then
  635. collect_propnamelist(propnamelist,objdef.childof);
  636. for i:=0 to objdef.symtable.SymList.Count-1 do
  637. begin
  638. sym:=tsym(objdef.symtable.SymList[i]);
  639. if (tsym(sym).typ=propertysym) and
  640. (sym.visibility=vis_published) then
  641. begin
  642. pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name));
  643. if not assigned(pn) then
  644. begin
  645. pn:=tpropnamelistitem.create(propnamelist,tsym(sym).name);
  646. pn.propindex:=propnamelist.count-1;
  647. pn.propowner:=tsym(sym).owner;
  648. end;
  649. end;
  650. end;
  651. end;
  652. procedure TRTTIWriter.published_properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList;st:tsymtable);
  653. var
  654. i : longint;
  655. sym : tsym;
  656. proctypesinfo : byte;
  657. propnameitem : tpropnamelistitem;
  658. propdefname : string;
  659. procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
  660. var
  661. typvalue : byte;
  662. hp : ppropaccesslistitem;
  663. extnumber: longint;
  664. address,space : longint;
  665. def : tdef;
  666. hpropsym : tpropertysym;
  667. propaccesslist : tpropaccesslist;
  668. begin
  669. hpropsym:=tpropertysym(sym);
  670. repeat
  671. propaccesslist:=hpropsym.propaccesslist[pap];
  672. if not propaccesslist.empty then
  673. break;
  674. hpropsym:=hpropsym.overriddenpropsym;
  675. until not assigned(hpropsym);
  676. if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then
  677. begin
  678. tcb.emit_tai(Tai_const.Create_int_codeptr(unsetvalue),codeptruinttype);
  679. typvalue:=3;
  680. end
  681. else if propaccesslist.firstsym^.sym.typ=fieldvarsym then
  682. begin
  683. address:=0;
  684. hp:=propaccesslist.firstsym;
  685. def:=nil;
  686. while assigned(hp) do
  687. begin
  688. case hp^.sltype of
  689. sl_load :
  690. begin
  691. def:=tfieldvarsym(hp^.sym).vardef;
  692. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  693. end;
  694. sl_subscript :
  695. begin
  696. if not(assigned(def) and
  697. ((def.typ=recorddef) or
  698. is_object(def))) then
  699. internalerror(200402171);
  700. inc(address,tfieldvarsym(hp^.sym).fieldoffset);
  701. def:=tfieldvarsym(hp^.sym).vardef;
  702. end;
  703. sl_vec :
  704. begin
  705. if not(assigned(def) and (def.typ=arraydef)) then
  706. internalerror(200402172);
  707. def:=tarraydef(def).elementdef;
  708. {Hp.value is a Tconstexprint, which can be rather large,
  709. sanity check for longint overflow.}
  710. space:=(high(address)-address) div def.size;
  711. if int64(space)<hp^.value then
  712. internalerror(200706101);
  713. inc(address,int64(def.size*hp^.value));
  714. end;
  715. else
  716. internalerror(2019050523);
  717. end;
  718. hp:=hp^.next;
  719. end;
  720. tcb.emit_tai(Tai_const.Create_int_codeptr(address),codeptruinttype);
  721. typvalue:=0;
  722. end
  723. else
  724. begin
  725. { When there was an error then procdef is not assigned }
  726. if not assigned(propaccesslist.procdef) then
  727. exit;
  728. if not(po_virtualmethod in tprocdef(propaccesslist.procdef).procoptions) or
  729. is_objectpascal_helper(tprocdef(propaccesslist.procdef).struct) then
  730. begin
  731. tcb.queue_init(codeptruinttype);
  732. tcb.queue_emit_proc(tprocdef(propaccesslist.procdef));
  733. typvalue:=1;
  734. end
  735. else
  736. begin
  737. { virtual method, write vmt offset }
  738. extnumber:=tprocdef(propaccesslist.procdef).extnumber;
  739. tcb.emit_tai(Tai_const.Create_int_codeptr(
  740. tobjectdef(tprocdef(propaccesslist.procdef).struct).vmtmethodoffset(extnumber)),
  741. codeptruinttype);
  742. { register for wpo }
  743. tobjectdef(tprocdef(propaccesslist.procdef).struct).register_vmt_call(extnumber);
  744. {$ifdef vtentry}
  745. { not sure if we can insert those vtentry symbols safely here }
  746. {$error register methods used for published properties}
  747. {$endif vtentry}
  748. typvalue:=2;
  749. end;
  750. end;
  751. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  752. end;
  753. begin
  754. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
  755. targetinfos[target_info.system]^.alignment.recordalignmin,
  756. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  757. tcb.emit_ord_const(published_properties_count(st),u16inttype);
  758. for i:=0 to st.SymList.Count-1 do
  759. begin
  760. sym:=tsym(st.SymList[i]);
  761. if (sym.typ=propertysym) and
  762. (sym.visibility=vis_published) then
  763. begin
  764. { we can only easily reuse defs if the property is not stored,
  765. because otherwise the rtti layout depends on how the "stored"
  766. is defined (field, indexed expression, virtual method, ...) }
  767. if not(ppo_stored in tpropertysym(sym).propoptions) then
  768. propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(tpropertysym(sym).realname))
  769. else
  770. propdefname:='';
  771. { TPropInfo is a packed record (even on targets that require
  772. alignment), but it starts aligned }
  773. tcb.begin_anonymous_record(
  774. propdefname,
  775. 1,min(reqalign,SizeOf(PInt)),
  776. targetinfos[target_info.system]^.alignment.recordalignmin,
  777. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  778. if ppo_indexed in tpropertysym(sym).propoptions then
  779. proctypesinfo:=$40
  780. else
  781. proctypesinfo:=0;
  782. write_rtti_reference(tcb,tpropertysym(sym).propdef,fullrtti);
  783. writeaccessproc(palt_read,0,0);
  784. writeaccessproc(palt_write,2,0);
  785. { is it stored ? }
  786. if not(ppo_stored in tpropertysym(sym).propoptions) then
  787. begin
  788. { no, so put a constant zero }
  789. tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype);
  790. proctypesinfo:=proctypesinfo or (3 shl 4);
  791. end
  792. else
  793. writeaccessproc(palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) }
  794. tcb.emit_ord_const(tpropertysym(sym).index,u32inttype);
  795. tcb.emit_ord_const(tpropertysym(sym).default,u32inttype);
  796. propnameitem:=TPropNameListItem(propnamelist.Find(tpropertysym(sym).name));
  797. if not assigned(propnameitem) then
  798. internalerror(200512201);
  799. tcb.emit_ord_const(propnameitem.propindex,u16inttype);
  800. tcb.emit_ord_const(proctypesinfo,u8inttype);
  801. tcb.emit_shortstring_const(tpropertysym(sym).realname);
  802. tcb.end_anonymous_record;
  803. end;
  804. end;
  805. tcb.end_anonymous_record;
  806. end;
  807. procedure TRTTIWriter.write_rtti_data(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  808. procedure unknown_rtti(def:tstoreddef);
  809. begin
  810. tcb.emit_ord_const(tkUnknown,u8inttype);
  811. write_rtti_name(tcb,def);
  812. end;
  813. procedure variantdef_rtti(def:tvariantdef);
  814. begin
  815. write_header(tcb,def,tkVariant);
  816. end;
  817. procedure stringdef_rtti(def:tstringdef);
  818. begin
  819. case def.stringtype of
  820. st_ansistring:
  821. begin
  822. write_header(tcb,def,tkAString);
  823. { align }
  824. tcb.begin_anonymous_record(
  825. internaltypeprefixName[itp_rtti_ansistr],
  826. defaultpacking,reqalign,
  827. targetinfos[target_info.system]^.alignment.recordalignmin,
  828. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  829. tcb.emit_ord_const(def.encoding,u16inttype);
  830. tcb.end_anonymous_record;
  831. end;
  832. st_widestring:
  833. write_header(tcb,def,tkWString);
  834. st_unicodestring:
  835. write_header(tcb,def,tkUString);
  836. st_longstring:
  837. write_header(tcb,def,tkLString);
  838. st_shortstring:
  839. begin
  840. write_header(tcb,def,tkSString);
  841. tcb.emit_ord_const(def.len,u8inttype);
  842. end;
  843. end;
  844. end;
  845. procedure enumdef_rtti(def: tenumdef);
  846. var
  847. i : integer;
  848. hp : tenumsym;
  849. begin
  850. write_header(tcb,def,tkEnumeration);
  851. { align; the named fields are so that we can let the compiler
  852. calculate the string offsets later on }
  853. tcb.next_field_name:='size_start_rec';
  854. { add a typename so that it can be reused when writing the the s2o
  855. and o2s arrays for llvm (otherwise we have to write out the entire
  856. type definition every time we access an element from this record) }
  857. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec]+def.unique_id_str,defaultpacking,reqalign,
  858. targetinfos[target_info.system]^.alignment.recordalignmin,
  859. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  860. case longint(def.size) of
  861. 1 :
  862. tcb.emit_ord_const(otUByte,u8inttype);
  863. 2 :
  864. tcb.emit_ord_const(otUWord,u8inttype);
  865. 4 :
  866. tcb.emit_ord_const(otULong,u8inttype);
  867. end;
  868. { we need to align by Tconstptruint here to satisfy the alignment
  869. rules set by records: in the typinfo unit we overlay a TTypeData
  870. record on this data, which at the innermost variant record needs an
  871. alignment of TConstPtrUint due to e.g. the "CompType" member for
  872. tkSet (also the "BaseType" member for tkEnumeration).
  873. We need to adhere to this, otherwise things will break. }
  874. tcb.next_field_name:='min_max_rec';
  875. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_min_max_rec]+def.unique_id_str,defaultpacking,reqalign,
  876. targetinfos[target_info.system]^.alignment.recordalignmin,
  877. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  878. tcb.emit_ord_const(def.min,s32inttype);
  879. tcb.emit_ord_const(def.max,s32inttype);
  880. tcb.next_field_name:='basetype_array_rec';
  881. { all strings must appear right after each other -> from now on
  882. packrecords 1 (but the start must still be aligned) }
  883. tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_basetype_array_rec]+def.unique_id_str,1,reqalign,
  884. targetinfos[target_info.system]^.alignment.recordalignmin,
  885. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  886. { write base type }
  887. write_rtti_reference(tcb,def.basedef,rt);
  888. for i:=0 to def.symtable.SymList.Count-1 do
  889. begin
  890. hp:=tenumsym(def.symtable.SymList[i]);
  891. if hp.value<def.minval then
  892. continue
  893. else
  894. if hp.value>def.maxval then
  895. break;
  896. tcb.next_field_name:=hp.name;
  897. tcb.emit_shortstring_const(hp.realname);
  898. end;
  899. { write unit name }
  900. tcb.emit_shortstring_const(current_module.realmodulename^);
  901. { write zero which is required by RTL }
  902. tcb.emit_ord_const(0,u8inttype);
  903. { terminate all records }
  904. tcb.end_anonymous_record;
  905. tcb.end_anonymous_record;
  906. tcb.end_anonymous_record;
  907. end;
  908. procedure orddef_rtti(def:torddef);
  909. procedure doint32_64(typekind: byte;min,max:int64);
  910. const
  911. trans : array[tordtype] of byte =
  912. (otUByte{otNone},
  913. otUByte,otUWord,otULong,otUQWord,otUByte{otNone},
  914. otSByte,otSWord,otSLong,otSQWord,otUByte{otNone},
  915. otUByte,otUByte,otUWord,otULong,otUQWord,
  916. otSByte,otSWord,otSLong,otSQWord,
  917. otUByte,otUWord,otUByte,255);
  918. var
  919. elesize: string[1];
  920. deftrans: byte;
  921. begin
  922. write_header(tcb,def,typekind);
  923. deftrans:=trans[def.ordtype];
  924. case deftrans of
  925. otUQWord,
  926. otSQWord:
  927. elesize:='8';
  928. 255:
  929. begin
  930. if def.packedbitsize<=32 then
  931. begin
  932. elesize:='4';
  933. if def.low<0 then
  934. deftrans:=otSLong
  935. else
  936. deftrans:=otULong;
  937. end
  938. else
  939. begin
  940. elesize:='8';
  941. if def.low<0 then
  942. deftrans:=otSQWord
  943. else
  944. deftrans:=otUQWord;
  945. end;
  946. end
  947. else
  948. elesize:='4'
  949. end;
  950. tcb.begin_anonymous_record(
  951. internaltypeprefixName[itp_rtti_ord_outer]+elesize,
  952. defaultpacking,reqalign,
  953. targetinfos[target_info.system]^.alignment.recordalignmin,
  954. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  955. tcb.emit_ord_const(byte(trans[def.ordtype]),u8inttype);
  956. tcb.begin_anonymous_record(
  957. internaltypeprefixName[itp_rtti_ord_inner]+elesize,
  958. defaultpacking,reqalign,
  959. targetinfos[target_info.system]^.alignment.recordalignmin,
  960. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  961. {Convert to longint to smuggle values in high(longint)+1..high(cardinal) into asmlist.}
  962. case deftrans of
  963. otUQWord:
  964. begin
  965. tcb.emit_ord_const(min,u64inttype);
  966. tcb.emit_ord_const(max,u64inttype);
  967. end;
  968. otSQWord:
  969. begin
  970. tcb.emit_ord_const(min,s64inttype);
  971. tcb.emit_ord_const(max,s64inttype);
  972. end;
  973. else
  974. begin
  975. tcb.emit_ord_const(longint(min),s32inttype);
  976. tcb.emit_ord_const(longint(max),s32inttype);
  977. end;
  978. end;
  979. tcb.end_anonymous_record;
  980. tcb.end_anonymous_record;
  981. end;
  982. procedure dointeger(typekind:byte);inline;
  983. begin
  984. doint32_64(typekind,int64(def.low.svalue),int64(def.high.svalue));
  985. end;
  986. begin
  987. case def.ordtype of
  988. s64bit :
  989. dointeger(tkInt64);
  990. u64bit :
  991. dointeger(tkQWord);
  992. pasbool1,
  993. pasbool8,
  994. pasbool16,
  995. pasbool32,
  996. pasbool64:
  997. dointeger(tkBool);
  998. { use different low/high values to be Delphi compatible }
  999. bool8bit,
  1000. bool16bit,
  1001. bool32bit:
  1002. doint32_64(tkBool,longint(low(longint)),longint(high(longint)));
  1003. bool64bit:
  1004. doint32_64(tkBool,low(int64),high(int64));
  1005. uchar:
  1006. dointeger(tkChar);
  1007. uwidechar:
  1008. dointeger(tkWChar);
  1009. scurrency:
  1010. begin
  1011. write_header(tcb,def,tkFloat);
  1012. tcb.begin_anonymous_record(
  1013. internaltypeprefixName[itp_1byte],
  1014. defaultpacking,reqalign,
  1015. targetinfos[target_info.system]^.alignment.recordalignmin,
  1016. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1017. tcb.emit_ord_const(ftCurr,u8inttype);
  1018. tcb.end_anonymous_record;
  1019. end;
  1020. else
  1021. dointeger(tkInteger);
  1022. end;
  1023. end;
  1024. procedure floatdef_rtti(def:tfloatdef);
  1025. const
  1026. {tfloattype = (s32real,s64real,s80real,sc80real,s64bit,s128bit);}
  1027. translate : array[tfloattype] of byte =
  1028. (ftSingle,ftDouble,ftExtended,ftExtended,ftComp,ftCurr,ftFloat128);
  1029. begin
  1030. write_header(tcb,def,tkFloat);
  1031. tcb.begin_anonymous_record(
  1032. internaltypeprefixName[itp_1byte],
  1033. defaultpacking,reqalign,
  1034. targetinfos[target_info.system]^.alignment.recordalignmin,
  1035. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1036. tcb.emit_ord_const(translate[def.floattype],u8inttype);
  1037. tcb.end_anonymous_record;
  1038. end;
  1039. procedure setdef_rtti(def:tsetdef);
  1040. begin
  1041. write_header(tcb,def,tkSet);
  1042. tcb.begin_anonymous_record(
  1043. internaltypeprefixName[itp_rtti_set_outer],
  1044. defaultpacking,reqalign,
  1045. targetinfos[target_info.system]^.alignment.recordalignmin,
  1046. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1047. case def.size of
  1048. 1:
  1049. tcb.emit_ord_const(otUByte,u8inttype);
  1050. 2:
  1051. tcb.emit_ord_const(otUWord,u8inttype);
  1052. 4:
  1053. tcb.emit_ord_const(otULong,u8inttype);
  1054. else
  1055. tcb.emit_ord_const(otUByte,u8inttype);
  1056. end;
  1057. tcb.begin_anonymous_record(
  1058. internaltypeprefixName[itp_rtti_set_inner],
  1059. defaultpacking,reqalign,
  1060. targetinfos[target_info.system]^.alignment.recordalignmin,
  1061. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1062. tcb.emit_ord_const(def.size,sizesinttype);
  1063. write_rtti_reference(tcb,def.elementdef,rt);
  1064. tcb.end_anonymous_record;
  1065. tcb.end_anonymous_record;
  1066. end;
  1067. procedure arraydef_rtti(def:tarraydef);
  1068. var
  1069. i,dimcount: byte;
  1070. totalcount: asizeuint;
  1071. finaldef: tdef;
  1072. curdef:tarraydef;
  1073. begin
  1074. if ado_IsDynamicArray in def.arrayoptions then
  1075. tcb.emit_ord_const(tkDynArray,u8inttype)
  1076. else
  1077. tcb.emit_ord_const(tkArray,u8inttype);
  1078. write_rtti_name(tcb,def);
  1079. if not(ado_IsDynamicArray in def.arrayoptions) then
  1080. begin
  1081. { remember tha last instruction. we will need to insert some
  1082. calculated values after it }
  1083. finaldef:=def;
  1084. totalcount:=1;
  1085. dimcount:=0;
  1086. repeat
  1087. curdef:=tarraydef(finaldef);
  1088. finaldef:=curdef.elementdef;
  1089. { Dims[i] PTypeInfo }
  1090. inc(dimcount);
  1091. totalcount:=totalcount*curdef.elecount;
  1092. until (finaldef.typ<>arraydef) or
  1093. (ado_IsDynamicArray in tarraydef(finaldef).arrayoptions);
  1094. tcb.begin_anonymous_record(
  1095. internaltypeprefixName[itp_rtti_normal_array]+tostr(dimcount),
  1096. defaultpacking,reqalign,
  1097. targetinfos[target_info.system]^.alignment.recordalignmin,
  1098. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1099. { total size = elecount * elesize of the first arraydef }
  1100. tcb.emit_tai(Tai_const.Create_sizeint(def.elecount*def.elesize),sizeuinttype);
  1101. { total element count }
  1102. tcb.emit_tai(Tai_const.Create_sizeint(asizeint(totalcount)),sizeuinttype);
  1103. { last dimension element type }
  1104. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(curdef.elementdef,rt,true)),voidpointertype);
  1105. { dimension count }
  1106. tcb.emit_ord_const(dimcount,u8inttype);
  1107. finaldef:=def;
  1108. { ranges of the dimensions }
  1109. for i:=1 to dimcount do
  1110. begin
  1111. curdef:=tarraydef(finaldef);
  1112. finaldef:=curdef.elementdef;
  1113. { Dims[i] PPTypeInfo }
  1114. write_rtti_reference(tcb,curdef.rangedef,rt);
  1115. end;
  1116. end
  1117. else
  1118. { write a delphi almost compatible dyn. array entry:
  1119. there are two types, eltype and eltype2, the latter is nil if the element type needs
  1120. no finalization, the former is always valid, delphi has this swapped, but for
  1121. compatibility with older fpc versions we do it different, to be delphi compatible,
  1122. the names are swapped in typinfo.pp
  1123. }
  1124. begin
  1125. tcb.begin_anonymous_record(
  1126. internaltypeprefixName[itp_rtti_dyn_array],
  1127. defaultpacking,reqalign,
  1128. targetinfos[target_info.system]^.alignment.recordalignmin,
  1129. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1130. { size of elements }
  1131. tcb.emit_tai(Tai_const.Create_sizeint(def.elesize),sizeuinttype);
  1132. { element type }
  1133. write_rtti_reference(tcb,def.elementdef,rt);
  1134. { variant type }
  1135. tcb.emit_ord_const(tstoreddef(def.elementdef).getvardef,s32inttype);
  1136. { element type }
  1137. if def.elementdef.needs_inittable then
  1138. write_rtti_reference(tcb,def.elementdef,rt)
  1139. else
  1140. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1141. { write unit name }
  1142. tcb.emit_shortstring_const(current_module.realmodulename^);
  1143. end;
  1144. tcb.end_anonymous_record;
  1145. end;
  1146. procedure classrefdef_rtti(def:tclassrefdef);
  1147. begin
  1148. write_header(tcb,def,tkClassRef);
  1149. tcb.begin_anonymous_record(
  1150. internaltypeprefixName[itp_rtti_ref],
  1151. defaultpacking,reqalign,
  1152. targetinfos[target_info.system]^.alignment.recordalignmin,
  1153. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1154. write_rtti_reference(tcb,def.pointeddef,rt);
  1155. tcb.end_anonymous_record;
  1156. end;
  1157. procedure pointerdef_rtti(def:tpointerdef);
  1158. begin
  1159. write_header(tcb,def,tkPointer);
  1160. tcb.begin_anonymous_record(
  1161. internaltypeprefixName[itp_rtti_ref],
  1162. defaultpacking,reqalign,
  1163. targetinfos[target_info.system]^.alignment.recordalignmin,
  1164. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1165. write_rtti_reference(tcb,def.pointeddef,rt);
  1166. tcb.end_anonymous_record;
  1167. end;
  1168. procedure recorddef_rtti(def:trecorddef);
  1169. procedure write_record_operators;
  1170. var
  1171. rttilab: Tasmsymbol;
  1172. rttidef: tdef;
  1173. tcb: ttai_typedconstbuilder;
  1174. mop: tmanagementoperator;
  1175. procdef: tprocdef;
  1176. begin
  1177. rttilab := current_asmdata.DefineAsmSymbol(
  1178. internaltypeprefixName[itp_init_record_operators]+def.rtti_mangledname(rt),
  1179. AB_GLOBAL,AT_DATA,def);
  1180. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]);
  1181. tcb.begin_anonymous_record(
  1182. rttilab.Name,
  1183. defaultpacking,reqalign,
  1184. targetinfos[target_info.system]^.alignment.recordalignmin,
  1185. targetinfos[target_info.system]^.alignment.maxCrecordalign
  1186. );
  1187. { use "succ" to omit first enum item "mop_none" }
  1188. for mop := succ(low(tmanagementoperator)) to high(tmanagementoperator) do
  1189. begin
  1190. if not (mop in trecordsymtable(def.symtable).managementoperators) then
  1191. tcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype)
  1192. else
  1193. begin
  1194. procdef := search_management_operator(mop, def);
  1195. if procdef = nil then
  1196. internalerror(201603021)
  1197. else
  1198. tcb.emit_tai(Tai_const.Createname(procdef.mangledname,AT_FUNCTION,0),
  1199. cprocvardef.getreusableprocaddr(procdef));
  1200. end;
  1201. end;
  1202. rttidef := tcb.end_anonymous_record;
  1203. current_asmdata.AsmLists[al_rtti].concatList(
  1204. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,
  1205. sizeof(PInt)));
  1206. tcb.free;
  1207. end;
  1208. begin
  1209. write_header(tcb,def,tkRecord);
  1210. { need extra reqalign record, because otherwise the u32 int will
  1211. only be aligned to 4 even on 64 bit target (while the rtti code
  1212. in typinfo expects alignments to sizeof(pointer)) }
  1213. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1214. targetinfos[target_info.system]^.alignment.recordalignmin,
  1215. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1216. { store special terminator for init table for more optimal rtl operations
  1217. strictly related to RecordRTTI procedure in rtti.inc (directly
  1218. related to RTTIRecordRttiInfoToInitInfo function) }
  1219. if (rt=initrtti) then
  1220. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1221. else
  1222. { we use a direct reference as the init RTTI is always in the same
  1223. unit as the full RTTI }
  1224. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype);
  1225. tcb.emit_ord_const(def.size,u32inttype);
  1226. { store rtti management operators only for init table }
  1227. if (rt=initrtti) then
  1228. begin
  1229. { for now records don't have the initializer table }
  1230. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1231. if (trecordsymtable(def.symtable).managementoperators=[]) then
  1232. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1233. else
  1234. tcb.emit_tai(Tai_const.Createname(
  1235. internaltypeprefixName[itp_init_record_operators]+def.rtti_mangledname(rt),
  1236. AT_DATA_FORCEINDIRECT,0),voidpointertype);
  1237. end;
  1238. fields_write_rtti_data(tcb,def,rt);
  1239. tcb.end_anonymous_record;
  1240. { write pointers to operators if needed }
  1241. if (rt=initrtti) and (trecordsymtable(def.symtable).managementoperators<>[]) then
  1242. write_record_operators;
  1243. end;
  1244. procedure procvardef_rtti(def:tprocvardef);
  1245. procedure write_para(parasym:tparavarsym);
  1246. begin
  1247. { write flags for current parameter }
  1248. write_param_flag(tcb,parasym);
  1249. { write name of current parameter }
  1250. tcb.emit_shortstring_const(parasym.realname);
  1251. { write name of type of current parameter }
  1252. write_rtti_name(tcb,parasym.vardef);
  1253. end;
  1254. procedure write_procedure_param(parasym:tparavarsym);
  1255. begin
  1256. { every parameter is expected to start aligned }
  1257. tcb.begin_anonymous_record(
  1258. internaltypeprefixName[itp_rtti_proc_param]+tostr(length(parasym.realname)),
  1259. defaultpacking,min(reqalign,SizeOf(PInt)),
  1260. targetinfos[target_info.system]^.alignment.recordalignmin,
  1261. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1262. { write flags for current parameter }
  1263. write_param_flag(tcb,parasym);
  1264. { write param type }
  1265. if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
  1266. write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti)
  1267. else if parasym.vardef=cformaltype then
  1268. write_rtti_reference(tcb,nil,fullrtti)
  1269. else
  1270. write_rtti_reference(tcb,parasym.vardef,fullrtti);
  1271. { write name of current parameter }
  1272. tcb.emit_shortstring_const(parasym.realname);
  1273. tcb.end_anonymous_record;
  1274. end;
  1275. var
  1276. methodkind : byte;
  1277. i : integer;
  1278. begin
  1279. if po_methodpointer in def.procoptions then
  1280. begin
  1281. { write method id and name }
  1282. write_header(tcb,def,tkMethod);
  1283. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1284. targetinfos[target_info.system]^.alignment.recordalignmin,
  1285. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1286. { write kind of method }
  1287. methodkind:=write_methodkind(tcb,def);
  1288. { write parameter info. The parameters must be written in reverse order
  1289. if this method uses right to left parameter pushing! }
  1290. tcb.emit_ord_const(def.paras.count,u8inttype);
  1291. for i:=0 to def.paras.count-1 do
  1292. write_para(tparavarsym(def.paras[i]));
  1293. if (methodkind=mkFunction) or (methodkind=mkClassFunction) then
  1294. begin
  1295. { write name of result type }
  1296. write_rtti_name(tcb,def.returndef);
  1297. { enclosing record takes care of alignment }
  1298. { write result typeinfo }
  1299. write_rtti_reference(tcb,def.returndef,fullrtti);
  1300. end;
  1301. { write calling convention }
  1302. write_callconv(tcb,def);
  1303. { enclosing record takes care of alignment }
  1304. { write params typeinfo }
  1305. for i:=0 to def.paras.count-1 do
  1306. begin
  1307. if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then
  1308. write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti)
  1309. else if tparavarsym(def.paras[i]).vardef=cformaltype then
  1310. write_rtti_reference(tcb,nil,fullrtti)
  1311. else
  1312. write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti);
  1313. end;
  1314. tcb.end_anonymous_record;
  1315. end
  1316. else
  1317. begin
  1318. write_header(tcb,def,tkProcvar);
  1319. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1320. targetinfos[target_info.system]^.alignment.recordalignmin,
  1321. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1322. { flags }
  1323. tcb.emit_ord_const(0,u8inttype);
  1324. { write calling convention }
  1325. write_callconv(tcb,def);
  1326. { enclosing record takes care of alignment }
  1327. { write result typeinfo }
  1328. write_rtti_reference(tcb,def.returndef,fullrtti);
  1329. { write parameter count }
  1330. tcb.emit_ord_const(def.paras.count,u8inttype);
  1331. for i:=0 to def.paras.count-1 do
  1332. write_procedure_param(tparavarsym(def.paras[i]));
  1333. tcb.end_anonymous_record;
  1334. end;
  1335. end;
  1336. procedure objectdef_rtti(def: tobjectdef);
  1337. procedure objectdef_rtti_fields(def:tobjectdef);
  1338. begin
  1339. { - for compatiblity with record RTTI we need to write a terminator-
  1340. Nil pointer for initrtti as well for objects
  1341. - for RTTI consistency for objects we need point from fullrtti
  1342. to initrtti
  1343. - classes are assumed to have the same INIT RTTI as records
  1344. (see TObject.CleanupInstance)
  1345. - neither helper nor class type have fullrtti for fields
  1346. }
  1347. if (rt=initrtti) then
  1348. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1349. else
  1350. if (def.objecttype=odt_object) then
  1351. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype)
  1352. else
  1353. internalerror(2017011801);
  1354. tcb.emit_ord_const(def.size, u32inttype);
  1355. { pointer to management operators available only for initrtti }
  1356. if (rt=initrtti) then
  1357. begin
  1358. { initializer table only available for classes currently }
  1359. if def.objecttype=odt_class then
  1360. write_mop_offset_table(tcb,def,mop_initialize)
  1361. else
  1362. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1363. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1364. end;
  1365. { enclosing record takes care of alignment }
  1366. fields_write_rtti_data(tcb,def,rt);
  1367. end;
  1368. procedure objectdef_rtti_interface_init(def:tobjectdef);
  1369. begin
  1370. tcb.emit_ord_const(def.size, u32inttype);
  1371. end;
  1372. procedure objectdef_rtti_class_full(def:tobjectdef);
  1373. var
  1374. propnamelist : TFPHashObjectList;
  1375. begin
  1376. { Collect unique property names with nameindex }
  1377. propnamelist:=TFPHashObjectList.Create;
  1378. collect_propnamelist(propnamelist,def);
  1379. if not is_objectpascal_helper(def) then
  1380. if (oo_has_vmt in def.objectoptions) then
  1381. tcb.emit_tai(
  1382. Tai_const.Createname(def.vmt_mangledname,AT_DATA_FORCEINDIRECT,0),
  1383. cpointerdef.getreusable(def.vmt_def))
  1384. else
  1385. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype);
  1386. { write parent typeinfo }
  1387. write_rtti_reference(tcb,def.childof,fullrtti);
  1388. { write typeinfo of extended type }
  1389. if is_objectpascal_helper(def) then
  1390. if assigned(def.extendeddef) then
  1391. write_rtti_reference(tcb,def.extendeddef,fullrtti)
  1392. else
  1393. InternalError(2011033001);
  1394. { total number of unique properties }
  1395. tcb.emit_ord_const(propnamelist.count,u16inttype);
  1396. { write unit name }
  1397. tcb.emit_shortstring_const(current_module.realmodulename^);
  1398. { write published properties for this object }
  1399. published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
  1400. propnamelist.free;
  1401. end;
  1402. procedure objectdef_rtti_interface_full(def:tobjectdef);
  1403. var
  1404. propnamelist : TFPHashObjectList;
  1405. { if changed to a set, make sure it's still a byte large, and
  1406. swap appropriately when cross-compiling
  1407. }
  1408. IntfFlags: byte;
  1409. begin
  1410. { Collect unique property names with nameindex }
  1411. propnamelist:=TFPHashObjectList.Create;
  1412. collect_propnamelist(propnamelist,def);
  1413. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1414. targetinfos[target_info.system]^.alignment.recordalignmin,
  1415. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1416. { write parent typeinfo }
  1417. write_rtti_reference(tcb,def.childof,fullrtti);
  1418. { interface: write flags, iid and iidstr }
  1419. IntfFlags:=0;
  1420. if assigned(def.iidguid) then
  1421. IntfFlags:=IntfFlags or (1 shl ord(ifHasGuid));
  1422. if (def.objecttype=odt_interfacecorba) and (def.iidstr^<>'') then
  1423. IntfFlags:=IntfFlags or (1 shl ord(ifHasStrGUID));
  1424. if (def.objecttype=odt_dispinterface) then
  1425. IntfFlags:=IntfFlags or (1 shl ord(ifDispInterface));
  1426. if (target_info.endian=endian_big) then
  1427. IntfFlags:=reverse_byte(IntfFlags);
  1428. {
  1429. ifDispatch, }
  1430. tcb.emit_ord_const(IntfFlags,u8inttype);
  1431. { write GUID }
  1432. tcb.emit_guid_const(def.iidguid^);
  1433. { write unit name }
  1434. tcb.emit_shortstring_const(current_module.realmodulename^);
  1435. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1436. targetinfos[target_info.system]^.alignment.recordalignmin,
  1437. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1438. { write iidstr }
  1439. if def.objecttype=odt_interfacecorba then
  1440. begin
  1441. { prepareguid always allocates an empty string }
  1442. if not assigned(def.iidstr) then
  1443. internalerror(2016021901);
  1444. tcb.emit_shortstring_const(def.iidstr^)
  1445. end;
  1446. { write published properties for this object }
  1447. published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
  1448. { write published methods for this interface }
  1449. write_methods(tcb,def.symtable,[vis_published]);
  1450. tcb.end_anonymous_record;
  1451. tcb.end_anonymous_record;
  1452. propnamelist.free;
  1453. end;
  1454. begin
  1455. case def.objecttype of
  1456. odt_class:
  1457. tcb.emit_ord_const(tkclass,u8inttype);
  1458. odt_object:
  1459. tcb.emit_ord_const(tkobject,u8inttype);
  1460. odt_dispinterface,
  1461. odt_interfacecom:
  1462. tcb.emit_ord_const(tkInterface,u8inttype);
  1463. odt_interfacecorba:
  1464. tcb.emit_ord_const(tkinterfaceCorba,u8inttype);
  1465. odt_helper:
  1466. tcb.emit_ord_const(tkhelper,u8inttype);
  1467. else
  1468. internalerror(200611034);
  1469. end;
  1470. { generate the name }
  1471. tcb.emit_shortstring_const(def.objrealname^);
  1472. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1473. targetinfos[target_info.system]^.alignment.recordalignmin,
  1474. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1475. case rt of
  1476. initrtti :
  1477. begin
  1478. if def.objecttype in [odt_class,odt_object,odt_helper] then
  1479. objectdef_rtti_fields(def)
  1480. else
  1481. objectdef_rtti_interface_init(def);
  1482. end;
  1483. fullrtti :
  1484. begin
  1485. case def.objecttype of
  1486. odt_helper,
  1487. odt_class:
  1488. objectdef_rtti_class_full(def);
  1489. odt_object:
  1490. objectdef_rtti_fields(def);
  1491. else
  1492. objectdef_rtti_interface_full(def);
  1493. end;
  1494. end;
  1495. else
  1496. ;
  1497. end;
  1498. tcb.end_anonymous_record;
  1499. end;
  1500. begin
  1501. case def.typ of
  1502. variantdef :
  1503. variantdef_rtti(tvariantdef(def));
  1504. stringdef :
  1505. stringdef_rtti(tstringdef(def));
  1506. enumdef :
  1507. enumdef_rtti(tenumdef(def));
  1508. orddef :
  1509. orddef_rtti(torddef(def));
  1510. floatdef :
  1511. floatdef_rtti(tfloatdef(def));
  1512. setdef :
  1513. setdef_rtti(tsetdef(def));
  1514. procvardef :
  1515. procvardef_rtti(tprocvardef(def));
  1516. arraydef :
  1517. begin
  1518. if ado_IsBitPacked in tarraydef(def).arrayoptions then
  1519. unknown_rtti(tstoreddef(def))
  1520. else
  1521. arraydef_rtti(tarraydef(def));
  1522. end;
  1523. recorddef :
  1524. begin
  1525. if trecorddef(def).is_packed then
  1526. unknown_rtti(tstoreddef(def))
  1527. else
  1528. recorddef_rtti(trecorddef(def));
  1529. end;
  1530. objectdef :
  1531. objectdef_rtti(tobjectdef(def));
  1532. classrefdef :
  1533. classrefdef_rtti(tclassrefdef(def));
  1534. pointerdef :
  1535. pointerdef_rtti(tpointerdef(def));
  1536. else
  1537. unknown_rtti(tstoreddef(def));
  1538. end;
  1539. end;
  1540. function enumsym_compare_name(item1, item2: pointer): Integer;
  1541. var
  1542. enum1: tenumsym absolute item1;
  1543. enum2: tenumsym absolute item2;
  1544. begin
  1545. if enum1=enum2 then
  1546. result:=0
  1547. else if enum1.name>enum2.name then
  1548. result:=1
  1549. else
  1550. { there can't be equal names, identifiers are unique }
  1551. result:=-1;
  1552. end;
  1553. function enumsym_compare_value(item1, item2: pointer): Integer;
  1554. var
  1555. enum1: tenumsym absolute item1;
  1556. enum2: tenumsym absolute item2;
  1557. begin
  1558. if enum1.value>enum2.value then
  1559. result:=1
  1560. else if enum1.value<enum2.value then
  1561. result:=-1
  1562. else
  1563. result:=0;
  1564. end;
  1565. procedure TRTTIWriter.write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
  1566. type Penumsym = ^Tenumsym;
  1567. { Writes a helper table for accelerated conversion of ordinal enum values to strings.
  1568. If you change something in this method, make sure to adapt the corresponding code
  1569. in sstrings.inc. }
  1570. procedure enumdef_rtti_ord2stringindex(rttidef: trecorddef; const syms: tfplist);
  1571. var rttilab:Tasmsymbol;
  1572. h,i,o,prev_value:longint;
  1573. mode:(lookup,search); {Modify with care, ordinal value of enum is written.}
  1574. r:single; {Must be real type because of integer overflow risk.}
  1575. tcb: ttai_typedconstbuilder;
  1576. sym_count: integer;
  1577. tabledef: tdef;
  1578. begin
  1579. {Decide wether a lookup array is size efficient.}
  1580. mode:=lookup;
  1581. sym_count:=syms.count;
  1582. if sym_count>0 then
  1583. begin
  1584. i:=1;
  1585. r:=0;
  1586. h:=tenumsym(syms[0]).value; {Next expected enum value is min.}
  1587. { set prev_value for the first iteration to a value that is
  1588. different from the first one without risking overflow (it's used
  1589. to detect whether two enum values are the same) }
  1590. if h=0 then
  1591. prev_value:=1
  1592. else
  1593. prev_value:=0;
  1594. while i<sym_count do
  1595. begin
  1596. { if two enum values are the same, we have to create a table }
  1597. if (prev_value=h) then
  1598. begin
  1599. mode:=search;
  1600. break;
  1601. end;
  1602. {Calculate size of hole between values. Avoid integer overflows.}
  1603. r:=r+(single(tenumsym(syms[i]).value)-single(h))-1;
  1604. prev_value:=h;
  1605. h:=tenumsym(syms[i]).value;
  1606. inc(i);
  1607. end;
  1608. if r>sym_count then
  1609. mode:=search; {Don't waste more than 50% space.}
  1610. end;
  1611. { write rtti data; make sure that the alignment matches the corresponding data structure
  1612. in the code that uses it (if alignment is required). }
  1613. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  1614. { use TConstPtrUInt packrecords to ensure good alignment }
  1615. tcb.begin_anonymous_record('',defaultpacking,reqalign,
  1616. targetinfos[target_info.system]^.alignment.recordalignmin,
  1617. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1618. { now emit the data: first the mode }
  1619. tcb.emit_tai(Tai_const.create_32bit(longint(mode)),u32inttype);
  1620. { align }
  1621. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  1622. targetinfos[target_info.system]^.alignment.recordalignmin,
  1623. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1624. if mode=lookup then
  1625. begin
  1626. o:=tenumsym(syms[0]).value; {Start with min value.}
  1627. for i:=0 to sym_count-1 do
  1628. begin
  1629. while o<tenumsym(syms[i]).value do
  1630. begin
  1631. tcb.emit_tai(Tai_const.create_nil_dataptr,ptruinttype);
  1632. inc(o);
  1633. end;
  1634. inc(o);
  1635. tcb.queue_init(voidpointertype);
  1636. tcb.queue_subscriptn_multiple_by_name(rttidef,
  1637. ['size_start_rec',
  1638. 'min_max_rec',
  1639. 'basetype_array_rec',
  1640. tsym(syms[i]).Name]
  1641. );
  1642. tcb.queue_emit_asmsym(mainrtti,rttidef);
  1643. end;
  1644. end
  1645. else
  1646. begin
  1647. tcb.emit_ord_const(sym_count,u32inttype);
  1648. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  1649. targetinfos[target_info.system]^.alignment.recordalignmin,
  1650. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1651. for i:=0 to sym_count-1 do
  1652. begin
  1653. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  1654. tcb.queue_init(voidpointertype);
  1655. tcb.queue_subscriptn_multiple_by_name(rttidef,
  1656. ['size_start_rec',
  1657. 'min_max_rec',
  1658. 'basetype_array_rec',
  1659. tsym(syms[i]).Name]
  1660. );
  1661. tcb.queue_emit_asmsym(mainrtti,rttidef);
  1662. end;
  1663. tcb.end_anonymous_record;
  1664. end;
  1665. tcb.end_anonymous_record;
  1666. tabledef:=tcb.end_anonymous_record;
  1667. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_o2s',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  1668. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  1669. rttilab,tabledef,sec_rodata,
  1670. rttilab.name,sizeof(PInt)));
  1671. tcb.free;
  1672. current_module.add_public_asmsym(rttilab);
  1673. end;
  1674. { Writes a helper table for accelerated conversion of string to ordinal enum values.
  1675. If you change something in this method, make sure to adapt the corresponding code
  1676. in sstrings.inc. }
  1677. procedure enumdef_rtti_string2ordindex(rttidef: trecorddef; const syms: tfplist);
  1678. var
  1679. tcb: ttai_typedconstbuilder;
  1680. rttilab: Tasmsymbol;
  1681. i:longint;
  1682. tabledef: tdef;
  1683. begin
  1684. { write rtti data }
  1685. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  1686. { begin of Tstring_to_ord }
  1687. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  1688. targetinfos[target_info.system]^.alignment.recordalignmin,
  1689. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1690. tcb.emit_ord_const(syms.count,s32inttype);
  1691. { begin of "data" array in Tstring_to_ord }
  1692. tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)),
  1693. targetinfos[target_info.system]^.alignment.recordalignmin,
  1694. targetinfos[target_info.system]^.alignment.maxCrecordalign);
  1695. for i:=0 to syms.count-1 do
  1696. begin
  1697. tcb.emit_ord_const(tenumsym(syms[i]).value,s32inttype);
  1698. { alignment of pointer value handled by enclosing record already }
  1699. tcb.queue_init(voidpointertype);
  1700. tcb.queue_subscriptn_multiple_by_name(rttidef,
  1701. ['size_start_rec',
  1702. 'min_max_rec',
  1703. 'basetype_array_rec',
  1704. tsym(syms[i]).Name]
  1705. );
  1706. tcb.queue_emit_asmsym(mainrtti,rttidef);
  1707. end;
  1708. tcb.end_anonymous_record;
  1709. tabledef:=tcb.end_anonymous_record;
  1710. rttilab:=current_asmdata.DefineAsmSymbol(Tstoreddef(def).rtti_mangledname(rt)+'_s2o',AB_GLOBAL,AT_DATA_NOINDIRECT,tabledef);
  1711. current_asmdata.asmlists[al_rtti].concatlist(tcb.get_final_asmlist(
  1712. rttilab,tabledef,sec_rodata,
  1713. rttilab.name,sizeof(PInt)));
  1714. tcb.free;
  1715. current_module.add_public_asmsym(rttilab);
  1716. end;
  1717. procedure enumdef_rtti_extrasyms(def:Tenumdef);
  1718. var
  1719. t:Tenumsym;
  1720. syms:tfplist;
  1721. i:longint;
  1722. rttitypesym: ttypesym;
  1723. rttidef: trecorddef;
  1724. begin
  1725. { collect enumsyms belonging to this enum type (could be a subsection
  1726. in case of a subrange type) }
  1727. syms:=tfplist.create;
  1728. for i := 0 to def.symtable.SymList.Count - 1 do
  1729. begin
  1730. t:=tenumsym(def.symtable.SymList[i]);
  1731. if t.value<def.minval then
  1732. continue
  1733. else
  1734. if t.value>def.maxval then
  1735. break;
  1736. syms.add(t);
  1737. end;
  1738. { sort the syms by enum name }
  1739. syms.sort(@enumsym_compare_name);
  1740. rttitypesym:=try_search_current_module_type(internaltypeprefixName[itp_rttidef]+def.rtti_mangledname(fullrtti));
  1741. if not assigned(rttitypesym) or
  1742. (ttypesym(rttitypesym).typedef.typ<>recorddef) then
  1743. internalerror(2015071402);
  1744. rttidef:=trecorddef(ttypesym(rttitypesym).typedef);
  1745. enumdef_rtti_string2ordindex(rttidef,syms);
  1746. { sort the syms by enum value }
  1747. syms.sort(@enumsym_compare_value);
  1748. enumdef_rtti_ord2stringindex(rttidef,syms);
  1749. syms.free;
  1750. end;
  1751. begin
  1752. case def.typ of
  1753. enumdef:
  1754. if rt=fullrtti then
  1755. begin
  1756. enumdef_rtti_extrasyms(Tenumdef(def));
  1757. end;
  1758. else
  1759. ;
  1760. end;
  1761. end;
  1762. procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
  1763. begin
  1764. case def.typ of
  1765. enumdef :
  1766. if assigned(tenumdef(def).basedef) then
  1767. write_rtti(tenumdef(def).basedef,rt);
  1768. setdef :
  1769. write_rtti(tsetdef(def).elementdef,rt);
  1770. arraydef :
  1771. begin
  1772. write_rtti(tarraydef(def).rangedef,rt);
  1773. write_rtti(tarraydef(def).elementdef,rt);
  1774. end;
  1775. recorddef :
  1776. begin
  1777. { guarantee initrtti for any record for RTTI purposes
  1778. also for fpc_initialize, fpc_finalize }
  1779. if (rt=fullrtti) then
  1780. begin
  1781. include(def.defstates,ds_init_table_used);
  1782. write_rtti(def, initrtti);
  1783. end;
  1784. fields_write_rtti(trecorddef(def).symtable,rt);
  1785. end;
  1786. objectdef :
  1787. begin
  1788. if assigned(tobjectdef(def).childof) then
  1789. write_rtti(tobjectdef(def).childof,rt);
  1790. if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
  1791. fields_write_rtti(tobjectdef(def).symtable,rt)
  1792. else
  1793. published_write_rtti(tobjectdef(def).symtable,rt);
  1794. if (rt=fullrtti) then
  1795. begin
  1796. { guarantee initrtti for any object for RTTI purposes
  1797. also for fpc_initialize, fpc_finalize }
  1798. if (tobjectdef(def).objecttype=odt_object) then
  1799. begin
  1800. include(def.defstates,ds_init_table_used);
  1801. write_rtti(def,initrtti);
  1802. end;
  1803. if (is_interface(def) or is_dispinterface(def))
  1804. and (oo_can_have_published in tobjectdef(def).objectoptions) then
  1805. methods_write_rtti(tobjectdef(def).symtable,rt,[vis_published],true);
  1806. end;
  1807. end;
  1808. classrefdef,
  1809. pointerdef:
  1810. if not is_objc_class_or_protocol(tabstractpointerdef(def).pointeddef) then
  1811. write_rtti(tabstractpointerdef(def).pointeddef,rt);
  1812. procvardef:
  1813. params_write_rtti(tabstractprocdef(def),rt,false);
  1814. else
  1815. ;
  1816. end;
  1817. end;
  1818. procedure TRTTIWriter.write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
  1819. begin
  1820. { we don't care about the real type here, because
  1821. a) we don't index into these elements
  1822. b) we may not have the rtti type available at the point that we
  1823. are emitting this data, because of forward definitions etc
  1824. c) if the rtti is emitted in another unit, we won't have the type
  1825. available at all
  1826. For the cases where the type is emitted in the current unit and hence
  1827. the underlying system will detect and complain about symbol def
  1828. mismatches, type conversions will have to be inserted afterwards (like
  1829. in llvm/llvmtype)
  1830. }
  1831. if not assigned(def) or is_void(def) or ((rt<>initrtti) and is_objc_class_or_protocol(def)) then
  1832. tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype)
  1833. else
  1834. tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,rt,true)),voidpointertype);
  1835. end;
  1836. function TRTTIWriter.ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
  1837. var
  1838. s : tsymstr;
  1839. begin
  1840. s:=def.rtti_mangledname(rt)+suffix;
  1841. result:=current_asmdata.RefAsmSymbol(s,AT_DATA,indirect);
  1842. if def.owner.moduleid<>current_module.moduleid then
  1843. current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA);
  1844. end;
  1845. procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype);
  1846. var
  1847. tcb: ttai_typedconstbuilder;
  1848. rttilab: tasmsymbol;
  1849. rttidef: tdef;
  1850. begin
  1851. { only write rtti of definitions from the current module }
  1852. if not findunitsymtable(def.owner).iscurrentunit then
  1853. exit;
  1854. { check if separate initrtti is actually needed }
  1855. if (rt=initrtti) and (not def.needs_separate_initrtti) then
  1856. rt:=fullrtti;
  1857. { prevent recursion }
  1858. if rttidefstate[rt] in def.defstates then
  1859. exit;
  1860. include(def.defstates,rttidefstate[rt]);
  1861. { write first all dependencies }
  1862. write_child_rtti_data(def,rt);
  1863. { write rtti data }
  1864. tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]);
  1865. tcb.begin_anonymous_record(
  1866. internaltypeprefixName[itp_rttidef]+tstoreddef(def).rtti_mangledname(rt),
  1867. defaultpacking,reqalign,
  1868. targetinfos[target_info.system]^.alignment.recordalignmin,
  1869. targetinfos[target_info.system]^.alignment.maxCrecordalign
  1870. );
  1871. write_rtti_data(tcb,def,rt);
  1872. rttidef:=tcb.end_anonymous_record;
  1873. rttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(rt),AB_GLOBAL,AT_DATA_NOINDIRECT,rttidef);
  1874. current_asmdata.AsmLists[al_rtti].concatList(
  1875. tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,min(target_info.alignment.maxCrecordalign,SizeOf(QWord))));
  1876. tcb.free;
  1877. current_module.add_public_asmsym(rttilab);
  1878. { write additional data }
  1879. write_rtti_extrasyms(def,rt,rttilab);
  1880. end;
  1881. constructor TRTTIWriter.create;
  1882. begin
  1883. if tf_requires_proper_alignment in target_info.flags then
  1884. begin
  1885. reqalign:=min(sizeof(QWord),target_info.alignment.maxCrecordalign);
  1886. defaultpacking:=C_alignment;
  1887. end
  1888. else
  1889. begin
  1890. reqalign:=1;
  1891. defaultpacking:=1;
  1892. end;
  1893. end;
  1894. end.