{ Copyright (c) 1998-2002 by Florian Klaempfl Routines for the code generation of RTTI data structures This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit ncgrtti; {$i fpcdefs.inc} interface uses cclasses,constexp,globtype, aasmbase,aasmcnst, symbase,symconst,symtype,symdef,symsym, parabase; type { TRTTIWriter } TRTTIWriter=class private { required internal alignment of the rtti data } reqalign: shortint; { required packing of all structures except for ttypeinfo and tpropinfo, which always use packrecords 1 } defaultpacking: shortint; { write comments ? } addcomments : boolean; procedure fields_write_rtti(st:tsymtable;rt:trttitype); procedure params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean); procedure fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype); procedure methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean); procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol); procedure published_write_rtti(def : tobjectdef;rt:trttitype); procedure properties_write_rtti_data(tcb:ttai_typedconstbuilder;propnamelist:TFPHashObjectList;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities); procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint); procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint); procedure collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities); { only use a direct reference if the referenced type can *only* reside in the same unit as the current one } function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol; procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef); procedure write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype); procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype); procedure write_attribute_data(tcb: ttai_typedconstbuilder;attr_list:trtti_attribute_list); procedure write_child_rtti_data(def:tdef;rt:trttitype); procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype); procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities); procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte); function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte; procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef); procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara); procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym); procedure write_param(tcb:ttai_typedconstbuilder;para:tparavarsym); procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator); procedure maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string); inline; public constructor create; procedure write_rtti(def:tdef;rt:trttitype); procedure write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline; procedure write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); inline; function get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline; function get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline; function get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline; end; { generate RTTI and init tables } procedure write_persistent_type_info(st:tsymtable;is_global:boolean); var RTTIWriter : TRTTIWriter; implementation uses cutils, globals,verbose,systems, node,ncal,ncon, fmodule, procinfo, symtable,symutil, aasmtai,aasmdata, defutil, paramgr ; const rttidefstate : array[trttitype] of tdefstate = (ds_rtti_table_written,ds_init_table_written, { Objective-C related, does not pass here } symconst.ds_none,symconst.ds_none, symconst.ds_none,symconst.ds_none); rttitypenames : array[trttitype] of string = ('full','init', 'objcmeta','objcmetaro', 'objcclass','objcclassro'); type TPropNameListItem = class(TFPHashObject) propindex : longint; propowner : TSymtable; end; function visibility_to_rtti_flags(vis: tvisibility): byte; begin case vis of vis_private: result:=byte(rv_private); vis_strictprivate: begin result:=byte(rv_private); // add bit to indicate "strict" result:=result or (1 shl 2); end; vis_protected: result:=byte(rv_protected); vis_strictprotected: begin result:=byte(rv_protected); // add bit to indicate "strict" result:=result or (1 shl 2); end; vis_public: result:=byte(rv_public); vis_published: result:=byte(rv_published); otherwise internalerror(2021061301); end; end; procedure write_persistent_type_info(st: tsymtable; is_global: boolean); var i : longint; def : tdef; begin { no Delphi-style RTTI for managed platforms } if target_info.system in systems_managed_vm then exit; for i:=0 to st.DefList.Count-1 do begin def:=tdef(st.DefList[i]); { skip generics } if [df_generic,df_genconstraint]*def.defoptions<>[] then continue; case def.typ of recorddef: write_persistent_type_info(trecorddef(def).symtable,is_global); objectdef : begin { Skip forward defs } if (oo_is_forward in tobjectdef(def).objectoptions) then continue; { skip unique type aliases, they use the RTTI from the parent class } if tobjectdef(def).is_unique_objpasdef then continue; write_persistent_type_info(tobjectdef(def).symtable,is_global); end; procdef : begin if assigned(tprocdef(def).localst) and (tprocdef(def).localst.symtabletype=localsymtable) then write_persistent_type_info(tprocdef(def).localst,false); if assigned(tprocdef(def).parast) then write_persistent_type_info(tprocdef(def).parast,false); end; errordef: { we shouldn't have come this far if we have an errordef somewhere } internalerror(2017010701); undefineddef: { don't write any RTTI for these } continue; else ; end; { always generate persistent tables for types in the interface so they can be reused in other units and give always the same pointer location. } { Init } if ( assigned(def.typesym) and is_global and not is_objc_class_or_protocol(def) ) or is_managed_type(def) or (ds_init_table_used in def.defstates) then RTTIWriter.write_rtti(def,initrtti); { RTTI } if not(df_internal in def.defoptions) and ( ( assigned(def.typesym) and is_global and not is_objc_class_or_protocol(def) ) or (ds_rtti_table_used in def.defstates) ) then RTTIWriter.write_rtti(def,fullrtti); end; end; {*************************************************************************** TRTTIWriter ***************************************************************************} function TRTTIWriter.get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; begin result:=ref_rtti(def,rt,indirect,''); end; function TRTTIWriter.get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; begin result:=ref_rtti(def,rt,indirect,'_o2s'); end; function TRTTIWriter.get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; begin result:=ref_rtti(def,rt,indirect,'_s2o'); end; procedure TRTTIWriter.write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;extended_rtti:boolean;visibilities:tvisibilities); var rtticount, totalcount, i,j,k : longint; sym : tprocsym; def : tprocdef; para : tparavarsym; begin maybe_add_comment(tcb,'RTTI: begin methods'); tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); totalcount:=0; rtticount:=0; for i:=0 to st.symlist.count-1 do if tsym(st.symlist[i]).typ=procsym then begin sym:=tprocsym(st.symlist[i]); inc(totalcount,sym.procdeflist.count); for j:=0 to sym.procdeflist.count-1 do begin def:=tprocdef(sym.procdeflist[j]); if (def.visibility in visibilities) and not (def.is_generic) then inc(rtticount); end; end; { write the count section for non-extended methods } if not extended_rtti then begin maybe_add_comment(tcb,#9'count'); tcb.emit_ord_const(totalcount,u16inttype); maybe_add_comment(tcb,#9'RTTI count'); if rtticount=0 then tcb.emit_ord_const($FFFF,u16inttype) else tcb.emit_ord_const(rtticount,u16inttype); end; if rtticount>0 then for i:=0 to st.symlist.count-1 do if tsym(st.symlist[i]).typ=procsym then begin sym:=tprocsym(st.symlist[i]); for j:=0 to sym.procdeflist.count-1 do begin def:=tprocdef(sym.procdeflist[j]); if (def.is_generic) or not (def.visibility in visibilities) then continue; def.init_paraloc_info(callerside); maybe_add_comment(tcb,'RTTI: begin method '+def.fullprocname(false)); tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); maybe_add_comment(tcb,#9'return type'); write_rtti_reference(tcb,def.returndef,fullrtti); maybe_add_comment(tcb,#9'calling convention'); write_callconv(tcb,def); maybe_add_comment(tcb,#9'method kind'); write_methodkind(tcb,def); maybe_add_comment(tcb,#9'param count'); tcb.emit_ord_const(def.paras.count,u16inttype); maybe_add_comment(tcb,#9'caller args size'); tcb.emit_ord_const(def.callerargareasize,sizesinttype); maybe_add_comment(tcb,#9'invoke helper'); if def.invoke_helper=nil then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidcodepointertype) else tcb.emit_procdef_const(def.invoke_helper); maybe_add_comment(tcb,#9'name'); tcb.emit_pooled_shortstring_const_ref(sym.realname); if extended_rtti then begin { write visibility section for extended RTTI } maybe_add_comment(tcb,#9'visibility'); tcb.emit_ord_const(visibility_to_rtti_flags(def.visibility),u8inttype); { for objects and classes write a VMT index } if st.defowner.typ=objectdef then begin maybe_add_comment(tcb,#9'VMT index'); tcb.emit_ord_const(def.extnumber,u16inttype); end; maybe_add_comment(tcb,#9'Code Address'); tcb.emit_procdef_const(def); maybe_add_comment(tcb,#9'Attribute table'); write_attribute_data(tcb,def.rtti_attribute_list); end; for k:=0 to def.paras.count-1 do write_param(tcb,tparavarsym(def.paras[k])); if not is_void(def.returndef) then begin maybe_add_comment(tcb,#9'return loc'); write_paralocs(tcb,@def.funcretloc[callerside]); end; tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI: end method '+def.fullprocname(false)); end; end; tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI: end methods'); end; procedure TRTTIWriter.write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte); var name: shortstring; begin if assigned(def.typesym) then name:=ttypesym(def.typesym).realname else name:=''; { TTypeInfo, always packed and doesn't need alignment } tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_header]+tostr(length(name)),1,1, targetinfos[target_info.system]^.alignment.recordalignmin); if def.typ=arraydef then InternalError(201012211); tcb.emit_tai(Tai_const.Create_8bit(typekind),u8inttype); tcb.emit_shortstring_const(name); tcb.end_anonymous_record; end; function TRTTIWriter.write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte; begin case def.proctypeoption of potype_constructor: result:=mkConstructor; potype_destructor: result:=mkDestructor; potype_class_constructor: result:=mkClassConstructor; potype_class_destructor: result:=mkClassDestructor; potype_operator: result:=mkOperatorOverload; potype_procedure: if po_classmethod in def.procoptions then result:=mkClassProcedure else result:=mkProcedure; potype_function: if po_classmethod in def.procoptions then result:=mkClassFunction else result:=mkFunction; else begin if def.returndef = voidtype then result:=mkProcedure else result:=mkFunction; end; end; tcb.emit_ord_const(result,u8inttype); end; procedure TRTTIWriter.write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef); const ProcCallOptionToCallConv: array[tproccalloption] of byte = ( { pocall_none } 0, { pocall_cdecl } 1, { pocall_cppdecl } 5, { pocall_far16 } 6, { pocall_oldfpccall } 7, { pocall_internproc } 8, { pocall_syscall } 9, { pocall_pascal } 2, { pocall_register } 0, { pocall_safecall } 4, { pocall_stdcall } 3, { pocall_softfloat } 10, { pocall_mwpascal } 11, { pocall_interrupt } 12, { pocall_hardfloat } 13, { pocall_sysv_abi_default } 14, { pocall_sysv_abi_cdecl } 15, { pocall_ms_abi_default } 16, { pocall_ms_abi_cdecl } 17, { pocall_vectorcall } 18 ); begin tcb.emit_ord_const(ProcCallOptionToCallConv[def.proccalloption],u8inttype); end; procedure TRTTIWriter.write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara); var locs : trttiparalocs; i : longint; pool : THashSet; entry : PHashSetItem; loclab : TAsmLabel; loctcb : ttai_typedconstbuilder; datadef : tdef; begin locs:=paramanager.cgparalocs_to_rttiparalocs(para^.location); if length(locs)>high(byte) then internalerror(2017010601); if length(locs)=0 then begin { *shrugs* } tcb.emit_tai(Tai_const.Create_nil_codeptr,voidpointertype); exit; end; { do we have such a paraloc already in the pool? } pool:=current_asmdata.ConstPools[sp_paraloc]; entry:=pool.FindOrAdd(@locs[0],length(locs)*sizeof(trttiparaloc)); if not assigned(entry^.Data) then begin current_asmdata.getglobaldatalabel(loclab); loctcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]); loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); loctcb.emit_ord_const(length(locs),u8inttype); for i:=low(locs) to high(locs) do begin loctcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); loctcb.emit_ord_const(locs[i].loctype,u8inttype); loctcb.emit_ord_const(locs[i].regsub,u8inttype); loctcb.emit_ord_const(locs[i].regindex,u16inttype); { the corresponding type for aint is alusinttype } loctcb.emit_ord_const(locs[i].offset,alusinttype); loctcb.end_anonymous_record; end; datadef:=loctcb.end_anonymous_record; current_asmdata.asmlists[al_typedconsts].concatList( loctcb.get_final_asmlist(loclab,datadef,sec_rodata_norel,loclab.name,const_align(sizeof(pint))) ); loctcb.free; entry^.data:=loclab; end else loclab:=TAsmLabel(entry^.Data); tcb.emit_tai(Tai_const.Create_sym(loclab),voidpointertype); end; procedure TRTTIWriter.write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym); var paraspec : word; begin case parasym.varspez of vs_value : paraspec := 0; vs_const : paraspec := pfConst; vs_var : paraspec := pfVar; vs_out : paraspec := pfOut; vs_constref: paraspec := pfConstRef; else internalerror(2013112904); end; { Kylix also seems to always add both pfArray and pfReference in this case } if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then paraspec:=paraspec or pfArray or pfReference; { and these for classes and interfaces (maybe because they are themselves addresses?) } if is_class_or_interface(parasym.vardef) then paraspec:=paraspec or pfAddress; { flags for the hidden parameters } if vo_is_hidden_para in parasym.varoptions then paraspec:=paraspec or pfHidden; if vo_is_high_para in parasym.varoptions then paraspec:=paraspec or pfHigh; if vo_is_self in parasym.varoptions then paraspec:=paraspec or pfSelf; if vo_is_vmt in parasym.varoptions then paraspec:=paraspec or pfVmt; if vo_is_funcret in parasym.varoptions then paraspec:=paraspec or pfResult; { set bits run from the highest to the lowest bit on big endian systems } if (target_info.endian = endian_big) then paraspec:=reverse_word(paraspec); { write flags for current parameter } tcb.emit_ord_const(paraspec,u16inttype); end; procedure TRTTIWriter.write_param(tcb: ttai_typedconstbuilder; para: tparavarsym); begin maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname); tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); maybe_add_comment(tcb,#9'type'); if is_open_array(para.vardef) or is_array_of_const(para.vardef) then write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti) else if para.vardef=cformaltype then write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,para.vardef,fullrtti); maybe_add_comment(tcb,#9'flags'); write_param_flag(tcb,para); maybe_add_comment(tcb,#9'name'); tcb.emit_pooled_shortstring_const_ref(para.realname); maybe_add_comment(tcb,#9'locs'); write_paralocs(tcb,@para.paraloc[callerside]); tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI: end param '+para.prettyname); end; function compare_mop_offset_entry(item1,item2:pointer):longint; var entry1: pmanagementoperator_offset_entry absolute item1; entry2: pmanagementoperator_offset_entry absolute item2; begin if entry1^.offsetentry2^.offset then result:=1 else result:=0; end; procedure TRTTIWriter.write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator); var list : tfplist; datatcb : ttai_typedconstbuilder; tbllbl : TAsmLabel; entry : pmanagementoperator_offset_entry; datadef,entrydef : tdef; i : longint; pdef : tobjectdef; begin list:=tfplist.create; tabstractrecordsymtable(def.symtable).get_managementoperator_offset_list(mop,list); if (def.typ=objectdef) then begin pdef:=tobjectdef(def).childof; while assigned(pdef) do begin tabstractrecordsymtable(pdef.symtable).get_managementoperator_offset_list(mop,list); pdef:=pdef.childof; end; list.sort(@compare_mop_offset_entry); end; if list.count=0 then tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype) else begin tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',datatcb,tbllbl); datatcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); datatcb.emit_ord_const(list.count,u32inttype); entrydef:=get_recorddef(itp_init_mop_offset_entry,[voidcodepointertype,sizeuinttype],defaultpacking); for i:=0 to list.count-1 do begin entry:=pmanagementoperator_offset_entry(list[i]); datatcb.maybe_begin_aggregate(entrydef); datatcb.queue_init(voidcodepointertype); datatcb.queue_emit_proc(entry^.pd); datatcb.queue_init(sizeuinttype); datatcb.queue_emit_ordconst(entry^.offset,sizeuinttype); datatcb.maybe_end_aggregate(entrydef); dispose(entry); end; datadef:=datatcb.end_anonymous_record; tcb.finish_internal_data_builder(datatcb,tbllbl,datadef,sizeof(pint)); tcb.emit_tai(tai_const.Create_sym(tbllbl),voidpointertype); end; list.free; end; procedure TRTTIWriter.write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef); begin if is_open_array(def) then { open arrays never have a typesym with a name, since you cannot define an "open array type". Kylix prints the type of the elements in the array in this case (so together with the pfArray flag, you can reconstruct the full typename, I assume (JM)) } def:=tarraydef(def).elementdef; { name } if assigned(def.typesym) then tcb.emit_shortstring_const(ttypesym(def.typesym).realname) else tcb.emit_shortstring_const(''); end; procedure TRTTIWriter.write_common_rtti_data(tcb:ttai_typedconstbuilder;def:tdef;rt:trttitype); begin if rt<>fullrtti then write_attribute_data(tcb,nil) else write_attribute_data(tcb,tstoreddef(def).rtti_attribute_list); end; { writes a 32-bit count followed by array of field infos for given symtable } procedure TRTTIWriter.fields_write_rtti_data(tcb: ttai_typedconstbuilder; def: tabstractrecorddef; rt: trttitype); var i : longint; sym : tsym; fieldcnt: longint; st: tsymtable; fields: tfplist; parentrtti: boolean; begin fieldcnt:=0; parentrtti:=false; st:=def.symtable; fields:=tfplist.create; fields.capacity:=st.symlist.count+1; { For objects, treat parent (if any) as a field with offset 0. This provides correct handling of entire instance with RTL rtti routines. } if (def.typ=objectdef) and (tobjectdef(def).objecttype=odt_object) and Assigned(tobjectdef(def).childof) and ((rt=fullrtti) or (tobjectdef(def).childof.needs_inittable)) then begin parentrtti:=true; inc(fieldcnt); end; for i:=0 to st.SymList.Count-1 do begin sym:=tsym(st.SymList[i]); if is_normal_fieldvarsym(sym) and ( (rt=fullrtti) or tfieldvarsym(sym).vardef.needs_inittable ) and not is_objc_class_or_protocol(tfieldvarsym(sym).vardef) then begin fields.add(tfieldvarsym(sym)); inc(fieldcnt); end; end; { insert field count before data } maybe_add_comment(tcb,'Field count'); tcb.emit_ord_const(fieldcnt,u32inttype); { parent object? } if parentrtti then begin write_rtti_reference(tcb,tobjectdef(def).childof,rt); tcb.emit_ord_const(0,ptruinttype); end; { fields } for i:=0 to fields.count-1 do begin sym:=tsym(fields[i]); maybe_add_comment(tcb,'RTTI begin field '+tostr(i)+': '+sym.prettyname); write_rtti_reference(tcb,tfieldvarsym(sym).vardef,rt); tcb.emit_ord_const(tfieldvarsym(sym).fieldoffset,sizeuinttype); maybe_add_comment(tcb,'RTTI end field '+tostr(i)+': '+sym.prettyname); end; fields.free; end; procedure TRTTIWriter.fields_write_rtti(st:tsymtable;rt:trttitype); var i : longint; sym : tsym; begin for i:=0 to st.SymList.Count-1 do begin sym:=tsym(st.SymList[i]); if is_normal_fieldvarsym(sym) and ( (rt=fullrtti) or tfieldvarsym(sym).vardef.needs_inittable ) then write_rtti(tfieldvarsym(sym).vardef,rt); end; end; procedure TRTTIWriter.params_write_rtti(def:tabstractprocdef;rt:trttitype;allow_hidden:boolean); var i : longint; sym : tparavarsym; begin for i:=0 to def.paras.count-1 do begin sym:=tparavarsym(def.paras[i]); if not (vo_is_hidden_para in sym.varoptions) or allow_hidden then begin if is_open_array(sym.vardef) or is_array_of_const(sym.vardef) then write_rtti(tarraydef(sym.vardef).elementdef,rt) else write_rtti(sym.vardef,rt); end; end; end; procedure TRTTIWriter.methods_write_rtti(st:tsymtable;rt:trttitype;visibilities:tvisibilities;allow_hidden:boolean); var i,j : longint; sym : tprocsym; def : tabstractprocdef; begin for i:=0 to st.symlist.count-1 do if tsym(st.symlist[i]).typ=procsym then begin sym:=tprocsym(st.symlist[i]); for j:=0 to sym.procdeflist.count-1 do begin def:=tabstractprocdef(sym.procdeflist[j]); write_rtti(def.returndef,rt); params_write_rtti(def,rt,allow_hidden); end; end; end; procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint); var methodcount, i, j: longint; sym: tprocsym; pdef : tprocdef; begin { count methods } methodcount:=0; for i:=0 to def.symtable.symlist.count-1 do if tsym(def.symtable.symlist[i]).typ=procsym then begin sym:=tprocsym(def.symtable.symlist[i]); for j:=0 to sym.procdeflist.count-1 do begin pdef:=tprocdef(sym.procdeflist[j]); if (not pdef.is_generic) and def.is_visible_for_rtti(ro_methods,pdef.visibility) then inc(methodcount); end; end; tcb.begin_anonymous_record('',packrecords,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); { emit method count } maybe_add_comment(tcb,'RTTI Method table: method count'); tcb.emit_ord_const(methodcount,u16inttype); { emit method entries (array) } if methodcount>0 then write_methods(tcb,def.symtable,true,def.rtti_visibilities_for_option(ro_methods)); tcb.end_anonymous_record; end; procedure TRTTIWriter.write_extended_method_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); begin write_extended_method_table(tcb,def,defaultpacking); end; procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;packrecords:longint); var i,cnt: integer; asym: tsym; fldsym : tfieldvarsym; list: TFPList; begin list:=TFPList.Create; { build list of visible fields } for i:=0 to def.symtable.symlist.Count-1 do begin asym:=tsym(def.symtable.symlist[i]); if (asym.typ=fieldvarsym) and not(sp_static in asym.symoptions) and def.is_visible_for_rtti(ro_fields, asym.visibility) then list.add(asym); end; { TExtendedFieldTable = record FieldCount: Word; Fields: array[0..0] of TExtendedFieldInfo; end; } tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_table]+tostr(list.count),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin); maybe_add_comment(tcb,'RTTI: Extended Field count'); tcb.emit_ord_const(list.count,u16inttype); for i := 0 to list.count-1 do begin fldsym:=tfieldvarsym(list[i]); { TExtendedFieldInfo = record FieldOffset: SizeUInt; FieldType: Pointer; FieldVisibility: Byte; Name: PShortString; Attributes : end; } tcb.begin_anonymous_record(internaltypeprefixName[itp_extended_rtti_field]+tostr(fldsym.fieldoffset),packrecords,min(reqalign,SizeOf(PInt)),targetinfos[target_info.system]^.alignment.recordalignmin); { FieldOffset } tcb.emit_tai(Tai_const.Create_sizeint(fldsym.fieldoffset),sizeuinttype); { FieldType: PPTypeInfo } if is_objc_class_or_protocol(fldsym.vardef) then tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(voidpointertype,fullrtti,true)),voidpointertype) else tcb.emit_tai(Tai_const.Create_sym(RTTIWriter.get_rtti_label(fldsym.vardef,fullrtti,true)),voidpointertype); { FieldVisibility } tcb.emit_ord_const(visibility_to_rtti_flags(fldsym.visibility),u8inttype); { Name } tcb.emit_pooled_shortstring_const_ref(fldsym.realname); { Attribute table } if assigned(fldsym.rtti_attribute_list) and assigned(fldsym.rtti_attribute_list.rtti_attributes) then cnt:=fldsym.rtti_attribute_list.rtti_attributes.count else cnt:=0; write_attribute_data(tcb,fldsym.rtti_attribute_list); tcb.end_anonymous_record; end; tcb.end_anonymous_record; list.free; end; procedure TRTTIWriter.write_extended_field_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef); begin write_extended_field_table(tcb,def,defaultpacking); end; procedure TRTTIWriter.published_write_rtti(def : tobjectdef;rt:trttitype); var i : longint; st : tsymtable; sym : tsym; begin st:=def.symtable; for i:=0 to st.SymList.Count-1 do begin sym:=tsym(st.SymList[i]); if (sym.visibility=vis_published) or def.is_visible_for_rtti(ro_properties, sym.visibility) then begin case tsym(sym).typ of propertysym: write_rtti(tpropertysym(sym).propdef,rt); fieldvarsym: write_rtti(tfieldvarsym(sym).vardef,rt); else ; end; end; end; end; procedure TRTTIWriter.collect_propnamelist(propnamelist:TFPHashObjectList;def:tabstractrecorddef;visibilities:tvisibilities); var i : longint; sym : tsym; pn : tpropnamelistitem; begin { search into parent for objects } if def.typ=objectdef then begin if assigned(tobjectdef(def).childof) then collect_propnamelist(propnamelist,tobjectdef(def).childof,visibilities); end; for i:=0 to def.symtable.SymList.Count-1 do begin sym:=tsym(def.symtable.SymList[i]); if (tsym(sym).typ=propertysym) and (sym.visibility in visibilities) then begin pn:=TPropNameListItem(propnamelist.Find(tsym(sym).name)); if not assigned(pn) then begin pn:=tpropnamelistitem.create(propnamelist,tsym(sym).name); pn.propindex:=propnamelist.count-1; pn.propowner:=tsym(sym).owner; end; end; end; end; procedure TRTTIWriter.properties_write_rtti_data(tcb: ttai_typedconstbuilder; propnamelist:TFPHashObjectList; st:tsymtable; extended_rtti:boolean; visibilities:tvisibilities); var i : longint; sym : tsym; proctypesinfo : byte; propnameitem : tpropnamelistitem; propdefname : string; tbltcb : ttai_typedconstbuilder; tbllab : tasmlabel; tbldef : tdef; visbyte : byte; procedure writeaccessproc(tcb: ttai_typedconstbuilder; pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte); var typvalue : byte; hp : ppropaccesslistitem; extnumber: longint; address,space : longint; def : tdef; hpropsym : tpropertysym; propaccesslist : tpropaccesslist; begin hpropsym:=tpropertysym(sym); repeat propaccesslist:=hpropsym.propaccesslist[pap]; if not propaccesslist.empty then break; hpropsym:=hpropsym.overriddenpropsym; until not assigned(hpropsym); if not(assigned(propaccesslist) and assigned(propaccesslist.firstsym)) then begin tcb.emit_tai(Tai_const.Create_int_codeptr(unsetvalue),codeptruinttype); typvalue:=3; end { also for accessing class fields } else if propaccesslist.firstsym^.sym.typ=fieldvarsym then begin address:=0; hp:=propaccesslist.firstsym; def:=nil; while assigned(hp) do begin case hp^.sltype of sl_load : begin def:=tfieldvarsym(hp^.sym).vardef; inc(address,tfieldvarsym(hp^.sym).fieldoffset); end; sl_subscript : begin if not(assigned(def) and ((def.typ=recorddef) or is_object(def))) then internalerror(200402171); inc(address,tfieldvarsym(hp^.sym).fieldoffset); def:=tfieldvarsym(hp^.sym).vardef; end; sl_vec : begin if not(assigned(def) and (def.typ=arraydef)) then internalerror(200402172); def:=tarraydef(def).elementdef; {Hp.value is a Tconstexprint, which can be rather large, sanity check for longint overflow.} space:=(high(address)-address) div def.size; if int64(space)paravarsym then Internalerror(2024103101); write_param(paramtcb,tparavarsym(paramst.symlist[i])); end; paramdef:=paramtcb.end_anonymous_record; tcb.finish_internal_data_builder(paramtcb,paramlbl,paramdef,sizeof(pint)); tcb.emit_tai(tai_const.Create_sym(paramlbl),voidpointertype); end; function write_propinfo_data(tcb: ttai_typedconstbuilder; sym: tpropertysym): tdef; begin { we can only easily reuse defs if the property is not stored, because otherwise the rtti layout depends on how the "stored" is defined (field, indexed expression, virtual method, ...) } if not(ppo_stored in sym.propoptions) then propdefname:=internaltypeprefixName[itp_rtti_prop]+tostr(length(sym.realname)) else propdefname:=''; { TPropInfo is a packed record (even on targets that require alignment), but it starts aligned } if addcomments then if assigned(st.name) then tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+' (class/rec: '+st.name^+')') else tcb.emit_comment('RTTI: begin propinfo record '+sym.realname+'(anon)'); tcb.begin_anonymous_record( propdefname, 1,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); if ppo_indexed in sym.propoptions then proctypesinfo:=$40 else proctypesinfo:=0; if addcomments then tcb.emit_comment(#9'type info '+sym.Name+' (Type: '+sym.propdef.GetTypeName+')'); write_rtti_reference(tcb,sym.propdef,fullrtti); if addcomments then tcb.emit_comment(#9'read access'); writeaccessproc(tcb,palt_read,0,0); if addcomments then tcb.emit_comment(#9'write access'); writeaccessproc(tcb,palt_write,2,0); { is it stored ? } if addcomments then tcb.emit_comment(#9'stored ?'); if not(ppo_stored in sym.propoptions) then begin { no, so put a constant zero } tcb.emit_tai(Tai_const.Create_nil_codeptr,codeptruinttype); proctypesinfo:=proctypesinfo or (3 shl 4); end else writeaccessproc(tcb,palt_stored,4,1); { maybe; if no procedure put a constant 1 (=true) } if addcomments then tcb.emit_comment(#9'Index'); tcb.emit_ord_const(sym.index,u32inttype); if addcomments then tcb.emit_comment(#9'default'); tcb.emit_ord_const(sym.default,u32inttype); propnameitem:=TPropNameListItem(propnamelist.Find(sym.name)); if not assigned(propnameitem) then internalerror(200512201); if addcomments then tcb.emit_comment(#9'property index'); tcb.emit_ord_const(propnameitem.propindex,u16inttype); if addcomments then tcb.emit_comment(#9'proc types'); tcb.emit_ord_const(proctypesinfo,u8inttype); if addcomments then tcb.emit_comment(#9'is static prop'); tcb.emit_ord_const(ord(sp_static in sym.symoptions),pasbool1type); { index parameters } if addcomments then tcb.emit_comment(#9'indexed params'); if extended_rtti and assigned(tpropertysym(sym).parast) then write_prop_params(tcb,sym.parast) else tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype); { write reference to attribute table } if addcomments then tcb.emit_comment(#9'attributes'); write_attribute_data(tcb,sym.rtti_attribute_list); { write property name } if addcomments then tcb.emit_comment(#9'name'); tcb.emit_shortstring_const(sym.realname); result:=tcb.end_anonymous_record; if addcomments then tcb.emit_comment('RTTI: End propinfo record '+sym.realname); end; begin tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); if extended_rtti then maybe_add_comment(tcb,'RTTI: Extended property data: Property count') else maybe_add_comment(tcb,'RTTI: Legacy property data: Property count'); tcb.emit_ord_const(properties_count(st),u16inttype); for i:=0 to st.SymList.Count-1 do begin sym:=tsym(st.SymList[i]); if (sym.typ=propertysym) and (sym.visibility in visibilities) and (extended_rtti or (tpropertysym(sym).parast=Nil)) then begin if extended_rtti then begin { TPropInfoEx = record Flags: Byte; Info: PPropInfo; // AttrData: TAttrData end; } maybe_add_comment(tcb,'RTTI: begin property '+sym.prettyname); tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); { write visiblity flags for extended RTTI } maybe_add_comment(tcb,#9'visibility flags'); visbyte:=byte(visibility_to_rtti_flags(sym.visibility)); tcb.emit_ord_const(visByte,u8inttype); { create separate constant builder } current_asmdata.getglobaldatalabel(tbllab); tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]); { write TPropInfo record } tbldef:=write_propinfo_data(tbltcb,tpropertysym(sym)); current_asmdata.asmlists[al_rtti].concatlist( tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint))) ); tbltcb.free; { write the pointer to the prop info } maybe_add_comment(tcb,#9'property info reference'); tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype); { end record } tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI: end property '+sym.prettyname); end else if not (sp_static in sym.symoptions) then write_propinfo_data(tcb,tpropertysym(sym)); end; end; tcb.end_anonymous_record; end; procedure TRTTIWriter.write_rtti_data(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype); procedure unknown_rtti(def:tstoreddef); begin tcb.emit_ord_const(tkUnknown,u8inttype); write_rtti_name(tcb,def); write_common_rtti_data(tcb,def,rt); end; procedure variantdef_rtti(def:tvariantdef); begin write_header(tcb,def,tkVariant); write_common_rtti_data(tcb,def,rt); end; procedure stringdef_rtti(def:tstringdef); const string_typekinds: array[tstringtype] of byte = ( tkSString,tkLString,tkAString,tkWString,tkUString ); begin write_header(tcb,def,string_typekinds[def.stringtype]); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_outer]+tostr(string_typekinds[def.stringtype]), defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); case def.stringtype of st_ansistring: begin tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]), defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(def.encoding,u16inttype); tcb.end_anonymous_record; end; st_shortstring: begin tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_case]+tostr(string_typekinds[def.stringtype]), defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(def.len,u8inttype); tcb.end_anonymous_record; end; st_widestring, st_unicodestring, st_longstring: { nothing } ; end; tcb.end_anonymous_record; end; procedure enumdef_rtti(def: tenumdef); var i : integer; hp : tenumsym; begin write_header(tcb,def,tkEnumeration); { align; the named fields are so that we can let the compiler calculate the string offsets later on } tcb.next_field_name:='size_start_rec'; { add a typename so that it can be reused when writing the the s2o and o2s arrays for llvm (otherwise we have to write out the entire type definition every time we access an element from this record) } tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec]+def.unique_id_str,defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.next_field_name:='typ_union_rec'; tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_size_start_rec2]+def.unique_id_str,defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); case longint(def.size) of 1 : tcb.emit_ord_const(otUByte,u8inttype); 2 : tcb.emit_ord_const(otUWord,u8inttype); 4 : tcb.emit_ord_const(otULong,u8inttype); end; { we need to align by Tconstptruint here to satisfy the alignment rules set by records: in the typinfo unit we overlay a TTypeData record on this data, which at the innermost variant record needs an alignment of TConstPtrUint due to e.g. the "CompType" member for tkSet (also the "BaseType" member for tkEnumeration). We need to adhere to this, otherwise things will break. } tcb.next_field_name:='min_max_rec'; tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_min_max_rec]+def.unique_id_str,defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(def.min,s32inttype); tcb.emit_ord_const(def.max,s32inttype); tcb.next_field_name:='basetype_array_rec'; { all strings must appear right after each other -> from now on packrecords 1 (but the start must still be aligned) } tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_enum_basetype_array_rec]+def.unique_id_str,1,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { write base type } write_rtti_reference(tcb,def.basedef,rt); for i:=0 to def.symtable.SymList.Count-1 do begin hp:=tenumsym(def.symtable.SymList[i]); if hp.valuedef.maxval then break; tcb.next_field_name:=hp.name; tcb.emit_shortstring_const(hp.realname); end; { write unit name } tcb.emit_shortstring_const(current_module.realmodulename^); { write zero which is required by RTL } tcb.emit_ord_const(0,u8inttype); { terminate all records } tcb.end_anonymous_record; tcb.end_anonymous_record; tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure orddef_rtti(def:torddef); procedure doint32_64(typekind: byte;min,max:int64); const trans : array[tordtype] of byte = (otUByte{otNone}, otUByte,otUWord,otULong,otUQWord,otUByte{otNone}, otSByte,otSWord,otSLong,otSQWord,otUByte{otNone}, otUByte,otUByte,otUWord,otULong,otUQWord, otSByte,otSWord,otSLong,otSQWord, otUByte,otUWord,otUByte,255); var elesize: string[1]; deftrans: byte; begin write_header(tcb,def,typekind); deftrans:=trans[def.ordtype]; case deftrans of otUQWord, otSQWord: elesize:='8'; 255: begin if def.packedbitsize<=32 then begin elesize:='4'; if def.low<0 then deftrans:=otSLong else deftrans:=otULong; end else begin elesize:='8'; if def.low<0 then deftrans:=otSQWord else deftrans:=otUQWord; end; end else elesize:='4' end; tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_ord_outer]+elesize, defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_ord_middle]+elesize, defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(byte(trans[def.ordtype]),u8inttype); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_ord_inner]+elesize, defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); {Convert to longint to smuggle values in high(longint)+1..high(cardinal) into asmlist.} case deftrans of otUQWord: begin tcb.emit_ord_const(min,u64inttype); tcb.emit_ord_const(max,u64inttype); end; otSQWord: begin tcb.emit_ord_const(min,s64inttype); tcb.emit_ord_const(max,s64inttype); end; else begin tcb.emit_ord_const(longint(min),s32inttype); tcb.emit_ord_const(longint(max),s32inttype); end; end; tcb.end_anonymous_record; tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure dointeger(typekind:byte);inline; begin doint32_64(typekind,int64(def.low.svalue),int64(def.high.svalue)); end; begin case def.ordtype of s64bit : dointeger(tkInt64); u64bit : dointeger(tkQWord); pasbool1, pasbool8, pasbool16, pasbool32, pasbool64: dointeger(tkBool); { use different low/high values to be Delphi compatible } bool8bit, bool16bit, bool32bit: doint32_64(tkBool,longint(low(longint)),longint(high(longint))); bool64bit: doint32_64(tkBool,low(int64),high(int64)); uchar: dointeger(tkChar); uwidechar: dointeger(tkWChar); scurrency: begin write_header(tcb,def,tkFloat); tcb.begin_anonymous_record( internaltypeprefixName[itp_1byte], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.emit_ord_const(ftCurr,u8inttype); tcb.end_anonymous_record; end; else dointeger(tkInteger); end; end; procedure floatdef_rtti(def:tfloatdef); const {tfloattype = (s32real,s64real,s80real,sc80real,s64bit,s128bit);} translate : array[tfloattype] of byte = (ftSingle,ftDouble,ftExtended,ftExtended,ftComp,ftCurr,ftFloat128); begin write_header(tcb,def,tkFloat); tcb.begin_anonymous_record( internaltypeprefixName[itp_1byte], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_float], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(translate[def.floattype],u8inttype); tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure setdef_rtti(def:tsetdef); begin write_header(tcb,def,tkSet); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_set_outer], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_set_middle], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); case def.size of 1: tcb.emit_ord_const(otUByte,u8inttype); 2: tcb.emit_ord_const(otUWord,u8inttype); 4: tcb.emit_ord_const(otULong,u8inttype); else tcb.emit_ord_const(otUByte,u8inttype); end; tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_set_inner], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); tcb.emit_ord_const(def.size,sizesinttype); write_rtti_reference(tcb,def.elementdef,rt); tcb.end_anonymous_record; tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure arraydef_rtti(def:tarraydef); var i,dimcount: byte; totalcount: asizeuint; finaldef: tdef; curdef:tarraydef; begin if ado_IsDynamicArray in def.arrayoptions then tcb.emit_ord_const(tkDynArray,u8inttype) else tcb.emit_ord_const(tkArray,u8inttype); write_rtti_name(tcb,def); if not(ado_IsDynamicArray in def.arrayoptions) then begin { remember tha last instruction. we will need to insert some calculated values after it } finaldef:=def; totalcount:=1; dimcount:=0; repeat curdef:=tarraydef(finaldef); finaldef:=curdef.elementdef; { Dims[i] PTypeInfo } inc(dimcount); totalcount:=totalcount*curdef.elecount; until (finaldef.typ<>arraydef) or (ado_IsDynamicArray in tarraydef(finaldef).arrayoptions); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_normal_array]+tostr(dimcount), defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_normal_array_inner]+tostr(dimcount), defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { total size = elecount * elesize of the first arraydef } tcb.emit_tai(Tai_const.Create_sizeint(def.elecount*def.elesize),sizeuinttype); { total element count } tcb.emit_tai(Tai_const.Create_sizeint(asizeint(totalcount)),sizeuinttype); { last dimension element type } if is_objc_class_or_protocol(curdef.elementdef) then tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(voidpointertype,rt,true)),voidpointertype) else tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(curdef.elementdef,rt,true)),voidpointertype); { dimension count } tcb.emit_ord_const(dimcount,u8inttype); finaldef:=def; { ranges of the dimensions } for i:=1 to dimcount do begin curdef:=tarraydef(finaldef); finaldef:=curdef.elementdef; { Dims[i] PPTypeInfo } write_rtti_reference(tcb,curdef.rangedef,rt); end; end else { write a delphi almost compatible dyn. array entry: there are two types, eltype and eltype2, the latter is nil if the element type needs no finalization, the former is always valid, delphi has this swapped, but for compatibility with older fpc versions we do it different, to be delphi compatible, the names are swapped in typinfo.pp } begin tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_dyn_array], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); { record in TypInfo is aligned differently from init rtti } tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_dyn_array_inner], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { size of elements } tcb.emit_tai(Tai_const.Create_sizeint(def.elesize),sizeuinttype); { element type } write_rtti_reference(tcb,def.elementdef,rt); { variant type } tcb.emit_ord_const(tstoreddef(def.elementdef).getvardef,s32inttype); { element type } if def.elementdef.needs_inittable then write_rtti_reference(tcb,def.elementdef,rt) else tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); { write unit name } tcb.emit_shortstring_const(current_module.realmodulename^); end; tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure classrefdef_rtti(def:tclassrefdef); begin write_header(tcb,def,tkClassRef); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_ref], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_classref], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_rtti_reference(tcb,def.pointeddef,rt); tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure pointerdef_rtti(def:tpointerdef); begin write_header(tcb,def,tkPointer); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_ref], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_pointer], defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_rtti_reference(tcb,def.pointeddef,rt); tcb.end_anonymous_record; tcb.end_anonymous_record; end; procedure recorddef_rtti(def:trecorddef); procedure write_record_operators(rttilab:tasmlabel); var rttidef: tdef; tcb: ttai_typedconstbuilder; mop: tmanagementoperator; procdef: tprocdef; begin tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable]); tcb.begin_anonymous_record( '', defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin ); { use "succ" to omit first enum item "mop_none" } for mop := succ(low(tmanagementoperator)) to high(tmanagementoperator) do begin if not (mop in trecordsymtable(def.symtable).managementoperators) then tcb.emit_tai(Tai_const.Create_nil_codeptr,voidcodepointertype) else begin procdef := search_management_operator(mop, def); if procdef = nil then internalerror(201603021) else tcb.emit_tai(Tai_const.Createname(procdef.mangledname,AT_FUNCTION,0), cprocvardef.getreusableprocaddr(procdef,pc_address_only)); end; end; rttidef := tcb.end_anonymous_record; current_asmdata.AsmLists[al_rtti].concatList( tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name, sizeof(PInt))); tcb.free; end; procedure write_extended_property_table; var propnamelist: TFPHashObjectList; visibilities: tvisibilities; begin propnamelist:=TFPHashObjectList.Create; visibilities:=def.rtti_visibilities_for_option(ro_properties); collect_propnamelist(propnamelist,def,visibilities); properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities); propnamelist.free; end; var oplab : tasmlabel; begin write_header(tcb,def,tkRecord); { need extra reqalign record, because otherwise the u32 int will only be aligned to 4 even on 64 bit target (while the rtti code in typinfo expects alignments to sizeof(pointer)) } tcb.begin_anonymous_record('', defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record('', defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { store special terminator for init table for more optimal rtl operations strictly related to RecordRTTI procedure in rtti.inc (directly related to RTTIRecordRttiInfoToInitInfo function) } if rt=initrtti then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype) else { we use a direct reference as the init RTTI is always in the same unit as the full RTTI } tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype); tcb.emit_ord_const(def.size,u32inttype); oplab:=nil; { store rtti management operators only for init table } if rt=initrtti then begin { for now records don't have the initializer table } tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); if (trecordsymtable(def.symtable).managementoperators=[]) then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype) else begin current_asmdata.getlocaldatalabel(oplab); tcb.emit_tai(Tai_const.Createname( oplab.name, AT_DATA_FORCEINDIRECT,0),voidpointertype); end; end; fields_write_rtti_data(tcb,def,rt); { write extended rtti } if rt=fullrtti then begin write_extended_field_table(tcb,def,defaultpacking); write_extended_method_table(tcb,def,defaultpacking); write_extended_property_table; end; tcb.end_anonymous_record; tcb.end_anonymous_record; { write pointers to operators if needed } if (rt=initrtti) and (trecordsymtable(def.symtable).managementoperators<>[]) then write_record_operators(oplab); end; procedure procvardef_rtti(def:tprocvardef); procedure write_para(parasym:tparavarsym); begin { write flags for current parameter } write_param_flag(tcb,parasym); { write name of current parameter } tcb.emit_shortstring_const(parasym.realname); { write name of type of current parameter } write_rtti_name(tcb,parasym.vardef); end; procedure write_procedure_param(parasym:tparavarsym); begin { every parameter is expected to start aligned } tcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_proc_param]+tostr(length(parasym.realname)), defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); { write flags for current parameter } write_param_flag(tcb,parasym); { write param type } if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti) else if parasym.vardef=cformaltype then write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,parasym.vardef,fullrtti); { write name of current parameter } tcb.emit_shortstring_const(parasym.realname); tcb.end_anonymous_record; end; var methodkind : byte; i : integer; begin if po_methodpointer in def.procoptions then begin { write method id and name } write_header(tcb,def,tkMethod); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record('', defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { write kind of method } methodkind:=write_methodkind(tcb,def); { write parameter info. The parameters must be written in reverse order if this method uses right to left parameter pushing! } tcb.emit_ord_const(def.paras.count,u8inttype); for i:=0 to def.paras.count-1 do write_para(tparavarsym(def.paras[i])); if (methodkind=mkFunction) or (methodkind=mkClassFunction) then begin { write name of result type } write_rtti_name(tcb,def.returndef); { enclosing record takes care of alignment } { write result typeinfo } write_rtti_reference(tcb,def.returndef,fullrtti); end; { write calling convention } write_callconv(tcb,def); { enclosing record takes care of alignment } { write params typeinfo } for i:=0 to def.paras.count-1 do begin if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti) else if tparavarsym(def.paras[i]).vardef=cformaltype then write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti); end; tcb.end_anonymous_record; tcb.end_anonymous_record; end else begin write_header(tcb,def,tkProcvar); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); tcb.begin_anonymous_record('', defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { flags } tcb.emit_ord_const(0,u8inttype); { write calling convention } write_callconv(tcb,def); { enclosing record takes care of alignment } { write result typeinfo } write_rtti_reference(tcb,def.returndef,fullrtti); { write parameter count } tcb.emit_ord_const(def.paras.count,u8inttype); for i:=0 to def.paras.count-1 do write_procedure_param(tparavarsym(def.paras[i])); tcb.end_anonymous_record; tcb.end_anonymous_record; end; end; procedure objectdef_rtti(def: tobjectdef); procedure objectdef_rtti_fields(def:tobjectdef); begin maybe_add_comment(tcb,'RTTI begin fields '+def.objname^); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { - for compatiblity with record RTTI we need to write a terminator- Nil pointer for initrtti as well for objects - for RTTI consistency for objects we need point from fullrtti to initrtti - classes are assumed to have the same INIT RTTI as records (see TObject.CleanupInstance) - neither helper nor class type have fullrtti for fields } if (rt=initrtti) then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype) else if (def.objecttype=odt_object) then tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,initrtti,false)),voidpointertype) else internalerror(2017011801); tcb.emit_ord_const(def.size, u32inttype); { pointer to management operators available only for initrtti } if (rt=initrtti) then begin { initializer table only available for classes currently } if def.objecttype=odt_class then write_mop_offset_table(tcb,def,mop_initialize) else tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); end; { enclosing record takes care of alignment } fields_write_rtti_data(tcb,def,rt); tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI end fields '+def.objname^); end; procedure objectdef_rtti_interface_init(def:tobjectdef); begin tcb.emit_ord_const(def.size, u32inttype); end; procedure objectdef_extended_rtti_class(def:tobjectdef); var propnamelist : TFPHashObjectList; visibilities : tvisibilities; begin propnamelist:=TFPHashObjectList.Create; visibilities:=def.rtti_visibilities_for_option(ro_properties); collect_propnamelist(propnamelist,def,visibilities); properties_write_rtti_data(tcb,propnamelist,def.symtable,true,visibilities); propnamelist.free; end; procedure objectdef_rtti_class_full(def:tobjectdef); var propnamelist : TFPHashObjectList; begin { Collect unique property names with nameindex } propnamelist:=TFPHashObjectList.Create; collect_propnamelist(propnamelist,def,[vis_published]); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); if not is_objectpascal_helper(def) then begin maybe_add_comment(tcb,#9'Parent type info'); if (oo_has_vmt in def.objectoptions) then tcb.emit_tai( Tai_const.Createname(def.vmt_mangledname,AT_DATA_FORCEINDIRECT,0), cpointerdef.getreusable(def.vmt_def)) else tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); end; { write parent typeinfo } maybe_add_comment(tcb,#9'Parent type info'); write_rtti_reference(tcb,def.childof,fullrtti); { write typeinfo of extended type } if is_objectpascal_helper(def) then if assigned(def.extendeddef) then begin maybe_add_comment(tcb,#9'helper for type info'); write_rtti_reference(tcb,def.extendeddef,fullrtti) end else InternalError(2011033001); { total number of unique properties } maybe_add_comment(tcb,#9'Number of properties'); tcb.emit_ord_const(propnamelist.count,u16inttype); { write unit name } maybe_add_comment(tcb, #9'Unit name'); tcb.emit_shortstring_const(current_module.realmodulename^); { write published properties for this object } properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]); { write extended properties } objectdef_extended_rtti_class(def); tcb.end_anonymous_record; propnamelist.free; end; procedure objectdef_rtti_interface_full(def:tobjectdef); var propnamelist : TFPHashObjectList; { if changed to a set, make sure it's still a byte large, and swap appropriately when cross-compiling } IntfFlags: byte; begin { Collect unique property names with nameindex } propnamelist:=TFPHashObjectList.Create; collect_propnamelist(propnamelist,def,[vis_published]); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { write parent typeinfo } write_rtti_reference(tcb,def.childof,fullrtti); { interface: write flags, iid and iidstr } IntfFlags:=0; if assigned(def.iidguid) then IntfFlags:=IntfFlags or (1 shl ord(ifHasGuid)); if (def.objecttype=odt_interfacecorba) and (def.iidstr^<>'') then IntfFlags:=IntfFlags or (1 shl ord(ifHasStrGUID)); if (def.objecttype=odt_dispinterface) then IntfFlags:=IntfFlags or (1 shl ord(ifDispInterface)); if (target_info.endian=endian_big) then IntfFlags:=reverse_byte(IntfFlags); { ifDispatch, } tcb.emit_ord_const(IntfFlags,u8inttype); { write GUID } tcb.emit_guid_const(def.iidguid^); { write hidden class reference - if it is nil, write_rtti_reference writes nil } write_rtti_reference(tcb,def.hiddenclassdef,fullrtti); { write unit name } tcb.emit_shortstring_const(current_module.realmodulename^); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { write iidstr } if def.objecttype=odt_interfacecorba then begin { prepareguid always allocates an empty string } if not assigned(def.iidstr) then internalerror(2016021901); tcb.emit_shortstring_const(def.iidstr^) end; { write published properties for this object } properties_write_rtti_data(tcb,propnamelist,def.symtable,false,[vis_published]); { write published methods for this interface } write_methods(tcb,def.symtable,false,[vis_published]); tcb.end_anonymous_record; tcb.end_anonymous_record; propnamelist.free; end; begin case def.objecttype of odt_class: tcb.emit_ord_const(tkclass,u8inttype); odt_object: tcb.emit_ord_const(tkobject,u8inttype); odt_dispinterface, odt_interfacecom: tcb.emit_ord_const(tkInterface,u8inttype); odt_interfacecorba: tcb.emit_ord_const(tkinterfaceCorba,u8inttype); odt_helper: tcb.emit_ord_const(tkhelper,u8inttype); else internalerror(200611034); end; { generate the name } tcb.emit_shortstring_const(def.objrealname^); tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); write_common_rtti_data(tcb,def,rt); case rt of initrtti : begin if def.objecttype in [odt_class,odt_object,odt_helper] then objectdef_rtti_fields(def) else objectdef_rtti_interface_init(def); end; fullrtti : begin tcb.begin_anonymous_record('', defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); case def.objecttype of odt_helper, odt_class: objectdef_rtti_class_full(def); odt_object: objectdef_rtti_fields(def); else objectdef_rtti_interface_full(def); end; tcb.end_anonymous_record; end; else ; end; tcb.end_anonymous_record; end; begin case def.typ of variantdef : variantdef_rtti(tvariantdef(def)); stringdef : stringdef_rtti(tstringdef(def)); enumdef : enumdef_rtti(tenumdef(def)); orddef : orddef_rtti(torddef(def)); floatdef : floatdef_rtti(tfloatdef(def)); setdef : setdef_rtti(tsetdef(def)); procvardef : procvardef_rtti(tprocvardef(def)); arraydef : begin if ado_IsBitPacked in tarraydef(def).arrayoptions then unknown_rtti(tstoreddef(def)) else arraydef_rtti(tarraydef(def)); end; recorddef : begin if trecorddef(def).is_packed then unknown_rtti(tstoreddef(def)) else recorddef_rtti(trecorddef(def)); end; objectdef : objectdef_rtti(tobjectdef(def)); classrefdef : classrefdef_rtti(tclassrefdef(def)); pointerdef : pointerdef_rtti(tpointerdef(def)); else unknown_rtti(tstoreddef(def)); end; end; procedure TRTTIWriter.write_attribute_data(tcb:ttai_typedconstbuilder;attr_list:trtti_attribute_list); procedure write_args(tbltcb:ttai_typedconstbuilder;attr:trtti_attribute); var argtcb : ttai_typedconstbuilder; arglab : tasmlabel; argdef : tdef; i : sizeint; begin if length(attr.paras)=0 then begin tbltcb.emit_tai(tai_const.Create_16bit(0),u16inttype); tbltcb.emit_tai(tai_const.Create_nil_dataptr,voidpointertype); end else begin current_asmdata.getglobaldatalabel(arglab); argtcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]); argtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); for i:=0 to High(attr.paras) do begin case attr.paras[i].nodetype of niln, ordconstn, realconstn, stringconstn, pointerconstn, guidconstn: tconstnode(attr.paras[i]).emit_data(argtcb); setconstn: tsetconstnode(attr.paras[i]).emit_data(argtcb); else internalerror(2019070803); end; end; argdef:=argtcb.end_anonymous_record; current_asmdata.asmlists[al_rtti].concatlist( argtcb.get_final_asmlist(arglab,argdef,sec_rodata,arglab.name,const_align(sizeof(pint))) ); argtcb.free; { write argument size and the reference to the argument entry } tbltcb.emit_ord_const(argdef.size,u16inttype); tbltcb.emit_tai(Tai_const.Create_sym(arglab),voidpointertype); end; end; var count,i: word; attr : trtti_attribute; tbltcb : ttai_typedconstbuilder; tbllab : tasmlabel; tbldef : tdef; begin if assigned(attr_list) then count:=attr_list.get_attribute_count else count:=0; if count=0 then begin { write a Nil reference } tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype); exit; end; { first write the attribute list as a separate table } current_asmdata.getglobaldatalabel(tbllab); tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable]); tbltcb.begin_anonymous_record( internaltypeprefixName[itp_rtti_attr_list]+tostr(count), defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); tbltcb.emit_ord_const(count,u16inttype); for i:=0 to count-1 do begin tbltcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_attr_entry],defaultpacking,min(reqalign,SizeOf(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); attr:=trtti_attribute(attr_list.rtti_attributes[i]); write_rtti_reference(tbltcb,ttypesym(attr.typesym).typedef,fullrtti); tbltcb.emit_procdef_const(tprocdef(tcallnode(attr.constructorcall).procdefinition)); if not assigned(attr.constructorpd) then internalerror(2019071004); tbltcb.emit_procdef_const(tprocdef(attr.constructorpd)); write_args(tbltcb,attr); tbltcb.end_anonymous_record; end; tbldef:=tbltcb.end_anonymous_record; current_asmdata.asmlists[al_rtti].concatlist( tbltcb.get_final_asmlist(tbllab,tbldef,sec_rodata,tbllab.name,const_align(sizeof(pint))) ); tbltcb.free; { write the reference to the attribute table } tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype); end; function enumsym_compare_name(item1, item2: pointer): Integer; var enum1: tenumsym absolute item1; enum2: tenumsym absolute item2; begin if enum1=enum2 then result:=0 else if enum1.name>enum2.name then result:=1 else { there can't be equal names, identifiers are unique } result:=-1; end; function enumsym_compare_value(item1, item2: pointer): Integer; var enum1: tenumsym absolute item1; enum2: tenumsym absolute item2; begin if enum1.value>enum2.value then result:=1 else if enum1.value0 then begin i:=1; r:=0; h:=tenumsym(syms[0]).value; {Next expected enum value is min.} { set prev_value for the first iteration to a value that is different from the first one without risking overflow (it's used to detect whether two enum values are the same) } if h=0 then prev_value:=1 else prev_value:=0; while isym_count then mode:=search; {Don't waste more than 50% space.} end; { write rtti data; make sure that the alignment matches the corresponding data structure in the code that uses it (if alignment is required). } tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]); { use TConstPtrUInt packrecords to ensure good alignment } tcb.begin_anonymous_record('',defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin); { now emit the data: first the mode } tcb.emit_tai(Tai_const.create_32bit(longint(mode)),u32inttype); { align } tcb.begin_anonymous_record('',defaultpacking,min(reqalign,sizeof(PInt)), targetinfos[target_info.system]^.alignment.recordalignmin); if mode=lookup then begin o:=tenumsym(syms[0]).value; {Start with min value.} for i:=0 to sym_count-1 do begin while odef.maxval then break; syms.add(t); end; { sort the syms by enum name } syms.sort(@enumsym_compare_name); s:=internaltypeprefixName[itp_rttidef]+def.rtti_mangledname(fullrtti); rttitypesym:=try_search_current_module_type(s); if not assigned(rttitypesym) or (ttypesym(rttitypesym).typedef.typ<>recorddef) then internalerror(2015071402); rttidef:=trecorddef(ttypesym(rttitypesym).typedef); enumdef_rtti_string2ordindex(rttidef,syms); { sort the syms by enum value } syms.sort(@enumsym_compare_value); enumdef_rtti_ord2stringindex(rttidef,syms); syms.free; end; begin case def.typ of enumdef: if rt=fullrtti then begin enumdef_rtti_extrasyms(Tenumdef(def)); end; else ; end; end; procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype); begin case def.typ of enumdef : if assigned(tenumdef(def).basedef) then write_rtti(tenumdef(def).basedef,rt); setdef : write_rtti(tsetdef(def).elementdef,rt); arraydef : begin write_rtti(tarraydef(def).rangedef,rt); write_rtti(tarraydef(def).elementdef,rt); end; recorddef : begin { guarantee initrtti for any record for RTTI purposes also for fpc_initialize, fpc_finalize } if (rt=fullrtti) then begin include(def.defstates,ds_init_table_used); write_rtti(def, initrtti); end; fields_write_rtti(trecorddef(def).symtable,rt); end; objectdef : begin if assigned(tobjectdef(def).childof) then write_rtti(tobjectdef(def).childof,rt); if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then fields_write_rtti(tobjectdef(def).symtable,rt) else published_write_rtti(tobjectdef(def),rt); if (rt=fullrtti) then begin { guarantee initrtti for any object for RTTI purposes also for fpc_initialize, fpc_finalize } if (tobjectdef(def).objecttype=odt_object) then begin include(def.defstates,ds_init_table_used); write_rtti(def,initrtti); end; if (is_interface(def) or is_dispinterface(def)) and (oo_can_have_published in tobjectdef(def).objectoptions) then methods_write_rtti(tobjectdef(def).symtable,rt,[vis_published],true); end; end; classrefdef, pointerdef: if not is_objc_class_or_protocol(tabstractpointerdef(def).pointeddef) then write_rtti(tabstractpointerdef(def).pointeddef,rt); procvardef: params_write_rtti(tabstractprocdef(def),rt,false); else ; end; end; procedure TRTTIWriter.write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype); begin { we don't care about the real type here, because a) we don't index into these elements b) we may not have the rtti type available at the point that we are emitting this data, because of forward definitions etc c) if the rtti is emitted in another unit, we won't have the type available at all For the cases where the type is emitted in the current unit and hence the underlying system will detect and complain about symbol def mismatches, type conversions will have to be inserted afterwards (like in llvm/llvmtype) } if not assigned(def) or is_void(def) or ((rt<>initrtti) and is_objc_class_or_protocol(def)) then tcb.emit_tai(Tai_const.Create_nil_dataptr,voidpointertype) else tcb.emit_tai(Tai_const.Create_sym(get_rtti_label(def,rt,true)),voidpointertype); end; function TRTTIWriter.ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol; var s : tsymstr; begin s:=def.rtti_mangledname(rt)+suffix; result:=current_asmdata.RefAsmSymbol(s,AT_DATA,indirect); if def.owner.moduleid<>current_module.moduleid then current_module.add_extern_asmsym(s,AB_EXTERNAL,AT_DATA); end; procedure TRTTIWriter.write_rtti(def:tdef;rt:trttitype); var tcb: ttai_typedconstbuilder; opts : ttcasmlistoptions; rttilab: tasmsymbol; rttidef: tdef; s: TIDString; begin { Objective-C has its own RTTI system } if is_objc_class_or_protocol(def) then exit; { only write rtti of definitions from the current module } if not findunitsymtable(def.owner).iscurrentunit then exit; { check if separate initrtti is actually needed } if (rt=initrtti) and (not def.needs_separate_initrtti) then rt:=fullrtti; { prevent recursion } if rttidefstate[rt] in def.defstates then exit; include(def.defstates,rttidefstate[rt]); { write first all dependencies } write_child_rtti_data(def,rt); { write rtti data } tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_data_force_indirect]); s:=internaltypeprefixName[itp_rttidef]+tstoreddef(def).rtti_mangledname(rt); maybe_add_comment(tcb,'RTTI: begin Type '+def.GetTypeName+' ('+rttitypenames[rt]+')'); tcb.begin_anonymous_record( s, defaultpacking,reqalign, targetinfos[target_info.system]^.alignment.recordalignmin ); write_rtti_data(tcb,def,rt); rttidef:=tcb.end_anonymous_record; maybe_add_comment(tcb,'RTTI: end Type '+def.GetTypeName+' ('+rttitypenames[rt]+')'); rttilab:=current_asmdata.DefineAsmSymbol(tstoreddef(def).rtti_mangledname(rt),AB_GLOBAL,AT_DATA_NOINDIRECT,rttidef); current_asmdata.AsmLists[al_rtti].concatList( tcb.get_final_asmlist(rttilab,rttidef,sec_rodata,rttilab.name,min(target_info.alignment.maxCrecordalign,SizeOf(QWord)))); tcb.free; current_module.add_public_asmsym(rttilab); { write additional data } write_rtti_extrasyms(def,rt,rttilab); end; procedure TRTTIWriter.maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string); begin if addcomments then tcb.emit_comment(comment); end; constructor TRTTIWriter.create; begin addcomments:=cs_asm_rtti_source in current_settings.globalswitches; if tf_requires_proper_alignment in target_info.flags then begin reqalign:=min(sizeof(QWord),target_info.alignment.maxCrecordalign); defaultpacking:=C_alignment; end else begin reqalign:=1; defaultpacking:=1; end; end; end.